{-# 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
------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | 'get' for InitializerState.
iGet :: Initializer b v (InitializerState b)
iGet :: forall b v. Initializer b v (InitializerState b)
iGet = forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase


------------------------------------------------------------------------------
-- | 'modify' for InitializerState.
iModify :: (InitializerState b -> InitializerState b) -> Initializer b v ()
iModify :: forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify InitializerState b -> InitializerState b
f = forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
    InitializerState b
b <- forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
    forall (m :: * -> *) s b v. Monad m => s -> LensT b v s m ()
LT.putBase forall a b. (a -> b) -> a -> b
$ InitializerState b -> InitializerState b
f InitializerState b
b


------------------------------------------------------------------------------
-- | 'gets' for InitializerState.
iGets :: (InitializerState b -> a) -> Initializer b v a
iGets :: forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> a
f = forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
    InitializerState b
b <- forall (m :: * -> *) b v s. Monad m => LensT b v s m s
LT.getBase
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ InitializerState b -> a
f InitializerState b
b


------------------------------------------------------------------------------
-- | Lets you retrieve the list of routes currently set up by an Initializer.
-- This can be useful in debugging.
getRoutes :: Initializer b v [ByteString]
getRoutes :: forall b v. Initializer b v [ByteString]
getRoutes = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers

------------------------------------------------------------------------------
-- | Return the current environment string.  This will be the
-- environment given to 'runSnaplet' or from the command line when
-- using 'serveSnaplet'.  Useful for changing behavior during
-- development and testing.
getEnvironment :: Initializer b v String
getEnvironment :: forall b v. Initializer b v String
getEnvironment = forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> String
_environment

------------------------------------------------------------------------------
-- | Converts a plain hook into a Snaplet hook.
toSnapletHook :: (v -> IO (Either Text v))
              -> (Snaplet v -> IO (Either Text (Snaplet v)))
toSnapletHook :: forall v.
(v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook v -> IO (Either Text v)
f (Snaplet SnapletConfig
cfg  v -> IO ()
reset v
val) = do
    Either Text v
val' <- v -> IO (Either Text v)
f v
val
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s. SnapletConfig -> (s -> IO ()) -> s -> Snaplet s
Snaplet SnapletConfig
cfg v -> IO ()
reset forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text v
val'


------------------------------------------------------------------------------
-- | Adds an IO action that modifies the current snaplet state to be run at
-- the end of initialization on the state that was created.  This makes it
-- easier to allow one snaplet's state to be modified by another snaplet's
-- initializer.  A good example of this is when a snaplet has templates that
-- define its views.  The Heist snaplet provides the 'addTemplates' function
-- which allows other snaplets to set up their own templates.  'addTemplates'
-- is implemented using this function.
addPostInitHook :: (v -> IO (Either Text v))
                -> Initializer b v ()
addPostInitHook :: forall v b. (v -> IO (Either Text v)) -> Initializer b v ()
addPostInitHook = forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v.
(v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook


addPostInitHook' :: (Snaplet v -> IO (Either Text (Snaplet v)))
                 -> Initializer b v ()
addPostInitHook' :: forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' Snaplet v -> IO (Either Text (Snaplet v))
h = do
    Snaplet b -> IO (Either Text (Snaplet b))
h' <- forall v b.
(Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook Snaplet v -> IO (Either Text (Snaplet v))
h
    forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase Snaplet b -> IO (Either Text (Snaplet b))
h'


------------------------------------------------------------------------------
-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.
addPostInitHookBase :: (Snaplet b -> IO (Either Text (Snaplet b)))
                    -> Initializer b v ()
addPostInitHookBase :: forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase = forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Snaplet a -> IO (Either Text (Snaplet a))) -> Hook a
Hook


------------------------------------------------------------------------------
-- | Helper function for transforming hooks.
upHook :: (Snaplet v -> IO (Either Text (Snaplet v)))
       -> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook :: forall v b.
(Snaplet v -> IO (Either Text (Snaplet v)))
-> Initializer b v (Snaplet b -> IO (Either Text (Snaplet b)))
upHook Snaplet v -> IO (Either Text (Snaplet v))
h = forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall a b. (a -> b) -> a -> b
$ do
    ALens' (Snaplet b) (Snaplet v)
l <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' ALens' (Snaplet b) (Snaplet v)
l Snaplet v -> IO (Either Text (Snaplet v))
h


------------------------------------------------------------------------------
-- | Helper function for transforming hooks.
upHook' :: Monad m => ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' :: forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' ALens' b a
l a -> m (Either e a)
h b
b = do
    Either e a
v <- a -> m (Either e a)
h (b
b forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either e a
v of
               Left e
e -> forall a b. a -> Either a b
Left e
e
               Right a
v' -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' b a
l a
v' b
b


------------------------------------------------------------------------------
-- | Modifies the Initializer's SnapletConfig.
modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg :: forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg SnapletConfig -> SnapletConfig
f = forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) SnapletConfig
curConfig forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> SnapletConfig -> SnapletConfig
f SnapletConfig
c


------------------------------------------------------------------------------
-- | If a snaplet has a filesystem presence, this function creates and copies
-- the files if they dont' already exist.
setupFilesystem :: Maybe (IO FilePath)
                    -- ^ The directory where the snaplet's reference files are
                    -- stored.  Nothing if the snaplet doesn't come with any
                    -- files that need to be installed.
                -> FilePath
                    -- ^ Directory where the files should be copied.
                -> Initializer b v ()
setupFilesystem :: forall b v. Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Maybe (IO String)
Nothing String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupFilesystem (Just IO String
getSnapletDataDir) String
targetDir = do
    Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
targetDir
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ do
        forall b v. Text -> Initializer b v ()
printInfo Text
"...setting up filesystem"
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetDir
        String
srcDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getSnapletDataDir
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
readDirectoryWith (String -> String -> String -> IO ()
doCopy String
srcDir String
targetDir) String
srcDir
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    doCopy :: String -> String -> String -> IO ()
doCopy String
srcRoot String
targetRoot String
filename = do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
        String -> String -> IO ()
copyFile String
filename String
toDir
      where
        toDir :: String
toDir = String
targetRoot String -> String -> String
</> String -> String -> String
makeRelative String
srcRoot String
filename
        directory :: String
directory = String -> String
dropFileName String
toDir


------------------------------------------------------------------------------
-- | All snaplet initializers must be wrapped in a call to @makeSnaplet@,
-- which handles standardized housekeeping common to all snaplets.
-- Common usage will look something like
-- this:
--
-- @
-- fooInit :: SnapletInit b Foo
-- fooInit = makeSnaplet \"foo\" \"An example snaplet\" Nothing $ do
--     -- Your initializer code here
--     return $ Foo 42
-- @
--
-- Note that you're writing your initializer code in the Initializer monad,
-- and makeSnaplet converts it into an opaque SnapletInit type.  This allows
-- us to use the type system to ensure that the API is used correctly.
makeSnaplet :: Text
                -- ^ A default id for this snaplet.  This is only used when
                -- the end-user has not already set an id using the
                -- nameSnaplet function.
            -> Text
                -- ^ A human readable description of this snaplet.
            -> Maybe (IO FilePath)
                -- ^ The path to the directory holding the snaplet's reference
                -- filesystem content.  This will almost always be the
                -- directory returned by Cabal's getDataDir command, but it
                -- has to be passed in because it is defined in a
                -- package-specific import.  Setting this value to Nothing
                -- doesn't preclude the snaplet from having files in in the
                -- filesystem, it just means that they won't be copied there
                -- automatically.
            -> Initializer b v v
                -- ^ Snaplet initializer.
            -> SnapletInit b v
makeSnaplet :: forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
snapletId Text
desc Maybe (IO String)
getSnapletDataDir Initializer b v v
m = forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit forall a b. (a -> b) -> a -> b
$ do
    forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> if forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ SnapletConfig -> Maybe Text
_scId SnapletConfig
c
        then forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig (Maybe Text)
scId (forall a. a -> Maybe a
Just Text
snapletId) SnapletConfig
c else SnapletConfig
c
    String
sid <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
    Bool
topLevel <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> Bool
_isTopLevel
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topLevel forall a b. (a -> b) -> a -> b
$ do
        forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig Config
scUserConfig (Text -> Config -> Config
subconfig (String -> Text
T.pack String
sid))
        forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig String
scFilePath
          (SnapletConfig -> String
_scFilePath SnapletConfig
c String -> String -> String
</> String
"snaplets" String -> String -> String
</> String
sid) SnapletConfig
c
    forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) Bool
isTopLevel Bool
False)
    forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig Text
scDescription Text
desc
    SnapletConfig
cfg <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> SnapletConfig
_curConfig
    forall b v. Text -> Initializer b v ()
printInfo forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [String
"Initializing "
      ,String
sid
      ,String
" @ /"
      ,ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
buildPath forall a b. (a -> b) -> a -> b
$ SnapletConfig -> [ByteString]
_scRouteContext SnapletConfig
cfg
      ]

    -- This has to happen here because it needs to be after scFilePath is set
    -- up but before the config file is read.
    forall b v. Maybe (IO String) -> String -> Initializer b v ()
setupFilesystem Maybe (IO String)
getSnapletDataDir (SnapletConfig -> String
_scFilePath SnapletConfig
cfg)

    String
env <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> String
_environment
    let configLocation :: String
configLocation = SnapletConfig -> String
_scFilePath SnapletConfig
cfg String -> String -> String
</> (String
env forall a. [a] -> [a] -> [a]
++ String
".cfg")
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Worth String] -> Config -> IO ()
addToConfig [forall a. a -> Worth a
Optional String
configLocation]
                         (SnapletConfig -> Config
_scUserConfig SnapletConfig
cfg)
    forall b v. Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet Initializer b v v
