AuthManager.hs

------------------------------------------------------------------------------
-- | 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 r unm pass = do
  now <- getCurrentTime
  let au = defAuthUser {
              userLogin     = unm
            , userPassword  = Nothing
            , userCreatedAt = Just now
            , userUpdatedAt = Just now
            }
  au' <- setPassword au pass
  save r 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)
  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

    , session               :: SnapletLens b SessionManager
        -- ^ A lens pointer to a SessionManager

    , activeUser            :: Maybe AuthUser
        -- ^ A per-request logged-in user cache

    , minPasswdLen          :: Int
        -- ^ Password length range

    , rememberCookieName    :: ByteString
        -- ^ Cookie name for the remember token

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

    , siteKey               :: Key
        -- ^ A unique encryption key used to encrypt remember cookie

    , lockout               :: Maybe (Int, NominalDiffTime)
        -- ^ Lockout after x tries, re-allow entry after y seconds

    , randomNumberGenerator :: RNG
        -- ^ Random number generator
    }

instance IAuthBackend (AuthManager b) where
    save AuthManager{..} u = save backend u
    lookupByUserId AuthManager{..} u = lookupByUserId backend u
    lookupByLogin AuthManager{..} u = lookupByLogin backend u
    lookupByRememberToken AuthManager{..} u = lookupByRememberToken backend u
    destroy AuthManager{..} u = destroy backend u