module Snap.Snaplet.Auth.Types where
import Control.Applicative
import Control.Arrow
import Control.Monad.CatchIO
import Control.Monad.Trans
import Control.Monad.Trans.Error
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.Typeable
import Snap.Snaplet
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"
}
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
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