diff --git a/snap.cabal b/snap.cabal
index 3b25ac31..146374fc 100644
--- a/snap.cabal
+++ b/snap.cabal
@@ -141,7 +141,7 @@ Library
lens >= 3.7.6 && < 4.5,
lifted-base >= 0.2 && < 0.3,
logict >= 0.4.2 && < 0.7,
- map-syntax >= 0.1 && < 0.2,
+ map-syntax >= 0.2 && < 0.3,
monad-control >= 0.3 && < 0.4,
mtl >= 2.0 && < 2.3,
mwc-random >= 0.8 && < 0.14,
@@ -262,7 +262,7 @@ Test-suite testsuite
lens >= 3.7.6 && < 4.5,
lifted-base >= 0.2 && < 0.3,
logict >= 0.4.2 && < 0.7,
- map-syntax >= 0.1 && < 0.2,
+ map-syntax >= 0.2 && < 0.3,
monad-control >= 0.3 && < 0.4,
mtl >= 2.0 && < 2.3,
mwc-random >= 0.8 && < 0.14,
diff --git a/src/Snap/Snaplet/Auth/SpliceHelpers.hs b/src/Snap/Snaplet/Auth/SpliceHelpers.hs
index 573ea63a..34c71fc3 100644
--- a/src/Snap/Snaplet/Auth/SpliceHelpers.hs
+++ b/src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -24,6 +24,8 @@ module Snap.Snaplet.Auth.SpliceHelpers
, cLoggedInUser
) where
+------------------------------------------------------------------------------
+import Control.Lens
import Control.Monad.Trans
import Data.Map.Syntax ((##), mapV)
import Data.Maybe
@@ -35,12 +37,12 @@ import Heist
import qualified Heist.Interpreted as I
import qualified Heist.Compiled as C
import Heist.Splices
-
import Snap.Snaplet
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Auth.Handlers
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Heist
+------------------------------------------------------------------------------
------------------------------------------------------------------------------
@@ -56,13 +58,16 @@ addAuthSplices
-> SnapletLens b (AuthManager b)
-- ^ A lens reference to 'AuthManager'
-> Initializer b v ()
-addAuthSplices h auth = addConfig h $ mempty
- { hcInterpretedSplices = do
- "ifLoggedIn" ## ifLoggedIn auth
- "ifLoggedOut" ## ifLoggedOut auth
- "loggedInUser" ## loggedInUser auth
- , hcCompiledSplices = compiledAuthSplices auth
- }
+addAuthSplices h auth = addConfig h sc
+ where
+ sc = mempty & scInterpretedSplices .~ is
+ & scCompiledSplices .~ cs
+ is = do
+ "ifLoggedIn" ## ifLoggedIn auth
+ "ifLoggedOut" ## ifLoggedOut auth
+ "loggedInUser" ## loggedInUser auth
+ cs = compiledAuthSplices auth
+
------------------------------------------------------------------------------
@@ -137,11 +142,11 @@ ifLoggedIn auth = do
-- > Show this when there is a logged in user
cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedIn auth = do
- children <- C.runChildren
+ cs <- C.runChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
- True -> C.codeGen children
+ True -> C.codeGen cs
False -> mempty
@@ -165,11 +170,11 @@ ifLoggedOut auth = do
-- > Show this when there is a logged in user
cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedOut auth = do
- children <- C.runChildren
+ cs <- C.runChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
- False -> C.codeGen children
+ False -> C.codeGen cs
True -> mempty
@@ -179,7 +184,7 @@ cIfLoggedOut auth = do
loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b
loggedInUser auth = do
u <- lift $ withTop auth currentUser
- maybe (return []) (I.textSplice . userLogin) u
+ maybe (return []) (I.textSplice . userLogin) u
-------------------------------------------------------------------------------
@@ -189,6 +194,6 @@ cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cLoggedInUser auth =
return $ C.yieldRuntimeText $ do
u <- lift $ withTop auth currentUser
- return $ maybe "" userLogin u
+ return $ maybe "" userLogin u
diff --git a/src/Snap/Snaplet/Heist/Internal.hs b/src/Snap/Snaplet/Heist/Internal.hs
index 5be069b1..0981ff8c 100644
--- a/src/Snap/Snaplet/Heist/Internal.hs
+++ b/src/Snap/Snaplet/Heist/Internal.hs
@@ -54,7 +54,10 @@ gHeistInit serve templateDir = do
]
return hs
where
- defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
+ sc = set scLoadTimeSplices defaultLoadTimeSplices mempty
+ defaultConfig = emptyHeistConfig & hcSpliceConfig .~ sc
+ & hcNamespace .~ ""
+ & hcErrorNotBound .~ True
------------------------------------------------------------------------------
@@ -74,8 +77,8 @@ heistInitWorker templateDir initialConfig = do
, "templates from"
, tDir
]
- let config = initialConfig `mappend`
- mempty { hcTemplateLocations = [loadTemplates tDir] }
+ let config = over hcTemplateLocations (<> [loadTemplates tDir])
+ initialConfig
ref <- liftIO $ newIORef (config, Compiled)
-- FIXME This runs after all the initializers, but before post init
diff --git a/src/Snap/Snaplet/HeistNoClass.hs b/src/Snap/Snaplet/HeistNoClass.hs
index 5c9590fb..df402537 100644
--- a/src/Snap/Snaplet/HeistNoClass.hs
+++ b/src/Snap/Snaplet/HeistNoClass.hs
@@ -206,9 +206,9 @@ addTemplatesAt h urlPrefix templateDir = do
, fullPrefix ++ "/"
]
let locations = [liftM addPrefix $ loadTemplates templateDir]
- hc' = mempty { hcTemplateLocations = locations }
- liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h)
- (\(hc,dm) -> ((hc `mappend` hc', dm), ()))
+ add (hc, dm) =
+ ((over hcTemplateLocations (mappend locations) hc, dm), ())
+ liftIO $ atomicModifyIORef (_heistConfig $ view snapletValue h) add
getCurHeistConfig :: Snaplet (Heist b)
@@ -263,15 +263,17 @@ withHeistState heist f = withHeistState' (subSnaplet heist) f
-- there. This is the preferred method for adding all four kinds of splices
-- as well as new templates.
addConfig :: Snaplet (Heist b)
- -> HeistConfig (Handler b b)
+ -> SpliceConfig (Handler b b)
-> Initializer b v ()
-addConfig h hc = case view snapletValue h of
+addConfig h sc = case view snapletValue h of
Configuring ref ->
- liftIO $ atomicModifyIORef ref
- (\(hc1,dm) -> ((hc1 `mappend` hc, dm), ()))
+ liftIO $ atomicModifyIORef ref add
Running _ _ _ _ -> do
printInfo "finalLoadHook called while running"
error "this shouldn't happen"
+ where
+ add (hc, dm) =
+ ((over hcSpliceConfig (`mappend` sc) hc, dm), ())
-----------------------
diff --git a/test/suite/Blackbox/App.hs b/test/suite/Blackbox/App.hs
index 250ae670..05fe115d 100644
--- a/test/suite/Blackbox/App.hs
+++ b/test/suite/Blackbox/App.hs
@@ -54,10 +54,10 @@ app = makeSnaplet "app" "Test application" Nothing $ do
initCookieSessionManager "sitekey.txt" "_session" (Just (30 * 60))
ns <- embedSnaplet "embed" embedded embeddedInit
_lens <- getLens
- addConfig hs $ mempty
- { hcInterpretedSplices = do
+ let splices = do
"appsplice" ## textSplice "contents of the app splice"
- "appconfig" ## shConfigSplice _lens }
+ "appconfig" ## shConfigSplice _lens
+ addConfig hs $ mempty & scInterpretedSplices .~ splices
addRoutes [ ("/hello", writeText "hello world")
, ("/routeWithSplice", routeWithSplice)
, ("/routeWithConfig", routeWithConfig)
diff --git a/test/suite/Blackbox/FooSnaplet.hs b/test/suite/Blackbox/FooSnaplet.hs
index b8a7bb16..c3c4c9fb 100644
--- a/test/suite/Blackbox/FooSnaplet.hs
+++ b/test/suite/Blackbox/FooSnaplet.hs
@@ -5,6 +5,7 @@ module Blackbox.FooSnaplet where
------------------------------------------------------------------------------
import Prelude hiding (lookup)
+import Control.Lens
import Control.Monad.State
import Data.Configurator
import Data.Maybe
@@ -32,11 +33,10 @@ fooInit h = makeSnaplet "foosnaplet" "A demonstration snaplet called foo."
fp <- getSnapletFilePath
name <- getSnapletName
_lens <- getLens
- addConfig h $ mempty
- { hcInterpretedSplices = do
+ let splices = do
"foosplice" ## textSplice "contents of the foo splice"
"fooconfig" ## shConfigSplice _lens
- }
+ addConfig h $ mempty & scInterpretedSplices .~ splices
addRoutes [("fooConfig", liftIO (lookup config "fooSnapletField") >>= writeLBS . fromJust)
,("fooRootUrl", writeBS rootUrl)
,("fooSnapletName", writeText $ fromMaybe "empty snaplet name" name)
diff --git a/test/suite/Snap/Snaplet/Auth/App.hs b/test/suite/Snap/Snaplet/Auth/App.hs
index ea3592be..17e17b9a 100644
--- a/test/suite/Snap/Snaplet/Auth/App.hs
+++ b/test/suite/Snap/Snaplet/Auth/App.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Snap.Snaplet.Auth.App
@@ -13,13 +13,12 @@ module Snap.Snaplet.Auth.App
) where
------------------------------------------------------------------------------
-import Control.Lens (makeLenses)
+import Control.Lens (makeLenses, (&), (.~))
import Control.Monad.Trans (lift)
import Data.Monoid (mempty)
------------------------------------------------------------------------------
-import Data.Map.Syntax ((#!))
-import Heist (Splices,
- hcCompiledSplices)
+import Data.Map.Syntax (( #! ))
+import Heist (Splices, scCompiledSplices)
import qualified Heist.Compiled as C
import Snap.Core (pass)
import Snap.Snaplet (Handler,
@@ -41,8 +40,10 @@ import Snap.Snaplet.Auth.Backends.JsonFile (initJsonFileAuthMa
import Snap.Snaplet.Session.Backends.CookieSession (initCookieSessionManager)
import Snap.Snaplet.Heist (Heist,
HasHeist,
+ addConfig,
heistLens,
- heistInit')
+ heistInit)
+import Snap.Snaplet.Session (SessionManager)
------------------------------------------------------------------------------
@@ -68,19 +69,18 @@ compiledSplices = do
appInit' :: Bool -> SnapletInit App App
appInit' useConfigFile = makeSnaplet "app" "Test application" Nothing $ do
- h <- nestSnaplet "heist" heist $
- heistInit'
- "templates"
- (mempty {hcCompiledSplices = compiledSplices})
+ h <- nestSnaplet "heist" heist $ heistInit "templates"
+
+ addConfig h $ mempty & scCompiledSplices .~ compiledSplices
+
-
s <- nestSnaplet "sess" sess $
initCookieSessionManager "site_key.txt" "sess" (Just 3600)
authSettings <- if useConfigFile
then authSettingsFromConfig
else return defAuthSettings
-
+
a <- nestSnaplet "auth" auth $ authInit authSettings
addAuthSplices h auth