m


------------------------------------------------------------------------------
-- | Internal function that gets the SnapletConfig out of the initializer
-- state and uses it to create a (Snaplet a).
mkSnaplet :: Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet :: forall b v. Initializer b v v -> Initializer b v (Snaplet v)
mkSnaplet Initializer b v v
m = do
    v
res <- Initializer b v v
m
    SnapletConfig
cfg <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> SnapletConfig
_curConfig
    (Snaplet b -> Snaplet b) -> IO ()
setInTop <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader
    SnapletLens (Snaplet b) v
l <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
    let modifier :: v -> IO ()
modifier = (Snaplet b -> Snaplet b) -> IO ()
setInTop  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Lens' (Snaplet s) s
snapletValue)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. SnapletConfig -> (s -> IO ()) -> s -> Snaplet s
Snaplet SnapletConfig
cfg v -> IO ()
modifier v
res



------------------------------------------------------------------------------
-- | Brackets an initializer computation, restoring curConfig after the
-- computation returns.
bracketInit :: Initializer b v a -> Initializer b v a
bracketInit :: forall b v a. Initializer b v a -> Initializer b v a
bracketInit Initializer b v a
m = do
    InitializerState b
s <- forall b v. Initializer b v (InitializerState b)
iGet
    a
res <- Initializer b v a
m
    forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) SnapletConfig
