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