{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings         #-}
{-# LANGUAGE RecordWildCards           #-}

{-|

  Some pre-packaged splices that add convenience to a Heist-enabled
  application.

-}

module Snap.Snaplet.Auth.SpliceHelpers
  ( addAuthSplices
  , compiledAuthSplices
  , userCSplices
  , userISplices
  , ifLoggedIn
  , ifLoggedOut
  , loggedInUser
  , cIfLoggedIn
  , cIfLoggedOut
  , cLoggedInUser
  ) where

------------------------------------------------------------------------------
import           Control.Lens
import           Control.Monad.Trans
import           Data.Map.Syntax ((##), mapV)
import           Data.Maybe
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

#if !MIN_VERSION_base(4,8,0)
import           Data.Monoid
#endif

------------------------------------------------------------------------------


------------------------------------------------------------------------------
-- | Add all standard auth splices to a Heist-enabled application.
--
-- This adds the following splices:
-- \<ifLoggedIn\>
-- \<ifLoggedOut\>
-- \<loggedInUser\>
addAuthSplices
  :: HasHeist b
  => Snaplet (Heist b)
  -> SnapletLens b (AuthManager b)
      -- ^ A lens reference to 'AuthManager'
  -> Initializer b v ()
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



------------------------------------------------------------------------------
-- | List containing compiled splices for ifLoggedIn, ifLoggedOut, and
-- loggedInUser.
compiledAuthSplices :: SnapletLens b (AuthManager b)
                    -> 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 -> 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 => Splices (RuntimeSplice m AuthUser -> C.Splice m)
userCSplices = fields `mappend` ifs
  where
    fields = mapV (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)


------------------------------------------------------------------------------
-- | 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>
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 []


------------------------------------------------------------------------------
-- | 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 :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedIn auth = do
    cs <- C.runChildren
    return $ C.yieldRuntime $ do
        chk <- lift $ withTop auth isLoggedIn
        case chk of
          True -> C.codeGen cs
          False -> mempty


------------------------------------------------------------------------------
-- | 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>
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 []


------------------------------------------------------------------------------
-- | 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 :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cIfLoggedOut auth = do
    cs <- C.runChildren
    return $ C.yieldRuntime $ do
        chk <- lift $ withTop auth isLoggedIn
        case chk of
          False -> C.codeGen cs
          True -> mempty


-------------------------------------------------------------------------------
-- | A splice that will simply print the current user's login, if
-- there is one.
loggedInUser :: SnapletLens b (AuthManager b) -> SnapletISplice b
loggedInUser auth = do
    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 :: SnapletLens b (AuthManager b) -> SnapletCSplice b
cLoggedInUser auth =
    return $ C.yieldRuntimeText $ do
        u <- lift $ withTop auth currentUser
        return $ maybe "" userLogin u