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


------------------------------------------------------------------------------
-- | '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 = 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


------------------------------------------------------------------------------
-- | '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 = 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


------------------------------------------------------------------------------
-- | 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 = ([(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

------------------------------------------------------------------------------
-- | 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 = (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

------------------------------------------------------------------------------
-- | 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
    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'


------------------------------------------------------------------------------
-- | 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 = (Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
forall v b.
(Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ()
addPostInitHook' ((Snaplet v -> IO (Either Text (Snaplet v))) -> Initializer b v ())
-> ((v -> IO (Either Text v))
    -> Snaplet v -> IO (Either Text (Snaplet v)))
-> (v -> IO (Either Text v))
-> Initializer b v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
forall v.
(v -> IO (Either Text v))
-> Snaplet v -> IO (Either Text (Snaplet v))
toSnapletHook


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


------------------------------------------------------------------------------
-- | 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 = 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


------------------------------------------------------------------------------
-- | 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 = 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


------------------------------------------------------------------------------
-- | 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 b -> ALens' b a -> a
forall s t a b. s -> ALens s t a b -> a
^# ALens' b a
l)
    Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e b -> m (Either e b)) -> Either e b -> m (Either e b)
forall a b. (a -> b) -> a -> b
$ case Either e a
v of
               Left e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e
               Right a
v' -> b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> b -> Either e b
forall a b. (a -> b) -> a -> b
$ ALens' b a -> a -> b -> b
forall s t a b. ALens s t a b -> b -> s -> t
storing ALens' b a
l a
v' b
b


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


------------------------------------------------------------------------------
-- | 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
_ = () -> Initializer b v ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setupFilesystem (Just IO String
getSnapletDataDir) String
targetDir = do
    Bool
exists <- IO Bool -> Initializer b v Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Initializer b v Bool)
-> IO Bool -> Initializer b v Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
targetDir
    Bool -> Initializer b v () -> Initializer b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (Initializer b v () -> Initializer b v ())
-> Initializer b v () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> Initializer b v ()
forall b v. Text -> Initializer b v ()
printInfo Text
"...setting up filesystem"
        IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetDir
        String
srcDir <- IO String -> Initializer b v String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getSnapletDataDir
        IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ()))
-> IO (AnchoredDirTree ()) -> Initializer b v (AnchoredDirTree ())
forall a b. (a -> b) -> a -> b
$ (String -> IO ()) -> String -> IO (AnchoredDirTree ())
forall a. (String -> IO a) -> String -> IO (AnchoredDirTree a)
readDirectoryWith (String -> String -> String -> IO ()
doCopy String
srcDir String
targetDir) String
srcDir
        () -> Initializer b v ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    doCopy :: String -> String -> String -> IO ()
doCopy String
srcRoot String
targetRoot String
filename = do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
        String -> String -> IO ()
copyFile String
filename String
toDir
      where
        toDir :: String
toDir = String
targetRoot String -> String -> String
</> String -> String -> String
makeRelative String
srcRoot String
filename
        directory :: String
directory = String -> String
dropFileName String
toDir


------------------------------------------------------------------------------
-- | 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 = Initializer b v (Snaplet v) -> SnapletInit b v
forall b v. Initializer b v (Snaplet v) -> SnapletInit b v
SnapletInit (Initializer b v (Snaplet v) -> SnapletInit b v)
-> Initializer b v (Snaplet v) -> SnapletInit b v
forall a b. (a -> b) -> a -> b
$ do
    (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> if Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ SnapletConfig -> Maybe Text
_scId SnapletConfig
c
        then ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
-> Maybe Text -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig (Maybe Text) (Maybe Text)
Lens' SnapletConfig (Maybe Text)
scId (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
snapletId) SnapletConfig
c else SnapletConfig
c
    String
sid <- (InitializerState b -> String) -> Initializer b v String
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (Text -> String
T.unpack (Text -> String)
-> (InitializerState b -> Text) -> InitializerState b -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text)
-> (InitializerState b -> Maybe Text) -> InitializerState b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletConfig -> Maybe Text
_scId (SnapletConfig -> Maybe Text)
-> (InitializerState b -> SnapletConfig)
-> InitializerState b
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig)
    Bool
topLevel <- (InitializerState b -> Bool) -> Initializer b v Bool
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> Bool
forall b. InitializerState b -> Bool
_isTopLevel
    Bool -> Initializer b v () -> Initializer b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
topLevel (Initializer b v () -> Initializer b v ())
-> Initializer b v () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ do
        (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter SnapletConfig SnapletConfig Config Config
-> (Config -> Config) -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter SnapletConfig SnapletConfig Config Config
Lens' SnapletConfig Config
scUserConfig (Text -> Config -> Config
subconfig (String -> Text
T.pack String
sid))
        (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ \SnapletConfig
c -> ASetter SnapletConfig SnapletConfig String String
-> String -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig String String
Lens' SnapletConfig String
scFilePath
          (SnapletConfig -> String
_scFilePath SnapletConfig
c String -> String -> String
</> String
"snaplets" String -> String -> String
</> String
sid) SnapletConfig
c
    (InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (ASetter (InitializerState b) (InitializerState b) Bool Bool
-> Bool -> InitializerState b -> InitializerState b
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (InitializerState b) (InitializerState b) Bool Bool
forall b. Lens' (InitializerState b) Bool
isTopLevel Bool
False)
    (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall b v. (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg ((SnapletConfig -> SnapletConfig) -> Initializer b v ())
-> (SnapletConfig -> SnapletConfig) -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ ASetter SnapletConfig SnapletConfig Text Text
-> Text -> SnapletConfig -> SnapletConfig
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter SnapletConfig SnapletConfig Text Text
Lens' SnapletConfig Text
scDescription Text
desc
    SnapletConfig
cfg <- (InitializerState b -> SnapletConfig)
-> Initializer b v SnapletConfig
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig
    Text -> Initializer b v ()
forall b v. Text -> Initializer b v ()
printInfo (Text -> Initializer b v ()) -> Text -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [String
"Initializing "
      ,String
sid
      ,String
" @ /"
      ,ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
buildPath ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ SnapletConfig -> [ByteString]
_scRouteContext SnapletConfig
cfg
      ]

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

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


------------------------------------------------------------------------------
-- | 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 <- (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



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


------------------------------------------------------------------------------
-- | 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 <- (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]
:))


------------------------------------------------------------------------------
-- | 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) =
    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


------------------------------------------------------------------------------
-- | 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) = Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1)
forall b v a. Initializer b v a -> Initializer b v a
bracketInit (Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1))
-> Initializer b v (Snaplet v1) -> Initializer b v (Snaplet v1)
forall a b. (a -> b) -> a -> b
$ do
    SnapletLens (Snaplet b) v
curLens <- Initializer b v (SnapletLens (Snaplet b) v)
forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
    ByteString -> Initializer b v ()
forall b v. ByteString -> Initializer b v ()
setupSnapletCall ByteString
""
    ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 (Snaplet v1)
-> Initializer b v (Snaplet v1)
forall b v1 a v.
ByteString
-> SnapletLens (Snaplet b) v1
-> Initializer v1 v1 a
-> Initializer b v a
chroot ByteString
rte (SnapletLens (Snaplet b) v
-> Lens (Snaplet b) (Snaplet b) (Snaplet v) (Snaplet v)
forall s t a b. ALens s t a b -> Lens s t a b
cloneLens SnapletLens (Snaplet b) v
curLens ((Snaplet v -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v))
 -> Snaplet b -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet b))