curConfig (forall b. InitializerState b -> SnapletConfig
_curConfig InitializerState b
s))
    forall (m :: * -> *) a. Monad m => a -> m a
return a
res


------------------------------------------------------------------------------
-- | Handles modifications to InitializerState that need to happen before a
-- snaplet is called with either nestSnaplet or embedSnaplet.
setupSnapletCall :: ByteString -> Initializer b v ()
setupSnapletCall :: forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
rte = do
    Text
curId <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
    forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig [Text]
scAncestry (Text
curIdforall a. a -> [a] -> [a]
:))
    forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig (Maybe Text)
scId (forall a b. a -> b -> a
const forall a. Maybe a
Nothing))
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
B.null ByteString
rte) forall a b. (a -> b) -> a -> b
$ forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' SnapletConfig [ByteString]
scRouteContext (ByteString
rteforall a. a -> [a] -> [a]
:))


------------------------------------------------------------------------------
-- | Runs another snaplet's initializer and returns the initialized Snaplet
-- value.  Calling an initializer with nestSnaplet gives the nested snaplet
-- access to the same base state that the current snaplet has.  This makes it
-- possible for the child snaplet to make use of functionality provided by
-- sibling snaplets.
nestSnaplet :: ByteString
                -- ^ The root url for all the snaplet's routes.  An empty
                -- string gives the routes the same root as the parent
                -- snaplet's routes.
            -> SnapletLens v v1
                -- ^ Lens identifying the snaplet
            -> SnapletInit b v1
                -- ^ The initializer function for the subsnaplet.
            -> Initializer b v (Snaplet v1)
nestSnaplet :: forall v v1 b.
ByteString
-> SnapletLens v v1
-> SnapletInit b v1
-> Initializer b v (Snaplet v1)
nestSnaplet ByteString
rte SnapletLens v v1
l (SnapletInit Initializer b v1 (Snaplet v1)
snaplet) =
    forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens v v' -> m b v' a -> m b v a
with SnapletLens v v1
l forall a b. (a -> b) -> a -> b
$ forall b v a. Initializer b v a -> Initializer b v a
bracketInit forall a b. (a -> b) -> a -> b
$ do
        forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
rte
        Initializer b v1 (Snaplet v1)
snaplet


------------------------------------------------------------------------------
-- | Runs another snaplet's initializer and returns the initialized Snaplet
-- value.  The difference between this and 'nestSnaplet' is the first type
-- parameter in the third argument.  The \"v1 v1\" makes the child snaplet
-- think that it is the top-level state, which means that it will not be able
-- to use functionality provided by snaplets included above it in the snaplet
-- tree. This strongly isolates the child snaplet, and allows you to eliminate
-- the b type variable.  The embedded snaplet can still get functionality
-- from other snaplets, but only if it nests or embeds the snaplet itself.
--
-- Note that this function does not change where this snaplet is located in
-- the filesystem.  The snaplet directory structure convention stays the same.
-- Also, embedSnaplet limits the ways that snaplets can interact, so we
-- usually recommend using nestSnaplet instead.  However, we provide this
-- function because sometimes reduced flexibility is useful.  In short, if
-- you don't understand what this function does for you from looking at its
-- type, you probably don't want to use it.
embedSnaplet :: ByteString
                 -- ^ The root url for all the snaplet's routes.  An empty
                 -- string gives the routes the same root as the parent
                 -- snaplet's routes.
                 --
                 -- NOTE: Because of the stronger isolation provided by
                 -- embedSnaplet, you should be more careful about using an
                 -- empty string here.
             -> SnapletLens v v1
                -- ^ Lens identifying the snaplet
             -> SnapletInit v1 v1
                -- ^ The initializer function for the subsnaplet.
             -> Initializer b v (Snaplet v1)
embedSnaplet :: forall v v1 b.
ByteString
-> SnapletLens v v1
-> SnapletInit v1 v1
-> Initializer b v (Snaplet v1)
embedSnaplet ByteString
rte SnapletLens v v1
l (SnapletInit Initializer v1 v1 (Snaplet v1)
snaplet) = forall b v a. Initializer b v a -> Initializer b v a
bracketInit forall a b. (a -> b) -> a -> b
$ do
    SnapletLens (Snaplet b) v
