module Snap.Snaplet.HeistNoClass
( Heist
, heistInit
, clearHeistCache
, addTemplates
, addTemplatesAt
, modifyHeistTS
, modifyHeistTS'
, withHeistTS
, withHeistTS'
, addSplices
, addSplices'
, render
, renderAs
, heistServe
, heistServeSingle
, heistLocal
, withSplices
, renderWithSplices
, heistLocal'
, withSplices'
, renderWithSplices'
, SnapletHeist
, SnapletSplice
, runSnapletSplice
, liftHeist
, liftWith
, liftHandler
, liftAppHandler
, bindSnapletSplices
) where
import Prelude hiding ((.), id)
import Control.Arrow
import Control.Applicative
import Control.Category
import Control.Monad.CatchIO (MonadCatchIO)
import Control.Monad.Reader
import Control.Monad.State
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.UTF8 as U
import Data.Maybe
import Data.Monoid
import Data.Lens.Lazy
import Data.Text (Text)
import qualified Data.Text as T
import System.FilePath.Posix
import Text.Templating.Heist
import Text.Templating.Heist.Splices.Cache
import Snap.Snaplet
import Snap.Core
import Snap.Util.FileServe
data Heist b = Heist
{ _heistTS :: TemplateState (Handler b b)
, _heistCTS :: CacheTagState
}
changeTS :: (TemplateState (Handler a a) -> TemplateState (Handler a a))
-> Heist a
-> Heist a
changeTS f (Heist ts cts) = Heist (f ts) cts
clearHeistCache :: Heist b -> IO ()
clearHeistCache = clearCacheTagState . _heistCTS
instance MonadSnap m => MonadSnap (HeistT m) where
liftSnap = lift . liftSnap
newtype SnapletHeist b v a = SnapletHeist
(ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)
deriving ( Monad
, Functor
, Applicative
, Alternative
, MonadIO
, MonadPlus
, MonadReader (Lens (Snaplet b) (Snaplet v))
, MonadCatchIO
, MonadSnap
)
type SnapletSplice b v = SnapletHeist b v Template
runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))
-> SnapletHeist b v a
-> HeistT (Handler b b) a
runSnapletSplice l (SnapletHeist m) = runReaderT m l
withSS :: (Lens (Snaplet b) (Snaplet v) -> Lens (Snaplet b) (Snaplet v'))
-> SnapletHeist b v' a
-> SnapletHeist b v a
withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m
liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a
liftHeist = SnapletHeist . lift
liftWith :: (Lens (Snaplet b) (Snaplet v'))
-> Handler b v' a
-> SnapletHeist b v a
liftWith l = liftHeist . lift . withTop' l
liftHandler :: Handler b v a -> SnapletHeist b v a
liftHandler m = do
l <- ask
liftWith l m
liftAppHandler :: Handler b b a -> SnapletHeist b v a
liftAppHandler = liftHeist . lift
instance MonadState v (SnapletHeist b v) where
get = do
l <- ask
b <- liftAppHandler getSnapletState
return $ getL (snapletValue . l) b
put s = do
l <- ask
b <- liftAppHandler getSnapletState
liftAppHandler $ putSnapletState $ setL (snapletValue . l) s b
instance MonadSnaplet SnapletHeist where
getLens = ask
with' l = withSS (l .)
withTop' l = withSS (const id) . with' l
getOpaqueConfig = do
l <- ask
b <- liftAppHandler getSnapletState
return $ getL (snapletConfig . l) b
bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))
-> [(Text, SnapletSplice b v)]
-> TemplateState (Handler b b)
-> TemplateState (Handler b b)
bindSnapletSplices l splices =
bindSplices $ map (second $ runSnapletSplice l) splices
heistInit :: FilePath
-> SnapletInit b (Heist b)
heistInit templateDir =
makeSnaplet "heist" "" Nothing $ do
(cacheFunc, cts) <- liftIO mkCacheTag
let origTs = cacheFunc emptyTemplateState
ts <- liftIO $ loadTemplates templateDir origTs >>=
either error return
addRoutes [ ("", heistServe) ]
printInfo $ T.pack $ unwords
[ "...loaded"
, (show $ length $ templateNames ts)
, "templates"
]
return $ Heist ts cts
addTemplates :: ByteString -> Initializer b (Heist b) ()
addTemplates urlPrefix = do
snapletPath <- getSnapletFilePath
addTemplatesAt urlPrefix (snapletPath </> "templates")
addTemplatesAt :: ByteString
-> FilePath
-> Initializer b (Heist b) ()
addTemplatesAt urlPrefix templateDir = do
ts <- liftIO $ loadTemplates templateDir emptyTemplateState
>>= either error return
printInfo $ T.pack $ unwords
[ "...adding"
, (show $ length $ templateNames ts)
, "templates from"
, templateDir
, "with route prefix"
, (U.toString urlPrefix) ++ "/"
]
addPostInitHook $ return . changeTS
(`mappend` addTemplatePathPrefix urlPrefix ts)
modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Initializer b v ()
modifyHeistTS' heist f = do
_lens <- getLens
withTop' heist $ addPostInitHook $ return . changeTS f
modifyHeistTS :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Initializer b v ()
modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f
withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> a)
-> Handler b v a
withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)
withHeistTS :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> a)
-> Handler b v a
withHeistTS heist f = withHeistTS' (subSnaplet heist) f
addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Initializer b v ()
addSplices' heist splices = do
_lens <- getLens
withTop' heist $ addPostInitHook $
return . changeTS (bindSnapletSplices _lens splices)
addSplices :: (Lens b (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
renderHelper :: Maybe MIMEType
-> ByteString
-> Handler b (Heist b) ()
renderHelper c t = do
(Heist ts _) <- get
withTop' id $ renderTemplate ts t >>= maybe pass serve
where
serve (b, mime) = do
modifyResponse $ setContentType $ fromMaybe mime c
writeBuilder b
render :: ByteString
-> Handler b (Heist b) ()
render t = renderHelper Nothing t
renderAs :: ByteString
-> ByteString
-> Handler b (Heist b) ()
renderAs ct t = renderHelper (Just ct) t
heistServe :: Handler b (Heist b) ()
heistServe =
ifTop (render "index") <|> (render . B.pack =<< getSafePath)
heistServeSingle :: ByteString
-> Handler b (Heist b) ()
heistServeSingle t =
render t <|> error ("Template " ++ show t ++ " not found.")
heistLocal' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Handler b v a
-> Handler b v a
heistLocal' heist f m = do
hs <- withTop' heist get
withTop' heist $ modify $ changeTS f
res <- m
withTop' heist $ put hs
return res
heistLocal :: (Lens b (Snaplet (Heist b)))
-> (TemplateState (Handler b b) -> TemplateState (Handler b b))
-> Handler b v a
-> Handler b v a
heistLocal heist f m = heistLocal' (subSnaplet heist) f m
withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Handler b v a
-> Handler b v a
withSplices' heist splices m = do
_lens <- getLens
heistLocal' heist (bindSnapletSplices _lens splices) m
withSplices :: (Lens b (Snaplet (Heist b)))
-> [(Text, SnapletSplice b v)]
-> Handler b v a
-> Handler b v a
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> ByteString
-> [(Text, SnapletSplice b v)]
-> Handler b v ()
renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
renderWithSplices :: (Lens b (Snaplet (Heist b)))
-> ByteString
-> [(Text, SnapletSplice b v)]
-> Handler b v ()
renderWithSplices heist t splices =
renderWithSplices' (subSnaplet heist) t splices