-> ((Snaplet v1
     -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v1))
    -> Snaplet v -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v))
-> SnapletLens (Snaplet b) v1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapletLens v v1
-> (Snaplet v1
    -> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v1))
-> Snaplet v
-> Pretext (->) (Snaplet v1) (Snaplet v1) (Snaplet v)
forall a b. SnapletLens a b -> SnapletLens (Snaplet a) b
subSnaplet SnapletLens v v1
l) Initializer v1 v1 (Snaplet v1)
snaplet


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


------------------------------------------------------------------------------
-- | 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) = Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
forall b v a.
Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
Handler (Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a)
-> Lensed (Snaplet b) (Snaplet v) Snap a -> Handler b v a
forall a b. (a -> b) -> a -> b
$ do
    Snaplet v
s <- Lensed (Snaplet b) (Snaplet v) Snap (Snaplet v)
forall s (m :: * -> *). MonadState s m => m s
get
    (a
a, Snaplet b'
s') <- Snap (a, Snaplet b')
-> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b')
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap (a, Snaplet b')
 -> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b'))
-> Snap (a, Snaplet b')
-> Lensed (Snaplet b) (Snaplet v) Snap (a, Snaplet b')
forall a b. (a -> b) -> a -> b
$ Lensed (Snaplet b') (Snaplet b') Snap a
-> ALens' (Snaplet b') (Snaplet b')
-> Snaplet b'
-> Snap (a, Snaplet b')
forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b') (Snaplet b') Snap a
h ALens' (Snaplet b') (Snaplet b')
forall a. a -> a
id (Snaplet v
s Snaplet v -> SnapletLens (Snaplet v) b' -> Snaplet b'
forall s t a b. s -> ALens s t a b -> a
^# SnapletLens (Snaplet v) b'
l)
    (Snaplet v -> Snaplet v) -> Lensed (Snaplet b) (Snaplet v) Snap ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Snaplet v -> Snaplet v)
 -> Lensed (Snaplet b) (Snaplet v) Snap ())
-> (Snaplet v -> Snaplet v)
-> Lensed (Snaplet b) (Snaplet v) Snap ()
forall a b. (a -> b) -> a -> b
$ SnapletLens (Snaplet v) b' -> Snaplet b' -> Snaplet v -> Snaplet v
forall s t a b. ALens s t a b -> b -> s -> t
storing SnapletLens (Snaplet v) b'
l Snaplet b'
s'
    a -> Lensed (Snaplet b) (Snaplet v) Snap a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


------------------------------------------------------------------------------
-- | 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) = 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


