Permalink
Browse files

Get rid of SnapletHeist newtype

The previous implementation did not work for compiled splices and my attempts
at generalizing it to work with both interpreted and compiled splices all
failed.  In some ways this is better anyway because it means we're always
working in HeistT and don't have to deal with the pain of not having a
MonadHeist type class.
  • Loading branch information...
1 parent 58f42dc commit 8b01abb7ec8eeddbe72b68b22c94827633a792d2 @mightybyte mightybyte committed Sep 20, 2012
@@ -13,15 +13,23 @@
module Snap.Snaplet.Auth.SpliceHelpers
(
addAuthSplices
+ , compiledAuthSplices
, ifLoggedIn
, ifLoggedOut
, loggedInUser
+ , cIfLoggedIn
+ , cIfLoggedOut
+ , cLoggedInUser
) where
+import Control.Monad.Trans
import Data.Lens.Lazy
+import Data.Monoid
+import Data.Text (Text)
import qualified Text.XmlHtml as X
import Heist
import qualified Heist.Interpreted as I
+import qualified Heist.Compiled as C
import Snap.Snaplet
import Snap.Snaplet.Auth.AuthManager
@@ -43,10 +51,19 @@ addAuthSplices
-- ^ A lens reference to 'AuthManager'
-> Initializer b v ()
addAuthSplices auth = addSplices
- [ ("ifLoggedIn", ifLoggedIn auth)
- , ("ifLoggedOut", ifLoggedOut auth)
- , ("loggedInUser", loggedInUser auth)
- ]
+ [ ("ifLoggedIn", ifLoggedIn auth)
+ , ("ifLoggedOut", ifLoggedOut auth)
+ , ("loggedInUser", loggedInUser auth)
+ ]
+
+
+compiledAuthSplices :: Lens b (Snaplet (AuthManager b))
+ -> [(Text, SnapletCSplice b v)]
+compiledAuthSplices auth =
+ [ ("ifLoggedIn", cIfLoggedIn auth)
+ , ("ifLoggedOut", cIfLoggedOut auth)
+ , ("loggedInUser", cLoggedInUser auth)
+ ]
------------------------------------------------------------------------------
@@ -56,10 +73,25 @@ addAuthSplices auth = addSplices
-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
ifLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
ifLoggedIn auth = do
- chk <- liftHandler $ withTop auth isLoggedIn
- case chk of
- True -> liftHeist $ getParamNode >>= return . X.childNodes
- False -> return []
+ chk <- lift $ withTop auth isLoggedIn
+ case chk of
+ True -> getParamNode >>= return . X.childNodes
+ False -> return []
+
+
+------------------------------------------------------------------------------
+-- | A splice that can be used to check for existence of a user. If a user is
+-- present, this will run the contents of the node.
+--
+-- > <ifLoggedIn> Show this when there is a logged in user </ifLoggedIn>
+cIfLoggedIn :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b v
+cIfLoggedIn auth = do
+ children <- C.promiseChildren
+ return $ C.yieldRuntime $ do
+ chk <- lift $ withTop auth isLoggedIn
+ case chk of
+ True -> children
+ False -> return mempty
------------------------------------------------------------------------------
@@ -69,16 +101,43 @@ ifLoggedIn auth = do
-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
ifLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
ifLoggedOut auth = do
- chk <- liftHandler $ withTop auth isLoggedIn
- case chk of
- False -> liftHeist $ getParamNode >>= return . X.childNodes
- True -> return []
+ chk <- lift $ withTop auth isLoggedIn
+ case chk of
+ False -> getParamNode >>= return . X.childNodes
+ True -> return []
+
+
+------------------------------------------------------------------------------
+-- | A splice that can be used to check for absence of a user. If a user is
+-- not present, this will run the contents of the node.
+--
+-- > <ifLoggedOut> Show this when there is a logged in user </ifLoggedOut>
+cIfLoggedOut :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b v
+cIfLoggedOut auth = do
+ children <- C.promiseChildren
+ return $ C.yieldRuntime $ do
+ chk <- lift $ withTop auth isLoggedIn
+ case chk of
+ False -> children
+ True -> return mempty
-------------------------------------------------------------------------------
-- | A splice that will simply print the current user's login, if
-- there is one.
loggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletISplice b v
loggedInUser auth = do
- u <- liftHandler $ withTop auth currentUser
- liftHeist $ maybe (return []) (I.textSplice . userLogin) u
+ u <- lift $ withTop auth currentUser
+ maybe (return []) (I.textSplice . userLogin) u
+
+
+-------------------------------------------------------------------------------
+-- | A splice that will simply print the current user's login, if
+-- there is one.
+cLoggedInUser :: Lens b (Snaplet (AuthManager b)) -> SnapletCSplice b v
+cLoggedInUser auth =
+ return $ C.yieldRuntimeText $ do
+ u <- lift $ withTop auth currentUser
+ return $ maybe "" userLogin u
+
+
View
@@ -38,12 +38,8 @@ module Snap.Snaplet.Heist
-- * Writing Splices
-- $spliceSection
, Unclassed.SnapletHeist
+ , Unclassed.SnapletCSplice
, Unclassed.SnapletISplice
- , Unclassed.liftHeist
- , Unclassed.liftHandler
- , Unclassed.liftAppHandler
- , Unclassed.liftWith
- , Unclassed.bindSnapletSplices
, clearHeistCache
) where
@@ -127,7 +123,7 @@ addTemplatesAt h pfx p =
-- templates with cRender. To add splices that work with cRender, you have to
-- use the addConfig function to add compiled splices or load time splices.
addSplices :: (HasHeist b)
- => [(Text, Unclassed.SnapletISplice b v)]
+ => [(Text, Unclassed.SnapletISplice b)]
-- ^ Splices to bind
-> Initializer b v ()
addSplices = Unclassed.addSplices' heistLens
@@ -246,7 +242,7 @@ cHeistServeSingle t = withTop' heistLens (Unclassed.cHeistServeSingle t)
renderWithSplices :: HasHeist b
=> ByteString
-- ^ Template name
- -> [(Text, Unclassed.SnapletISplice b v)]
+ -> [(Text, Unclassed.SnapletISplice b)]
-- ^ Splices to bind
-> Handler b v ()
renderWithSplices = Unclassed.renderWithSplices' heistLens
@@ -256,7 +252,7 @@ renderWithSplices = Unclassed.renderWithSplices' heistLens
-- | Runs an action with additional splices bound into the Heist
-- 'HeistState'.
withSplices :: HasHeist b
- => [(Text, Unclassed.SnapletISplice b v)]
+ => [(Text, Unclassed.SnapletISplice b)]
-- ^ Splices to bind
-> Handler b v a
-- ^ Handler to run
@@ -1,8 +1,11 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-|
@@ -47,12 +50,6 @@ module Snap.Snaplet.HeistNoClass
, SnapletHeist
, SnapletISplice
, SnapletCSplice
- , runSnapletSplice
- , liftHeist
- , liftWith
- , liftHandler
- , liftAppHandler
- , bindSnapletSplices
) where
import Prelude hiding ((.), id)
@@ -123,116 +120,20 @@ 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 m) where
+instance MonadSnap m => MonadSnap (HeistT n 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)) (HeistHandler b) a)
- deriving ( Monad
- , Functor
- , Applicative
- , Alternative
- , MonadIO
- , MonadPlus
- , MonadReader (Lens (Snaplet b) (Snaplet v))
- , MonadCatchIO
- , MonadSnap
- )
-
-
-------------------------------------------------------------------------------
--- | Type alias for convenience.
-type SnapletISplice b v = SnapletHeist b v Template
-type SnapletCSplice b v = SnapletHeist b v (DList (Chunk (Handler b b)))
-
-
-------------------------------------------------------------------------------
--- | Runs the SnapletISplice.
-runSnapletSplice :: (Lens (Snaplet b) (Snaplet v))
- -> SnapletHeist b v a
- -> HeistHandler 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
-
-
-------------------------------------------------------------------------------
--- | Lifts a HeistT action into SnapletHeist. Use this with all the functions
--- from the Heist API.
-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
-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
- liftWith l m
-
-
-------------------------------------------------------------------------------
--- | Lifts a (Handler b b) into SnapletHeist.
-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
-
-
-------------------------------------------------------------------------------
--- | MonadSnaplet instance gives us access to the snaplet infrastructure.
-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
-
-
-------------------------------------------------------------------------------
--- | SnapletSplices version of bindSplices.
-bindSnapletSplices :: (Lens (Snaplet b) (Snaplet v))
- -> [(Text, SnapletISplice b v)]
- -> HeistState (Handler b b)
- -> HeistState (Handler b b)
-bindSnapletSplices l splices =
- I.bindSplices $ map (second $ runSnapletSplice l) splices
+type SnapletHeist b m a = HeistT (Handler b b) m a
+type SnapletCSplice b = SnapletHeist b IO (DList (Chunk (Handler b b)))
+type SnapletISplice b = SnapletHeist b (Handler b b) Template
---------------------------
-- Initializer functions --
---------------------------
+
------------------------------------------------------------------------------
-- | The 'Initializer' for 'Heist'. This function is a convenience wrapper
-- around `heistInit'` that uses defaultHeistState and sets up routes for all
@@ -389,17 +290,16 @@ addConfig h hc = case extract h of
------------------------------------------------------------------------------
addSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices' heist splices = do
- _lens <- getLens
withTop' heist $ addPostInitHook $
- return . changeState (bindSnapletSplices _lens splices)
+ return . changeState (I.bindSplices splices)
------------------------------------------------------------------------------
addSplices :: (Lens b (Snaplet (Heist b)))
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Initializer b v ()
addSplices heist splices = addSplices' (subSnaplet heist) splices
@@ -484,8 +384,7 @@ heistServe =
------------------------------------------------------------------------------
-heistServeSingle :: ByteString
- -> Handler b (Heist b) ()
+heistServeSingle :: ByteString -> Handler b (Heist b) ()
heistServeSingle t =
render t <|> error ("Template " ++ show t ++ " not found.")
@@ -497,8 +396,7 @@ cHeistServe =
------------------------------------------------------------------------------
-cHeistServeSingle :: ByteString
- -> Handler b (Heist b) ()
+cHeistServeSingle :: ByteString -> Handler b (Heist b) ()
cHeistServeSingle t =
cRender t <|> error ("Template " ++ show t ++ " not found.")
@@ -526,17 +424,16 @@ heistLocal heist f m = heistLocal' (subSnaplet heist) f m
------------------------------------------------------------------------------
withSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
withSplices' heist splices m = do
- _lens <- getLens
- heistLocal' heist (bindSnapletSplices _lens splices) m
+ heistLocal' heist (I.bindSplices splices) m
------------------------------------------------------------------------------
withSplices :: (Lens b (Snaplet (Heist b)))
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Handler b v a
-> Handler b v a
withSplices heist splices m = withSplices' (subSnaplet heist) splices m
@@ -545,7 +442,7 @@ withSplices heist splices m = withSplices' (subSnaplet heist) splices m
------------------------------------------------------------------------------
renderWithSplices' :: (Lens (Snaplet b) (Snaplet (Heist b)))
-> ByteString
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Handler b v ()
renderWithSplices' heist t splices =
withSplices' heist splices $ withTop' heist $ render t
@@ -554,7 +451,7 @@ renderWithSplices' heist t splices =
------------------------------------------------------------------------------
renderWithSplices :: (Lens b (Snaplet (Heist b)))
-> ByteString
- -> [(Text, SnapletISplice b v)]
+ -> [(Text, SnapletISplice b)]
-> Handler b v ()
renderWithSplices heist t splices =
renderWithSplices' (subSnaplet heist) t splices
Oops, something went wrong.

0 comments on commit 8b01abb

Please sign in to comment.