curLens <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
    forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
""
    forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
curLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. SnapletLens a b -> SnapletLens (Snaplet a) b
subSnaplet SnapletLens v v1
l) Initializer v1 v1 (Snaplet v1)
snaplet


------------------------------------------------------------------------------
-- | Changes the base state of an initializer.
chroot :: ByteString
       -> SnapletLens (Snaplet b) v1
       -> Initializer v1 v1 a
       -> Initializer b v a
chroot :: forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte SnapletLens (Snaplet b) v1
l (Initializer LensT
  (Snaplet v1)
  (Snaplet v1)
  (InitializerState v1)
  (WriterT (Hook v1) IO)
  a
m) = do
    InitializerState b
curState <- forall b v. Initializer b v (InitializerState b)
iGet
    let newSetter :: (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter Snaplet v1 -> Snaplet v1
f = forall b. InitializerState b -> (Snaplet b -> Snaplet b) -> IO ()
masterReloader InitializerState b
curState (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v1
l) Snaplet v1 -> Snaplet v1
f)
    ((a
a,InitializerState v1
s), (Hook Snaplet v1 -> IO (Either Text (Snaplet v1))
hook)) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s a.
Monad m =>
LensT b v s m a -> ALens' b v -> s -> m (a, s)
LT.runLensT LensT
  (Snaplet v1)
  (Snaplet v1)
  (InitializerState v1)
  (WriterT (Hook v1) IO)
  a
m forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
        InitializerState b
curState {
          _handlers :: [(ByteString, Handler v1 v1 ())]
_handlers = [],
          _hFilter :: Handler v1 v1 () -> Handler v1 v1 ()
_hFilter = forall a. a -> a
id,
          masterReloader :: (Snaplet v1 -> Snaplet v1) -> IO ()
masterReloader = (Snaplet v1 -> Snaplet v1) -> IO ()
newSetter
        }
    let handler :: Handler b b ()
handler = forall v b' a b.
SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler SnapletLens (Snaplet b) v1
l forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState v1
s forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState v1
s
    forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers (forall a. [a] -> [a] -> [a]
++[(ByteString
rte,Handler b b ()
handler)])
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set forall b. Lens' (InitializerState b) (IORef (IO ()))
cleanup (forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState v1
s)
    forall b v.
(Snaplet b -> IO (Either Text (Snaplet b))) -> Initializer b v ()
addPostInitHookBase forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b a e.
Monad m =>
ALens' b a -> (a -> m (Either e a)) -> b -> m (Either e b)
upHook' SnapletLens (Snaplet b) v1
l Snaplet v1 -> IO (Either Text (Snaplet v1))
hook
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a


------------------------------------------------------------------------------
-- | Changes the base state of a handler.
chrootHandler :: SnapletLens (Snaplet v) b'
              -> Handler b' b' a -> Handler b v a
chrootHandler :: forall v b' a b.
SnapletLens (Snaplet v) b' -> Handler b' b' a -> Handler b v a
chrootHandler SnapletLens (Snaplet v) b'
l (Handler Lensed (Snaplet b') (Snaplet b') Snap a
h) = forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler forall a b. (a -> b) -> a -> b
$ do
    Snaplet v
s <- forall s (m :: * -> *). MonadState s m => m s
get
    (a
a, Snaplet b'
s') <- forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b') (Snaplet b') Snap a
h forall a. a -> a
id (Snaplet v
s forall s t a b. s -> ALens s t a b -> a
^# SnapletLens (Snaplet v) b'
l)
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall s t a b. ALens s t a b -> b -> s -> t
storing SnapletLens (Snaplet v) b'
l Snaplet b'
s'
    forall (m :: * -> *) a. Monad m => a -> m a
return a
a


------------------------------------------------------------------------------
-- | Sets a snaplet's name.  All snaplets have a default name set by the
-- snaplet author.  This function allows you to override that name.  You will
-- have to do this if you have more than one instance of the same kind of
-- snaplet because snaplet names must be unique.  This function must
-- immediately surround the snaplet's initializer.  For example:
--
-- @fooState <- nestSnaplet \"fooA\" $ nameSnaplet \"myFoo\" $ fooInit@
nameSnaplet :: Text
                -- ^ The snaplet name
            -> SnapletInit b v
                -- ^ The snaplet initializer function
            -> SnapletInit b v
nameSnaplet :: forall b v. Text -> SnapletInit b v -> SnapletInit b v
nameSnaplet Text
nm (SnapletInit Initializer b v (Snaplet v)
m) = forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit forall a b. (a -> b) -> a -> b
$
    forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' SnapletConfig (Maybe Text)
scId (forall a. a -> Maybe a
Just Text
nm)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Initializer b v (Snaplet v)
m


------------------------------------------------------------------------------
-- | Adds routing to the current 'Handler'.  The new routes are merged with
-- the main routing section and take precedence over existing routing that was
-- previously defined.
addRoutes :: [(ByteString, Handler b v ())]
           -> Initializer b v ()
addRoutes :: forall b v. [(ByteString, Handler b v ())] -> Initializer b v ()
addRoutes [(ByteString, Handler b v ())]
rs = do
    SnapletLens (Snaplet b) v
l <- forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
    [ByteString]
ctx <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (SnapletConfig -> [ByteString]
_scRouteContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. InitializerState b -> SnapletConfig
_curConfig)
    let modRoute :: (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute (ByteString
r,Handler b v ()
h) = ( [ByteString] -> ByteString
buildPath (ByteString
rforall a. a -> [a] -> [a]
:[ByteString]
ctx)
                         , forall {b} {v}. ByteString -> Handler b v ()
setPattern ByteString
r forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) v
l Handler b v ()
h)
    let rs' :: [(ByteString, Handler b b ())]
rs' = forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute [(ByteString, Handler b v ())]
rs
    forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers (forall a. [a] -> [a] -> [a]
++[(ByteString, Handler b b ())]
rs') InitializerState b
v)
  where
    setPattern :: ByteString -> Handler b v ()
setPattern ByteString
r = do
      Maybe ByteString
p <- forall b v. Handler b v (Maybe ByteString)
getRoutePattern
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe ByteString
p) forall a b. (a -> b) -> a -> b
$ forall {b} {v}. ByteString -> Handler b v ()
setRoutePattern ByteString
r


