module Servant.Server.Auth.Token(
authServer
, migrateAll
, AuthMonad(..)
, guardAuthToken
, ensureAdmin
, authUserByToken
, authSignin
, authTouch
, authToken
, authSignout
, authSignup
, authUsersInfo
, authUserInfo
, authUserPatch
, authUserPut
, authUserDelete
, authRestore
, authGroupGet
, authGroupPost
, authGroupPut
, authGroupPatch
, authGroupDelete
, authGroupList
) where
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
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 Database.Persist.Postgresql
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 qualified Data.ByteString.Lazy as BS
convertAuthHandler :: AuthConfig -> AuthHandler :~> ExceptT ServantErr IO
convertAuthHandler cfg = Nat (flip runReaderT cfg . runAuthHandler)
class Monad m => AuthMonad m where
getAuthConfig :: m AuthConfig
liftAuthAction :: ExceptT ServantErr IO a -> m a
instance AuthMonad AuthHandler where
getAuthConfig = getConfig
liftAuthAction = AuthHandler . lift
runAuth :: AuthMonad m => AuthHandler a -> m a
runAuth m = do
cfg <- getAuthConfig
let Nat conv = convertAuthHandler cfg
liftAuthAction $ conv m
authServer :: AuthConfig -> Server AuthAPI
authServer cfg = enter (convertAuthHandler cfg) (
authSignin
:<|> authTouch
:<|> authToken
:<|> authSignout
:<|> authSignup
:<|> authUsersInfo
:<|> authUserInfo
:<|> authUserPatch
:<|> authUserPut
:<|> authUserDelete
:<|> authRestore
:<|> authGroupGet
:<|> authGroupPost
:<|> authGroupPut
:<|> authGroupPatch
:<|> authGroupDelete
:<|> authGroupList)
authSignin :: AuthMonad m
=> Maybe Login
-> Maybe Password
-> Maybe Seconds
-> m (OnlyField "token" SimpleToken)
authSignin mlogin mpass mexpire = runAuth $ do
login <- require "login" mlogin
pass <- require "pass" mpass
Entity uid UserImpl{..} <- guardLogin login pass
expire <- calcExpire mexpire
mt <- getExistingToken uid
OnlyField <$> case mt of
Nothing -> createToken uid expire
Just t -> touchToken t expire
where
guardLogin login pass = do
muser <- runDB $ selectFirst [UserImplLogin ==. login] []
let err = throw401 "Cannot find user with given combination of login and pass"
case muser of
Nothing -> err
Just user@(Entity _ UserImpl{..}) -> if passToByteString pass `verifyPassword` passToByteString userImplPassword
then return user
else err
getExistingToken uid = do
t <- liftIO getCurrentTime
runDB $ selectFirst [AuthTokenUser ==. uid, AuthTokenExpire >. t] []
createToken uid expire = do
token <- toText <$> liftIO nextRandom
_ <- runDB $ insert AuthToken {
authTokenValue = token
, authTokenUser = uid
, authTokenExpire = expire
}
return token
calcExpire :: Maybe Seconds -> AuthHandler 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 :: Entity AuthToken -> UTCTime -> AuthHandler SimpleToken
touchToken (Entity tid tok) expire = do
runDB $ replace tid tok {
authTokenExpire = expire
}
return $ authTokenValue tok
authTouch :: AuthMonad m
=> Maybe Seconds
-> MToken '[]
-> m Unit
authTouch mexpire token = runAuth $ do
Entity i mt <- guardAuthToken' (fmap unToken token) []
expire <- calcExpire mexpire
runDB $ replace i mt { authTokenExpire = expire }
return Unit
authToken :: AuthMonad m
=> MToken '[]
-> m RespUserInfo
authToken token = runAuth $ do
i <- authUserByToken token
runDB404 "user" . readUserInfo . fromKey $ i
authUserByToken :: AuthMonad m => MToken '[] -> m UserImplId
authUserByToken token = runAuth $ do
Entity _ mt <- guardAuthToken' (fmap unToken token) []
return $ authTokenUser mt
authSignout :: AuthMonad m
=> Maybe (Token '[])
-> m Unit
authSignout token = runAuth $ do
Entity i mt <- guardAuthToken' (fmap unToken token) []
expire <- liftIO getCurrentTime
runDB $ replace i mt { authTokenExpire = expire }
return Unit
guardPassword :: Password -> AuthHandler ()
guardPassword p = do
AuthConfig{..} <- getConfig
whenJust (passwordValidator p) $ throw400 . BS.fromStrict . encodeUtf8
authSignup :: AuthMonad m
=> ReqRegister
-> MToken' '["auth-register"]
-> m (OnlyField "user" UserId)
authSignup ReqRegister{..} token = runAuth $ do
guardAuthToken token
guardUserInfo
guardPassword reqRegPassword
strength <- getsConfig passwordsStrength
i <- runDB $ do
i <- createUser strength reqRegLogin reqRegPassword reqRegEmail reqRegPermissions
whenJust reqRegGroups $ setUserGroups i
return i
return $ OnlyField . fromKey $ i
where
guardUserInfo = do
c <- runDB $ count [UserImplLogin ==. reqRegLogin]
when (c > 0) $ throw400 "User with specified id is already registered"
authUsersInfo :: AuthMonad m
=> Maybe Page
-> Maybe PageSize
-> MToken' '["auth-info"]
-> m RespUsersInfo
authUsersInfo mp msize token = runAuth $ do
guardAuthToken token
pagination mp msize $ \page size -> do
(users, total) <- runDB $ (,)
<$> (do
users <- selectList [] [Asc UserImplId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)]
perms <- mapM (getUserPermissions . entityKey) users
groups <- mapM (getUserGroups . entityKey) users
return $ zip3 users perms groups)
<*> count ([] :: [Filter UserImpl])
return RespUsersInfo {
respUsersItems = (\(user, perms, groups) -> userToUserInfo user perms groups) <$> users
, respUsersPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
}
authUserInfo :: AuthMonad m
=> UserId
-> MToken' '["auth-info"]
-> m RespUserInfo
authUserInfo uid' token = runAuth $ do
guardAuthToken token
runDB404 "user" $ readUserInfo uid'
authUserPatch :: AuthMonad m
=> UserId
-> PatchUser
-> MToken' '["auth-update"]
-> m Unit
authUserPatch uid' body token = runAuth $ do
guardAuthToken token
whenJust (patchUserPassword body) guardPassword
let uid = toSqlKey . fromIntegral $ uid'
user <- guardUser uid
strength <- getsConfig passwordsStrength
Entity _ user' <- runDB $ patchUser strength body $ Entity uid user
runDB $ replace uid user'
return Unit
authUserPut :: AuthMonad m
=> UserId
-> ReqRegister
-> MToken' '["auth-update"]
-> m Unit
authUserPut uid' ReqRegister{..} token = runAuth $ do
guardAuthToken token
guardPassword reqRegPassword
let uid = toSqlKey . fromIntegral $ uid'
let user = UserImpl {
userImplLogin = reqRegLogin
, userImplPassword = ""
, userImplEmail = reqRegEmail
}
user' <- setUserPassword reqRegPassword user
runDB $ do
replace uid user'
setUserPermissions uid reqRegPermissions
whenJust reqRegGroups $ setUserGroups uid
return Unit
authUserDelete :: AuthMonad m
=> UserId
-> MToken' '["auth-delete"]
-> m Unit
authUserDelete uid' token = runAuth $ do
guardAuthToken token
runDB $ deleteCascade (toKey uid' :: UserImplId)
return Unit
authRestore :: AuthMonad m
=> UserId
-> Maybe RestoreCode
-> Maybe Password
-> m Unit
authRestore uid' mcode mpass = runAuth $ do
let uid = toKey uid'
user <- guardUser uid
case mcode of
Nothing -> do
dt <- getsConfig restoreExpire
t <- liftIO getCurrentTime
AuthConfig{..} <- getConfig
rc <- runDB $ getRestoreCode restoreCodeGenerator uid $ addUTCTime dt t
uinfo <- runDB404 "user" $ readUserInfo uid'
sendRestoreCode uinfo rc
Just code -> do
pass <- require "password" mpass
guardPassword pass
guardRestoreCode uid code
user' <- setUserPassword pass user
runDB $ replace uid user'
return Unit
guardUser :: UserImplId -> AuthHandler UserImpl
guardUser uid = do
muser <- runDB $ get uid
case muser of
Nothing -> throw404 "User not found"
Just user -> return user
guardAuthToken :: forall perms m . (PermsList perms, AuthMonad m) => MToken perms -> m ()
guardAuthToken mt = runAuth $ void $ guardAuthToken' (fmap unToken mt) $ unliftPerms (Proxy :: Proxy perms)
guardAuthToken' :: Maybe SimpleToken -> [Permission] -> AuthHandler (Entity AuthToken)
guardAuthToken' Nothing _ = throw401 "Token required"
guardAuthToken' (Just token) perms = do
t <- liftIO getCurrentTime
mt <- runDB $ selectFirst [AuthTokenValue ==. token] []
case mt of
Nothing -> throw401 "Token is not valid"
Just et@(Entity _ AuthToken{..}) -> do
when (t > authTokenExpire) $ throwError $ err401 { errBody = "Token expired" }
mu <- runDB $ get authTokenUser
case mu of
Nothing -> throw500 "User of the token doesn't exist"
Just UserImpl{..} -> do
isAdmin <- runDB $ hasPerm authTokenUser adminPerm
hasAllPerms <- runDB $ hasPerms authTokenUser perms
unless (isAdmin || hasAllPerms) $ throw401 $
"User doesn't have all required permissions: " <> showb perms
return et
setUserPassword :: Password -> UserImpl -> AuthHandler UserImpl
setUserPassword pass user = do
strength <- getsConfig passwordsStrength
setUserPassword' strength pass user
authGroupGet :: AuthMonad m
=> UserGroupId
-> MToken' '["auth-info"]
-> m UserGroup
authGroupGet i token = runAuth $ do
guardAuthToken token
runDB404 "user group" $ readUserGroup i
authGroupPost :: AuthMonad m
=> UserGroup
-> MToken' '["auth-update"]
-> m (OnlyId UserGroupId)
authGroupPost ug token = runAuth $ do
guardAuthToken token
runDB $ OnlyField <$> insertUserGroup ug
authGroupPut :: AuthMonad m
=> UserGroupId
-> UserGroup
-> MToken' '["auth-update"]
-> m Unit
authGroupPut i ug token = runAuth $ do
guardAuthToken token
runDB $ updateUserGroup i ug
return Unit
authGroupPatch :: AuthMonad m
=> UserGroupId
-> PatchUserGroup
-> MToken' '["auth-update"]
-> m Unit
authGroupPatch i up token = runAuth $ do
guardAuthToken token
runDB $ patchUserGroup i up
return Unit
authGroupDelete :: AuthMonad m
=> UserGroupId
-> MToken' '["auth-delete"]
-> m Unit
authGroupDelete i token = runAuth $ do
guardAuthToken token
runDB $ deleteUserGroup i
return Unit
authGroupList :: AuthMonad m
=> Maybe Page
-> Maybe PageSize
-> MToken' '["auth-info"]
-> m (PagedList UserGroupId UserGroup)
authGroupList mp msize token = runAuth $ do
guardAuthToken token
pagination mp msize $ \page size -> do
(groups, total) <- runDB $ (,)
<$> (do
is <- selectKeysList [] [Asc AuthUserGroupId, OffsetBy (fromIntegral $ page * size), LimitTo (fromIntegral size)]
forM is $ (\i -> fmap (WithField i) <$> readUserGroup i) . fromKey)
<*> count ([] :: [Filter AuthUserGroup])
return PagedList {
pagedListItems = catMaybes groups
, pagedListPages = ceiling $ (fromIntegral total :: Double) / fromIntegral size
}