module Snap.Snaplet.Internal.Initializer
( addPostInitHook
, addPostInitHookBase
, toSnapletHook
, bracketInit
, modifyCfg
, nestSnaplet
, embedSnaplet
, makeSnaplet
, nameSnaplet
, onUnload
, addRoutes
, wrapHandlers
, runInitializer
, runSnaplet
, combineConfig
, serveSnaplet
, printInfo
) where
import Prelude hiding ((.), id, catch)
import Control.Category
import Control.Concurrent.MVar
import Control.Exception (SomeException)
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 Data.IORef
import Data.Maybe
import Data.Lens.Lazy
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 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
toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v))
toSnapletHook f (Snaplet cfg val) = do
val' <- f val
return $! Snaplet cfg val'
addPostInitHook :: (v -> IO v) -> Initializer b v ()
addPostInitHook = addPostInitHook' . toSnapletHook
addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v ()
addPostInitHook' h = do
h' <- upHook h
addPostInitHookBase h'
addPostInitHookBase :: (Snaplet b -> IO (Snaplet b))
-> Initializer b v ()
addPostInitHookBase = Initializer . lift . tell . Hook
upHook :: (Snaplet v -> IO (Snaplet v))
-> Initializer b v (Snaplet b -> IO (Snaplet b))
upHook h = Initializer $ do
l <- ask
return $ upHook' l h
upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b
upHook' l h b = do
v <- h (getL l b)
return $ setL l v b
modifyCfg :: (SnapletConfig -> SnapletConfig) -> Initializer b v ()
modifyCfg f = iModify $ modL 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 to
where
to = targetRoot </> makeRelative srcRoot filename
directory = dropFileName to
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 setL scId (Just snapletId) c else c
sid <- iGets (T.unpack . fromJust . _scId . _curConfig)
topLevel <- iGets _isTopLevel
unless topLevel $ modifyCfg $ \c -> setL scFilePath
(_scFilePath c </> "snaplets" </> sid) c
iModify (setL isTopLevel False)
modifyCfg $ modL scUserConfig (subconfig (T.pack sid))
modifyCfg $ setL scDescription desc
cfg <- iGets _curConfig
printInfo $ T.pack $ concat
["Initializing "
,sid
," @ /"
,B.unpack $ buildPath $ _scRouteContext cfg
]
setupFilesystem getSnapletDataDir (_scFilePath cfg)
liftIO $ addToConfig [Optional (_scFilePath cfg </> "snaplet.cfg")]
(_scUserConfig cfg)
mkSnaplet m
mkSnaplet :: Initializer b v a -> Initializer b v (Snaplet a)
mkSnaplet m = do
res <- m
cfg <- iGets _curConfig
return $ Snaplet cfg res
bracketInit :: Initializer b v a -> Initializer b v a
bracketInit m = do
s <- iGet
res <- m
iModify (setL curConfig (_curConfig s))
return res
setupSnapletCall :: ByteString -> Initializer b v ()
setupSnapletCall rte = do
curId <- iGets (fromJust . _scId . _curConfig)
modifyCfg (modL scAncestry (curId:))
modifyCfg (modL scId (const Nothing))
unless (B.null rte) $ modifyCfg (modL scRouteContext (rte:))
nestSnaplet :: ByteString
-> (Lens v (Snaplet v1))
-> SnapletInit b v1
-> Initializer b v (Snaplet v1)
nestSnaplet rte l (SnapletInit snaplet) = with l $ bracketInit $ do
setupSnapletCall rte
snaplet
embedSnaplet :: ByteString
-> (Lens v (Snaplet v1))
-> SnapletInit v1 v1
-> Initializer b v (Snaplet v1)
embedSnaplet rte l (SnapletInit snaplet) = bracketInit $ do
curLens <- getLens
setupSnapletCall ""
chroot rte (subSnaplet l . curLens) snaplet
chroot :: ByteString
-> (Lens (Snaplet b) (Snaplet v1))
-> Initializer v1 v1 a
-> Initializer b v a
chroot rte l (Initializer m) = do
curState <- iGet
((a,s), (Hook hook)) <- liftIO $ runWriterT $ LT.runLensT m id $
curState {
_handlers = [],
_hFilter = id
}
let handler = chrootHandler l $ _hFilter s $ route $ _handlers s
iModify $ modL handlers (++[(rte,handler)])
. setL cleanup (_cleanup s)
addPostInitHookBase $ upHook' l hook
return a
chrootHandler :: (Lens (Snaplet v) (Snaplet b'))
-> Handler b' b' a -> Handler b v a
chrootHandler l (Handler h) = Handler $ do
s <- get
(a, s') <- liftSnap $ L.runLensed h id (getL l s)
modify $ setL l s'
return a
nameSnaplet :: Text
-> SnapletInit b v
-> SnapletInit b v
nameSnaplet nm (SnapletInit m) = SnapletInit $
modifyCfg (setL 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 -> modL handlers (++rs') v)
where
setPattern r = do
p <- getRoutePattern
when (isNothing p) $ setRoutePattern r
wrapHandlers :: (Handler b v () -> Handler b v ()) -> Initializer b v ()
wrapHandlers f0 = do
f <- mungeFilter f0
iModify (\v -> modL 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
-> MVar (Snaplet b)
-> Initializer b b (Snaplet b)
-> IO (Either Text Text)
mkReloader cwd mvar i = do
!res <- runInitializer' mvar i cwd
either (return . Left) good res
where
good (b,is) = do
_ <- swapMVar mvar 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
runInitializer :: MVar (Snaplet b)
-> Initializer b b (Snaplet b)
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer mvar b = getCurrentDirectory >>= runInitializer' mvar b
runInitializer' :: MVar (Snaplet b)
-> Initializer b b (Snaplet b)
-> FilePath
-> IO (Either Text (Snaplet b, InitializerState b))
runInitializer' mvar b@(Initializer i) cwd = do
userConfig <- load [Optional "snaplet.cfg"]
let builtinHandlers = [("/admin/reload", reloadSite)]
let cfg = SnapletConfig [] cwd Nothing "" userConfig [] Nothing
(mkReloader cwd mvar b)
logRef <- newIORef ""
cleanupRef <- newIORef (return ())
let body = do
((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $
InitializerState True cleanupRef builtinHandlers id cfg logRef
res' <- hook res
return $ 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 :: SnapletInit b b -> IO (Text, Snap (), IO ())
runSnaplet (SnapletInit b) = do
snapletMVar <- newEmptyMVar
eRes <- runInitializer snapletMVar 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 a -> SnapletInit b b -> IO ()
serveSnaplet startConfig initializer = do
(msgs, handler, doCleanup) <- runSnaplet initializer
config <- commandLineConfig startConfig
(conf, site) <- combineConfig config handler
createDirectoryIfMissing False "log"
let serve = simpleHttpServe conf
liftIO $ hPutStrLn stderr $ T.unpack msgs
_ <- try $ serve $ site
:: IO (Either SomeException ())
doCleanup