module Snap.Snaplet.HeistNoClass
( Heist
, heistInit
, heistInit'
, clearHeistCache
, addTemplates
, addTemplatesAt
, modifyHeistState
, modifyHeistState'
, withHeistState
, withHeistState'
, addSplices
, addSplices'
, addConfig
, cRender
, cRenderAs
, cHeistServe
, cHeistServeSingle
, render
, renderAs
, heistServe
, heistServeSingle
, heistLocal
, withSplices
, renderWithSplices
, heistLocal'
, withSplices'
, renderWithSplices'
, SnapletHeist
, SnapletISplice
, SnapletCSplice
) where
import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Error
import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.DList (DList)
import qualified Data.HashMap.Strict as Map
import Data.IORef
import Data.List
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import System.FilePath.Posix
import Heist
import qualified Heist.Compiled as C
import qualified Heist.Interpreted as I
import Heist.Splices.Cache
import Snap.Snaplet
import Snap.Core
import Snap.Util.FileServe
data Heist b = Configuring
{ _heistConfig :: IORef (HeistConfig (Handler b b)) }
| Running
{ _heistState :: HeistState (Handler b b)
, _heistCTS :: CacheTagState
}
changeState :: (HeistState (Handler a a) -> HeistState (Handler a a))
-> Heist a
-> Heist a
changeState _ (Configuring _) =
error "changeState: HeistState has not been initialized"
changeState f (Running hs cts) = Running (f hs) cts
clearHeistCache :: Heist b -> IO ()
clearHeistCache = clearCacheTagState . _heistCTS
instance MonadSnap m => MonadSnap (HeistT n m) where
liftSnap = lift . liftSnap
type SnapletHeist b m a = HeistT (Handler b b) m a
type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b)))
type SnapletISplice b = SnapletHeist b (Handler b b) Template
heistInit :: FilePath
-> SnapletInit b (Heist b)
heistInit templateDir = do
makeSnaplet "heist" "" Nothing $ do
hs <- heistInitWorker templateDir defaultConfig
addRoutes [ ("", heistServe) ]
return hs
where
defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
heistInit' :: FilePath
-> HeistConfig (Handler b b)
-> SnapletInit b (Heist b)
heistInit' templateDir initialConfig =
makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig
heistInitWorker :: FilePath
-> HeistConfig (Handler b b)
-> Initializer b (Heist b) (Heist b)
heistInitWorker templateDir initialConfig = do
snapletPath <- getSnapletFilePath
let tDir = snapletPath </> templateDir
templates <- liftIO $ runEitherT (loadTemplates tDir) >>=
either (error . concat) return
let config = initialConfig `mappend` mempty { hcTemplates = templates }
printInfo $ T.pack $ unwords
[ "...loaded"
, (show $ Map.size templates)
, "templates from"
, tDir
]
ref <- liftIO $ newIORef config
addPostInitHook finalLoadHook
return $ Configuring ref
finalLoadHook :: Heist b -> EitherT Text IO (Heist b)
finalLoadHook (Configuring ref) = do
hc <- lift $ readIORef ref
(hs,cts) <- toTextErrors $ initHeistWithCacheTag hc
return $ Running hs cts
where
toTextErrors = mapEitherT (T.pack . intercalate "\n") id
finalLoadHook (Running _ _) = left "finalLoadHook called while running"
addTemplates :: Snaplet (Heist b)
-> ByteString
-> Initializer b (Heist b) ()
addTemplates h urlPrefix = do
snapletPath <- getSnapletFilePath
addTemplatesAt h urlPrefix (snapletPath </> "templates")
addTemplatesAt :: Snaplet (Heist b)
-> ByteString
-> FilePath
-> Initializer b (Heist b) ()
addTemplatesAt h urlPrefix templateDir = do
rootUrl <- getSnapletRootURL
let fullPrefix = (T.unpack $ decodeUtf8 rootUrl) </>
(T.unpack $ decodeUtf8 urlPrefix)
addPrefix = return . addTemplatePathPrefix
(encodeUtf8 $ T.pack fullPrefix)
ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=
either (error . concat) addPrefix
printInfo $ T.pack $ unwords
[ "...adding"
, (show $ Map.size ts)
, "templates from"
, templateDir
, "with route prefix"
, fullPrefix ++ "/"
]
liftIO $ atomicModifyIORef (_heistConfig $ extract h)
(\hc -> (hc `mappend` mempty { hcTemplates = ts }, ()))
modifyHeistState' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Initializer b v ()
modifyHeistState' heist f = do
withTop' heist $ addPostInitHook $ return . changeState f
modifyHeistState :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Initializer b v ()
modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f
withHeistState' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> a)
-> Handler b v a
withHeistState' heist f = do
hs <- withTop' heist $ gets _heistState
return $ f hs
withHeistState :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> a)
-> Handler b v a
withHeistState heist f = withHeistState' (subSnaplet heist) f
addConfig :: Snaplet (Heist b)
-> HeistConfig (Handler b b)
-> Initializer b v ()
addConfig h hc = case extract h of
Configuring ref ->
liftIO $ atomicModifyIORef ref (\hc1 -> (hc1 `mappend` hc, ()))
Running _ _ -> do
printInfo "finalLoadHook called while running"
error "this shouldn't happen"
addSplices' :: SnapletLens (Snaplet b) (Heist b)
-> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices' heist splices = do
withTop' heist $ addPostInitHook $
return . changeState (I.bindSplices splices)
addSplices :: SnapletLens b (Heist b)
-> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
iRenderHelper :: Maybe MIMEType
-> ByteString
-> Handler b (Heist b) ()
iRenderHelper c t = do
(Running hs _) <- get
withTop' id $ I.renderTemplate hs t >>= maybe pass serve
where
serve (b, mime) = do
modifyResponse $ setContentType $ fromMaybe mime c
writeBuilder b
cRenderHelper :: Maybe MIMEType
-> ByteString
-> Handler b (Heist b) ()
cRenderHelper c t = do
(Running hs _) <- get
withTop' id $ maybe pass serve $ C.renderTemplate hs t
where
serve (b, mime) = do
modifyResponse $ setContentType $ fromMaybe mime c
writeBuilder =<< b
render :: ByteString
-> Handler b (Heist b) ()
render t = iRenderHelper Nothing t
renderAs :: ByteString
-> ByteString
-> Handler b (Heist b) ()
renderAs ct t = iRenderHelper (Just ct) t
cRender :: ByteString
-> Handler b (Heist b) ()
cRender t = cRenderHelper Nothing t
cRenderAs :: ByteString
-> ByteString
-> Handler b (Heist b) ()
cRenderAs ct t = cRenderHelper (Just ct) t
serveURI :: Handler b (Heist b) ByteString
serveURI = do
p <- getSafePath
if take 1 p == "_" then pass else return $ B.pack p
heistServe :: Handler b (Heist b) ()
heistServe =
ifTop (render "index") <|> (render =<< serveURI)
heistServeSingle :: ByteString -> Handler b (Heist b) ()
heistServeSingle t =
render t <|> error ("Template " ++ show t ++ " not found.")
cHeistServe :: Handler b (Heist b) ()
cHeistServe =
ifTop (cRender "index") <|> (cRender =<< serveURI)
cHeistServeSingle :: ByteString -> Handler b (Heist b) ()
cHeistServeSingle t =
cRender t <|> error ("Template " ++ show t ++ " not found.")
heistLocal' :: SnapletLens (Snaplet b) (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Handler b v a
-> Handler b v a
heistLocal' heist f m = do
hs <- withTop' heist get
withTop' heist $ modify $ changeState f
res <- m
withTop' heist $ put hs
return res
heistLocal :: SnapletLens b (Heist b)
-> (HeistState (Handler b b) -> HeistState (Handler b b))
-> Handler b v a
-> Handler b v a
heistLocal heist f m = heistLocal' (subSnaplet heist) f m
withSplices' :: SnapletLens (Snaplet b) (Heist b)
-> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
withSplices' heist splices m = do
heistLocal' heist (I.bindSplices splices) m
withSplices :: SnapletLens b (Heist b)
-> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
renderWithSplices' :: SnapletLens (Snaplet b) (Heist b)
-> ByteString
-> [(Text, SnapletISplice b)]
-> Handler b v ()
renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
renderWithSplices :: SnapletLens b (Heist b)
-> ByteString
-> [(Text, SnapletISplice b)]
-> Handler b v ()
renderWithSplices heist t splices =
renderWithSplices' (subSnaplet heist) t splices