{-# 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 :: 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 :: (InitializerState b -> InitializerState b) -> Initializer b v ()
iModify f :: 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 :: (InitializerState b -> a) -> Initializer b v a
iGets f :: 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 :: 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 :: 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 :: (v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook f :: v -> IO (Either Text v)
f (Snaplet cfg :: SnapletConfig
cfg reset :: v -> IO ()
reset val :: 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 :: (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' :: (Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' h :: 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 :: (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 :: (Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook h :: 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' :: ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' l :: ALens' b a
l h :: a -> m (Either e a)
h b :: 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 -> e -> Either e b
forall a b. a -> Either a b
Left e
e
Right v' :: 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 :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg f :: 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
$ \c :: SnapletConfig
c -> SnapletConfig -> SnapletConfig
f SnapletConfig
c
setupFilesystem :: Maybe (IO FilePath)
-> FilePath
-> Initializer b v ()
setupFilesystem :: Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Nothing _ = () -> Initializer b v ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupFilesystem (Just getSnapletDataDir :: IO String
getSnapletDataDir) targetDir :: 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 "...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 srcRoot :: String
srcRoot targetRoot :: String
targetRoot filename :: 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 :: Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet snapletId :: Text
snapletId desc :: Text
desc getSnapletDataDir :: Maybe (IO String)
getSnapletDataDir m :: 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
$ \c :: 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
$ \c :: 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
</> "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
["Initializing "
,String
sid
," @ /"
,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]
++ ".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 :: Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet m :: 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 :: Initializer b v a -> Initializer b v a
bracketInit m :: 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 :: ByteString -> Initializer b v ()
setupSnapletCall rte :: 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 :: ByteString
-> SnapletLens v v1
-> SnapletInit b v1
-> Initializer b v (Snaplet v1)
nestSnaplet rte :: ByteString
rte l :: SnapletLens v v1
l (SnapletInit snaplet :: 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 :: ByteString
-> SnapletLens v v1
-> SnapletInit v1 v1
-> Initializer b v (Snaplet v1)
embedSnaplet rte :: ByteString
rte l :: SnapletLens v v1
l (SnapletInit snaplet :: 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
-> 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 :: ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot rte :: ByteString
rte l :: SnapletLens (Snaplet b) v1
l (Initializer m :: 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 f :: 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
a,s :: InitializerState v1
s), (Hook 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 :: SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler l :: SnapletLens (Snaplet v) b'
l (Handler h :: 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
a, s' :: 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 :: Text -> SnapletInit b v -> SnapletInit b v
nameSnaplet nm :: Text
nm (SnapletInit m :: 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 :: [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes rs :: [(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 (r :: ByteString
r,h :: 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 (\v :: 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 r :: 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 :: (Handler b v () -> Handler b v ()) -> Initializer b v ()
wrapSite f0 :: 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 (\v :: 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 :: (Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter f :: 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
$ \m :: 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 m :: 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 :: IO () -> Initializer b v ()
onUnload m :: 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 curCleanup :: 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 ref :: IORef Text
ref msg :: Text
msg = IORef Text -> (Text -> (Text, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Text
ref (\cur :: Text
cur -> (Text
cur Text -> Text -> Text
`T.append` Text
msg, ()))
printInfo :: Text -> Initializer b v ()
printInfo :: Text -> Initializer b v ()
printInfo msg :: 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` "\n")
mkReloader :: FilePath
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader :: String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader cwd :: String
cwd env :: String
env resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter cleanupRef :: IORef (IO ())
cleanupRef i :: 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 (b :: Snaplet b
b,is :: 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 :: Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (Handler m :: Lensed (Snaplet b) (Snaplet b) Snap a
m) mvar :: 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, _) <- 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 :: v -> Handler b v ()
modifyMaster v :: 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 :: ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter env :: String
env b :: 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' :: ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter env :: String
env b :: Initializer b b (Snaplet b)
b@(Initializer i :: LensT
(Snaplet b)
(Snaplet b)
(InitializerState b)
(WriterT (Hook b) IO)
(Snaplet b)
i) cwd :: 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 = [("/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 "" 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 ""
let body :: IO (Either Text (Snaplet b, InitializerState b))
body = do
((res :: Snaplet b
res, s :: InitializerState b
s), (Hook 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 e :: 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
[ "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)
, ""
, "...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 :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet env :: Maybe String
env (SnapletInit b :: 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 f :: 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 "devel" Maybe String
env) Initializer b b (Snaplet b)
b
let go :: (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go (siteSnaplet :: Snaplet b
siteSnaplet,is :: 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
. ('\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 :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig config :: Config Snap a
config handler :: 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 :: Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnaplet startConfig :: Config Snap AppConfig
startConfig initializer :: 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 :: Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnapletNoArgParsing config :: Config Snap AppConfig
config initializer :: 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
(msgs :: Text
msgs, handler :: Snap ()
handler, doCleanup :: 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
(conf :: Config Snap AppConfig
conf, site :: 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 "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 cfg :: String
cfg root :: 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 "" (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' :: String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' cfg :: String
cfg _prefix :: Text
_prefix d :: DirTree a
d@(Dir _ c :: [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 (\a :: 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 p :: String
p = [Text] -> Text
T.concat [Text
_prefix, String -> Text
T.pack String
p, "."]
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' _ _ _ = []
isSnapletsDir :: DirTree t -> Bool
isSnapletsDir :: DirTree t -> Bool
isSnapletsDir (Dir "snaplets" _) = Bool
True
isSnapletsDir _ = Bool
False
isDir :: DirTree t -> Bool
isDir :: DirTree t -> Bool
isDir (Dir _ _) = Bool
True
isDir _ = Bool
False
isCfg :: FileName -> DirTree t -> Bool
isCfg :: String -> DirTree t -> Bool
isCfg cfg :: String
cfg (File n :: String
n _) = String
cfg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n
isCfg _ _ = Bool
False
getCfg :: FileName -> DirTree b -> [b]
getCfg :: String -> DirTree b -> [b]
getCfg cfg :: String
cfg (Dir _ c :: [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 _ _ = []