module Snap.Snaplet.Auth.SpliceHelpers
( addAuthSplices
, compiledAuthSplices
, userCSplices
, userISplices
, ifLoggedIn
, ifLoggedOut
, loggedInUser
, cIfLoggedIn
, cIfLoggedOut
, cLoggedInUser
) where
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
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
addAuthSplices
:: HasHeist b
=> Snaplet (Heist b)
-> SnapletLens b (AuthManager b)
-> Initializer b v ()
addAuthSplices h auth = addConfig h $ mempty
{ hcInterpretedSplices = [ ("ifLoggedIn", ifLoggedIn auth)
, ("ifLoggedOut", ifLoggedOut auth)
, ("loggedInUser", loggedInUser auth)
]
, hcCompiledSplices = compiledAuthSplices auth
}
compiledAuthSplices :: SnapletLens b (AuthManager b)
-> [(Text, SnapletCSplice b)]
compiledAuthSplices auth =
[ ("ifLoggedIn", cIfLoggedIn auth)
, ("ifLoggedOut", cIfLoggedOut auth)
, ("loggedInUser", cLoggedInUser auth)
]
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))
]
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))
]
ifLoggedIn :: SnapletLens b (AuthManager b) -> SnapletISplice b
ifLoggedIn auth = do
chk <- lift $ withTop auth isLoggedIn
case chk of
True -> getParamNode >>= return . X.childNodes
False -> return []
cIfLoggedIn :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedIn auth = do
children <- C.promiseChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
True -> children
False -> return mempty
ifLoggedOut :: SnapletLens b (AuthManager b) -> SnapletISplice b
ifLoggedOut auth = do
chk <- lift $ withTop auth isLoggedIn
case chk of
False -> getParamNode >>= return . X.childNodes
True -> return []
cIfLoggedOut :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedOut auth = do
children <- C.promiseChildren
return $ C.yieldRuntime $ do
chk <- lift $ withTop auth isLoggedIn
case chk of
False -> children
True -> return mempty
loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b
loggedInUser auth = do
u <- lift $ withTop auth currentUser
maybe (return []) (I.textSplice . userLogin) u
cLoggedInUser :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cLoggedInUser auth =
return $ C.yieldRuntimeText $ do
u <- lift $ withTop auth currentUser
return $ maybe "" userLogin u