------------------------------------------------------------------------------
-- | Wraps the /base/ snaplet's routing in another handler, allowing you to run
-- code before and after all routes in an application.
--
-- Here are some examples of things you might do:
--
-- > wrapSite (\site -> logHandlerStart >> site >> logHandlerFinished)
-- > wrapSite (\site -> ensureAdminUser >> site)
--
wrapSite :: (Handler b v () -> Handler b v ())
             -- ^ Handler modifier function
         -> Initializer b v ()
wrapSite :: forall b v.
(Handler b v () -> Handler b v ()) -> Initializer b v ()
wrapSite Handler b v () -> Handler b v ()
f0 = do
    Handler b b () -> Handler b b ()
f <- forall b v.
(Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter Handler b v () -> Handler b v ()
f0
    forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall b.
Lens' (InitializerState b) (Handler b b () -> Handler b b ())
hFilter (Handler b b () -> Handler b b ()
fforall b c a. (b -> c) -> (a -> b) -> a -> c
.) InitializerState b
v)


------------------------------------------------------------------------------
mungeFilter :: (Handler b v () -> Handler b v ())
            -> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter :: forall b v.
(Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter Handler b v () -> Handler b v ()
f = do
    SnapletLens (Snaplet b) v
myLens <- forall b v a.
LensT
  (Snaplet b)
  (Snaplet v)
  (InitializerState b)
  (WriterT (Hook b) IO)
  a
-> Initializer b v a
Initializer forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Handler b b ()
m -> forall (m :: * -> * -> * -> *) v v' b a.
MonadSnaplet m =>
SnapletLens (Snaplet v) v' -> m b v' a -> m b v a
with' SnapletLens (Snaplet b) v
myLens forall a b. (a -> b) -> a -> b
$ Handler b b () -> Handler b v ()
f' Handler b b ()
m
  where
    f' :: Handler b b () -> Handler b v ()
f' (Handler Lensed (Snaplet b) (Snaplet b) Snap ()
m)       = Handler b v () -> Handler b v ()
f forall a b. (a -> b) -> a -> b
$ forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v' a v.
Monad m =>
ALens' b v' -> Lensed b v' m a -> Lensed b v m a
L.withTop forall a. a -> a
id Lensed (Snaplet b) (Snaplet b) Snap ()
m


------------------------------------------------------------------------------
-- | Attaches an unload handler to the snaplet.  The unload handler will be
-- called when the server shuts down, or is reloaded.
onUnload :: IO () -> Initializer b v ()
onUnload :: forall b v. IO () -> Initializer b v ()
onUnload IO ()
m = do
    IORef (IO ())
cleanupRef <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> IORef (IO ())
_cleanup
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IO ())
cleanupRef IO () -> (IO (), ())
f
  where
    f :: IO () -> (IO (), ())
f IO ()
curCleanup = (IO ()
curCleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m, ())


------------------------------------------------------------------------------
-- |
logInitMsg :: IORef Text -> Text -> IO ()
logInitMsg :: IORef Text -> Text -> IO ()
logInitMsg IORef Text
ref Text
msg = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Text
ref (\Text
cur -> (Text
cur Text -> Text -> Text
`T.append` Text
msg, ()))


------------------------------------------------------------------------------
-- | Initializers should use this function for all informational or error
-- messages to be displayed to the user.  On application startup they will be
-- sent to the console.  When executed from the reloader, they will be sent
-- back to the user in the HTTP response.
printInfo :: Text -> Initializer b v ()
printInfo :: forall b v. Text -> Initializer b v ()
printInfo Text
msg = do
    IORef Text
logRef <- forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets forall b. InitializerState b -> IORef Text
_initMessages
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef Text -> Text -> IO ()
logInitMsg IORef Text
logRef (Text
msg Text -> Text -> Text
`T.append` Text
"\n")


