Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'new-heist-api'

  • Loading branch information...
commit 5ad1328c008e593c5f1fbcab33dd25ce3547d5d1 2 parents 1e5d73e + 4bf44c1
@mightybyte mightybyte authored
View
2  snap.cabal
@@ -159,7 +159,7 @@ Library
filepath >= 1.1 && < 1.4,
-- Blacklist bad versions of hashable
hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.3),
- heist >= 0.12 && < 0.13,
+ heist >= 0.13 && < 0.14,
logict >= 0.4.2 && < 0.7,
mtl > 2.0 && < 2.2,
mwc-random >= 0.8 && < 0.13,
View
100 src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -27,7 +27,6 @@ module Snap.Snaplet.Auth.SpliceHelpers
import Control.Monad.Trans
import Data.Maybe
import Data.Monoid
-import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding
import qualified Text.XmlHtml as X
@@ -57,10 +56,10 @@ addAuthSplices
-- ^ A lens reference to 'AuthManager'
-> Initializer b v ()
addAuthSplices h auth = addConfig h $ mempty
- { hcInterpretedSplices = [ ("ifLoggedIn", ifLoggedIn auth)
- , ("ifLoggedOut", ifLoggedOut auth)
- , ("loggedInUser", loggedInUser auth)
- ]
+ { hcInterpretedSplices = do
+ "ifLoggedIn" ## ifLoggedIn auth
+ "ifLoggedOut" ## ifLoggedOut auth
+ "loggedInUser" ## loggedInUser auth
, hcCompiledSplices = compiledAuthSplices auth
}
@@ -69,53 +68,52 @@ addAuthSplices h auth = addConfig h $ mempty
-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and
-- loggedInUser.
compiledAuthSplices :: SnapletLens b (AuthManager b)
- -> [(Text, SnapletCSplice b)]
-compiledAuthSplices auth =
- [ ("ifLoggedIn", cIfLoggedIn auth)
- , ("ifLoggedOut", cIfLoggedOut auth)
- , ("loggedInUser", cLoggedInUser auth)
- ]
+ -> Splices (SnapletCSplice b)
+compiledAuthSplices auth = do
+ "ifLoggedIn" ## cIfLoggedIn auth
+ "ifLoggedOut" ## cIfLoggedOut auth
+ "loggedInUser" ## cLoggedInUser auth
------------------------------------------------------------------------------
-- | Function to generate interpreted splices from an AuthUser.
-userISplices :: Monad m => AuthUser -> [(Text, I.Splice m)]
-userISplices AuthUser{..} =
- [ ("userId", I.textSplice $ maybe "-" unUid userId)
- , ("userLogin", I.textSplice userLogin)
- , ("userEmail", I.textSplice $ fromMaybe "-" userEmail)
- , ("userActive", I.textSplice $ T.pack $ show $ isNothing userSuspendedAt)
- , ("userLoginCount", I.textSplice $ T.pack $ show userLoginCount)
- , ("userFailedCount", I.textSplice $ T.pack $ show userFailedLoginCount)
- , ("userLoginAt", I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt)
- , ("userLastLoginAt", I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt)
- , ("userSuspendedAt", I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt)
- , ("userLoginIP", I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp)
- , ("userLastLoginIP", I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp)
- , ("userIfActive", ifISplice (isNothing userSuspendedAt))
- , ("userIfSuspended", ifISplice (isJust userSuspendedAt))
- ]
+userISplices :: Monad m => AuthUser -> Splices (I.Splice m)
+userISplices AuthUser{..} = do
+ "userId" ## I.textSplice $ maybe "-" unUid userId
+ "userLogin" ## I.textSplice userLogin
+ "userEmail" ## I.textSplice $ fromMaybe "-" userEmail
+ "userActive" ## I.textSplice $ T.pack $ show $ isNothing userSuspendedAt
+ "userLoginCount" ## I.textSplice $ T.pack $ show userLoginCount
+ "userFailedCount" ## I.textSplice $ T.pack $ show userFailedLoginCount
+ "userLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userCurrentLoginAt
+ "userLastLoginAt" ## I.textSplice $ maybe "-" (T.pack . show) userLastLoginAt
+ "userSuspendedAt" ## I.textSplice $ maybe "-" (T.pack . show) userSuspendedAt
+ "userLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userCurrentLoginIp
+ "userLastLoginIP" ## I.textSplice $ maybe "-" decodeUtf8 userLastLoginIp
+ "userIfActive" ## ifISplice $ isNothing userSuspendedAt
+ "userIfSuspended" ## ifISplice $ isJust userSuspendedAt
------------------------------------------------------------------------------
-- | Compiled splices for AuthUser.
-userCSplices :: Monad m => [(Text, C.Promise AuthUser -> C.Splice m)]
-userCSplices = (C.pureSplices $ C.textSplices
- [ ("userId", maybe "-" unUid . userId)
- , ("userLogin", userLogin)
- , ("userEmail", fromMaybe "-" . userEmail)
- , ("userActive", T.pack . show . isNothing . userSuspendedAt)
- , ("userLoginCount", T.pack . show . userLoginCount)
- , ("userFailedCount", T.pack . show . userFailedLoginCount)
- , ("userLoginAt", maybe "-" (T.pack . show) . userCurrentLoginAt)
- , ("userLastLoginAt", maybe "-" (T.pack . show) . userLastLoginAt)
- , ("userSuspendedAt", maybe "-" (T.pack . show) . userSuspendedAt)
- , ("userLoginIP", maybe "-" decodeUtf8 . userCurrentLoginIp)
- , ("userLastLoginIP", maybe "-" decodeUtf8 . userLastLoginIp)
- ]) ++
- [ ("userIfActive", ifCSplice (isNothing . userSuspendedAt))
- , ("userIfSuspended", ifCSplice (isJust . userSuspendedAt))
- ]
+userCSplices :: Monad m => Splices (RuntimeSplice m AuthUser -> C.Splice m)
+userCSplices = fields `mappend` ifs
+ where
+ fields = mapS (C.pureSplice . C.textSplice) $ do
+ "userId" ## maybe "-" unUid . userId
+ "userLogin" ## userLogin
+ "userEmail" ## fromMaybe "-" . userEmail
+ "userActive" ## T.pack . show . isNothing . userSuspendedAt
+ "userLoginCount" ## T.pack . show . userLoginCount
+ "userFailedCount" ## T.pack . show . userFailedLoginCount
+ "userLoginAt" ## maybe "-" (T.pack . show) . userCurrentLoginAt
+ "userLastLoginAt" ## maybe "-" (T.pack . show) . userLastLoginAt
+ "userSuspendedAt" ## maybe "-" (T.pack . show) . userSuspendedAt
+ "userLoginIP" ## maybe "-" decodeUtf8 . userCurrentLoginIp
+ "userLastLoginIP" ## maybe "-" decodeUtf8 . userLastLoginIp
+ ifs = do
+ "userIfActive" ## ifCSplice (isNothing . userSuspendedAt)
+ "userIfSuspended" ## ifCSplice (isJust . userSuspendedAt)
------------------------------------------------------------------------------
@@ -138,12 +136,12 @@ 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.promiseChildren
+ children <- C.runChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
- True -> children
- False -> return mempty
+ True -> C.codeGen children
+ False -> mempty
------------------------------------------------------------------------------
@@ -166,12 +164,12 @@ 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.promiseChildren
+ children <- C.runChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
- False -> children
- True -> return mempty
+ False -> C.codeGen children
+ True -> mempty
-------------------------------------------------------------------------------
View
5 src/Snap/Snaplet/Heist.hs
@@ -56,7 +56,6 @@ module Snap.Snaplet.Heist
import Prelude hiding (id, (.))
import Control.Monad.State
import Data.ByteString (ByteString)
-import Data.Text (Text)
import Heist
------------------------------------------------------------------------------
import Snap.Snaplet
@@ -296,7 +295,7 @@ heistServeSingle t = withTop' heistLens (Unclassed.heistServeSingle t)
renderWithSplices :: HasHeist b
=> ByteString
-- ^ Template name
- -> [(Text, Unclassed.SnapletISplice b)]
+ -> Splices (Unclassed.SnapletISplice b)
-- ^ Splices to bind
-> Handler b v ()
renderWithSplices = Unclassed.renderWithSplices' heistLens
@@ -306,7 +305,7 @@ renderWithSplices = Unclassed.renderWithSplices' heistLens
-- | Runs an action with additional splices bound into the Heist
-- 'HeistState'.
withSplices :: HasHeist b
- => [(Text, Unclassed.SnapletISplice b)]
+ => Splices (Unclassed.SnapletISplice b)
-- ^ Splices to bind
-> Handler b v a
-- ^ Handler to run
View
16 src/Snap/Snaplet/Heist/Compiled.hs
@@ -14,8 +14,9 @@ module Snap.Snaplet.Heist.Compiled
-- * Initializer Functions
-- $initializerSection
- , H.heistInit
+ , heistInit
, H.heistInit'
+ , H.heistReloader
, H.addTemplates
, H.addTemplatesAt
, H.addConfig
@@ -34,7 +35,20 @@ module Snap.Snaplet.Heist.Compiled
import Data.ByteString (ByteString)
import Snap.Snaplet
+import Snap.Snaplet.Heist.Internal
import qualified Snap.Snaplet.Heist as H
+import qualified Snap.Snaplet.HeistNoClass as HNC
+
+
+------------------------------------------------------------------------------
+-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper
+-- around `heistInit'` that uses defaultHeistState and sets up routes for all
+-- the templates. It sets up a \"heistReload\" route that reloads the heist
+-- templates when you request it from localhost.
+heistInit :: FilePath
+ -- ^ Path to templates
+ -> SnapletInit b (Heist b)
+heistInit = gHeistInit HNC.cHeistServe
------------------------------------------------------------------------------
View
2  src/Snap/Snaplet/Heist/Generic.hs
@@ -15,8 +15,6 @@ module Snap.Snaplet.Heist.Generic
-- * Initializer Functions
-- $initializerSection
- , heistInit
- , heistInit'
, addTemplates
, addTemplatesAt
, addConfig
View
87 src/Snap/Snaplet/Heist/Internal.hs
@@ -1,11 +1,21 @@
+{-# LANGUAGE TemplateHaskell #-}
module Snap.Snaplet.Heist.Internal where
-import Prelude hiding ((.), id)
+import Prelude
+import Control.Error
import Control.Lens
+import Control.Monad.State
+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 Heist
import Heist.Splices.Cache
+import System.FilePath.Posix
+import Snap.Core
import Snap.Snaplet
@@ -28,3 +38,78 @@ data Heist b = Configuring
}
makeLenses ''Heist
+
+
+------------------------------------------------------------------------------
+-- | Generic initializer function that allows compiled/interpreted template
+-- serving to be specified by the caller.
+gHeistInit :: Handler b (Heist b) ()
+ -> FilePath
+ -> SnapletInit b (Heist b)
+gHeistInit serve templateDir = do
+ makeSnaplet "heist" "" Nothing $ do
+ hs <- heistInitWorker templateDir defaultConfig
+ addRoutes [ ("", serve)
+ , ("heistReload", failIfNotLocal heistReloader)
+ ]
+ return hs
+ where
+ defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
+
+
+------------------------------------------------------------------------------
+-- | Internal worker function used by variants of heistInit. This is
+-- necessary because of the divide between SnapletInit and Initializer.
+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
+ printInfo $ T.pack $ unwords
+ [ "...loaded"
+ , (show $ Map.size templates)
+ , "templates from"
+ , tDir
+ ]
+ let config = initialConfig `mappend`
+ mempty { hcTemplateLocations = [loadTemplates tDir] }
+ ref <- liftIO $ newIORef (config, Compiled)
+
+ -- FIXME This runs after all the initializers, but before post init
+ -- hooks registered by other snaplets.
+ addPostInitHook finalLoadHook
+ return $ Configuring ref
+
+
+------------------------------------------------------------------------------
+-- | 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,dm) <- lift $ readIORef ref
+ (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc
+ return $ Running hc hs cts dm
+ where
+ toTextErrors = bimapEitherT (T.pack . intercalate "\n") id
+finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running"
+
+
+------------------------------------------------------------------------------
+-- | Handler that triggers a template reload. For large sites, this can be
+-- desireable because it may be much quicker than the full site reload
+-- provided at the /admin/reload route. This allows you to reload only the
+-- heist templates This handler is automatically set up by heistInit, but if
+-- you use heistInit', then you can create your own route with it.
+heistReloader :: Handler b (Heist b) ()
+heistReloader = do
+ h <- get
+ ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h
+ either (writeText . T.pack . unlines)
+ (\hs -> do writeText "Heist reloaded."
+ modifyMaster $ set heistState hs h)
+ ehs
+
+
View
76 src/Snap/Snaplet/HeistNoClass.hs
@@ -71,9 +71,7 @@ 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
@@ -105,22 +103,6 @@ clearHeistCache :: Heist b -> IO ()
clearHeistCache = clearCacheTagState . _heistCTS
-------------------------------------------------------------------------------
--- | Handler that triggers a template reload. For large sites, this can be
--- desireable because it may be much quicker than the full site reload
--- provided at the /admin/reload route. This allows you to reload only the
--- heist templates This handler is automatically set up by heistInit, but if
--- you use heistInit', then you can create your own route with it.
-heistReloader :: Handler b (Heist b) ()
-heistReloader = do
- h <- get
- ehs <- liftIO $ runEitherT $ initHeist $ _masterConfig h
- either (writeText . T.pack . unlines)
- (\hs -> do writeText "Heist reloaded."
- modifyMaster $ set heistState hs h)
- ehs
-
-
-----------------------------
-- SnapletSplice functions --
-----------------------------
@@ -150,15 +132,7 @@ type SnapletISplice b = SnapletHeist b (Handler b b) Template
heistInit :: FilePath
-- ^ Path to templates
-> SnapletInit b (Heist b)
-heistInit templateDir = do
- makeSnaplet "heist" "" Nothing $ do
- hs <- heistInitWorker templateDir defaultConfig
- addRoutes [ ("", heistServe)
- , ("heistReload", failIfNotLocal heistReloader)
- ]
- return hs
- where
- defaultConfig = mempty { hcLoadTimeSplices = defaultLoadTimeSplices }
+heistInit = gHeistInit heistServe
------------------------------------------------------------------------------
@@ -175,33 +149,6 @@ heistInit' templateDir initialConfig =
------------------------------------------------------------------------------
--- | Internal worker function used by variants of heistInit. This is
--- necessary because of the divide between SnapletInit and Initializer.
-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
- printInfo $ T.pack $ unwords
- [ "...loaded"
- , (show $ Map.size templates)
- , "templates from"
- , tDir
- ]
- let config = initialConfig `mappend`
- mempty { hcTemplateLocations = [loadTemplates tDir] }
- ref <- liftIO $ newIORef (config, Compiled)
-
- -- FIXME This runs after all the initializers, but before post init
- -- hooks registered by other snaplets.
- addPostInitHook finalLoadHook
- return $ Configuring ref
-
-
-------------------------------------------------------------------------------
-- | Sets the snaplet to default to interpreted mode. Initially, the
-- initializer sets the value to compiled mode. This function allows you to
-- override that setting. Note that this is just a default. It only has an
@@ -216,19 +163,6 @@ setInterpreted h =
------------------------------------------------------------------------------
--- | 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,dm) <- lift $ readIORef ref
- (hs,cts) <- toTextErrors $ initHeistWithCacheTag hc
- return $ Running hc hs cts dm
- where
- toTextErrors = bimapEitherT (T.pack . intercalate "\n") id
-finalLoadHook (Running _ _ _ _) = left "finalLoadHook called while running"
-
-
-------------------------------------------------------------------------------
-- | 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.
@@ -503,7 +437,7 @@ heistLocal heist f m = heistLocal' (subSnaplet heist) f m
------------------------------------------------------------------------------
withSplices' :: SnapletLens (Snaplet b) (Heist b)
- -> [(Text, SnapletISplice b)]
+ -> Splices (SnapletISplice b)
-> Handler b v a
-> Handler b v a
withSplices' heist splices m = do
@@ -512,7 +446,7 @@ withSplices' heist splices m = do
------------------------------------------------------------------------------
withSplices :: SnapletLens b (Heist b)
- -> [(Text, SnapletISplice b)]
+ -> Splices (SnapletISplice b)
-> Handler b v a
-> Handler b v a
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
@@ -521,7 +455,7 @@ withSplices heist splices m = withSplices' (subSnaplet heist) splices m
------------------------------------------------------------------------------
renderWithSplices' :: SnapletLens (Snaplet b) (Heist b)
-> ByteString
- -> [(Text, SnapletISplice b)]
+ -> Splices (SnapletISplice b)
-> Handler b v ()
renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
@@ -530,7 +464,7 @@ renderWithSplices' heist t splices =
------------------------------------------------------------------------------
renderWithSplices :: SnapletLens b (Heist b)
-> ByteString
- -> [(Text, SnapletISplice b)]
+ -> Splices (SnapletISplice b)
-> Handler b v ()
renderWithSplices heist t splices =
renderWithSplices' (subSnaplet heist) t splices
Please sign in to comment.
Something went wrong with that request. Please try again.