{-# 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