{-# LANGUAGE DefaultSignatures #-}

{-|
Module      : Servant.Server.Auth.Token.Config
Description : Configuration of auth server
Copyright   : (c) Anton Gushcha, 2016
License     : MIT
Maintainer  : ncrashed@gmail.com
Stability   : experimental
Portability : Portable
-}
module Servant.Server.Auth.Token.Config(
    AuthConfig(..)
  , HasAuthConfig(..)
  , defaultAuthConfig
  ) where

import Control.Monad.Cont (ContT)
import Control.Monad.Except (ExceptT)
import Control.Monad.IO.Class
import Control.Monad.Reader (ReaderT)
import qualified Control.Monad.RWS.Lazy as LRWS
import qualified Control.Monad.RWS.Strict as SRWS
import qualified Control.Monad.State.Lazy as LS
import qualified Control.Monad.State.Strict as SS
import qualified Control.Monad.Writer.Lazy as LW
import qualified Control.Monad.Writer.Strict as SW
import Control.Monad.Trans.Class (MonadTrans(lift))
import Data.Text (Text)
import Data.Time
import Data.UUID
import Data.UUID.V4
import Servant.Server

import Servant.API.Auth.Token

-- | Monad that can read an auth config
class Monad m => HasAuthConfig m where
  getAuthConfig :: m AuthConfig
  default getAuthConfig :: (m ~ t n, MonadTrans t, HasAuthConfig n) => m AuthConfig
  getAuthConfig = lift getAuthConfig

instance HasAuthConfig m => HasAuthConfig (ContT r m)
instance HasAuthConfig m => HasAuthConfig (ExceptT e m)
instance HasAuthConfig m => HasAuthConfig (ReaderT r m)
instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LRWS.RWST r w s m)
instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SRWS.RWST r w s m)
instance HasAuthConfig m => HasAuthConfig (LS.StateT s m)
instance HasAuthConfig m => HasAuthConfig (SS.StateT s m)
instance (HasAuthConfig m, Monoid w) => HasAuthConfig (LW.WriterT w m)
instance (HasAuthConfig m, Monoid w) => HasAuthConfig (SW.WriterT w m)

-- | Configuration specific for authorisation system
data AuthConfig = AuthConfig {
  -- | For authorisation, defines amounts of seconds
  -- when token becomes invalid.
    defaultExpire :: !NominalDiffTime
  -- | For password restore, defines amounts of seconds
  -- when restore code becomes invalid.
  , restoreExpire :: !NominalDiffTime
  -- | User specified implementation of restore code sending. It could
  -- be a email sender or SMS message or mobile application method, whatever
  -- the implementation needs.
  , restoreCodeSender :: !(RespUserInfo -> RestoreCode -> IO ())
  -- | User specified generator for restore codes. By default the server
  -- generates UUID that can be unacceptable for SMS restoration routine.
  , restoreCodeGenerator :: !(IO RestoreCode)
  -- | Upper bound of expiration time that user can request
  -- for a token.
  , maximumExpire :: !(Maybe NominalDiffTime)
  -- | For authorisation, defines amount of hashing
  -- of new user passwords (should be greater or equal 14).
  -- The passwords hashed 2^strength times. It is needed to
  -- prevent almost all kinds of brute force attacks, rainbow
  -- tables and dictionary attacks.
  , passwordsStrength :: !Int
  -- | Validates user password at registration / password change.
  --
  -- If the function returns 'Just', then a 400 error is raised with
  -- specified text.
  --
  -- Default value doesn't validate passwords at all.
  , passwordValidator :: !(Text -> Maybe Text)
  -- | Transformation of errors produced by the auth server
  , servantErrorFormer :: !(ServantErr -> ServantErr)
  -- | Default size of page for pagination
  , defaultPageSize :: !Word
  -- | User specified method of sending single usage code for authorisation.
  --
  -- See also: endpoints 'AuthSigninGetCodeMethod' and 'AuthSigninPostCodeMethod'.
  --
  -- By default does nothing.
  , singleUseCodeSender :: !(RespUserInfo -> SingleUseCode -> IO ())
  -- | Time the generated single usage code expires after.
  --
  -- By default 1 hour.
  , singleUseCodeExpire :: !NominalDiffTime
  -- | User specified generator for single use codes.
  --
  -- By default the server generates UUID that can be unacceptable for SMS way of sending.
  , singleUseCodeGenerator :: !(IO SingleUseCode)
  -- | Number of not expiring single use codes that user can have at once.
  --
  -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 100.
  , singleUseCodePermanentMaximum :: !Word
  -- | Number of not expiring single use codes that generated by default when client doesn't
  -- specify the value.
  --
  -- Used by 'AuthGetSingleUseCodes' endpoint. Default is 20.
  , singleUseCodeDefaultCount :: !Word
  }

-- | Default configuration for authorisation server
defaultAuthConfig :: AuthConfig
defaultAuthConfig = AuthConfig {
    defaultExpire = fromIntegral (600 :: Int)
  , restoreExpire = fromIntegral (3*24*3600 :: Int) -- 3 days
  , restoreCodeSender = const $ const $ return ()
  , restoreCodeGenerator = uuidCodeGenerate
  , maximumExpire = Nothing
  , passwordsStrength = 17
  , passwordValidator = const Nothing
  , servantErrorFormer = id
  , defaultPageSize = 50
  , singleUseCodeSender = const $ const $ return ()
  , singleUseCodeExpire = fromIntegral (60 * 60 :: Int) -- 1 hour
  , singleUseCodeGenerator = uuidSingleUseCodeGenerate
  , singleUseCodePermanentMaximum = 100
  , singleUseCodeDefaultCount = 20
  }

-- | Default generator of restore codes
uuidCodeGenerate :: IO RestoreCode
uuidCodeGenerate = toText <$> liftIO nextRandom

-- | Default generator of restore codes
uuidSingleUseCodeGenerate :: IO RestoreCode
uuidSingleUseCodeGenerate = toText <$> liftIO nextRandom