Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Converted the Heist snaplet to Heist 0.10

  • Loading branch information...
commit aece75ec73819c18f82aae7eb44d39b38a9a8b8d 1 parent 2641ff5
@mightybyte mightybyte authored
View
7 snap.cabal
@@ -105,6 +105,7 @@ Library
Snap,
Snap.Snaplet
Snap.Snaplet.Heist
+ Snap.Snaplet.HeistNoClass
Snap.Snaplet.Auth
Snap.Snaplet.Auth.Backends.JsonFile
Snap.Snaplet.Config
@@ -125,7 +126,7 @@ Library
Snap.Snaplet.Auth.Types
Snap.Snaplet.Auth.Handlers
Snap.Snaplet.Auth.SpliceHelpers
- Snap.Snaplet.HeistNoClass
+-- Snap.Snaplet.HeistNoClass
Snap.Snaplet.Internal.Initializer
Snap.Snaplet.Internal.LensT
Snap.Snaplet.Internal.Lensed
@@ -152,9 +153,11 @@ Library
directory-tree >= 0.10 && < 0.11,
data-lens >= 2.0.1 && < 2.11,
data-lens-template >= 2.1 && < 2.2,
+ dlist >= 0.5 && < 0.6,
+ errors >= 1.3 && < 1.4,
filepath >= 1.1 && < 1.4,
hashable >= 1.1 && < 1.2,
- heist >= 0.7 && < 0.9,
+ heist >= 0.10 && < 0.11,
logict >= 0.4.2 && < 0.6,
mtl > 2.0 && < 2.2,
mwc-random >= 0.8 && < 0.13,
View
11 src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -20,7 +20,8 @@ module Snap.Snaplet.Auth.SpliceHelpers
import Data.Lens.Lazy
import qualified Text.XmlHtml as X
-import Text.Templating.Heist
+import Heist
+import qualified Heist.Interpreted as I
import Snap.Snaplet
import Snap.Snaplet.Auth.AuthManager
@@ -53,7 +54,7 @@ addAuthSplices auth = addSplices
-- present, this will run the contents of the node.
--
-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
-ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v
+ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
ifLoggedIn auth = do
chk <- liftHandler $ withTop auth isLoggedIn
case chk of
@@ -66,7 +67,7 @@ ifLoggedIn auth = do
-- not present, this will run the contents of the node.
--
-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
-ifLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v
+ifLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
ifLoggedOut auth = do
chk <- liftHandler $ withTop auth isLoggedIn
case chk of
@@ -77,7 +78,7 @@ ifLoggedOut auth = do
-------------------------------------------------------------------------------
-- | A splice that will simply print the current user's login, if
-- there is one.
-loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletSplice b v
+loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
loggedInUser auth = do
u <- liftHandler $ withTop auth currentUser
- liftHeist $ maybe (return []) (textSplice . userLogin) u
+ liftHeist $ maybe (return []) (I.textSplice . userLogin) u
View
92 src/Snap/Snaplet/Heist.hs
@@ -15,10 +15,16 @@ module Snap.Snaplet.Heist
, heistInit'
, addTemplates
, addTemplatesAt
- , modifyHeistTS
- , withHeistTS
+ , modifyHeistState
+ , withHeistState
, addSplices
+ , Unclassed.addConfig
+ , cRender
+ , cRenderAs
+ , cHeistServe
+ , cHeistServeSingle
+
-- * Handler Functions
-- $handlerSection
, render
@@ -32,7 +38,7 @@ module Snap.Snaplet.Heist
-- * Writing Splices
-- $spliceSection
, Unclassed.SnapletHeist
- , Unclassed.SnapletSplice
+ , Unclassed.SnapletISplice
, Unclassed.liftHeist
, Unclassed.liftHandler
, Unclassed.liftAppHandler
@@ -47,7 +53,7 @@ import Prelude hiding (id, (.))
import Data.ByteString (ByteString)
import Data.Lens.Lazy
import Data.Text (Text)
-import Text.Templating.Heist
+import Heist
------------------------------------------------------------------------------
import Snap.Snaplet
import qualified Snap.Snaplet.HeistNoClass as Unclassed
@@ -89,10 +95,11 @@ class HasHeist b where
-- this function to add their own templates. The templates are automatically
-- read from the templates directory in the current snaplet's filesystem root.
addTemplates :: HasHeist b
- => ByteString
+ => Heist b
+ -> ByteString
-- ^ The url prefix for the template routes
-> Initializer b v ()
-addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)
+addTemplates h pfx = withTop' heistLens (Unclassed.addTemplates h pfx)
------------------------------------------------------------------------------
@@ -103,18 +110,20 @@ addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)
-- getSnapletFilePath if you want your snaplet to use templates within its
-- normal directory structure.
addTemplatesAt :: HasHeist b
- => ByteString
+ => Heist b
+ -> ByteString
-- ^ URL prefix for template routes
-> FilePath
-- ^ Path to templates
-> Initializer b v ()
-addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)
+addTemplatesAt h pfx p =
+ withTop' heistLens (Unclassed.addTemplatesAt h pfx p)
------------------------------------------------------------------------------
-- | Allows snaplets to add splices.
addSplices :: (HasHeist b)
- => [(Text, Unclassed.SnapletSplice b v)]
+ => [(Text, Unclassed.SnapletISplice b v)]
-- ^ Splices to bind
-> Initializer b v ()
addSplices = Unclassed.addSplices' heistLens
@@ -124,20 +133,20 @@ addSplices = Unclassed.addSplices' heistLens
-- | More general function allowing arbitrary HeistState modification.
-- Without this function you wouldn't be able to bind more complicated splices
-- like the cache tag.
-modifyHeistTS :: (HasHeist b)
- => (HeistState (Handler b b) -> HeistState (Handler b b))
- -- ^ HeistState modifying function
- -> Initializer b v ()
-modifyHeistTS = Unclassed.modifyHeistTS' heistLens
+modifyHeistState :: (HasHeist b)
+ => (HeistState (Handler b b) -> HeistState (Handler b b))
+ -- ^ HeistState modifying function
+ -> Initializer b v ()
+modifyHeistState = Unclassed.modifyHeistState' heistLens
------------------------------------------------------------------------------
-- | Runs a function on with the Heist snaplet's 'HeistState'.
-withHeistTS :: (HasHeist b)
- => (HeistState (Handler b b) -> a)
- -- ^ HeistState function to run
- -> Handler b v a
-withHeistTS = Unclassed.withHeistTS' heistLens
+withHeistState :: (HasHeist b)
+ => (HeistState (Handler b b) -> a)
+ -- ^ HeistState function to run
+ -> Handler b v a
+withHeistState = Unclassed.withHeistState' heistLens
-- $handlerSection
@@ -168,6 +177,28 @@ renderAs ct t = withTop' heistLens (Unclassed.renderAs ct t)
------------------------------------------------------------------------------
+-- | Renders a template as text\/html. If the given template is not found,
+-- this returns 'empty'.
+cRender :: HasHeist b
+ => ByteString
+ -- ^ Template name
+ -> Handler b v ()
+cRender t = withTop' heistLens (Unclassed.cRender t)
+
+
+------------------------------------------------------------------------------
+-- | Renders a template as the given content type. If the given template
+-- is not found, this returns 'empty'.
+cRenderAs :: HasHeist b
+ => ByteString
+ -- ^ Content type to render with
+ -> ByteString
+ -- ^ Template name
+ -> Handler b v ()
+cRenderAs ct t = withTop' heistLens (Unclassed.cRenderAs ct t)
+
+
+------------------------------------------------------------------------------
-- | Analogous to 'fileServe'. If the template specified in the request path
-- is not found, it returns 'empty'.
heistServe :: HasHeist b => Handler b v ()
@@ -185,12 +216,29 @@ heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t)
------------------------------------------------------------------------------
+-- | Analogous to 'fileServe'. If the template specified in the request path
+-- is not found, it returns 'empty'.
+cHeistServe :: HasHeist b => Handler b v ()
+cHeistServe = withTop' heistLens Unclassed.cHeistServe
+
+
+------------------------------------------------------------------------------
+-- | Analogous to 'fileServeSingle'. If the given template is not found,
+-- this throws an error.
+cHeistServeSingle :: HasHeist b
+ => ByteString
+ -- ^ Template name
+ -> Handler b v ()
+cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)
+
+
+------------------------------------------------------------------------------
-- | Renders a template with a given set of splices. This is syntax sugar for
-- a common combination of heistLocal, bindSplices, and render.
renderWithSplices :: HasHeist b
=> ByteString
-- ^ Template name
- -> [(Text, Unclassed.SnapletSplice b v)]
+ -> [(Text, Unclassed.SnapletISplice b v)]
-- ^ Splices to bind
-> Handler b v ()
renderWithSplices = Unclassed.renderWithSplices' heistLens
@@ -200,7 +248,7 @@ renderWithSplices = Unclassed.renderWithSplices' heistLens
-- | Runs an action with additional splices bound into the Heist
-- 'HeistState'.
withSplices :: HasHeist b
- => [(Text, Unclassed.SnapletSplice b v)]
+ => [(Text, Unclassed.SnapletISplice b v)]
-- ^ Splices to bind
-> Handler b v a
-- ^ Handler to run
@@ -232,6 +280,6 @@ heistLocal = Unclassed.heistLocal' heistLens
-- work with @Handler b v@ so your local snaplet's state is available. We
-- provide the SnapletHeist monad to make this possible. The general rule is
-- that when you're using Snaplets and Heist, use SnapletHeist instead of
--- HeistT (previously called TemplateMonad) and use SnapletSplice instead of
+-- HeistT (previously called TemplateMonad) and use SnapletISplice instead of
-- Splice.
View
288 src/Snap/Snaplet/HeistNoClass.hs
@@ -4,6 +4,14 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
+
+{-|
+
+This module implements the Heist snaplet without using type classes. It is
+provided mainly as an example of how snaplets can be written with and without
+a type class for convenience.
+
+-}
module Snap.Snaplet.HeistNoClass
( Heist
, heistInit
@@ -12,12 +20,19 @@ module Snap.Snaplet.HeistNoClass
, addTemplates
, addTemplatesAt
- , modifyHeistTS
- , modifyHeistTS'
- , withHeistTS
- , withHeistTS'
+ , modifyHeistState
+ , modifyHeistState'
+ , withHeistState
+ , withHeistState'
, addSplices
, addSplices'
+
+ , addConfig
+ , cRender
+ , cRenderAs
+ , cHeistServe
+ , cHeistServeSingle
+
, render
, renderAs
, heistServe
@@ -30,7 +45,8 @@ module Snap.Snaplet.HeistNoClass
, renderWithSplices'
, SnapletHeist
- , SnapletSplice
+ , SnapletISplice
+ , SnapletCSplice
, runSnapletSplice
, liftHeist
, liftWith
@@ -40,23 +56,30 @@ module Snap.Snaplet.HeistNoClass
) where
import Prelude hiding ((.), id)
-import Control.Arrow
+import Control.Arrow (second)
import Control.Applicative
import Control.Category
+import Control.Comonad
+import Control.Error
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.DList (DList)
+import qualified Data.HashMap.Strict as Map
+import Data.IORef
+import Data.List
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 Heist
+import qualified Heist.Compiled as C
+import qualified Heist.Interpreted as I
+import Heist.Splices.Cache
import Snap.Snaplet
import Snap.Core
@@ -68,25 +91,27 @@ import Snap.Util.FileServe
-- include this in your application state and use 'heistInit' to initialize
-- it. The type parameter b will typically be the base state type for your
-- application.
---
-data Heist b = Heist
- { _heistTS :: HeistState (Handler b b)
- , _heistCTS :: CacheTagState
- }
+data Heist b = Configuring
+ { _heistConfig :: IORef (HeistConfig (Handler b b)) }
+ | Running
+ { _heistState :: HeistState (Handler b b)
+ , _heistCTS :: CacheTagState
+ }
------------------------------------------------------------------------------
-changeTS :: (HeistState (Handler a a) -> HeistState (Handler a a))
- -> Heist a
- -> Heist a
-changeTS f (Heist ts cts) = Heist (f ts) cts
+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
------------------------------------------------------------------------------
-- | Clears data stored by the cache tag. The cache tag automatically reloads
-- its data when the specified TTL expires, but sometimes you may want to
-- trigger a manual reload. This function lets you do that.
---
clearHeistCache :: Heist b -> IO ()
clearHeistCache = clearCacheTagState . _heistCTS
@@ -98,16 +123,16 @@ clearHeistCache = clearCacheTagState . _heistCTS
------------------------------------------------------------------------------
-- | This instance is here because we don't want the heist package to depend
-- on anything from snap packages.
---
-instance MonadSnap m => MonadSnap (HeistT m) where
+instance MonadSnap m => MonadSnap (HeistT m m) where
liftSnap = lift . liftSnap
+type HeistHandler b = HeistT (Handler b b) (Handler b b)
+
------------------------------------------------------------------------------
-- | Monad for working with Heist's API from within a snaplet.
---
newtype SnapletHeist b v a = SnapletHeist
- (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistT (Handler b b)) a)
+ (ReaderT (Lens (Snaplet b) (Snaplet v)) (HeistHandler b) a)
deriving ( Monad
, Functor
, Applicative
@@ -122,16 +147,15 @@ newtype SnapletHeist b v a = SnapletHeist
------------------------------------------------------------------------------
-- | Type alias for convenience.
---
-type SnapletSplice b v = SnapletHeist b v Template
+type SnapletISplice b v = SnapletHeist b v Template
+type SnapletCSplice b v = SnapletHeist b v (DList (Chunk (Handler b b)))
------------------------------------------------------------------------------
--- | Runs the SnapletSplice.
---
+-- | Runs the SnapletISplice.
runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))
-> SnapletHeist b v a
- -> HeistT (Handler b b) a
+ -> HeistHandler b a
runSnapletSplice l (SnapletHeist m) = runReaderT m l
@@ -145,14 +169,12 @@ withSS f (SnapletHeist m) = SnapletHeist $ withReaderT f m
------------------------------------------------------------------------------
-- | Lifts a HeistT action into SnapletHeist. Use this with all the functions
-- from the Heist API.
---
-liftHeist :: HeistT (Handler b b) a -> SnapletHeist b v a
+liftHeist :: HeistT (Handler b b) (Handler b b) a -> SnapletHeist b v a
liftHeist = SnapletHeist . lift
------------------------------------------------------------------------------
-- | Common idiom for the combination of liftHandler and withTop.
---
liftWith :: (Lens (Snaplet b) (Snaplet v'))
-> Handler b v' a
-> SnapletHeist b v a
@@ -161,7 +183,6 @@ liftWith l = liftHeist . lift . withTop' l
------------------------------------------------------------------------------
-- | Lifts a Handler into SnapletHeist.
---
liftHandler :: Handler b v a -> SnapletHeist b v a
liftHandler m = do
l <- ask
@@ -170,7 +191,6 @@ liftHandler m = do
------------------------------------------------------------------------------
-- | Lifts a (Handler b b) into SnapletHeist.
---
liftAppHandler :: Handler b b a -> SnapletHeist b v a
liftAppHandler = liftHeist . lift
@@ -189,7 +209,6 @@ instance MonadState v (SnapletHeist b v) where
------------------------------------------------------------------------------
-- | MonadSnaplet instance gives us access to the snaplet infrastructure.
---
instance MonadSnaplet SnapletHeist where
getLens = ask
with' l = withSS (l .)
@@ -202,13 +221,12 @@ instance MonadSnaplet SnapletHeist where
------------------------------------------------------------------------------
-- | SnapletSplices version of bindSplices.
---
bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> HeistState (Handler b b)
-> HeistState (Handler b b)
bindSnapletSplices l splices =
- bindSplices $ map (second $ runSnapletSplice l) splices
+ I.bindSplices $ map (second $ runSnapletSplice l) splices
---------------------------
@@ -219,139 +237,166 @@ bindSnapletSplices l splices =
-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper
-- around `heistInit'` that uses defaultHeistState and sets up routes for all
-- the templates.
---
heistInit :: FilePath -- ^ Path to templates
-> SnapletInit b (Heist b)
heistInit templateDir = do
makeSnaplet "heist" "" Nothing $ do
- hs <- heistInitWorker templateDir defaultHeistState
+ hs <- heistInitWorker templateDir defaultConfig
addRoutes [ ("", heistServe) ]
return hs
+ where
+ defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
------------------------------------------------------------------------------
-- | A lower level 'Initializer' for 'Heist'. This initializer requires you
--- to specify the initial HeistState. It also does not add any routes for
+-- to specify the initial HeistConfig. It also does not add any routes for
-- templates, allowing you complete control over which templates get routed.
---
heistInit' :: FilePath
-- ^ Path to templates
- -> HeistState (Handler b b)
- -- ^ Initial HeistState
+ -> HeistConfig (Handler b b)
+ -- ^ Initial HeistConfig
-> SnapletInit b (Heist b)
-heistInit' templateDir initialHeistState =
- makeSnaplet "heist" "" Nothing $
- heistInitWorker templateDir initialHeistState
+heistInit' templateDir initialConfig =
+ makeSnaplet "heist" "" Nothing $ heistInitWorker templateDir initialConfig
------------------------------------------------------------------------------
-- | Internal worker function used by variantsof heistInit. This is necessary
-- because of the divide between SnapletInit and Initializer.
---
heistInitWorker :: FilePath
- -> HeistState (Handler b b)
- -> Initializer b v (Heist b)
-heistInitWorker templateDir initialHeistState = do
- (cacheFunc, cts) <- liftIO mkCacheTag
- let origTs = cacheFunc initialHeistState
+ -> HeistConfig (Handler b b)
+ -> Initializer b (Heist b) (Heist b)
+heistInitWorker templateDir initialConfig = do
snapletPath <- getSnapletFilePath
let tDir = snapletPath </> templateDir
- ts <- liftIO $ loadTemplates tDir origTs >>=
- either error return
+ templates <- liftIO $ runEitherT (loadTemplates tDir) >>=
+ either (error . concat) return
+ let config = initialConfig `mappend` mempty { hcTemplates = templates }
printInfo $ T.pack $ unwords
[ "...loaded"
- , (show $ length $ templateNames ts)
+ , (show $ Map.size templates)
, "templates from"
, tDir
]
+ ref <- liftIO $ newIORef config
+ addPostInitHook finalLoadHook
+ return $ Configuring ref
+
- return $ Heist ts cts
+------------------------------------------------------------------------------
+-- | Hook that converts the Heist type from Configuring to Running at the end
+-- of initialization.
+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"
------------------------------------------------------------------------------
--- | Adds templates to the Heist HeistState. Other snaplets should use
+-- | Adds templates to the Heist HeistConfig. Other snaplets should use
-- this function to add their own templates. The templates are automatically
-- read from the templates directory in the current snaplet's filesystem root.
-addTemplates :: ByteString
+addTemplates :: Heist b
+ -> ByteString
-- ^ The url prefix for the template routes
-> Initializer b (Heist b) ()
-addTemplates urlPrefix = do
+addTemplates h urlPrefix = do
snapletPath <- getSnapletFilePath
- addTemplatesAt urlPrefix (snapletPath </> "templates")
+ addTemplatesAt h urlPrefix (snapletPath </> "templates")
------------------------------------------------------------------------------
--- | Adds templates to the Heist HeistState, and lets you specify where
+-- | Adds templates to the Heist HeistConfig, and lets you specify where
-- they are found in the filesystem. Note that the path to the template
-- directory is an absolute path. This allows you more flexibility in where
-- your templates are located, but means that you have to explicitly call
-- getSnapletFilePath if you want your snaplet to use templates within its
-- normal directory structure.
-addTemplatesAt :: ByteString
+addTemplatesAt :: Heist b
+ -> ByteString
-- ^ URL prefix for template routes
-> FilePath
-- ^ Path to templates
-> Initializer b (Heist b) ()
-addTemplatesAt urlPrefix templateDir = do
- ts <- liftIO $ loadTemplates templateDir mempty
- >>= either error return
+addTemplatesAt h urlPrefix templateDir = do
rootUrl <- getSnapletRootURL
let fullPrefix = U.toString rootUrl </> U.toString urlPrefix
+ addPrefix = return . addTemplatePathPrefix (U.fromString fullPrefix)
+ ts <- liftIO $ runEitherT (loadTemplates templateDir) >>=
+ either (error . concat) addPrefix
printInfo $ T.pack $ unwords
[ "...adding"
- , (show $ length $ templateNames ts)
+ , (show $ Map.size ts)
, "templates from"
, templateDir
, "with route prefix"
, fullPrefix ++ "/"
]
- addPostInitHook $ return . changeTS
- (`mappend` addTemplatePathPrefix (U.fromString fullPrefix) ts)
+ liftIO $ atomicModifyIORef (_heistConfig h)
+ (\hc -> (hc `mappend` mempty { hcTemplates = ts }, ()))
------------------------------------------------------------------------------
-modifyHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> (HeistState (Handler b b) -> HeistState (Handler b b))
- -> Initializer b v ()
-modifyHeistTS' heist f = do
- _lens <- getLens
- withTop' heist $ addPostInitHook $ return . changeTS f
+modifyHeistState' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+ -> (HeistState (Handler b b) -> HeistState (Handler b b))
+ -> Initializer b v ()
+modifyHeistState' heist f = do
+ withTop' heist $ addPostInitHook $ return . changeState f
------------------------------------------------------------------------------
-modifyHeistTS :: (Lens b (Snaplet (Heist b)))
- -> (HeistState (Handler b b) -> HeistState (Handler b b))
- -> Initializer b v ()
-modifyHeistTS heist f = modifyHeistTS' (subSnaplet heist) f
+modifyHeistState :: (Lens b (Snaplet (Heist b)))
+ -> (HeistState (Handler b b) -> HeistState (Handler b b))
+ -> Initializer b v ()
+modifyHeistState heist f = modifyHeistState' (subSnaplet heist) f
------------------------------------------------------------------------------
-withHeistTS' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> (HeistState (Handler b b) -> a)
- -> Handler b v a
-withHeistTS' heist f = withTop' heist $ gets (f . _heistTS)
+withHeistState' :: (Lens (Snaplet b) (Snaplet (Heist b)))
+ -> (HeistState (Handler b b) -> a)
+ -> Handler b v a
+withHeistState' heist f = do
+ hs <- withTop' heist $ gets _heistState
+ return $ f hs
------------------------------------------------------------------------------
-withHeistTS :: (Lens b (Snaplet (Heist b)))
- -> (HeistState (Handler b b) -> a)
- -> Handler b v a
-withHeistTS heist f = withHeistTS' (subSnaplet heist) f
+withHeistState :: (Lens b (Snaplet (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' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Initializer b v ()
addSplices' heist splices = do
_lens <- getLens
withTop' heist $ addPostInitHook $
- return . changeTS (bindSnapletSplices _lens splices)
+ return . changeState (bindSnapletSplices _lens splices)
------------------------------------------------------------------------------
addSplices :: (Lens b (Snaplet (Heist b)))
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
@@ -362,12 +407,12 @@ addSplices heist splices = addSplices' (subSnaplet heist) splices
------------------------------------------------------------------------------
-- | Internal helper function for rendering.
-renderHelper :: Maybe MIMEType
+iRenderHelper :: Maybe MIMEType
-> ByteString
-> Handler b (Heist b) ()
-renderHelper c t = do
- (Heist ts _) <- get
- withTop' id $ renderTemplate ts t >>= maybe pass serve
+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
@@ -375,10 +420,24 @@ renderHelper c t = do
------------------------------------------------------------------------------
+-- | Internal helper function for rendering.
+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
-- ^ Name of the template
-> Handler b (Heist b) ()
-render t = renderHelper Nothing t
+render t = iRenderHelper Nothing t
------------------------------------------------------------------------------
@@ -387,7 +446,23 @@ renderAs :: ByteString
-> ByteString
-- ^ Name of the template
-> Handler b (Heist b) ()
-renderAs ct t = renderHelper (Just ct) t
+renderAs ct t = iRenderHelper (Just ct) t
+
+
+------------------------------------------------------------------------------
+cRender :: ByteString
+ -- ^ Name of the template
+ -> Handler b (Heist b) ()
+cRender t = cRenderHelper Nothing t
+
+
+------------------------------------------------------------------------------
+cRenderAs :: ByteString
+ -- ^ Content type
+ -> ByteString
+ -- ^ Name of the template
+ -> Handler b (Heist b) ()
+cRenderAs ct t = cRenderHelper (Just ct) t
------------------------------------------------------------------------------
@@ -404,13 +479,26 @@ heistServeSingle t =
------------------------------------------------------------------------------
+cHeistServe :: Handler b (Heist b) ()
+cHeistServe =
+ ifTop (cRender "index") <|> (cRender . B.pack =<< getSafePath)
+
+
+------------------------------------------------------------------------------
+cHeistServeSingle :: ByteString
+ -> Handler b (Heist b) ()
+cHeistServeSingle t =
+ cRender t <|> error ("Template " ++ show t ++ " not found.")
+
+
+------------------------------------------------------------------------------
heistLocal' :: (Lens (Snaplet b) (Snaplet (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 $ changeTS f
+ withTop' heist $ modify $ changeState f
res <- m
withTop' heist $ put hs
return res
@@ -426,7 +514,7 @@ heistLocal heist f m = heistLocal' (subSnaplet heist) f m
------------------------------------------------------------------------------
withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Handler b v a
-> Handler b v a
withSplices' heist splices m = do
@@ -436,7 +524,7 @@ withSplices' heist splices m = do
------------------------------------------------------------------------------
withSplices :: (Lens b (Snaplet (Heist b)))
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Handler b v a
-> Handler b v a
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
@@ -445,7 +533,7 @@ withSplices heist splices m = withSplices' (subSnaplet heist) splices m
------------------------------------------------------------------------------
renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> ByteString
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Handler b v ()
renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
@@ -454,7 +542,7 @@ renderWithSplices' heist t splices =
------------------------------------------------------------------------------
renderWithSplices :: (Lens b (Snaplet (Heist b)))
-> ByteString
- -> [(Text, SnapletSplice b v)]
+ -> [(Text, SnapletISplice b v)]
-> Handler b v ()
renderWithSplices heist t splices =
renderWithSplices' (subSnaplet heist) t splices
View
24 src/Snap/Snaplet/Internal/Initializer.hs
@@ -25,6 +25,7 @@ module Snap.Snaplet.Internal.Initializer
import Prelude hiding ((.), id, catch)
import Control.Category
import Control.Concurrent.MVar
+import Control.Error
import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.CatchIO hiding (Handler)
@@ -77,7 +78,8 @@ iGets f = Initializer $ do
------------------------------------------------------------------------------
-- | Converts a plain hook into a Snaplet hook.
-toSnapletHook :: (v -> IO v) -> (Snaplet v -> IO (Snaplet v))
+toSnapletHook :: (v -> EitherT Text IO v)
+ -> (Snaplet v -> EitherT Text IO (Snaplet v))
toSnapletHook f (Snaplet cfg val) = do
val' <- f val
return $! Snaplet cfg val'
@@ -91,11 +93,13 @@ toSnapletHook f (Snaplet cfg val) = do
-- 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 v) -> Initializer b v ()
+addPostInitHook :: (v -> EitherT Text IO v)
+ -> Initializer b v ()
addPostInitHook = addPostInitHook' . toSnapletHook
-addPostInitHook' :: (Snaplet v -> IO (Snaplet v)) -> Initializer b v ()
+addPostInitHook' :: (Snaplet v -> EitherT Text IO (Snaplet v))
+ -> Initializer b v ()
addPostInitHook' h = do
h' <- upHook h
addPostInitHookBase h'
@@ -103,15 +107,15 @@ addPostInitHook' h = do
------------------------------------------------------------------------------
-- | Variant of addPostInitHook for when you have things wrapped in a Snaplet.
-addPostInitHookBase :: (Snaplet b -> IO (Snaplet b))
+addPostInitHookBase :: (Snaplet b -> EitherT Text IO (Snaplet b))
-> Initializer b v ()
addPostInitHookBase = Initializer . lift . tell . Hook
------------------------------------------------------------------------------
-- | Helper function for transforming hooks.
-upHook :: (Snaplet v -> IO (Snaplet v))
- -> Initializer b v (Snaplet b -> IO (Snaplet b))
+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
@@ -119,7 +123,7 @@ upHook h = Initializer $ do
------------------------------------------------------------------------------
-- | Helper function for transforming hooks.
-upHook' :: (Lens b a) -> (a -> IO a) -> b -> IO b
+upHook' :: Monad m => Lens b a -> (a -> m a) -> b -> m b
upHook' l h b = do
v <- h (getL l b)
return $ setL l v b
@@ -487,12 +491,12 @@ runInitializer' mvar env b@(Initializer i) cwd = do
(mkReloader cwd env mvar cleanupRef b)
logRef <- newIORef ""
- let body = do
- ((res, s), (Hook hook)) <- runWriterT $ LT.runLensT i id $
+ let body = runEitherT $ do
+ ((res, s), (Hook hook)) <- lift $ runWriterT $ LT.runLensT i id $
InitializerState True cleanupRef builtinHandlers id cfg logRef
env
res' <- hook res
- return $ Right (res', s)
+ right (res', s)
handler e = do
join $ readIORef cleanupRef
View
3  src/Snap/Snaplet/Internal/Types.hs
@@ -12,6 +12,7 @@ import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category ((.), id)
import Control.Comonad
+import Control.Error
import Control.Monad.CatchIO hiding (Handler)
import Control.Monad.Reader
import Control.Monad.State.Class
@@ -358,7 +359,7 @@ data InitializerState b = InitializerState
------------------------------------------------------------------------------
-- | Wrapper around IO actions that modify state elements created during
-- initialization.
-newtype Hook a = Hook (Snaplet a -> IO (Snaplet a))
+newtype Hook a = Hook (Snaplet a -> EitherT Text IO (Snaplet a))
instance Monoid (Hook a) where
View
6 test/snap-testsuite.cabal
@@ -21,7 +21,7 @@ Executable snap-testsuite
directory,
directory-tree >= 0.10 && < 0.11,
filepath,
- heist >= 0.7 && < 0.9,
+ heist >= 0.10 && < 0.11,
http-conduit >= 1.4 && < 1.5,
http-types >= 0.6 && < 0.7,
mtl >= 2,
@@ -79,7 +79,7 @@ Executable app
directory-tree >= 0.10 && < 0.11,
filepath,
hashable >= 1.1,
- heist >= 0.7 && < 0.9,
+ heist >= 0.10 && < 0.11,
mtl >= 2,
mwc-random >= 0.8,
process == 1.*,
@@ -131,7 +131,7 @@ Executable nesttest
directory,
directory-tree >= 0.10 && < 0.11,
filepath,
- heist >= 0.7 && < 0.9,
+ heist >= 0.10 && < 0.11,
mtl >= 2,
process == 1.*,
snap-core >= 0.9 && < 0.10,
Please sign in to comment.
Something went wrong with that request. Please try again.