------------------------------------------------------------------------------
-- | 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 <- Initializer b v (SnapletLens (Snaplet b) v)
forall (m :: * -> * -> * -> *) b v.
MonadSnaplet m =>
m b v (SnapletLens (Snaplet b) v)
getLens
    [ByteString]
ctx <- (InitializerState b -> [ByteString])
-> Initializer b v [ByteString]
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets (SnapletConfig -> [ByteString]
_scRouteContext (SnapletConfig -> [ByteString])
-> (InitializerState b -> SnapletConfig)
-> InitializerState b
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InitializerState b -> SnapletConfig
forall b. InitializerState b -> SnapletConfig
_curConfig)
    let modRoute :: (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute (ByteString
r,Handler b v ()
h) = ( [ByteString] -> ByteString
buildPath (ByteString
rByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
ctx)
                         , ByteString -> Handler b b ()
forall {b} {v}. ByteString -> Handler b v ()
setPattern ByteString
r Handler b b () -> Handler b b () -> Handler b b ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SnapletLens (Snaplet b) v -> Handler b v () -> Handler b b ()
forall (m :: * -> * -> * -> *) b v' a v.
MonadSnaplet m =>
SnapletLens (Snaplet b) v' -> m b v' a -> m b v a
withTop' SnapletLens (Snaplet b) v
l Handler b v ()
h)
    let rs' :: [(ByteString, Handler b b ())]
rs' = ((ByteString, Handler b v ()) -> (ByteString, Handler b b ()))
-> [(ByteString, Handler b v ())] -> [(ByteString, Handler b b ())]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Handler b v ()) -> (ByteString, Handler b b ())
modRoute [(ByteString, Handler b v ())]
rs
    (InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> ASetter
  (InitializerState b)
  (InitializerState b)
  [(ByteString, Handler b b ())]
  [(ByteString, Handler b b ())]
-> ([(ByteString, Handler b b ())]
    -> [(ByteString, Handler b b ())])
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (InitializerState b)
  (InitializerState b)
  [(ByteString, Handler b b ())]
  [(ByteString, Handler b b ())]
forall b. Lens' (InitializerState b) [(ByteString, Handler b b ())]
handlers ([(ByteString, Handler b b ())]
-> [(ByteString, Handler b b ())] -> [(ByteString, Handler b b ())]
forall a. [a] -> [a] -> [a]
++[(ByteString, Handler b b ())]
rs') InitializerState b
v)
  where
    setPattern :: ByteString -> Handler b v ()
setPattern ByteString
r = do
      Maybe ByteString
p <- Handler b v (Maybe ByteString)
forall b v. Handler b v (Maybe ByteString)
getRoutePattern
      Bool -> Handler b v () -> Handler b v ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ByteString
p) (Handler b v () -> Handler b v ())
-> Handler b v () -> Handler b v ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Handler b v ()
forall {b} {v}. ByteString -> Handler b v ()
setRoutePattern ByteString
r