------------------------------------------------------------------------------
-- | Builds an IO reload action for storage in the SnapletState.
mkReloader :: FilePath
           -> String
           -> ((Snaplet b -> Snaplet b) -> IO ())
           -> IORef (IO ())
           -> Initializer b b (Snaplet b)
           -> IO (Either Text Text)
mkReloader :: forall b.
String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader String
cwd String
env (Snaplet b -> Snaplet b) -> IO ()
resetter IORef (IO ())
cleanupRef Initializer b b (Snaplet b)
i = do
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
    !Either Text (Snaplet b, InitializerState b)
res <- forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
i String
cwd
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (Snaplet b, InitializerState b) -> IO (Either Text Text)
good Either Text (Snaplet b, InitializerState b)
res
  where
    good :: (Snaplet b, InitializerState b) -> IO (Either Text Text)
good (Snaplet b
b,InitializerState b
is) = do
        ()
_ <- (Snaplet b -> Snaplet b) -> IO ()
resetter (forall a b. a -> b -> a
const Snaplet b
b)
        Text
msgs <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
msgs


------------------------------------------------------------------------------
-- | Runs a top-level snaplet in the Snap monad.
runBase :: Handler b b a
        -> MVar (Snaplet b)
        -> Snap a
runBase :: forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (Handler Lensed (Snaplet b) (Snaplet b) Snap a
m) MVar (Snaplet b)
mvar = do
    !Snaplet b
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. MVar a -> IO a
readMVar MVar (Snaplet b)
mvar)
    (!a
a, Snaplet b
_) <- forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b) (Snaplet b) Snap a
m forall a. a -> a
id Snaplet b
b
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! a
a


------------------------------------------------------------------------------
-- | Lets you change a snaplet's initial state.  It's almost like a reload,
-- except that it doesn't run the initializer.  It just modifies the result of
-- the initializer.  This can be used to let you define actions for reloading
-- individual snaplets.
modifyMaster :: v -> Handler b v ()
modifyMaster :: forall v b. v -> Handler b v ()
modifyMaster v
v = do
    v -> IO ()
modifier <- forall v b b1. (Snaplet v -> b) -> Handler b1 v b
getsSnapletState forall s. Snaplet s -> s -> IO ()
_snapletModifier
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ v -> IO ()
modifier v
v


------------------------------------------------------------------------------
-- | Internal function for running Initializers.  If any exceptions were
-- thrown by the initializer, this function catches them, runs any cleanup
-- actions that had been registered, and returns an expanded error message
-- containing the exception details as well as all messages generated by the
-- initializer before the exception was thrown.
runInitializer :: ((Snaplet b -> Snaplet b) -> IO ())
               -> String
               -> Initializer b b (Snaplet b)
               -> IO (Either Text (Snaplet b, InitializerState b))
runInitializer :: forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
b =
    IO String
getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
b


------------------------------------------------------------------------------
runInitializer' :: ((Snaplet b -> Snaplet b) -> IO ())
                -> String
                -> Initializer b b (Snaplet b)
                -> FilePath
                -> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' :: forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env b :: Initializer b b (Snaplet b)
b@(Initializer LensT
  (Snaplet b)
  (Snaplet b)
  (InitializerState b)
  (WriterT (Hook b) IO)
  (Snaplet b)
i) String
cwd = do
    IORef (IO ())
cleanupRef <- forall a. a -> IO (IORef a)
newIORef (forall (m :: * -> *) a. Monad m => a -> m a
return ())
    let reloader_ :: IO (Either Text Text)
reloader_ = forall b.
String
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> IORef (IO ())
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader String
cwd String
env (Snaplet b -> Snaplet b) -> IO ()
resetter IORef (IO ())
cleanupRef Initializer b b (Snaplet b)
b
    let builtinHandlers :: [(a, Handler b v ())]
builtinHandlers = [(a
"/admin/reload", forall b v. Handler b v ()
reloadSite)]
    let cfg :: SnapletConfig
cfg = [Text]
-> String
-> Maybe Text
-> Text
-> Config
-> [ByteString]
-> Maybe ByteString
-> IO (Either Text Text)
-> SnapletConfig
SnapletConfig [] String
cwd forall a. Maybe a
Nothing Text
"" Config
empty [] forall a. Maybe a
Nothing IO (Either Text Text)
reloader_
    IORef Text
logRef <- forall a. a -> IO (IORef a)
newIORef Text
""

    let body :: IO (Either Text (Snaplet b, InitializerState b))
body = do
            ((Snaplet b
res, InitializerState b
s), (Hook Snaplet b -> IO (Either Text (Snaplet b))
hook)) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b v s a.
Monad m =>
LensT b v s m a -> ALens' b v -> s -> m (a, s)
LT.runLensT LensT
  (Snaplet b)
  (Snaplet b)
  (InitializerState b)
  (WriterT (Hook b) IO)
  (Snaplet b)
i forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
                forall b.
Bool
-> IORef (IO ())
-> [(ByteString, Handler b b ())]
-> (Handler b b () -> Handler b b ())
-> SnapletConfig
-> IORef Text
-> String
-> ((Snaplet b -> Snaplet b) -> IO ())
-> InitializerState b
InitializerState Bool
True IORef (IO ())
cleanupRef forall {a} {b} {v}. IsString a => [(a, Handler b v ())]
builtinHandlers forall a. a -> a
id SnapletConfig
cfg IORef Text
logRef
                                 String
