content: {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE DeriveDataTypeable         #-}
  {-# LANGUAGE ExistentialQuantification  #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE OverloadedStrings          #-}
  {-# LANGUAGE StandaloneDeriving         #-}
  
  module Snap.Snaplet.Auth.Types where
  
  ------------------------------------------------------------------------------
  import           Control.Arrow
  import           Control.Monad.Trans
  import           Crypto.PasswordStore
  import           Data.Aeson
  import           Data.ByteString       (ByteString)
  import qualified Data.Configurator as C
  import           Data.HashMap.Strict   (HashMap)
  import qualified Data.HashMap.Strict   as HM
  import           Data.Hashable         (Hashable)
  import           Data.Time
  import           Data.Text             (Text)
  import           Data.Text.Encoding    (decodeUtf8, encodeUtf8)
  import           Data.Typeable
  import           Snap.Snaplet
  
  #if !MIN_VERSION_base(4,8,0)
  import           Control.Applicative
  #endif
  
  
  ------------------------------------------------------------------------------
  -- | Password is clear when supplied by the user and encrypted later when
  -- returned from the db.
  data Password = ClearText ByteString
                | Encrypted ByteString
    deriving (Read, Show, Ord, Eq)
  
  
  ------------------------------------------------------------------------------
  -- | Default strength level to pass into makePassword.
  defaultStrength :: Int
  defaultStrength = 12
  
  
  -------------------------------------------------------------------------------
  -- | The underlying encryption function, in case you need it for
  -- external processing.
  encrypt :: ByteString -> IO ByteString
  encrypt = flip makePassword defaultStrength
  
  
  -------------------------------------------------------------------------------
  -- | The underlying verify function, in case you need it for external
  -- processing.
  verify 
      :: ByteString               -- ^ Cleartext
      -> ByteString               -- ^ Encrypted reference
      -> Bool
  verify = verifyPassword 
  
  
  ------------------------------------------------------------------------------
  -- | Turn a 'ClearText' password into an 'Encrypted' password, ready to
  -- be stuffed into a database.
  encryptPassword :: Password -> IO Password
  encryptPassword p@(Encrypted {}) = return p
  encryptPassword (ClearText p)    = Encrypted `fmap` encrypt p 
  
  
  ------------------------------------------------------------------------------
  checkPassword :: Password -> Password -> Bool
  checkPassword (ClearText pw) (Encrypted pw') = verify pw pw'
  checkPassword (ClearText pw) (ClearText pw') = pw == pw'
  checkPassword (Encrypted pw) (Encrypted pw') = pw == pw'
  checkPassword _ _ =
    error "checkPassword failed. Make sure you pass ClearText passwords"
  
  
  ------------------------------------------------------------------------------
  -- | Authentication failures indicate what went wrong during authentication.
  -- They may provide useful information to the developer, although it is
  -- generally not advisable to show the user the exact details about why login
  -- failed.
  data AuthFailure = AuthError String
                   | BackendError
                   | DuplicateLogin
                   | EncryptedPassword
                   | IncorrectPassword
                   | LockedOut UTCTime    -- ^ Locked out until given time
                   | PasswordMissing
                   | UsernameMissing
                   | UserNotFound
    deriving (Read, Ord, Eq, Typeable)
  
  
  instance Show AuthFailure where
          show (AuthError s) = s
          show (BackendError) = "Failed to store data in the backend."
          show (DuplicateLogin) = "This login already exists in the backend."
          show (EncryptedPassword) = "Cannot login with encrypted password."
          show (IncorrectPassword) = "The password provided was not valid."
          show (LockedOut time) = "The login is locked out until " ++ show time
          show (PasswordMissing) = "No password provided."
          show (UsernameMissing) = "No username provided."
          show (UserNotFound) = "User not found in the backend."
  
  
  ------------------------------------------------------------------------------
  -- | Internal representation of a 'User'. By convention, we demand that the
  -- application is able to directly fetch a 'User' using this identifier.
  --
  -- Think of this type as a secure, authenticated user. You should normally
  -- never see this type unless a user has been authenticated.
  newtype UserId = UserId { unUid :: Text }
    deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable )
  
  #if MIN_VERSION_aeson(1,0,0)
  deriving instance FromJSONKey UserId
  deriving instance ToJSONKey UserId
  #endif
  
  ------------------------------------------------------------------------------
  -- | This will be replaced by a role-based permission system.
  data Role = Role ByteString
    deriving (Read, Show, Ord, Eq)
  
  
  ------------------------------------------------------------------------------
  -- | Type representing the concept of a User in your application.
  data AuthUser = AuthUser
      { userId               :: Maybe UserId
      , userLogin            :: Text
  
      -- We have to have an email field for password reset functionality, but we
      -- don't want to force users to log in with their email address.
      , userEmail            :: Maybe Text
      , userPassword         :: Maybe Password
      , userActivatedAt      :: Maybe UTCTime
      , userSuspendedAt      :: Maybe UTCTime
      , userRememberToken    :: Maybe Text
      , userLoginCount       :: Int
      , userFailedLoginCount :: Int
      , userLockedOutUntil   :: Maybe UTCTime
      , userCurrentLoginAt   :: Maybe UTCTime
      , userLastLoginAt      :: Maybe UTCTime
      , userCurrentLoginIp   :: Maybe ByteString
      , userLastLoginIp      :: Maybe ByteString
      , userCreatedAt        :: Maybe UTCTime
      , userUpdatedAt        :: Maybe UTCTime
      , userResetToken       :: Maybe Text
      , userResetRequestedAt :: Maybe UTCTime
      , userRoles            :: [Role]
      , userMeta             :: HashMap Text Value
      }
    deriving (Show,Eq)
  
  
  ------------------------------------------------------------------------------
  -- | Default AuthUser that has all empty values.
  defAuthUser :: AuthUser
  defAuthUser = AuthUser
      { userId               = Nothing
      , userLogin            = ""
      , userEmail            = Nothing
      , userPassword         = Nothing
      , userActivatedAt      = Nothing
      , userSuspendedAt      = Nothing
      , userRememberToken    = Nothing
      , userLoginCount       = 0
      , userFailedLoginCount = 0
      , userLockedOutUntil   = Nothing
      , userCurrentLoginAt   = Nothing
      , userLastLoginAt      = Nothing
      , userCurrentLoginIp   = Nothing
      , userLastLoginIp      = Nothing
      , userCreatedAt        = Nothing
      , userUpdatedAt        = Nothing
      , userResetToken       = Nothing
      , userResetRequestedAt = Nothing
      , userRoles            = []
      , userMeta             = HM.empty
      }
  
  
  ------------------------------------------------------------------------------
  -- | Set a new password for the given user. Given password should be
  -- clear-text; it will be encrypted into a 'Encrypted'.
  setPassword :: AuthUser -> ByteString -> IO AuthUser
  setPassword au pass = do
      pw <- Encrypted <$> makePassword pass defaultStrength
      return $! au { userPassword = Just pw }
  
  
  ------------------------------------------------------------------------------
  -- | Authentication settings defined at initialization time
  data AuthSettings = AuthSettings {
      asMinPasswdLen       :: Int
        -- ^ Currently not used/checked
  
    , asRememberCookieName :: ByteString
        -- ^ Name of the desired remember cookie
  
    , asRememberPeriod     :: Maybe Int
        -- ^ How long to remember when the option is used in rest of the API.
      -- 'Nothing' means remember until end of session.
  
    , asLockout            :: Maybe (Int, NominalDiffTime)
        -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])
  
    , asSiteKey            :: FilePath
        -- ^ Location of app's encryption key
  }
  
  
  ------------------------------------------------------------------------------
  -- | Default settings for Auth.
  --
  -- > asMinPasswdLen = 8
  -- > asRememberCookieName = "_remember"
  -- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks
  -- > asLockout = Nothing
  -- > asSiteKey = "site_key.txt"
  defAuthSettings :: AuthSettings
  defAuthSettings = AuthSettings {
      asMinPasswdLen       = 8
    , asRememberCookieName = "_remember"
    , asRememberPeriod     = Just (2*7*24*60*60)
    , asLockout            = Nothing
    , asSiteKey            = "site_key.txt"
  }
  
  
  ------------------------------------------------------------------------------
  -- | Function to get auth settings from a config file.  This function can be
  -- used by the authors of auth snaplet backends in the initializer to let the
  -- user configure the auth snaplet from a config file.  All options are
  -- optional and default to what's in defAuthSettings if not supplied.
  -- Here's what the default options would look like in the config file:
  --
  -- > minPasswordLen = 8
  -- > rememberCookie = "_remember"
  -- > rememberPeriod = 1209600 # 2 weeks
  -- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds
  -- > siteKey = "site_key.txt"
  authSettingsFromConfig :: Initializer b v AuthSettings
  authSettingsFromConfig = do
      config <- getSnapletUserConfig
      minPasswordLen <- liftIO $ C.lookup config "minPasswordLen"
      let pw = maybe id (\x s -> s { asMinPasswdLen = x }) minPasswordLen
      rememberCookie <- liftIO $ C.lookup config "rememberCookie"
      let rc = maybe id (\x s -> s { asRememberCookieName = x }) rememberCookie
      rememberPeriod <- liftIO $ C.lookup config "rememberPeriod"
      let rp = maybe id (\x s -> s { asRememberPeriod = Just x }) rememberPeriod
      lockout <- liftIO $ C.lookup config "lockout"
      let lo = maybe id (\x s -> s { asLockout = Just (second fromInteger x) })
                     lockout
      siteKey <- liftIO $ C.lookup config "siteKey"
      let sk = maybe id (\x s -> s { asSiteKey = x }) siteKey
      return $ (pw . rc . rp . lo . sk) defAuthSettings
  
  
                               --------------------
                               -- JSON Instances --
                               --------------------
  
  ------------------------------------------------------------------------------
  instance ToJSON AuthUser where
    toJSON u = object
      [ "uid"                .= userId                u
      , "login"              .= userLogin             u
      , "email"              .= userEmail             u
      , "pw"                 .= userPassword          u
      , "activated_at"       .= userActivatedAt       u
      , "suspended_at"       .= userSuspendedAt       u
      , "remember_token"     .= userRememberToken     u
      , "login_count"        .= userLoginCount        u
      , "failed_login_count" .= userFailedLoginCount  u
      , "locked_until"       .= userLockedOutUntil    u
      , "current_login_at"   .= userCurrentLoginAt    u
      , "last_login_at"      .= userLastLoginAt       u
      , "current_ip"         .= fmap decodeUtf8 (userCurrentLoginIp u)
      , "last_ip"            .= fmap decodeUtf8 (userLastLoginIp u)
      , "created_at"         .= userCreatedAt         u
      , "updated_at"         .= userUpdatedAt         u
      , "reset_token"        .= userResetToken        u
      , "reset_requested_at" .= userResetRequestedAt  u
      , "roles"              .= userRoles             u
      , "meta"               .= userMeta              u
      ]
  
  
  ------------------------------------------------------------------------------
  instance FromJSON AuthUser where
    parseJSON (Object v) = AuthUser
      <$> v .: "uid"
      <*> v .: "login"
      <*> v .: "email"
      <*> v .: "pw"
      <*> v .: "activated_at"
      <*> v .: "suspended_at"
      <*> v .: "remember_token"
      <*> v .: "login_count"
      <*> v .: "failed_login_count"
      <*> v .: "locked_until"
      <*> v .: "current_login_at"
      <*> v .: "last_login_at"
      <*> fmap (fmap encodeUtf8) (v .: "current_ip")
      <*> fmap (fmap encodeUtf8) (v .: "last_ip")
      <*> v .: "created_at"
      <*> v .: "updated_at"
      <*> v .: "reset_token"
      <*> v .: "reset_requested_at"
      <*> v .:? "roles" .!= []
      <*> v .: "meta"
    parseJSON _ = error "Unexpected JSON input"
  
  
  ------------------------------------------------------------------------------
  instance ToJSON Password where
    toJSON (Encrypted x) = toJSON $ decodeUtf8 x
    toJSON (ClearText _) =
        error "ClearText passwords can't be serialized into JSON"
  
  
  ------------------------------------------------------------------------------
  instance FromJSON Password where
    parseJSON = fmap (Encrypted . encodeUtf8) . parseJSON
  
  
  ------------------------------------------------------------------------------
  instance ToJSON Role where
    toJSON (Role x) = toJSON $ decodeUtf8 x
  
  
  ------------------------------------------------------------------------------
  instance FromJSON Role where
    parseJSON = fmap (Role . encodeUtf8) . parseJSON
  