------------------------------------------------------------------------------
-- | 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 <- (Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
forall b v.
(Handler b v () -> Handler b v ())
-> Initializer b v (Handler b b () -> Handler b b ())
mungeFilter Handler b v () -> Handler b v ()
f0
    (InitializerState b -> InitializerState b) -> Initializer b v ()
forall b v.
(InitializerState b -> InitializerState b) -> Initializer b v ()
iModify (\InitializerState b
v -> ASetter
  (InitializerState b)
  (InitializerState b)
  (Handler b b () -> Handler b b ())
  (Handler b b () -> Handler b b ())
-> ((Handler b b () -> Handler b b ())
    -> Handler b b () -> Handler b b ())
-> InitializerState b
-> InitializerState b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (InitializerState b)
  (InitializerState b)
  (Handler b b () -> Handler b b ())
  (Handler b b () -> Handler b b ())
forall b.
Lens' (InitializerState b) (Handler b b () -> Handler b b ())
hFilter (Handler b b () -> Handler b b ()
f(Handler b b () -> Handler b b ())
-> (Handler b b () -> Handler b b ())
-> Handler b b ()
-> Handler b b ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) InitializerState b
v)


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


------------------------------------------------------------------------------
-- | 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 <- (InitializerState b -> IORef (IO ()))
-> Initializer b v (IORef (IO ()))
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> IORef (IO ())
forall b. InitializerState b -> IORef (IO ())
_cleanup
    IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> (IO () -> (IO (), ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IO ())
cleanupRef IO () -> (IO (), ())
f
  where
    f :: IO () -> (IO (), ())
f IO ()
curCleanup = (IO ()
curCleanup IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
m, ())


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


------------------------------------------------------------------------------
-- | 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 <- (InitializerState b -> IORef Text) -> Initializer b v (IORef Text)
forall b a v. (InitializerState b -> a) -> Initializer b v a
iGets InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages
    IO () -> Initializer b v ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Initializer b v ()) -> IO () -> Initializer b v ()
forall a b. (a -> b) -> a -> b
$ IORef Text -> Text -> IO ()
logInitMsg IORef Text
logRef (Text
msg Text -> Text -> Text
`T.append` Text
"\n")


------------------------------------------------------------------------------
-- | 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
    IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef IORef (IO ())
cleanupRef
    !Either Text (Snaplet b, InitializerState b)
res <- ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
i String
cwd
    (Text -> IO (Either Text Text))
-> ((Snaplet b, InitializerState b) -> IO (Either Text Text))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Either Text Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> IO (Either Text Text))
-> (Text -> Either Text Text) -> Text -> IO (Either Text Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text Text
forall a b. a -> Either a b
Left) (Snaplet b, InitializerState b) -> IO (Either Text Text)
good Either Text (Snaplet b, InitializerState b)
res
  where
    good :: (Snaplet b, InitializerState b) -> IO (Either Text Text)
good (Snaplet b
b,InitializerState b
is) = do
        ()
_ <- (Snaplet b -> Snaplet b) -> IO ()
resetter (Snaplet b -> Snaplet b -> Snaplet b
forall a b. a -> b -> a
const Snaplet b
b)
        Text
msgs <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (IORef Text -> IO Text) -> IORef Text -> IO Text
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
        Either Text Text -> IO (Either Text Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Text -> IO (Either Text Text))
-> Either Text Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right Text
msgs


------------------------------------------------------------------------------
-- | 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 <- IO (Snaplet b) -> Snap (Snaplet b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar (Snaplet b) -> IO (Snaplet b)
forall a. MVar a -> IO a
readMVar MVar (Snaplet b)
mvar)
    (!a
a, Snaplet b
_) <- Lensed (Snaplet b) (Snaplet b) Snap a
-> ALens' (Snaplet b) (Snaplet b)
-> Snaplet b
-> Snap (a, Snaplet b)
forall (m :: * -> *) t1 b t.
Monad m =>
Lensed t1 b m t -> ALens' t1 b -> t1 -> m (t, t1)
L.runLensed Lensed (Snaplet b) (Snaplet b) Snap a
m ALens' (Snaplet b) (Snaplet b)
forall a. a -> a
id Snaplet b
b
    a -> Snap a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Snap a) -> a -> Snap a
forall a b. (a -> b) -> a -> b
$! a
a