env (Snaplet b -> Snaplet b) -> IO ()
resetter
            Either Text (Snaplet b)
res' <- Snaplet b -> IO (Either Text (Snaplet b))
hook Snaplet b
res
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (,InitializerState b
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text (Snaplet b)
res'

        handler :: SomeException -> IO (Either Text (Snaplet b, InitializerState b))
handler SomeException
e = do
            forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
            Text
logMessages <- forall a. IORef a -> IO a
readIORef IORef Text
logRef

            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
                [ Text
"Initializer threw an exception..."
                , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (SomeException
e :: SomeException)
                , Text
""
                , Text
"...but before it died it generated the following output:"
                , Text
logMessages
                ]

    forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch IO (Either Text (Snaplet b, InitializerState b))
body SomeException -> IO (Either Text (Snaplet b, InitializerState b))
handler


------------------------------------------------------------------------------
-- | Given an environment and a Snaplet initializer, produce a concatenated log
-- of all messages generated during initialization, a snap handler, and a
-- cleanup action.  The environment is an arbitrary string such as \"devel\" or
-- \"production\".  This string is used to determine the name of the
-- configuration files used by each snaplet.  If an environment of Nothing is
-- used, then runSnaplet defaults to \"devel\".
runSnaplet :: Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet :: forall b.
Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet Maybe String
env (SnapletInit Initializer b b (Snaplet b)
b) = do
    MVar (Snaplet b)
snapletMVar <- forall a. IO (MVar a)
newEmptyMVar
    let resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter Snaplet b -> Snaplet b
f = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Snaplet b)
snapletMVar (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snaplet b -> Snaplet b
f)
    Either Text (Snaplet b, InitializerState b)
eRes <- forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer (Snaplet b -> Snaplet b) -> IO ()
resetter (forall a. a -> Maybe a -> a
fromMaybe String
"devel" Maybe String
env) Initializer b b (Snaplet b)
b
    let go :: (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go (Snaplet b
siteSnaplet,InitializerState b
is) = do
            forall a. MVar a -> a -> IO ()
putMVar MVar (Snaplet b)
snapletMVar Snaplet b
siteSnaplet
            Text
msgs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
            let handler :: Snap ()
handler = forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState b
is forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState b
is) MVar (Snaplet b)
snapletMVar
            IO ()
cleanupAction <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState b
is
            forall (m :: * -> *) a. Monad m => a -> m a
return (Text
msgs, Snap ()
handler, IO ()
cleanupAction)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go Either Text (Snaplet b, InitializerState b)
eRes


------------------------------------------------------------------------------
-- | Given a configuration and a snap handler, complete it and produce the
-- completed configuration as well as a new toplevel handler with things like
-- compression and a 500 handler set up.
combineConfig :: Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig :: forall a. Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig Config Snap a
config Snap ()
handler = do
    Config Snap a
conf <- forall (m :: * -> *) a.
MonadSnap m =>
Config m a -> IO (Config m a)
completeConfig Config Snap a
config

    let catch500 :: Snap () -> Snap ()
catch500 = (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
catch forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Config m a -> Maybe (SomeException -> m ())
getErrorHandler Config Snap a
conf)
    let compress :: Snap () -> Snap ()
compress = if forall a. HasCallStack => Maybe a -> a
fromJust (forall (m :: * -> *) a. Config m a -> Maybe Bool
getCompression Config Snap a
conf)
                     then forall (m :: * -> *) a. MonadSnap m => m a -> m ()
withCompression else forall a. a -> a
id
    let site :: Snap ()
site     = Snap () -> Snap ()
compress forall a b. (a -> b) -> a -> b
$ Snap () -> Snap ()
catch500 Snap ()
handler

    forall (m :: * -> *) a. Monad m => a -> m a
return (Config Snap a
conf, Snap ()
site)


------------------------------------------------------------------------------
-- | Initialize and run a Snaplet. This function parses command-line arguments,
-- runs the given Snaplet initializer, and starts an HTTP server running the
-- Snaplet's toplevel 'Handler'.
serveSnaplet :: Config Snap AppConfig
                 -- ^ The configuration of the server - you can usually pass a
                 -- default 'Config' via
                 -- 'Snap.Http.Server.Config.defaultConfig'.
             -> SnapletInit b b
                 -- ^ The snaplet initializer function.
             -> IO ()
serveSnaplet :: forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnaplet Config Snap AppConfig
startConfig SnapletInit b b
initializer = do
    Config Snap AppConfig
config <- forall (m :: * -> *).
MonadSnap m =>
Config m AppConfig -> IO (Config m AppConfig)
commandLineAppConfig Config Snap AppConfig
startConfig
    forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnapletNoArgParsing Config Snap AppConfig
config SnapletInit b b
initializer

