{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Snap.Snaplet.Internal.Initializer
( addPostInitHook
, addPostInitHookBase
, toSnapletHook
, bracketInit
, modifyCfg
, nestSnaplet
, embedSnaplet
, makeSnaplet
, nameSnaplet
, onUnload
, addRoutes
, wrapSite
, runInitializer
, runSnaplet
, combineConfig
, serveSnaplet
, serveSnapletNoArgParsing
, loadAppConfig
, printInfo
, getRoutes
, getEnvironment
, modifyMaster
) where
import Control.Applicative ((<$>))
import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar,
putMVar, readMVar)
import Control.Exception.Lifted (SomeException, catch, try)
import Control.Lens (ALens', cloneLens, over, set,
storing, (^#))
import Control.Monad (Monad (..), join, liftM, unless,
when, (=<<))
import Control.Monad.Reader (ask)
import Control.Monad.State (get, modify)
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Writer hiding (pass)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Configurator (Worth (..), addToConfig, empty,
loadGroups, subconfig)
import qualified Data.Configurator.Types as C
import Data.IORef (IORef, atomicModifyIORef,
newIORef, readIORef)
import Data.Maybe (Maybe (..), fromJust, fromMaybe,
isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Prelude (Bool (..), Either (..), Eq (..),
String, concat, concatMap,
const, either,
error, filter, flip, fst, id,
map, not, show, ($), ($!), (++),
(.))
import Snap.Core (Snap, liftSnap, route)
import Snap.Http.Server (Config, completeConfig,
getCompression, getErrorHandler,
getOther, getVerbose, httpServe)
import Snap.Util.GZip (withCompression)
import System.Directory (copyFile,
createDirectoryIfMissing,
doesDirectoryExist,
getCurrentDirectory)
import System.Directory.Tree (DirTree (..), FileName, buildL,
dirTree, readDirectoryWith)
import System.FilePath.Posix (dropFileName, makeRelative,
(</>))
import System.IO (FilePath, IO, hPutStrLn, stderr)
import Snap.Snaplet.Config (AppConfig, appEnvironment,
commandLineAppConfig)
import qualified Snap.Snaplet.Internal.Lensed as L
import qualified Snap.Snaplet.Internal.LensT as LT
import Snap.Snaplet.Internal.Types
iGet :: Initializer b v (InitializerState b)
iGet :: forall b v. Initializer b v (InitializerState b)
iGet = forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
iModify :: (InitializerState b -> InitializerState b) -> Initializer b v ()
iModify :: forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify InitializerState b -> InitializerState b
f = forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
InitializerState b
b <- forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
forall (m :: * -> *) s b v. Monad m => s -> LensT b v s m ()
LT.putBase forall a b. (a -> b) -> a -> b
$ InitializerState b -> InitializerState b
f InitializerState b
b
iGets :: (InitializerState b -> a) -> Initializer b v a
iGets :: forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> a
f = forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
InitializerState b
b <- forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InitializerState b -> a
f InitializerState b
b
getRoutes :: Initializer b v [ByteString]
getRoutes :: forall b v. Initializer b v [ByteString]
getRoutes = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers
getEnvironment :: Initializer b v String
getEnvironment :: forall b v. Initializer b v String
getEnvironment = forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> String
_environment
toSnapletHook :: (v -> IO (Either Text v))
-> (Snaplet v -> IO (Either Text (Snaplet v)))
toSnapletHook :: forall v.
(v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook v -> IO (Either Text v)
f (Snaplet SnapletConfig
cfg v -> IO ()
reset v
val) = do
Either Text v
val' <- v -> IO (Either Text v)
f v
val
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s. SnapletConfig -> (s -> IO ()) -> s -> Snaplet s
Snaplet SnapletConfig
cfg v -> IO ()
reset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text v
val'
addPostInitHook :: (v -> IO (Either Text v))
-> Initializer b v ()
addPostInitHook :: forall v b. (v -> IO (Either Text v)) -> Initializer b v ()
addPostInitHook = forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v.
(v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook
addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v ()
addPostInitHook' :: forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' Snaplet v -> IO (Either Text (Snaplet v))
h = do
Snaplet b -> IO (Either Text (Snaplet b))
h' <- forall v b.
(Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook Snaplet v -> IO (Either Text (Snaplet v))
h
forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase Snaplet b -> IO (Either Text (Snaplet b))
h'
addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v ()
addPostInitHookBase :: forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase = forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Snaplet a -> IO (Either Text (Snaplet a))) -> Hook a
Hook
upHook :: (Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook :: forall v b.
(Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook Snaplet v -> IO (Either Text (Snaplet v))
h = forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
ALens' (Snaplet b) (Snaplet v)
l <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' ALens' (Snaplet b) (Snaplet v)
l Snaplet v -> IO (Either Text (Snaplet v))
h
upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' :: forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' ALens' b a
l a -> m (Either e a)
h b
b = do
Either e a
v <- a -> m (Either e a)
h (b
b forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either e a
v of
Left e
e -> forall a b. a -> Either a b
Left e
e
Right a
v' -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' b a
l a
v' b
b
modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg :: forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg SnapletConfig -> SnapletConfig
f = forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) SnapletConfig
curConfig forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> SnapletConfig -> SnapletConfig
f SnapletConfig
c
setupFilesystem :: Maybe (IO FilePath)
-> FilePath
-> Initializer b v ()
setupFilesystem :: forall b v. Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Maybe (IO String)
Nothing String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupFilesystem (Just IO String
getSnapletDataDir) String
targetDir = do
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
targetDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
forall b v. Text -> Initializer b v ()
printInfo Text
"...setting up filesystem"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetDir
String
srcDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getSnapletDataDir
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
readDirectoryWith (String -> String -> String -> IO ()
doCopy String
srcDir String
targetDir) String
srcDir
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
doCopy :: String -> String -> String -> IO ()
doCopy String
srcRoot String
targetRoot String
filename = do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
String -> String -> IO ()
copyFile String
filename String
toDir
where
toDir :: String
toDir = String
targetRoot String -> String -> String
</> String -> String -> String
makeRelative String
srcRoot String
filename
directory :: String
directory = String -> String
dropFileName String
toDir
makeSnaplet :: Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet :: forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
snapletId Text
desc Maybe (IO String)
getSnapletDataDir Initializer b v v
m = forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit forall a b. (a -> b) -> a -> b
$ do
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> if forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ SnapletConfig -> Maybe Text
_scId SnapletConfig
c
then forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig (Maybe Text)
scId (forall a. a -> Maybe a
Just Text
snapletId) SnapletConfig
c else SnapletConfig
c
String
sid <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
Bool
topLevel <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> Bool
_isTopLevel
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topLevel forall a b. (a -> b) -> a -> b
$ do
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig Config
scUserConfig (Text -> Config -> Config
subconfig (String -> Text
T.pack String
sid))
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig String
scFilePath
(SnapletConfig -> String
_scFilePath SnapletConfig
c String -> String -> String
</> String
"snaplets" String -> String -> String
</> String
sid) SnapletConfig
c
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) Bool
isTopLevel Bool
False)
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig Text
scDescription Text
desc
SnapletConfig
cfg <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> SnapletConfig
_curConfig
forall b v. Text -> Initializer b v ()
printInfo forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"Initializing "
,String
sid
,String
" @ /"
,ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
buildPath forall a b. (a -> b) -> a -> b
$ SnapletConfig -> [ByteString]
_scRouteContext SnapletConfig
cfg
]
forall b v. Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Maybe (IO String)
getSnapletDataDir (SnapletConfig -> String
_scFilePath SnapletConfig
cfg)
String
env <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> String
_environment
let configLocation :: String
configLocation = SnapletConfig -> String
_scFilePath SnapletConfig
cfg String -> String -> String
</> (String
env forall a. [a] -> [a] -> [a]
++ String
".cfg")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Worth String] -> Config -> IO ()
addToConfig [forall a. a -> Worth a
Optional String
configLocation]
(SnapletConfig -> Config
_scUserConfig SnapletConfig
cfg)
forall b v. Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet Initializer b v v
m
mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet :: forall b v. Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet Initializer b v v
m = do
v
res <- Initializer b v v
m
SnapletConfig
cfg <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> SnapletConfig
_curConfig
(Snaplet b -> Snaplet b) -> IO ()
setInTop <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader
SnapletLens (Snaplet b) v
l <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
let modifier :: v -> IO ()
modifier = (Snaplet b -> Snaplet b) -> IO ()
setInTop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Lens' (Snaplet s) s
snapletValue)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. SnapletConfig -> (s -> IO ()) -> s -> Snaplet s
Snaplet SnapletConfig
cfg v -> IO ()
modifier v
res
bracketInit :: Initializer b v a -> Initializer b v a
bracketInit :: forall b v a. Initializer b v a -> Initializer b v a
bracketInit Initializer b v a
m = do
InitializerState b
s <- forall b v. Initializer b v (InitializerState b)
iGet
a
res <- Initializer b v a
m
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) SnapletConfig
curConfig (forall b. InitializerState b -> SnapletConfig
_curConfig InitializerState b
s))
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
setupSnapletCall :: ByteString -> Initializer b v ()
setupSnapletCall :: forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
rte = do
Text
curId <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig [Text]
scAncestry (Text
curIdforall a. a -> [a] -> [a]
:))
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig (Maybe Text)
scId (forall a b. a -> b -> a
const forall a. Maybe a
Nothing))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
rte) forall a b. (a -> b) -> a -> b
$ forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig [ByteString]
scRouteContext (ByteString
rteforall a. a -> [a] -> [a]
:))
nestSnaplet :: ByteString
-> SnapletLens v v1
-> SnapletInit b v1
-> Initializer b v (Snaplet v1)
nestSnaplet :: forall v v1 b.
ByteString
-> SnapletLens v v1
-> SnapletInit b v1
-> Initializer b v (Snaplet v1)
nestSnaplet ByteString
rte SnapletLens v v1
l (SnapletInit Initializer b v1 (Snaplet v1)
snaplet) =
forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens v v1
l forall a b. (a -> b) -> a -> b
$ forall b v a. Initializer b v a -> Initializer b v a
bracketInit forall a b. (a -> b) -> a -> b
$ do
forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
rte
Initializer b v1 (Snaplet v1)
snaplet
embedSnaplet :: ByteString
-> SnapletLens v v1
-> SnapletInit v1 v1
-> Initializer b v (Snaplet v1)
embedSnaplet :: forall v v1 b.
ByteString
-> SnapletLens v v1
-> SnapletInit v1 v1
-> Initializer b v (Snaplet v1)
embedSnaplet ByteString
rte SnapletLens v v1
l (SnapletInit Initializer v1 v1 (Snaplet v1)
snaplet) = forall b v a. Initializer b v a -> Initializer b v a
bracketInit forall a b. (a -> b) -> a -> b
$ do
SnapletLens (Snaplet b) v
curLens <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
""
forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
curLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. SnapletLens a b -> SnapletLens (Snaplet a) b
subSnaplet SnapletLens v v1
l) Initializer v1 v1 (Snaplet v1)
snaplet
chroot :: ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot :: forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte SnapletLens (Snaplet b) v1
l (Initializer LensT
(Snaplet v1)
(Snaplet v1)
(InitializerState v1)
(WriterT (Hook v1) IO)
a
m) = do
InitializerState b
curState <- forall b v. Initializer b v (InitializerState b)
iGet
let newSetter :: (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter Snaplet v1 -> Snaplet v1
f = forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader InitializerState b
curState (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v1
l) Snaplet v1 -> Snaplet v1
f)
((a
a,InitializerState v1
s), (Hook Snaplet v1 -> IO (Either Text (Snaplet v1))
hook)) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s a.
Monad m =>
LensT b v s m a -> ALens' b v -> s -> m (a, s)
LT.runLensT LensT
(Snaplet v1)
(Snaplet v1)
(InitializerState v1)
(WriterT (Hook v1) IO)
a
m forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
InitializerState b
curState {
_handlers :: [(ByteString, Handler v1 v1 ())]
_handlers = [],
_hFilter :: Handler v1 v1 () -> Handler v1 v1 ()
_hFilter = forall a. a -> a
id,
masterReloader :: (Snaplet v1 -> Snaplet v1) -> IO ()
masterReloader = (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter
}
let handler :: Handler b b ()
handler = forall v b' a b.
SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler SnapletLens (Snaplet b) v1
l forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState v1
s forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState v1
s
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers (forall a. [a] -> [a] -> [a]
++[(ByteString
rte,Handler b b ()
handler)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) (IORef (IO ()))
cleanup (forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState v1
s)
forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' SnapletLens (Snaplet b) v1
l Snaplet v1 -> IO (Either Text (Snaplet v1))
hook
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
chrootHandler :: SnapletLens (Snaplet v) b'
-> Handler b' b' a -> Handler b v a
chrootHandler :: forall v b' a b.
SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler SnapletLens (Snaplet v) b'
l (Handler Lensed (Snaplet b') (Snaplet b') Snap a
h) = forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler forall a b. (a -> b) -> a -> b
$ do
Snaplet v
s <- forall s (m :: * -> *). MonadState s m => m s
get
(a
a, Snaplet b'
s') <- forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b') (Snaplet b') Snap a
h forall a. a -> a
id (Snaplet v
s forall s t a b. s -> ALens s t a b -> a
^# SnapletLens (Snaplet v) b'
l)
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall s t a b. ALens s t a b -> b -> s -> t
storing SnapletLens (Snaplet v) b'
l Snaplet b'
s'
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
nameSnaplet :: Text
-> SnapletInit b v
-> SnapletInit b v
nameSnaplet :: forall b v. Text -> SnapletInit b v -> SnapletInit b v
nameSnaplet Text
nm (SnapletInit Initializer b v (Snaplet v)
m) = forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit forall a b. (a -> b) -> a -> b
$
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig (Maybe Text)
scId (forall a. a -> Maybe a
Just Text
nm)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Initializer b v (Snaplet v)
m
addRoutes :: [(ByteString, Handler b v ())]
-> Initializer b v ()
addRoutes :: forall b v. [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes [(ByteString, Handler b v ())]
rs = do
SnapletLens (Snaplet b) v
l <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
[ByteString]
ctx <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (SnapletConfig -> [ByteString]
_scRouteContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
let modRoute :: (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute (ByteString
r,Handler b v ()
h) = ( [ByteString] -> ByteString
buildPath (ByteString
rforall a. a -> [a] -> [a]
:[ByteString]
ctx)
, forall {b} {v}. ByteString -> Handler b v ()
setPattern ByteString
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) v
l Handler b v ()
h)
let rs' :: [(ByteString, Handler b b ())]
rs' = forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute [(ByteString, Handler b v ())]
rs
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers (forall a. [a] -> [a] -> [a]
++[(ByteString, Handler b b ())]
rs') InitializerState b
v)
where
setPattern :: ByteString -> Handler b v ()
setPattern ByteString
r = do
Maybe ByteString
p <- forall b v. Handler b v (Maybe ByteString)
getRoutePattern
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe ByteString
p) forall a b. (a -> b) -> a -> b
$ forall {b} {v}. ByteString -> Handler b v ()
setRoutePattern ByteString
r
wrapSite :: (Handler b v () -> Handler b v ())
-> Initializer b v ()
wrapSite :: forall b v.
(Handler b v () -> Handler b v ()) -> Initializer b v ()
wrapSite Handler b v () -> Handler b v ()
f0 = do
Handler b b () -> Handler b b ()
f <- forall b v.
(Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter Handler b v () -> Handler b v ()
f0
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b.
Lens' (InitializerState b) (Handler b b () -> Handler b b ())
hFilter (Handler b b () -> Handler b b ()
fforall b c a. (b -> c) -> (a -> b) -> a -> c
.) InitializerState b
v)
mungeFilter :: (Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter :: forall b v.
(Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter Handler b v () -> Handler b v ()
f = do
SnapletLens (Snaplet b) v
myLens <- forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Handler b b ()
m -> forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens (Snaplet v) v' -> m b v' a -> m b v a
with' SnapletLens (Snaplet b) v
myLens forall a b. (a -> b) -> a -> b
$ Handler b b () -> Handler b v ()
f' Handler b b ()
m
where
f' :: Handler b b () -> Handler b v ()
f' (Handler Lensed (Snaplet b) (Snaplet b) Snap ()
m) = Handler b v () -> Handler b v ()
f forall a b. (a -> b) -> a -> b
$ forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
L.withTop forall a. a -> a
id Lensed (Snaplet b) (Snaplet b) Snap ()
m
onUnload :: IO () -> Initializer b v ()
onUnload :: forall b v. IO () -> Initializer b v ()
onUnload IO ()
m = do
IORef (IO ())
cleanupRef <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> IORef (IO ())
_cleanup
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IO ())
cleanupRef IO () -> (IO (), ())
f
where
f :: IO () -> (IO (), ())
f IO ()
curCleanup = (IO ()
curCleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m, ())
logInitMsg :: IORef Text -> Text -> IO ()
logInitMsg :: IORef Text -> Text -> IO ()
logInitMsg IORef Text
ref Text
msg = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Text
ref (\Text
cur -> (Text
cur Text -> Text -> Text
`T.append` Text
msg, ()))
printInfo :: Text -> Initializer b v ()
printInfo :: forall b v. Text -> Initializer b v ()
printInfo Text
msg = do
IORef Text
logRef <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> IORef Text
_initMessages
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef Text -> Text -> IO ()
logInitMsg IORef Text
logRef (Text
msg Text -> Text -> Text
`T.append` Text
"\n")
mkReloader :: FilePath
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader :: forall b.
String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader String
cwd String
env (Snaplet b -> Snaplet b) -> IO ()
resetter IORef (IO ())
cleanupRef Initializer b b (Snaplet b)
i = do
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
!Either Text (Snaplet b, InitializerState b)
res <- forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
i String
cwd
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (Snaplet b, InitializerState b) -> IO (Either Text Text)
good Either Text (Snaplet b, InitializerState b)
res
where
good :: (Snaplet b, InitializerState b) -> IO (Either Text Text)
good (Snaplet b
b,InitializerState b
is) = do
()
_ <- (Snaplet b -> Snaplet b) -> IO ()
resetter (forall a b. a -> b -> a
const Snaplet b
b)
Text
msgs <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
msgs
runBase :: Handler b b a
-> MVar (Snaplet b)
-> Snap a
runBase :: forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (Handler Lensed (Snaplet b) (Snaplet b) Snap a
m) MVar (Snaplet b)
mvar = do
!Snaplet b
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. MVar a -> IO a
readMVar MVar (Snaplet b)
mvar)
(!a
a, Snaplet b
_) <- forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b) (Snaplet b) Snap a
m forall a. a -> a
id Snaplet b
b
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
a
modifyMaster :: v -> Handler b v ()
modifyMaster :: forall v b. v -> Handler b v ()
modifyMaster v
v = do
v -> IO ()
modifier <- forall v b b1. (Snaplet v -> b) -> Handler b1 v b
getsSnapletState forall s. Snaplet s -> s -> IO ()
_snapletModifier
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ v -> IO ()
modifier v
v
runInitializer :: ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer :: forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
b =
IO String
getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
b
runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> FilePath
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' :: forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env b :: Initializer b b (Snaplet b)
b@(Initializer LensT
(Snaplet b)
(Snaplet b)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b)
i) String
cwd = do
IORef (IO ())
cleanupRef <- forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *) a. Monad m => a -> m a
return ())
let reloader_ :: IO (Either Text Text)
reloader_ = forall b.
String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader String
cwd String
env (Snaplet b -> Snaplet b) -> IO ()
resetter IORef (IO ())
cleanupRef Initializer b b (Snaplet b)
b
let builtinHandlers :: [(a, Handler b v ())]
builtinHandlers = [(a
"/admin/reload", forall b v. Handler b v ()
reloadSite)]
let cfg :: SnapletConfig
cfg = [Text]
-> String
-> Maybe Text
-> Text
-> Config
-> [ByteString]
-> Maybe ByteString
-> IO (Either Text Text)
-> SnapletConfig
SnapletConfig [] String
cwd forall a. Maybe a
Nothing Text
"" Config
empty [] forall a. Maybe a
Nothing IO (Either Text Text)
reloader_
IORef Text
logRef <- forall a. a -> IO (IORef a)
newIORef Text
""
let body :: IO (Either Text (Snaplet b, InitializerState b))
body = do
((Snaplet b
res, InitializerState b
s), (Hook Snaplet b -> IO (Either Text (Snaplet b))
hook)) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s a.
Monad m =>
LensT b v s m a -> ALens' b v -> s -> m (a, s)
LT.runLensT LensT
(Snaplet b)
(Snaplet b)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b)
i forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
forall b.
Bool
-> IORef (IO ())
-> [(ByteString, Handler b b ())]
-> (Handler b b () -> Handler b b ())
-> SnapletConfig
-> IORef Text
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> InitializerState b
InitializerState Bool
True IORef (IO ())
cleanupRef forall {a} {b} {v}. IsString a => [(a, Handler b v ())]
builtinHandlers forall a. a -> a
id SnapletConfig
cfg IORef Text
logRef
String
env (Snaplet b -> Snaplet b) -> IO ()
resetter
Either Text (Snaplet b)
res' <- Snaplet b -> IO (Either Text (Snaplet b))
hook Snaplet b
res
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (,InitializerState b
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text (Snaplet b)
res'
handler :: SomeException -> IO (Either Text (Snaplet b, InitializerState b))
handler SomeException
e = do
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
Text
logMessages <- forall a. IORef a -> IO a
readIORef IORef Text
logRef
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ Text
"Initializer threw an exception..."
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (SomeException
e :: SomeException)
, Text
""
, Text
"...but before it died it generated the following output:"
, Text
logMessages
]
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch IO (Either Text (Snaplet b, InitializerState b))
body SomeException -> IO (Either Text (Snaplet b, InitializerState b))
handler
runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet :: forall b.
Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet Maybe String
env (SnapletInit Initializer b b (Snaplet b)
b) = do
MVar (Snaplet b)
snapletMVar <- forall a. IO (MVar a)
newEmptyMVar
let resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter Snaplet b -> Snaplet b
f = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Snaplet b)
snapletMVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snaplet b -> Snaplet b
f)
Either Text (Snaplet b, InitializerState b)
eRes <- forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer (Snaplet b -> Snaplet b) -> IO ()
resetter (forall a. a -> Maybe a -> a
fromMaybe String
"devel" Maybe String
env) Initializer b b (Snaplet b)
b
let go :: (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go (Snaplet b
siteSnaplet,InitializerState b
is) = do
forall a. MVar a -> a -> IO ()
putMVar MVar (Snaplet b)
snapletMVar Snaplet b
siteSnaplet
Text
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
let handler :: Snap ()
handler = forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState b
is forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState b
is) MVar (Snaplet b)
snapletMVar
IO ()
cleanupAction <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState b
is
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
msgs, Snap ()
handler, IO ()
cleanupAction)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go Either Text (Snaplet b, InitializerState b)
eRes
combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig :: forall a. Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig Config Snap a
config Snap ()
handler = do
Config Snap a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config
let catch500 :: Snap () -> Snap ()
catch500 = (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
getErrorHandler Config Snap a
conf)
let compress :: Snap () -> Snap ()
compress = if forall a. HasCallStack => Maybe a -> a
fromJust (forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config Snap a
conf)
then forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else forall a. a -> a
id
let site :: Snap ()
site = Snap () -> Snap ()
compress forall a b. (a -> b) -> a -> b
$ Snap () -> Snap ()
catch500 Snap ()
handler
forall (m :: * -> *) a. Monad m => a -> m a
return (Config Snap a
conf, Snap ()
site)
serveSnaplet :: Config Snap AppConfig
-> SnapletInit b b
-> IO ()
serveSnaplet :: forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnaplet Config Snap AppConfig
startConfig SnapletInit b b
initializer = do
Config Snap AppConfig
config <- forall (m :: * -> *).
MonadSnap m =>
Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig Config Snap AppConfig
startConfig
forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnapletNoArgParsing Config Snap AppConfig
config SnapletInit b b
initializer
serveSnapletNoArgParsing :: Config Snap AppConfig
-> SnapletInit b b
-> IO ()
serveSnapletNoArgParsing :: forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnapletNoArgParsing Config Snap AppConfig
config SnapletInit b b
initializer = do
let env :: Maybe String
env = AppConfig -> Maybe String
appEnvironment forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config Snap AppConfig
config
(Text
msgs, Snap ()
handler, IO ()
doCleanup) <- forall b.
Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet Maybe String
env SnapletInit b b
initializer
(Config Snap AppConfig
conf, Snap ()
site) <- forall a. Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig Config Snap AppConfig
config Snap ()
handler
Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
"log"
let serve :: Snap () -> IO ()
serve = forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap AppConfig
conf
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {m :: * -> *} {a}. Config m a -> Bool
loggingEnabled Config Snap AppConfig
conf) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msgs
Either SomeException ()
_ <- forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ Snap () -> IO ()
serve forall a b. (a -> b) -> a -> b
$ Snap ()
site
:: IO (Either SomeException ())
IO ()
doCleanup
where
loggingEnabled :: Config m a -> Bool
loggingEnabled = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose
loadAppConfig :: FileName
-> FilePath
-> IO C.Config
loadAppConfig :: String -> String -> IO Config
loadAppConfig String
cfg String
root = do
AnchoredDirTree String
tree <- String -> IO (AnchoredDirTree String)
buildL String
root
let groups :: [(Text, Worth String)]
groups = forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
"" forall a b. (a -> b) -> a -> b
$ forall a. AnchoredDirTree a -> DirTree a
dirTree AnchoredDirTree String
tree
[(Text, Worth String)] -> IO Config
loadGroups [(Text, Worth String)]
groups
loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' :: forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
_prefix d :: DirTree a
d@(Dir String
_ [DirTree a]
c) =
(forall a b. (a -> b) -> [a] -> [b]
map ((Text
_prefix,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Worth a
Required) forall a b. (a -> b) -> a -> b
$ forall b. String -> DirTree b -> [b]
getCfg String
cfg DirTree a
d) forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\DirTree a
a -> forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg (String -> Text
nextPrefix forall a b. (a -> b) -> a -> b
$ forall a. DirTree a -> String
name DirTree a
a) DirTree a
a) [DirTree a]
snaplets
where
nextPrefix :: String -> Text
nextPrefix String
p = [Text] -> Text
T.concat [Text
_prefix, String -> Text
T.pack String
p, Text
"."]
snapletsDirs :: [DirTree a]
snapletsDirs = forall a. (a -> Bool) -> [a] -> [a]
filter forall t. DirTree t -> Bool
isSnapletsDir [DirTree a]
c
snaplets :: [DirTree a]
snaplets = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> Bool) -> [a] -> [a]
filter forall t. DirTree t -> Bool
isDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DirTree a -> [DirTree a]
contents) [DirTree a]
snapletsDirs
loadAppConfig' String
_ Text
_ DirTree a
_ = []
isSnapletsDir :: DirTree t -> Bool
isSnapletsDir :: forall t. DirTree t -> Bool
isSnapletsDir (Dir String
"snaplets" [DirTree t]
_) = Bool
True
isSnapletsDir DirTree t
_ = Bool
False
isDir :: DirTree t -> Bool
isDir :: forall t. DirTree t -> Bool
isDir (Dir String
_ [DirTree t]
_) = Bool
True
isDir DirTree t
_ = Bool
False
isCfg :: FileName -> DirTree t -> Bool
isCfg :: forall t. String -> DirTree t -> Bool
isCfg String
cfg (File String
n t
_) = String
cfg forall a. Eq a => a -> a -> Bool
== String
n
isCfg String
_ DirTree t
_ = Bool
False
getCfg :: FileName -> DirTree b -> [b]
getCfg :: forall b. String -> DirTree b -> [b]
getCfg String
cfg (Dir String
_ [DirTree b]
c) = forall a b. (a -> b) -> [a] -> [b]
map forall a. DirTree a -> a
file forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall t. String -> DirTree t -> Bool
isCfg String
cfg) [DirTree b]
c
getCfg String
_ DirTree b
_ = []