------------------------------------------------------------------------------
-- | 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 <- (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


------------------------------------------------------------------------------
-- | 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 IO String
-> (String -> IO (Either Text (Snaplet b, InitializerState b)))
-> IO (Either Text (Snaplet b, InitializerState b))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> String
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' (Snaplet b -> Snaplet b) -> IO ()
resetter String
env Initializer b b (Snaplet b)
b


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

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

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

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

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


------------------------------------------------------------------------------
-- | 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 <- IO (MVar (Snaplet b))
forall a. IO (MVar a)
newEmptyMVar
    let resetter :: (Snaplet b -> Snaplet b) -> IO ()
resetter Snaplet b -> Snaplet b
f = MVar (Snaplet b) -> (Snaplet b -> IO (Snaplet b)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Snaplet b)
snapletMVar (Snaplet b -> IO (Snaplet b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Snaplet b -> IO (Snaplet b))
-> (Snaplet b -> Snaplet b) -> Snaplet b -> IO (Snaplet b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Snaplet b -> Snaplet b
f)
    Either Text (Snaplet b, InitializerState b)
eRes <- ((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
forall b.
((Snaplet b -> Snaplet b) -> IO ())
-> String
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer (Snaplet b -> Snaplet b) -> IO ()
resetter (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"devel" Maybe String
env) Initializer b b (Snaplet b)
b
    let go :: (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go (Snaplet b
siteSnaplet,InitializerState b
is) = do
            MVar (Snaplet b) -> Snaplet b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Snaplet b)
snapletMVar Snaplet b
siteSnaplet
            Text
msgs <- IO Text -> IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef (IORef Text -> IO Text) -> IORef Text -> IO Text
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef Text
forall b. InitializerState b -> IORef Text
_initMessages InitializerState b
is
            let handler :: Snap ()
handler = Handler b b () -> MVar (Snaplet b) -> Snap ()
forall b a. Handler b b a -> MVar (Snaplet b) -> Snap a
runBase (InitializerState b -> Handler b b () -> Handler b b ()
forall b. InitializerState b -> Handler b b () -> Handler b b ()
_hFilter InitializerState b
is (Handler b b () -> Handler b b ())
-> Handler b b () -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ [(ByteString, Handler b b ())] -> Handler b b ()
forall (m :: * -> *) a. MonadSnap m => [(ByteString, m a)] -> m a
route ([(ByteString, Handler b b ())] -> Handler b b ())
-> [(ByteString, Handler b b ())] -> Handler b b ()
forall a b. (a -> b) -> a -> b
$ InitializerState b -> [(ByteString, Handler b b ())]
forall b. InitializerState b -> [(ByteString, Handler b b ())]
_handlers InitializerState b
is) MVar (Snaplet b)
snapletMVar
            IO ()
cleanupAction <- IORef (IO ()) -> IO (IO ())
forall a. IORef a -> IO a
readIORef (IORef (IO ()) -> IO (IO ())) -> IORef (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ InitializerState b -> IORef (IO ())
forall b. InitializerState b -> IORef (IO ())
_cleanup InitializerState b
is
            (Text, Snap (), IO ()) -> IO (Text, Snap (), IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
msgs, Snap ()
handler, IO ()
cleanupAction)
    (Text -> IO (Text, Snap (), IO ()))
-> ((Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ()))
-> Either Text (Snaplet b, InitializerState b)
-> IO (Text, Snap (), IO ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Text, Snap (), IO ())
forall a. HasCallStack => String -> a
error (String -> IO (Text, Snap (), IO ()))
-> (Text -> String) -> Text -> IO (Text, Snap (), IO ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) (Snaplet b, InitializerState b) -> IO (Text, Snap (), IO ())
go Either Text (Snaplet b, InitializerState b)
eRes


------------------------------------------------------------------------------
-- | 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 <- 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)


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

------------------------------------------------------------------------------
-- | 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 (AppConfig -> Maybe String) -> Maybe AppConfig -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Config Snap AppConfig -> Maybe AppConfig
forall (m :: * -> *) a. Config m a -> Maybe a
getOther Config Snap AppConfig
config
    (Text
msgs, Snap ()
handler, IO ()
doCleanup) <- Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
forall b.
Maybe String -> SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet Maybe String
env SnapletInit b b
initializer

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

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


------------------------------------------------------------------------------
-- | 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 = String -> Text -> DirTree String -> [(Text, Worth String)]
forall a. String -> Text -> DirTree a -> [(Text, Worth a)]
loadAppConfig' String
cfg Text
"" (DirTree String -> [(Text, Worth String)])
-> DirTree String -> [(Text, Worth String)]
forall a b. (a -> b) -> a -> b
$ AnchoredDirTree String -> DirTree String
forall a. AnchoredDirTree a -> DirTree a
dirTree AnchoredDirTree String
tree
    [(Text, Worth String)] -> IO Config
loadGroups [(Text, Worth String)]
groups


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


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


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


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


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