------------------------------------------------------------------------------
-- | Internal module exporting AuthManager implementation.
--
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

module Snap.Snaplet.Auth.AuthManager
  ( -- * AuthManager Datatype
    AuthManager(..)

    -- * Backend Typeclass
    , IAuthBackend(..)

    -- * Context-free Operations
    , buildAuthUser
  ) where

------------------------------------------------------------------------------
import           Data.ByteString (ByteString)
import           Data.Text (Text)
import           Data.Time
import           Web.ClientSession

import           Snap.Snaplet
import           Snap.Snaplet.Session
import           Snap.Snaplet.Auth.Types


------------------------------------------------------------------------------
-- | Creates a new user from a username and password.
--
buildAuthUser :: IAuthBackend r =>
                 r            -- ^ An auth backend
              -> Text         -- ^ Username
              -> ByteString   -- ^ Password
              -> IO (Either AuthFailure AuthUser)
buildAuthUser :: forall r.
IAuthBackend r =>
r -> Text -> ByteString -> IO (Either AuthFailure AuthUser)
buildAuthUser r
r Text
unm ByteString
pass = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let au :: AuthUser
au = AuthUser
defAuthUser {
              userLogin :: Text
userLogin     = Text
unm
            , userPassword :: Maybe Password
userPassword  = forall a. Maybe a
Nothing
            , userCreatedAt :: Maybe UTCTime
userCreatedAt = forall a. a -> Maybe a
Just UTCTime
now
            , userUpdatedAt :: Maybe UTCTime
userUpdatedAt = forall a. a -> Maybe a
Just UTCTime
now
            }
  AuthUser
au' <- AuthUser -> ByteString -> IO AuthUser
setPassword AuthUser
au ByteString
pass
  forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
r AuthUser
au'


------------------------------------------------------------------------------
-- | All storage backends need to implement this typeclass
--
class IAuthBackend r where
  -- | Create or update the given 'AuthUser' record.  A 'userId' of Nothing
  -- indicates that a new user should be created, otherwise the user
  -- information for that userId should be updated.
  save                  :: r -> AuthUser -> IO (Either AuthFailure AuthUser)
  lookupByUserId        :: r -> UserId   -> IO (Maybe AuthUser)
  lookupByLogin         :: r -> Text     -> IO (Maybe AuthUser)
  lookupByEmail         :: r -> Text     -> IO (Maybe AuthUser)
  lookupByRememberToken :: r -> Text     -> IO (Maybe AuthUser)
  destroy               :: r -> AuthUser -> IO ()


------------------------------------------------------------------------------
-- | Abstract data type holding all necessary information for auth operation
data AuthManager b = forall r. IAuthBackend r => AuthManager {
      ()
backend               :: r
        -- ^ Storage back-end

    , forall b. AuthManager b -> SnapletLens b SessionManager
session               :: SnapletLens b SessionManager
        -- ^ A lens pointer to a SessionManager

    , forall b. AuthManager b -> Maybe AuthUser
activeUser            :: Maybe AuthUser
        -- ^ A per-request logged-in user cache

    , forall b. AuthManager b -> Int
minPasswdLen          :: Int
        -- ^ Password length range

    , forall b. AuthManager b -> ByteString
rememberCookieName    :: ByteString
        -- ^ Cookie name for the remember token

    , forall b. AuthManager b -> Maybe ByteString
rememberCookieDomain  :: Maybe ByteString
        -- ^ Domain for which remember cookie will be created.

    , forall b. AuthManager b -> Maybe Int
rememberPeriod        :: Maybe Int
        -- ^ Remember period in seconds. Defaults to 2 weeks.

    , forall b. AuthManager b -> Key
siteKey               :: Key
        -- ^ A unique encryption key used to encrypt remember cookie

    , forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
lockout               :: Maybe (Int, NominalDiffTime)
        -- ^ Lockout after x tries, re-allow entry after y seconds

    , forall b. AuthManager b -> RNG
randomNumberGenerator :: RNG
        -- ^ Random number generator
    }

instance IAuthBackend (AuthManager b) where
    save :: AuthManager b -> AuthUser -> IO (Either AuthFailure AuthUser)
save AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..} AuthUser
u = forall r.
IAuthBackend r =>
r -> AuthUser -> IO (Either AuthFailure AuthUser)
save r
backend AuthUser
u
    lookupByUserId :: AuthManager b -> UserId -> IO (Maybe AuthUser)
lookupByUserId AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..} UserId
u = forall r. IAuthBackend r => r -> UserId -> IO (Maybe AuthUser)
lookupByUserId r
backend UserId
u
    lookupByLogin :: AuthManager b -> Text -> IO (Maybe AuthUser)
lookupByLogin AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..} Text
u = forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByLogin r
backend Text
u
    lookupByEmail :: AuthManager b -> Text -> IO (Maybe AuthUser)
lookupByEmail AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..}  Text
u = forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByEmail r
backend Text
u
    lookupByRememberToken :: AuthManager b -> Text -> IO (Maybe AuthUser)
lookupByRememberToken AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..} Text
u = forall r. IAuthBackend r => r -> Text -> IO (Maybe AuthUser)
lookupByRememberToken r
backend Text
u
    destroy :: AuthManager b -> AuthUser -> IO ()
destroy AuthManager{r
Int
Maybe Int
Maybe (Int, NominalDiffTime)
Maybe ByteString
Maybe AuthUser
ByteString
Key
RNG
SnapletLens b SessionManager
randomNumberGenerator :: RNG
lockout :: Maybe (Int, NominalDiffTime)
siteKey :: Key
rememberPeriod :: Maybe Int
rememberCookieDomain :: Maybe ByteString
rememberCookieName :: ByteString
minPasswdLen :: Int
activeUser :: Maybe AuthUser
session :: SnapletLens b SessionManager
backend :: r
randomNumberGenerator :: forall b. AuthManager b -> RNG
lockout :: forall b. AuthManager b -> Maybe (Int, NominalDiffTime)
siteKey :: forall b. AuthManager b -> Key
rememberPeriod :: forall b. AuthManager b -> Maybe Int
rememberCookieDomain :: forall b. AuthManager b -> Maybe ByteString
rememberCookieName :: forall b. AuthManager b -> ByteString
minPasswdLen :: forall b. AuthManager b -> Int
activeUser :: forall b. AuthManager b -> Maybe AuthUser
session :: forall b. AuthManager b -> SnapletLens b SessionManager
backend :: ()
..} AuthUser
u = forall r. IAuthBackend r => r -> AuthUser -> IO ()
destroy r
backend AuthUser
u