Skip to content

Commit

Permalink
Port to the new Heist API
Browse files Browse the repository at this point in the history
  • Loading branch information
@mightybyte
mightybyte committed Jun 10, 2013
1 parent 7da5a64 commit bde4a8a
Show file tree
Hide file tree
Showing 5 changed files with 58 additions and 60 deletions.
4 changes: 2 additions & 2 deletions snap.cabal
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
name: snap
version: 0.12.1
version: 0.13.0
synopsis: Top-level package for the Snap Web Framework
description:
This is the top-level package for the official Snap Framework libraries.
Expand Down Expand Up @@ -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,
Expand Down
100 changes: 49 additions & 51 deletions src/Snap/Snaplet/Auth/SpliceHelpers.hs
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

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

Expand All @@ -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 = unionWith const fields 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)


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


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


-------------------------------------------------------------------------------
Expand Down
5 changes: 2 additions & 3 deletions src/Snap/Snaplet/Heist.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
1 change: 1 addition & 0 deletions src/Snap/Snaplet/Heist/Internal.hs
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
module Snap.Snaplet.Heist.Internal where

import Prelude hiding ((.), id)
Expand Down
8 changes: 4 additions & 4 deletions src/Snap/Snaplet/HeistNoClass.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -503,7 +503,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
Expand All @@ -512,7 +512,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
Expand All @@ -521,7 +521,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
Expand All @@ -530,7 +530,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
Expand Down

0 comments on commit bde4a8a

Please sign in to comment.