------------------------------------------------------------------------------
-- | Like 'serveSnaplet', but don't try to parse command-line arguments.
serveSnapletNoArgParsing :: Config Snap AppConfig
                 -- ^ The configuration of the server - you can usually pass a
                 -- default 'Config' via
                 -- 'Snap.Http.Server.Config.defaultConfig'.
             -> SnapletInit b b
                 -- ^ The snaplet initializer function.
             -> IO ()
serveSnapletNoArgParsing :: forall b. Config Snap AppConfig -> SnapletInit b b -> IO ()
serveSnapletNoArgParsing Config Snap AppConfig
config SnapletInit b b
initializer = do
    let env :: Maybe String
env = AppConfig -> Maybe String
appEnvironment forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config Snap AppConfig
config
    (Text
msgs, Snap ()
handler, IO ()
doCleanup) <- forall b.
Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet Maybe String
env SnapletInit b b
initializer

    (Config Snap AppConfig
conf, Snap ()
site) <- forall a. Config Snap a -> Snap () -> IO (Config Snap a, Snap ())
combineConfig Config Snap AppConfig
config Snap ()
handler
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
"log"
    let serve :: Snap () -> IO ()
serve = forall a. Config Snap a -> Snap () -> IO ()
httpServe Config Snap AppConfig
conf

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {m :: * -> *} {a}. Config m a -> Bool
loggingEnabled Config Snap AppConfig
conf) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
msgs
    Either SomeException ()
_ <- forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ Snap () -> IO ()
serve forall a b. (a -> b) -> a -> b
$ Snap ()
site
         :: IO (Either SomeException ())
    IO ()
doCleanup
  where
    loggingEnabled :: Config m a -> Bool
loggingEnabled = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Config m a -> Maybe Bool
getVerbose


------------------------------------------------------------------------------
-- | Allows you to get all of your app's config data in the IO monad without
-- the web server infrastructure.
loadAppConfig :: FileName
              -- ^ The name of the config file to look for.  In snap
              -- applications, this is something based on the
              -- environment...i.e. @devel.cfg@.
              -> FilePath
              -- ^ Path to the root directory of your project.
              -> IO C.Config
loadAppConfig :: String -> String -> IO Config
loadAppConfig String
cfg String
root = do
    AnchoredDirTree String
tree <- String -> IO (AnchoredDirTree String)
buildL String
root
    let groups :: [(Text, Worth String)]
groups = forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
"" forall a b. (a -> b) -> a -> b
$ forall a. AnchoredDirTree a -> DirTree a
dirTree AnchoredDirTree String
tree
    [(Text, Worth String)] -> IO Config
loadGroups [(Text, Worth String)]
groups


------------------------------------------------------------------------------
-- | Recursive worker for loadAppConfig.
loadAppConfig' :: FileName -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' :: forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
_prefix d :: DirTree a
d@(Dir String
_ [DirTree a]
c) =
    (forall a b. (a -> b) -> [a] -> [b]
map ((Text
_prefix,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Worth a
Required) forall a b. (a -> b) -> a -> b
$ forall b. String -> DirTree b -> [b]
getCfg String
cfg DirTree a
d) forall a. [a] -> [a] -> [a]
++
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\DirTree a
a -> forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg (String -> Text
nextPrefix forall a b. (a -> b) -> a -> b
$ forall a. DirTree a -> String
name DirTree a
a) DirTree a
a) [DirTree a]
snaplets
  where
    nextPrefix :: String -> Text
nextPrefix String
p = [Text] -> Text
T.concat [Text
_prefix, String -> Text
T.pack String
p, Text
"."]
    snapletsDirs :: [DirTree a]
snapletsDirs = forall a. (a -> Bool) -> [a] -> [a]
filter forall t. DirTree t -> Bool
isSnapletsDir [DirTree a]
c
    snaplets :: [DirTree a]
snaplets = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (a -> Bool) -> [a] -> [a]
filter forall t. DirTree t -> Bool
isDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DirTree a -> [DirTree a]
contents) [DirTree a]
snapletsDirs
loadAppConfig' String
_ Text
_ DirTree a
_ = []


isSnapletsDir :: DirTree t -> Bool
isSnapletsDir :: forall t. DirTree t -> Bool
isSnapletsDir (Dir String
"snaplets" [DirTree t]
_) = Bool
True
isSnapletsDir DirTree t
_ = Bool
False


isDir :: DirTree t -> Bool
isDir :: forall t. DirTree t -> Bool
isDir (Dir String
_ [DirTree t]
_) = Bool
True
isDir DirTree t
_ = Bool
False


isCfg :: FileName -> DirTree t -> Bool
isCfg :: forall t. String -> DirTree t -> Bool
isCfg String
cfg (File String
n t
_) = String
cfg forall a. Eq a => a -> a -> Bool
== String
n
isCfg String
_ DirTree t
_ = Bool
False


getCfg :: FileName -> DirTree b -> [b]
getCfg :: forall b. String -> DirTree b -> [b]
getCfg String
cfg (Dir String
_ [DirTree b]
c) = forall a b. (a -> b) -> [a] -> [b]
map forall a. DirTree a -> a
file forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall t. String -> DirTree t -> Bool
isCfg String
cfg) [DirTree b]
c
getCfg String
_ DirTree b
_ = []