module Servant.Server.Auth.Token(
authServer
, HasStorage(..)
, AuthHandler
, guardAuthToken
, ensureAdmin
, authUserByToken
, authSignin
, authSigninGetCode
, authSigninPostCode
, authTouch
, authToken
, authSignout
, authSignup
, authUsersInfo
, authUserInfo
, authUserPatch
, authUserPut
, authUserDelete
, authRestore
, authGetSingleUseCodes
, authGroupGet
, authGroupPost
, authGroupPut
, authGroupPatch
, authGroupDelete
, authGroupList
, getAuthToken
) where
import Control.Monad
import Control.Monad.Except
import Crypto.PasswordStore
import Data.Aeson.Unit
import Data.Aeson.WithField
import Data.Maybe
import Data.Monoid
import Data.Text.Encoding
import Data.Time.Clock
import Data.UUID
import Data.UUID.V4
import Servant
import Servant.API.Auth.Token
import Servant.API.Auth.Token.Pagination
import Servant.Server.Auth.Token.Common
import Servant.Server.Auth.Token.Config
import Servant.Server.Auth.Token.Model
import Servant.Server.Auth.Token.Monad
import Servant.Server.Auth.Token.Pagination
import Servant.Server.Auth.Token.Restore
import Servant.Server.Auth.Token.SingleUse
import qualified Data.ByteString.Lazy as BS
authServer :: AuthHandler m => ServerT AuthAPI m
authServer =
authSignin
:<|> authSigninGetCode
:<|> authSigninPostCode
:<|> authTouch
:<|> authToken
:<|> authSignout
:<|> authSignup
:<|> authUsersInfo
:<|> authUserInfo
:<|> authUserPatch
:<|> authUserPut
:<|> authUserDelete
:<|> authRestore
:<|> authGetSingleUseCodes
:<|> authGroupGet
:<|> authGroupPost
:<|> authGroupPut
:<|> authGroupPatch
:<|> authGroupDelete
:<|> authGroupList
authSignin :: AuthHandler m
=> Maybe Login
-> Maybe Password
-> Maybe Seconds
-> m (OnlyField "token" SimpleToken)
authSignin mlogin mpass mexpire = do
login <- require "login" mlogin
pass <- require "pass" mpass
WithField uid UserImpl{..} <- guardLogin login pass
OnlyField <$> getAuthToken uid mexpire
where
guardLogin login pass = do
muser <- getUserImplByLogin login
let err = throw401 "Cannot find user with given combination of login and pass"
case muser of
Nothing -> err
Just user@(WithField _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
then return user
else err
getAuthToken :: AuthHandler m
=> UserImplId
-> Maybe Seconds
-> m SimpleToken
getAuthToken uid mexpire = do
expire <- calcExpire mexpire
mt <- getExistingToken
case mt of
Nothing -> createToken expire
Just t -> touchToken t expire
where
getExistingToken = do
t <- liftIO getCurrentTime
findAuthToken uid t
createToken expire = do
token <- toText <$> liftIO nextRandom
_ <- insertAuthToken AuthToken {
authTokenValue = token
, authTokenUser = uid
, authTokenExpire = expire
}
return token
authSigninGetCode :: AuthHandler m
=> Maybe Login
-> m Unit
authSigninGetCode mlogin = do
login <- require "login" mlogin
uinfo <- guard404 "user" $ readUserInfoByLogin login
let uid = toKey $ respUserId uinfo
AuthConfig{..} <- getConfig
code <- liftIO singleUseCodeGenerator
expire <- makeSingleUseExpire singleUseCodeExpire
registerSingleUseCode uid code (Just expire)
liftIO $ singleUseCodeSender uinfo code
return Unit
authSigninPostCode :: AuthHandler m
=> Maybe Login
-> Maybe SingleUseCode
-> Maybe Seconds
-> m (OnlyField "token" SimpleToken)
authSigninPostCode mlogin mcode mexpire = do
login <- require "login" mlogin
code <- require "code" mcode
uinfo <- guard404 "user" $ readUserInfoByLogin login
let uid = toKey $ respUserId uinfo
isValid <- validateSingleUseCode uid code
unless isValid $ throw401 "Single usage code doesn't match"
OnlyField <$> getAuthToken uid mexpire
calcExpire :: AuthHandler m => Maybe Seconds -> m UTCTime
calcExpire mexpire = do
t <- liftIO getCurrentTime
AuthConfig{..} <- getConfig
let requestedExpire = maybe defaultExpire fromIntegral mexpire
let boundedExpire = maybe requestedExpire (min requestedExpire) maximumExpire
return $ boundedExpire `addUTCTime` t
touchToken :: AuthHandler m => WithId AuthTokenId AuthToken -> UTCTime -> m SimpleToken
touchToken (WithField tid tok) expire = do
replaceAuthToken tid tok {
authTokenExpire = expire
}
return $ authTokenValue tok
authTouch :: AuthHandler m
=> Maybe Seconds
-> MToken '[]
-> m Unit
authTouch mexpire token = do
WithField i mt <- guardAuthToken' (fmap unToken token) []
expire <- calcExpire mexpire
replaceAuthToken i mt { authTokenExpire = expire }
return Unit
authToken :: AuthHandler m
=> MToken '[]
-> m RespUserInfo
authToken token = do
i <- authUserByToken token
guard404 "user" . readUserInfo . fromKey $ i
authUserByToken :: AuthHandler m => MToken '[] -> m UserImplId
authUserByToken token = do
WithField _ mt <- guardAuthToken' (fmap unToken token) []
return $ authTokenUser mt
authSignout :: AuthHandler m
=> Maybe (Token '[])
-> m Unit
authSignout token = do
WithField i mt <- guardAuthToken' (fmap unToken token) []
expire <- liftIO getCurrentTime
replaceAuthToken i mt { authTokenExpire = expire }
return Unit
guardPassword :: AuthHandler m => Password -> m ()
guardPassword p = do
AuthConfig{..} <- getConfig
whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
authSignup :: AuthHandler m
=> ReqRegister
-> MToken' '["auth-register"]
-> m (OnlyField "user" UserId)
authSignup ReqRegister{..} token = do
guardAuthToken token
guardUserInfo
guardPassword reqRegPassword
strength <- getsConfig passwordsStrength
i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions
whenJust reqRegGroups $ setUserGroups i
return $ OnlyField . fromKey $ i
where
guardUserInfo = do
mu <- getUserImplByLogin reqRegLogin
whenJust mu $ const $ throw400 "User with specified id is already registered"
authUsersInfo :: AuthHandler m
=> Maybe Page
-> Maybe PageSize
-> MToken' '["auth-info"]
-> m RespUsersInfo
authUsersInfo mp msize token = do
guardAuthToken token
pagination mp msize $ \page size -> do
(users', total) <- listUsersPaged page size
perms <- mapM (getUserPermissions . (\(WithField i _) -> i)) users'
groups <- mapM (getUserGroups . (\(WithField i _) -> i)) users'
let users = zip3 users' perms groups
return RespUsersInfo {
respUsersItems = (\(user, ps, grs) -> userToUserInfo user ps grs) <$> users
, respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
}
authUserInfo :: AuthHandler m
=> UserId
-> MToken' '["auth-info"]
-> m RespUserInfo
authUserInfo uid' token = do
guardAuthToken token
guard404 "user" $ readUserInfo uid'
authUserPatch :: AuthHandler m
=> UserId
-> PatchUser
-> MToken' '["auth-update"]
-> m Unit
authUserPatch uid' body token = do
guardAuthToken token
whenJust (patchUserPassword body) guardPassword
let uid = toKey uid'
user <- guardUser uid
strength <- getsConfig passwordsStrength
WithField _ user' <- patchUser strength body $ WithField uid user
replaceUserImpl uid user'
return Unit
authUserPut :: AuthHandler m
=> UserId
-> ReqRegister
-> MToken' '["auth-update"]
-> m Unit
authUserPut uid' ReqRegister{..} token = do
guardAuthToken token
guardPassword reqRegPassword
let uid = toKey uid'
let user = UserImpl {
userImplLogin = reqRegLogin
, userImplPassword = ""
, userImplEmail = reqRegEmail
}
user' <- setUserPassword reqRegPassword user
replaceUserImpl uid user'
setUserPermissions uid reqRegPermissions
whenJust reqRegGroups $ setUserGroups uid
return Unit
authUserDelete :: AuthHandler m
=> UserId
-> MToken' '["auth-delete"]
-> m Unit
authUserDelete uid' token = do
guardAuthToken token
deleteUserImpl $ toKey uid'
return Unit
authRestore :: AuthHandler m
=> UserId
-> Maybe RestoreCode
-> Maybe Password
-> m Unit
authRestore uid' mcode mpass = do
let uid = toKey uid'
user <- guardUser uid
case mcode of
Nothing -> do
dt <- getsConfig restoreExpire
t <- liftIO getCurrentTime
AuthConfig{..} <- getConfig
rc <- getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t
uinfo <- guard404 "user" $ readUserInfo uid'
sendRestoreCode uinfo rc
Just code -> do
pass <- require "password" mpass
guardPassword pass
guardRestoreCode uid code
user' <- setUserPassword pass user
replaceUserImpl uid user'
return Unit
authGetSingleUseCodes :: AuthHandler m
=> UserId
-> Maybe Word
-> MToken' '["auth-single-codes"]
-> m (OnlyField "codes" [SingleUseCode])
authGetSingleUseCodes uid mcount token = do
guardAuthToken token
let uid' = toKey uid
_ <- guard404 "user" $ readUserInfo uid
AuthConfig{..} <- getConfig
let n = min singleUseCodePermamentMaximum $ fromMaybe singleUseCodeDefaultCount mcount
OnlyField <$> generateSingleUsedCodes uid' singleUseCodeGenerator n
guardUser :: AuthHandler m => UserImplId -> m UserImpl
guardUser uid = do
muser <- getUserImpl uid
case muser of
Nothing -> throw404 "User not found"
Just user -> return user
guardAuthToken :: forall perms m . (PermsList perms, AuthHandler m) => MToken perms -> m ()
guardAuthToken mt = void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
guardAuthToken' :: AuthHandler m => Maybe SimpleToken -> [Permission] -> m (WithId AuthTokenId AuthToken)
guardAuthToken' Nothing _ = throw401 "Token required"
guardAuthToken' (Just token) perms = do
t <- liftIO getCurrentTime
mt <- findAuthTokenByValue token
case mt of
Nothing -> throw401 "Token is not valid"
Just et@(WithField _ AuthToken{..}) -> do
when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
mu <- getUserImpl authTokenUser
case mu of
Nothing -> throw500 "User of the token doesn't exist"
Just UserImpl{..} -> do
isAdmin <- hasPerm authTokenUser adminPerm
hasAllPerms <- hasPerms authTokenUser perms
unless (isAdmin || hasAllPerms) $ throw401 $
"User doesn't have all required permissions: " <> showb perms
return et
setUserPassword :: AuthHandler m => Password -> UserImpl -> m UserImpl
setUserPassword pass user = do
strength <- getsConfig passwordsStrength
setUserPassword' strength pass user
authGroupGet :: AuthHandler m
=> UserGroupId
-> MToken' '["auth-info"]
-> m UserGroup
authGroupGet i token = do
guardAuthToken token
guard404 "user group" $ readUserGroup i
authGroupPost :: AuthHandler m
=> UserGroup
-> MToken' '["auth-update"]
-> m (OnlyId UserGroupId)
authGroupPost ug token = do
guardAuthToken token
OnlyField <$> insertUserGroup ug
authGroupPut :: AuthHandler m
=> UserGroupId
-> UserGroup
-> MToken' '["auth-update"]
-> m Unit
authGroupPut i ug token = do
guardAuthToken token
updateUserGroup i ug
return Unit
authGroupPatch :: AuthHandler m
=> UserGroupId
-> PatchUserGroup
-> MToken' '["auth-update"]
-> m Unit
authGroupPatch i up token = do
guardAuthToken token
patchUserGroup i up
return Unit
authGroupDelete :: AuthHandler m
=> UserGroupId
-> MToken' '["auth-delete"]
-> m Unit
authGroupDelete i token = do
guardAuthToken token
deleteUserGroup i
return Unit
authGroupList :: AuthHandler m
=> Maybe Page
-> Maybe PageSize
-> MToken' '["auth-info"]
-> m (PagedList UserGroupId UserGroup)
authGroupList mp msize token = do
guardAuthToken token
pagination mp msize $ \page size -> do
(groups', total) <- listGroupsPaged page size
groups <- forM groups' $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey . (\(WithField i _) -> i)
return PagedList {
pagedListItems = catMaybes groups
, pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
}