Skip to content

Commit

Permalink
Update heist
Browse files Browse the repository at this point in the history 
Conflicts:
	snap.cabal
	test/snap-testsuite.cabal
  • Loading branch information
@mightybyte @sopvop
mightybyte authored and sopvop committed Oct 8, 2014
1 parent 5b20bb8 commit eb2cdef
Show file tree
Hide file tree
Showing 7 changed files with 54 additions and 44 deletions.
4 changes: 2 additions & 2 deletions snap.cabal
View file
Expand Up @@ -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,
Expand Down Expand Up @@ -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,
Expand Down
33 changes: 19 additions & 14 deletions src/Snap/Snaplet/Auth/SpliceHelpers.hs
View file
Expand Up @@ -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
Expand All @@ -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
------------------------------------------------------------------------------


------------------------------------------------------------------------------
Expand All @@ -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



------------------------------------------------------------------------------
Expand Down Expand Up @@ -137,11 +142,11 @@ ifLoggedIn auth = do
-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
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


Expand All @@ -165,11 +170,11 @@ ifLoggedOut auth = do
-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
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


Expand All @@ -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


-------------------------------------------------------------------------------
Expand All @@ -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


9 changes: 6 additions & 3 deletions src/Snap/Snaplet/Heist/Internal.hs
View file
Expand Up @@ -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


------------------------------------------------------------------------------
Expand All @@ -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
Expand Down
16 changes: 9 additions & 7 deletions src/Snap/Snaplet/HeistNoClass.hs
View file
Expand Up @@ -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)
Expand Down Expand Up @@ -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), ())


-----------------------
Expand Down
6 changes: 3 additions & 3 deletions test/suite/Blackbox/App.hs
View file
Expand Up @@ -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)
Expand Down
6 changes: 3 additions & 3 deletions test/suite/Blackbox/FooSnaplet.hs
View file
Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down
24 changes: 12 additions & 12 deletions test/suite/Snap/Snaplet/Auth/App.hs
View file
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Snap.Snaplet.Auth.App
Expand All @@ -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,
Expand All @@ -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)


------------------------------------------------------------------------------
Expand All @@ -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
Expand Down

0 comments on commit eb2cdef

Please sign in to comment.