module Snap.Snaplet.Auth.Types where
import Control.Applicative
import Control.Monad.CatchIO
import Control.Monad.Trans.Error
import Crypto.PasswordStore
import Data.Aeson
import Data.ByteString (ByteString)
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.Typeable
data Password = ClearText ByteString
| Encrypted ByteString
deriving (Read, Show, Ord, Eq)
defaultStrength :: Int
defaultStrength = 12
encrypt :: ByteString -> IO ByteString
encrypt = flip makePassword defaultStrength
verify
:: ByteString
-> ByteString
-> Bool
verify = verifyPassword
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"
data AuthFailure = UserNotFound
| IncorrectPassword
| PasswordMissing
| LockedOut UTCTime
| AuthError String
deriving (Read, Show, Ord, Eq, Typeable)
instance Exception AuthFailure
instance Error AuthFailure where
strMsg = AuthError
newtype UserId = UserId { unUid :: Text }
deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable )
data Role = Role ByteString
deriving (Read, Show, Ord, Eq)
data AuthUser = AuthUser
{ userId :: Maybe UserId
, userLogin :: 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
, userRoles :: [Role]
, userMeta :: HashMap Text Value
}
deriving (Show,Eq)
defAuthUser :: AuthUser
defAuthUser = AuthUser
{ userId = Nothing
, userLogin = ""
, 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
, userRoles = []
, userMeta = HM.empty
}
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword au pass = do
pw <- Encrypted <$> makePassword pass defaultStrength
return $! au { userPassword = Just pw }
data AuthSettings = AuthSettings {
asMinPasswdLen :: Int
, asRememberCookieName :: ByteString
, asRememberPeriod :: Maybe Int
, asLockout :: Maybe (Int, NominalDiffTime)
, asSiteKey :: FilePath
}
defAuthSettings :: AuthSettings
defAuthSettings = AuthSettings {
asMinPasswdLen = 8
, asRememberCookieName = "_remember"
, asRememberPeriod = Just (2*7*24*60*60)
, asLockout = Nothing
, asSiteKey = "site_key.txt"
}
data BackendError = DuplicateLogin
| BackendError String
deriving (Eq,Show,Read,Typeable)
instance Exception BackendError
instance ToJSON AuthUser where
toJSON u = object
[ "uid" .= userId u
, "login" .= userLogin 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" .= userCurrentLoginIp u
, "last_ip" .= userLastLoginIp u
, "created_at" .= userCreatedAt u
, "updated_at" .= userUpdatedAt u
, "roles" .= userRoles u
, "meta" .= userMeta u
]
instance FromJSON AuthUser where
parseJSON (Object v) = AuthUser
<$> v .: "uid"
<*> v .: "login"
<*> 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"
<*> v .: "current_ip"
<*> v .: "last_ip"
<*> v .: "created_at"
<*> v .: "updated_at"
<*> v .:? "roles" .!= []
<*> v .: "meta"
parseJSON _ = error "Unexpected JSON input"
instance ToJSON Password where
toJSON (Encrypted x) = toJSON x
toJSON (ClearText _) =
error "ClearText passwords can't be serialized into JSON"
instance FromJSON Password where
parseJSON = fmap Encrypted . parseJSON
instance ToJSON Role where
toJSON (Role x) = toJSON x
instance FromJSON Role where
parseJSON = fmap Role . parseJSON