{-# 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 = LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState b)
-> Initializer b v (InitializerState b)
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer (LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState b)
-> Initializer b v (InitializerState b))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState b)
-> Initializer b v (InitializerState b)
forall a b. (a -> b) -> a -> b
$ LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState 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 = LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
-> Initializer b v ()
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer (LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
-> Initializer b v ())
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
-> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ do
InitializerState b
b <- LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState b)
forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
InitializerState b
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
forall (m :: * -> *) s b v. Monad m => s -> LensT b v s m ()
LT.putBase (InitializerState b
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
())
-> InitializerState b
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
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 = LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer (LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a)
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
forall a b. (a -> b) -> a -> b
$ do
InitializerState b
b <- LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(InitializerState b)
forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
a
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a)
-> a
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
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 = ([(ByteString, Handler b b ())] -> [ByteString])
-> Initializer b v [(ByteString, Handler b b ())]
-> Initializer b v [ByteString]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((ByteString, Handler b b ()) -> ByteString)
-> [(ByteString, Handler b b ())] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Handler b b ()) -> ByteString
forall a b. (a, b) -> a
fst) (Initializer b v [(ByteString, Handler b b ())]
-> Initializer b v [ByteString])
-> Initializer b v [(ByteString, Handler b b ())]
-> Initializer b v [ByteString]
forall a b. (a -> b) -> a -> b
$ (InitializerState b -> [(ByteString, Handler b b ())])
-> Initializer b v [(ByteString, Handler b b ())]
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> [(ByteString, Handler b b ())]
forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers
getEnvironment :: Initializer b v String
getEnvironment :: forall b v. Initializer b v String
getEnvironment = (InitializerState b -> String) -> Initializer b v String
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> String
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
Either Text (Snaplet v) -> IO (Either Text (Snaplet v))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Snaplet v) -> IO (Either Text (Snaplet v)))
-> Either Text (Snaplet v) -> IO (Either Text (Snaplet v))
forall a b. (a -> b) -> a -> b
$! SnapletConfig -> (v -> IO ()) -> v -> Snaplet v
forall s. SnapletConfig -> (s -> IO ()) -> s -> Snaplet s
Snaplet SnapletConfig
cfg v -> IO ()
reset (v -> Snaplet v) -> Either Text v -> Either Text (Snaplet v)
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 = (Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' ((Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ())
-> ((v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v)))
-> (v -> IO (Either Text v))
-> Initializer b v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
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' <- (Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
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
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
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 = LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
-> Initializer b v ()
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer (LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
-> Initializer b v ())
-> ((Snaplet b -> IO (Either Text (Snaplet b)))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
())
-> (Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (Hook b) IO ()
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Hook b) IO ()
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
())
-> ((Snaplet b -> IO (Either Text (Snaplet b)))
-> WriterT (Hook b) IO ())
-> (Snaplet b -> IO (Either Text (Snaplet b)))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hook b -> WriterT (Hook b) IO ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Hook b -> WriterT (Hook b) IO ())
-> ((Snaplet b -> IO (Either Text (Snaplet b))) -> Hook b)
-> (Snaplet b -> IO (Either Text (Snaplet b)))
-> WriterT (Hook b) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Snaplet b -> IO (Either Text (Snaplet b))) -> Hook b
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 = LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer (LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b))))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
forall a b. (a -> b) -> a -> b
$ do
ALens' (Snaplet b) (Snaplet v)
l <- LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(ALens' (Snaplet b) (Snaplet v))
forall r (m :: * -> *). MonadReader r m => m r
ask
(Snaplet b -> IO (Either Text (Snaplet b)))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b)))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Snaplet b -> IO (Either Text (Snaplet b)))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b))))
-> (Snaplet b -> IO (Either Text (Snaplet b)))
-> LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b -> IO (Either Text (Snaplet b)))
forall a b. (a -> b) -> a -> b
$ ALens' (Snaplet b) (Snaplet v)
-> (Snaplet v -> IO (Either Text (Snaplet v)))
-> Snaplet b
-> IO (Either Text (Snaplet 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 b -> ALens' b a -> a
forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l)
Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ case Either e a
v of
Left e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right a
v' -> b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> b -> Either e b
forall a b. (a -> b) -> a -> b
$ ALens' b a -> a -> b -> 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 = (InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify ((InitializerState b -> InitializerState b) -> Initializer b v ())
-> (InitializerState b -> InitializerState b) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter
(InitializerState b)
(InitializerState b)
SnapletConfig
SnapletConfig
-> (SnapletConfig -> SnapletConfig)
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
(InitializerState b)
(InitializerState b)
SnapletConfig
SnapletConfig
forall b. Lens' (InitializerState b) SnapletConfig
curConfig ((SnapletConfig -> SnapletConfig)
-> InitializerState b -> InitializerState b)
-> (SnapletConfig -> SnapletConfig)
-> InitializerState b
-> InitializerState b
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
_ = () -> Initializer b v ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupFilesystem (Just IO String
getSnapletDataDir) String
targetDir = do
Bool
exists <- IO Bool -> Initializer b v Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Initializer b v Bool)
-> IO Bool -> Initializer b v Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
targetDir
Bool -> Initializer b v () -> Initializer b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Initializer b v () -> Initializer b v ())
-> Initializer b v () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ do
Text -> Initializer b v ()
forall b v. Text -> Initializer b v ()
printInfo Text
"...setting up filesystem"
IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetDir
String
srcDir <- IO String -> Initializer b v String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getSnapletDataDir
IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ()))
-> IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ())
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> String -> IO (AnchoredDirTree ())
forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
readDirectoryWith (String -> String -> String -> IO ()
doCopy String
srcDir String
targetDir) String
srcDir
() -> Initializer b v ()
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 = Initializer b v (Snaplet v) -> SnapletInit b v
forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit (Initializer b v (Snaplet v) -> SnapletInit b v)
-> Initializer b v (Snaplet v) -> SnapletInit b v
forall a b. (a -> b) -> a -> b
$ do
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> if Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ SnapletConfig -> Maybe Text
_scId SnapletConfig
c
then ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
-> Maybe Text -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
Lens' SnapletConfig (Maybe Text)
scId (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
snapletId) SnapletConfig
c else SnapletConfig
c
String
sid <- (InitializerState b -> String) -> Initializer b v String
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (Text -> String
T.unpack (Text -> String)
-> (InitializerState b -> Text) -> InitializerState b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text)
-> (InitializerState b -> Maybe Text) -> InitializerState b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId (SnapletConfig -> Maybe Text)
-> (InitializerState b -> SnapletConfig)
-> InitializerState b
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig)
Bool
topLevel <- (InitializerState b -> Bool) -> Initializer b v Bool
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> Bool
forall b. InitializerState b -> Bool
_isTopLevel
Bool -> Initializer b v () -> Initializer b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topLevel (Initializer b v () -> Initializer b v ())
-> Initializer b v () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ do
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter SnapletConfig SnapletConfig Config Config
-> (Config -> Config) -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter SnapletConfig SnapletConfig Config Config
Lens' SnapletConfig Config
scUserConfig (Text -> Config -> Config
subconfig (String -> Text
T.pack String
sid))
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> ASetter SnapletConfig SnapletConfig String String
-> String -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig String String
Lens' SnapletConfig String
scFilePath
(SnapletConfig -> String
_scFilePath SnapletConfig
c String -> String -> String
</> String
"snaplets" String -> String -> String
</> String
sid) SnapletConfig
c
(InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (ASetter (InitializerState b) (InitializerState b) Bool Bool
-> Bool -> InitializerState b -> InitializerState b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (InitializerState b) (InitializerState b) Bool Bool
forall b. Lens' (InitializerState b) Bool
isTopLevel Bool
False)
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter SnapletConfig SnapletConfig Text Text
-> Text -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig Text Text
Lens' SnapletConfig Text
scDescription Text
desc
SnapletConfig
cfg <- (InitializerState b -> SnapletConfig)
-> Initializer b v SnapletConfig
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig
Text -> Initializer b v ()
forall b v. Text -> Initializer b v ()
printInfo (Text -> Initializer b v ()) -> Text -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[String
"Initializing "
,String
sid
,String
" @ /"
,ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
buildPath ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ SnapletConfig -> [ByteString]
_scRouteContext SnapletConfig
cfg
]
Maybe (IO String) -> String -> Initializer b v ()
forall b v. Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Maybe (IO String)
getSnapletDataDir (SnapletConfig -> String
_scFilePath SnapletConfig
cfg)
String
env <- (InitializerState b -> String) -> Initializer b v String
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> String
forall b. InitializerState b -> String
_environment
let configLocation :: String
configLocation = SnapletConfig -> String
_scFilePath SnapletConfig
cfg String -> String -> String
</> (String
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".cfg")
IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ [Worth String] -> Config -> IO ()
addToConfig [String -> Worth String
forall a. a -> Worth a
Optional String
configLocation]
(SnapletConfig -> Config
_scUserConfig SnapletConfig
cfg)
Initializer b v v -> Initializer b v (Snaplet v)
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 <- (InitializerState b -> SnapletConfig)
-> Initializer b v SnapletConfig
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig
(Snaplet b -> Snaplet b) -> IO ()
setInTop <- (InitializerState b -> (Snaplet b -> Snaplet b) -> IO ())
-> Initializer b v ((Snaplet b -> Snaplet b) -> IO ())
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader
SnapletLens (Snaplet b) v
l <- Initializer b v (SnapletLens (Snaplet b) v)
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 ((Snaplet b -> Snaplet b) -> IO ())
-> (v -> Snaplet b -> Snaplet b) -> v -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter (Snaplet b) (Snaplet b) v v -> v -> Snaplet b -> Snaplet b
forall s t a b. ASetter s t a b -> b -> s -> t
set (SnapletLens (Snaplet b) v
-> Lens (Snaplet b) (Snaplet b) (Snaplet v) (Snaplet v)
forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
l ((Snaplet v -> Identity (Snaplet v))
-> Snaplet b -> Identity (Snaplet b))
-> ((v -> Identity v) -> Snaplet v -> Identity (Snaplet v))
-> ASetter (Snaplet b) (Snaplet b) v v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> Identity v) -> Snaplet v -> Identity (Snaplet v)
forall s. Lens' (Snaplet s) s
snapletValue)
Snaplet v -> Initializer b v (Snaplet v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Snaplet v -> Initializer b v (Snaplet v))
-> Snaplet v -> Initializer b v (Snaplet v)
forall a b. (a -> b) -> a -> b
$ SnapletConfig -> (v -> IO ()) -> v -> Snaplet v
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 <- Initializer b v (InitializerState b)
forall b v. Initializer b v (InitializerState b)
iGet
a
res <- Initializer b v a
m
(InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (ASetter
(InitializerState b)
(InitializerState b)
SnapletConfig
SnapletConfig
-> SnapletConfig -> InitializerState b -> InitializerState b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(InitializerState b)
(InitializerState b)
SnapletConfig
SnapletConfig
forall b. Lens' (InitializerState b) SnapletConfig
curConfig (InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig InitializerState b
s))
a -> Initializer b v a
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 <- (InitializerState b -> Text) -> Initializer b v Text
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text)
-> (InitializerState b -> Maybe Text) -> InitializerState b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId (SnapletConfig -> Maybe Text)
-> (InitializerState b -> SnapletConfig)
-> InitializerState b
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig)
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (ASetter SnapletConfig SnapletConfig [Text] [Text]
-> ([Text] -> [Text]) -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter SnapletConfig SnapletConfig [Text] [Text]
Lens' SnapletConfig [Text]
scAncestry (Text
curIdText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:))
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
-> (Maybe Text -> Maybe Text) -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
Lens' SnapletConfig (Maybe Text)
scId (Maybe Text -> Maybe Text -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing))
Bool -> Initializer b v () -> Initializer b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
rte) (Initializer b v () -> Initializer b v ())
-> Initializer b v () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (ASetter SnapletConfig SnapletConfig [ByteString] [ByteString]
-> ([ByteString] -> [ByteString]) -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter SnapletConfig SnapletConfig [ByteString] [ByteString]
Lens' SnapletConfig [ByteString]
scRouteContext (ByteString
rteByteString -> [ByteString] -> [ByteString]
forall 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) =
SnapletLens v v1
-> Initializer b v1 (Snaplet v1) -> Initializer b v (Snaplet v1)
forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens v v1
l (Initializer b v1 (Snaplet v1) -> Initializer b v (Snaplet v1))
-> Initializer b v1 (Snaplet v1) -> Initializer b v (Snaplet v1)
forall a b. (a -> b) -> a -> b
$ Initializer b v1 (Snaplet v1) -> Initializer b v1 (Snaplet v1)
forall b v a. Initializer b v a -> Initializer b v a
bracketInit (Initializer b v1 (Snaplet v1) -> Initializer b v1 (Snaplet v1))
-> Initializer b v1 (Snaplet v1) -> Initializer b v1 (Snaplet v1)
forall a b. (a -> b) -> a -> b
$ do
ByteString -> Initializer b v1 ()
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) = Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1)
forall b v a. Initializer b v a -> Initializer b v a
bracketInit (Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1))
-> Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1)
forall a b. (a -> b) -> a -> b
$ do
SnapletLens (Snaplet b) v
curLens <- Initializer b v (SnapletLens (Snaplet b) v)
forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
ByteString -> Initializer b v ()
forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
""
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 (Snaplet v1)
-> Initializer b v (Snaplet v1)
forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte (SnapletLens (Snaplet b) v
-> Lens (Snaplet b) (Snaplet b) (Snaplet v) (Snaplet v)
forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
curLens ((Snaplet v -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v))
-> Snaplet b -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet b))
-> ((Snaplet v1
-> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v1))
-> Snaplet v -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v))
-> SnapletLens (Snaplet b) v1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletLens v v1
-> (Snaplet v1
-> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v1))
-> Snaplet v
-> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v)
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 <- Initializer b v (InitializerState b)
forall b v. Initializer b v (InitializerState b)
iGet
let newSetter :: (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter Snaplet v1 -> Snaplet v1
f = InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader InitializerState b
curState (ASetter (Snaplet b) (Snaplet b) (Snaplet v1) (Snaplet v1)
-> (Snaplet v1 -> Snaplet v1) -> Snaplet b -> Snaplet b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (SnapletLens (Snaplet b) v1
-> Lens (Snaplet b) (Snaplet b) (Snaplet v1) (Snaplet v1)
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)) <- IO ((a, InitializerState v1), Hook v1)
-> Initializer b v ((a, InitializerState v1), Hook v1)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((a, InitializerState v1), Hook v1)
-> Initializer b v ((a, InitializerState v1), Hook v1))
-> IO ((a, InitializerState v1), Hook v1)
-> Initializer b v ((a, InitializerState v1), Hook v1)
forall a b. (a -> b) -> a -> b
$ WriterT (Hook v1) IO (a, InitializerState v1)
-> IO ((a, InitializerState v1), Hook v1)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Hook v1) IO (a, InitializerState v1)
-> IO ((a, InitializerState v1), Hook v1))
-> WriterT (Hook v1) IO (a, InitializerState v1)
-> IO ((a, InitializerState v1), Hook v1)
forall a b. (a -> b) -> a -> b
$ LensT
(Snaplet v1)
(Snaplet v1)
(InitializerState v1)
(WriterT (Hook v1) IO)
a
-> ALens' (Snaplet v1) (Snaplet v1)
-> InitializerState v1
-> WriterT (Hook v1) IO (a, InitializerState v1)
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 ALens' (Snaplet v1) (Snaplet v1)
forall a. a -> a
id (InitializerState v1
-> WriterT (Hook v1) IO (a, InitializerState v1))
-> InitializerState v1
-> WriterT (Hook v1) IO (a, InitializerState v1)
forall a b. (a -> b) -> a -> b
$
InitializerState b
curState {
_handlers :: [(ByteString, Handler v1 v1 ())]
_handlers = [],
_hFilter :: Handler v1 v1 () -> Handler v1 v1 ()
_hFilter = Handler v1 v1 () -> Handler v1 v1 ()
forall a. a -> a
id,
masterReloader :: (Snaplet v1 -> Snaplet v1) -> IO ()
masterReloader = (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter
}
let handler :: Handler b b ()
handler = SnapletLens (Snaplet b) v1 -> Handler v1 v1 () -> Handler b b ()
forall v b' a b.
SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler SnapletLens (Snaplet b) v1
l (Handler v1 v1 () -> Handler b b ())
-> Handler v1 v1 () -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ InitializerState v1 -> Handler v1 v1 () -> Handler v1 v1 ()
forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState v1
s (Handler v1 v1 () -> Handler v1 v1 ())
-> Handler v1 v1 () -> Handler v1 v1 ()
forall a b. (a -> b) -> a -> b
$ [(ByteString, Handler v1 v1 ())] -> Handler v1 v1 ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route ([(ByteString, Handler v1 v1 ())] -> Handler v1 v1 ())
-> [(ByteString, Handler v1 v1 ())] -> Handler v1 v1 ()
forall a b. (a -> b) -> a -> b
$ InitializerState v1 -> [(ByteString, Handler v1 v1 ())]
forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState v1
s
(InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify ((InitializerState b -> InitializerState b) -> Initializer b v ())
-> (InitializerState b -> InitializerState b) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter
(InitializerState b)
(InitializerState b)
[(ByteString, Handler b b ())]
[(ByteString, Handler b b ())]
-> ([(ByteString, Handler b b ())]
-> [(ByteString, Handler b b ())])
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
(InitializerState b)
(InitializerState b)
[(ByteString, Handler b b ())]
[(ByteString, Handler b b ())]
forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers ([(ByteString, Handler b b ())]
-> [(ByteString, Handler b b ())] -> [(ByteString, Handler b b ())]
forall a. [a] -> [a] -> [a]
++[(ByteString
rte,Handler b b ()
handler)])
(InitializerState b -> InitializerState b)
-> (InitializerState b -> InitializerState b)
-> InitializerState b
-> InitializerState b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
(InitializerState b)
(InitializerState b)
(IORef (IO ()))
(IORef (IO ()))
-> IORef (IO ()) -> InitializerState b -> InitializerState b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
(InitializerState b)
(InitializerState b)
(IORef (IO ()))
(IORef (IO ()))
forall b. Lens' (InitializerState b) (IORef (IO ()))
cleanup (InitializerState v1 -> IORef (IO ())
forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState v1
s)
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase ((Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ())
-> (Snaplet b -> IO (Either Text (Snaplet b)))
-> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet b) v1
-> (Snaplet v1 -> IO (Either Text (Snaplet v1)))
-> Snaplet b
-> IO (Either Text (Snaplet 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
a -> Initializer b v a
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) = Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler (Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a)
-> Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
forall a b. (a -> b) -> a -> b
$ do
Snaplet v
s <- Lensed (Snaplet b) (Snaplet v) Snap (Snaplet v)
forall s (m :: * -> *). MonadState s m => m s
get
(a
a, Snaplet b'
s') <- Snap (a, Snaplet b')
-> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b')
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap (a, Snaplet b')
-> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b'))
-> Snap (a, Snaplet b')
-> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b')
forall a b. (a -> b) -> a -> b
$ Lensed (Snaplet b') (Snaplet b') Snap a
-> ALens' (Snaplet b') (Snaplet b')
-> Snaplet b'
-> Snap (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
h ALens' (Snaplet b') (Snaplet b')
forall a. a -> a
id (Snaplet v
s Snaplet v -> SnapletLens (Snaplet v) b' -> Snaplet b'
forall s t a b. s -> ALens s t a b -> a
^# SnapletLens (Snaplet v) b'
l)
(Snaplet v -> Snaplet v) -> Lensed (Snaplet b) (Snaplet v) Snap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Snaplet v -> Snaplet v)
-> Lensed (Snaplet b) (Snaplet v) Snap ())
-> (Snaplet v -> Snaplet v)
-> Lensed (Snaplet b) (Snaplet v) Snap ()
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet v) b' -> Snaplet b' -> Snaplet v -> Snaplet v
forall s t a b. ALens s t a b -> b -> s -> t
storing SnapletLens (Snaplet v) b'
l Snaplet b'
s'
a -> Lensed (Snaplet b) (Snaplet v) Snap a
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) = Initializer b v (Snaplet v) -> SnapletInit b v
forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit (Initializer b v (Snaplet v) -> SnapletInit b v)
-> Initializer b v (Snaplet v) -> SnapletInit b v
forall a b. (a -> b) -> a -> b
$
(SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
-> Maybe Text -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
Lens' SnapletConfig (Maybe Text)
scId (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nm)) Initializer b v ()
-> Initializer b v (Snaplet v) -> Initializer b v (Snaplet v)
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 <- Initializer b v (SnapletLens (Snaplet b) v)
forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
[ByteString]
ctx <- (InitializerState b -> [ByteString])
-> Initializer b v [ByteString]
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (SnapletConfig -> [ByteString]
_scRouteContext (SnapletConfig -> [ByteString])
-> (InitializerState b -> SnapletConfig)
-> InitializerState b
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializerState b -> SnapletConfig
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
rByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ctx)
, ByteString -> Handler b b ()
forall {b} {v}. ByteString -> Handler b v ()
setPattern ByteString
r Handler b b () -> Handler b b () -> Handler b b ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SnapletLens (Snaplet b) v -> Handler b v () -> Handler b 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' = ((ByteString, Handler b v ()) -> (ByteString, Handler b b ()))
-> [(ByteString, Handler b v ())] -> [(ByteString, Handler b b ())]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute [(ByteString, Handler b v ())]
rs
(InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> ASetter
(InitializerState b)
(InitializerState b)
[(ByteString, Handler b b ())]
[(ByteString, Handler b b ())]
-> ([(ByteString, Handler b b ())]
-> [(ByteString, Handler b b ())])
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
(InitializerState b)
(InitializerState b)
[(ByteString, Handler b b ())]
[(ByteString, Handler b b ())]
forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers ([(ByteString, Handler b b ())]
-> [(ByteString, Handler b b ())] -> [(ByteString, Handler b b ())]
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 <- Handler b v (Maybe ByteString)
forall b v. Handler b v (Maybe ByteString)
getRoutePattern
Bool -> Handler b v () -> Handler b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
p) (Handler b v () -> Handler b v ())
-> Handler b v () -> Handler b v ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b v ()
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 <- (Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
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
(InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> ASetter
(InitializerState b)
(InitializerState b)
(Handler b b () -> Handler b b ())
(Handler b b () -> Handler b b ())
-> ((Handler b b () -> Handler b b ())
-> Handler b b () -> Handler b b ())
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
(InitializerState b)
(InitializerState b)
(Handler b b () -> Handler b b ())
(Handler b b () -> Handler b b ())
forall b.
Lens' (InitializerState b) (Handler b b () -> Handler b b ())
hFilter (Handler b b () -> Handler b b ()
f(Handler b b () -> Handler b b ())
-> (Handler b b () -> Handler b b ())
-> Handler b b ()
-> Handler b b ()
forall 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 <- LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(SnapletLens (Snaplet b) v)
-> Initializer b v (SnapletLens (Snaplet b) v)
forall b v a.
LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
a
-> Initializer b v a
Initializer LensT
(Snaplet b)
(Snaplet v)
(InitializerState b)
(WriterT (Hook b) IO)
(SnapletLens (Snaplet b) v)
forall r (m :: * -> *). MonadReader r m => m r
ask
(Handler b b () -> Handler b b ())
-> Initializer b v (Handler b b () -> Handler b b ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Handler b b () -> Handler b b ())
-> Initializer b v (Handler b b () -> Handler b b ()))
-> (Handler b b () -> Handler b b ())
-> Initializer b v (Handler b b () -> Handler b b ())
forall a b. (a -> b) -> a -> b
$ \Handler b b ()
m -> SnapletLens (Snaplet b) v -> Handler b v () -> Handler b b ()
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 (Handler b v () -> Handler b b ())
-> Handler b v () -> Handler b b ()
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 (Handler b v () -> Handler b v ())
-> Handler b v () -> Handler b v ()
forall a b. (a -> b) -> a -> b
$ Lensed (Snaplet b) (Snaplet v) Snap () -> Handler b v ()
forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler (Lensed (Snaplet b) (Snaplet v) Snap () -> Handler b v ())
-> Lensed (Snaplet b) (Snaplet v) Snap () -> Handler b v ()
forall a b. (a -> b) -> a -> b
$ ALens' (Snaplet b) (Snaplet b)
-> Lensed (Snaplet b) (Snaplet b) Snap ()
-> Lensed (Snaplet b) (Snaplet v) Snap ()
forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
L.withTop ALens' (Snaplet b) (Snaplet b)
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 <- (InitializerState b -> IORef (IO ()))
-> Initializer b v (IORef (IO ()))
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> IORef (IO ())
forall b. InitializerState b -> IORef (IO ())
_cleanup
IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> (IO () -> (IO (), ())) -> IO ()
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 IO () -> IO () -> IO ()
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 = IORef Text -> (Text -> (Text, ())) -> IO ()
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 <- (InitializerState b -> IORef Text) -> Initializer b v (IORef Text)
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages
IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
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
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
!Either Text (Snaplet b, InitializerState b)
res <- ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState 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)
i String
cwd
(Text -> IO (Either Text Text))
-> ((Snaplet b, InitializerState b) -> IO (Either Text Text))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Either Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> IO (Either Text Text))
-> (Text -> Either Text Text) -> Text -> IO (Either Text Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Text
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 (Snaplet b -> Snaplet b -> Snaplet b
forall a b. a -> b -> a
const Snaplet b
b)
Text
msgs <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (IORef Text -> IO Text) -> IORef Text -> IO Text
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
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 <- IO (Snaplet b) -> Snap (Snaplet b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar (Snaplet b) -> IO (Snaplet b)
forall a. MVar a -> IO a
readMVar MVar (Snaplet b)
mvar)
(!a
a, Snaplet b
_) <- Lensed (Snaplet b) (Snaplet b) Snap a
-> ALens' (Snaplet b) (Snaplet b)
-> Snaplet b
-> Snap (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 ALens' (Snaplet b) (Snaplet b)
forall a. a -> a
id Snaplet b
b
a -> Snap a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Snap a) -> a -> Snap a
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 <- (Snaplet v -> v -> IO ()) -> Handler b v (v -> IO ())
forall v b b1. (Snaplet v -> b) -> Handler b1 v b
getsSnapletState Snaplet v -> v -> IO ()
forall s. Snaplet s -> s -> IO ()
_snapletModifier
IO () -> Handler b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler b v ()) -> IO () -> Handler b v ()
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 IO String
-> (String -> IO (Either Text (Snaplet b, InitializerState b)))
-> IO (Either Text (Snaplet b, InitializerState b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState 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 <- IO () -> IO (IORef (IO ()))
forall a. a -> IO (IORef a)
newIORef (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
let reloader_ :: IO (Either Text Text)
reloader_ = String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
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", Handler b v ()
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 Maybe Text
forall a. Maybe a
Nothing Text
"" Config
empty [] Maybe ByteString
forall a. Maybe a
Nothing IO (Either Text Text)
reloader_
IORef Text
logRef <- Text -> IO (IORef Text)
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)) <- WriterT (Hook b) IO (Snaplet b, InitializerState b)
-> IO ((Snaplet b, InitializerState b), Hook b)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Hook b) IO (Snaplet b, InitializerState b)
-> IO ((Snaplet b, InitializerState b), Hook b))
-> WriterT (Hook b) IO (Snaplet b, InitializerState b)
-> IO ((Snaplet b, InitializerState b), Hook b)
forall a b. (a -> b) -> a -> b
$ LensT
(Snaplet b)
(Snaplet b)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b)
-> ALens' (Snaplet b) (Snaplet b)
-> InitializerState b
-> WriterT (Hook b) IO (Snaplet b, InitializerState 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 ALens' (Snaplet b) (Snaplet b)
forall a. a -> a
id (InitializerState b
-> WriterT (Hook b) IO (Snaplet b, InitializerState b))
-> InitializerState b
-> WriterT (Hook b) IO (Snaplet b, InitializerState b)
forall a b. (a -> b) -> a -> 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
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 [(ByteString, Handler b b ())]
forall {a} {b} {v}. IsString a => [(a, Handler b v ())]
builtinHandlers Handler b b () -> Handler b b ()
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
Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b)))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b))
forall a b. (a -> b) -> a -> b
$ (,InitializerState b
s) (Snaplet b -> (Snaplet b, InitializerState b))
-> Either Text (Snaplet b)
-> Either Text (Snaplet b, InitializerState b)
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
IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
Text
logMessages <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef IORef Text
logRef
Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b)))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Either Text (Snaplet b, InitializerState b))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Snaplet b, InitializerState b)
forall a b. a -> Either a b
Left (Text -> Either Text (Snaplet b, InitializerState b))
-> Text -> Either Text (Snaplet b, InitializerState b)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
[ Text
"Initializer threw an exception..."
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException)
, Text
""
, Text
"...but before it died it generated the following output:"
, Text
logMessages
]
IO (Either Text (Snaplet b, InitializerState b))
-> (SomeException
-> IO (Either Text (Snaplet b, InitializerState b)))
-> IO (Either Text (Snaplet b, InitializerState b))
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 <- IO (MVar (Snaplet b))
forall a. IO (MVar a)
newEmptyMVar
let resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter Snaplet b -> Snaplet b
f = MVar (Snaplet b) -> (Snaplet b -> IO (Snaplet b)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Snaplet b)
snapletMVar (Snaplet b -> IO (Snaplet b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Snaplet b -> IO (Snaplet b))
-> (Snaplet b -> Snaplet b) -> Snaplet b -> IO (Snaplet b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snaplet b -> Snaplet b
f)
Either Text (Snaplet b, InitializerState b)
eRes <- ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
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 -> Maybe String -> String
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
MVar (Snaplet b) -> Snaplet b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Snaplet b)
snapletMVar Snaplet b
siteSnaplet
Text
msgs <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (IORef Text -> IO Text) -> IORef Text -> IO Text
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
let handler :: Snap ()
handler = Handler b b () -> MVar (Snaplet b) -> Snap ()
forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (InitializerState b -> Handler b b () -> Handler b b ()
forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState b
is (Handler b b () -> Handler b b ())
-> Handler b b () -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ [(ByteString, Handler b b ())] -> Handler b b ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route ([(ByteString, Handler b b ())] -> Handler b b ())
-> [(ByteString, Handler b b ())] -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ InitializerState b -> [(ByteString, Handler b b ())]
forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState b
is) MVar (Snaplet b)
snapletMVar
IO ()
cleanupAction <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef (IORef (IO ()) -> IO (IO ())) -> IORef (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef (IO ())
forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState b
is
(Text, Snap (), IO ()) -> IO (Text, Snap (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
msgs, Snap ()
handler, IO ()
cleanupAction)
(Text -> IO (Text, Snap (), IO ()))
-> ((Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ()))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Text, Snap (), IO ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Text, Snap (), IO ())
forall a. HasCallStack => String -> a
error (String -> IO (Text, Snap (), IO ()))
-> (Text -> String) -> Text -> IO (Text, Snap (), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Text -> String) -> Text -> String
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 <- Config Snap a -> IO (Config Snap a)
forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config
let catch500 :: Snap () -> Snap ()
catch500 = ((Snap () -> (SomeException -> Snap ()) -> Snap ())
-> (SomeException -> Snap ()) -> Snap () -> Snap ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Snap () -> (SomeException -> Snap ()) -> Snap ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch ((SomeException -> Snap ()) -> Snap () -> Snap ())
-> (SomeException -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ Maybe (SomeException -> Snap ()) -> SomeException -> Snap ()
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (SomeException -> Snap ()) -> SomeException -> Snap ())
-> Maybe (SomeException -> Snap ()) -> SomeException -> Snap ()
forall a b. (a -> b) -> a -> b
$ Config Snap a -> Maybe (SomeException -> Snap ())
forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
getErrorHandler Config Snap a
conf)
let compress :: Snap () -> Snap ()
compress = if Maybe Bool -> Bool
forall a. HasCallStack => Maybe a -> a
fromJust (Config Snap a -> Maybe Bool
forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config Snap a
conf)
then Snap () -> Snap ()
forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else Snap () -> Snap ()
forall a. a -> a
id
let site :: Snap ()
site = Snap () -> Snap ()
compress (Snap () -> Snap ()) -> Snap () -> Snap ()
forall a b. (a -> b) -> a -> b
$ Snap () -> Snap ()
catch500 Snap ()
handler
(Config Snap a, Snap ()) -> IO (Config Snap a, Snap ())
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 <- Config Snap AppConfig -> IO (Config Snap AppConfig)
forall (m :: * -> *).
MonadSnap m =>
Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig Config Snap AppConfig
startConfig
Config Snap AppConfig -> SnapletInit b b -> IO ()
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 (AppConfig -> Maybe String) -> Maybe AppConfig -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config Snap AppConfig -> Maybe AppConfig
forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config Snap AppConfig
config
(Text
msgs, Snap ()
handler, IO ()
doCleanup) <- Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
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) <- Config Snap AppConfig
-> Snap () -> IO (Config Snap AppConfig, Snap ())
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 = Config Snap AppConfig -> Snap () -> IO ()
forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap AppConfig
conf
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config Snap AppConfig -> Bool
forall {m :: * -> *} {a}. Config m a -> Bool
loggingEnabled Config Snap AppConfig
conf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msgs
Either SomeException ()
_ <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ Snap () -> IO ()
serve (Snap () -> IO ()) -> Snap () -> IO ()
forall a b. (a -> b) -> a -> b
$ Snap ()
site
:: IO (Either SomeException ())
IO ()
doCleanup
where
loggingEnabled :: Config m a -> Bool
loggingEnabled = Bool -> Bool
not (Bool -> Bool) -> (Config m a -> Bool) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False) (Maybe Bool -> Bool)
-> (Config m a -> Maybe Bool) -> Config m a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config m a -> Maybe Bool
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 = String -> Text -> DirTree String -> [(Text, Worth String)]
forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
"" (DirTree String -> [(Text, Worth String)])
-> DirTree String -> [(Text, Worth String)]
forall a b. (a -> b) -> a -> b
$ AnchoredDirTree String -> DirTree String
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) =
((a -> (Text, Worth a)) -> [a] -> [(Text, Worth a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
_prefix,) (Worth a -> (Text, Worth a))
-> (a -> Worth a) -> a -> (Text, Worth a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Worth a
forall a. a -> Worth a
Required) ([a] -> [(Text, Worth a)]) -> [a] -> [(Text, Worth a)]
forall a b. (a -> b) -> a -> b
$ String -> DirTree a -> [a]
forall b. String -> DirTree b -> [b]
getCfg String
cfg DirTree a
d) [(Text, Worth a)] -> [(Text, Worth a)] -> [(Text, Worth a)]
forall a. [a] -> [a] -> [a]
++
(DirTree a -> [(Text, Worth a)])
-> [DirTree a] -> [(Text, Worth a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\DirTree a
a -> String -> Text -> DirTree a -> [(Text, Worth a)]
forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg (String -> Text
nextPrefix (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ DirTree a -> String
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 = (DirTree a -> Bool) -> [DirTree a] -> [DirTree a]
forall a. (a -> Bool) -> [a] -> [a]
filter DirTree a -> Bool
forall t. DirTree t -> Bool
isSnapletsDir [DirTree a]
c
snaplets :: [DirTree a]
snaplets = (DirTree a -> [DirTree a]) -> [DirTree a] -> [DirTree a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((DirTree a -> Bool) -> [DirTree a] -> [DirTree a]
forall a. (a -> Bool) -> [a] -> [a]
filter DirTree a -> Bool
forall t. DirTree t -> Bool
isDir ([DirTree a] -> [DirTree a])
-> (DirTree a -> [DirTree a]) -> DirTree a -> [DirTree a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DirTree a -> [DirTree a]
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 String -> String -> Bool
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) = (DirTree b -> b) -> [DirTree b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map DirTree b -> b
forall a. DirTree a -> a
file ([DirTree b] -> [b]) -> [DirTree b] -> [b]
forall a b. (a -> b) -> a -> b
$ (DirTree b -> Bool) -> [DirTree b] -> [DirTree b]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> DirTree b -> Bool
forall t. String -> DirTree t -> Bool
isCfg String
cfg) [DirTree b]
c
getCfg String
_ DirTree b
_ = []