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