mateamt/src/Control/Auth.hs

124 lines
3.2 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Control.Auth where
import Servant
import Control.Monad (void)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO)
import Crypto.KDF.Argon2
import Crypto.Error
import Data.String (fromString)
import Data.Text.Encoding
-- internal imports
import Types
import Model
import Util.Crypto
import Util (throwUnauthAccess)
authGet
:: TicketRequest
-> MateHandler AuthInfo
authGet (TicketRequest uid method) =
getUserAuthInfo uid method =<< asks rsConnection
authSend
:: AuthRequest
-> MateHandler AuthResult
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
(liftIO . readTVarIO =<< asks rsTicketStore) <*>
asks rsConnection
)
authLogout
:: Maybe (Int, AuthMethod)
-> MateHandler NoContent
authLogout (Just (muid, _)) = do
processLogout muid =<< asks rsConnection
return NoContent
authLogout Nothing =
throwUnauthAccess
authManageList
:: Maybe (Int, AuthMethod)
-> MateHandler [AuthOverview]
authManageList (Just (uid, method)) =
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
selectAuthOverviews uid conn
else
throwUnauthAccess
authManageList Nothing =
throwUnauthAccess
authManageNewAuth
:: Maybe (Int, AuthMethod)
-> AuthSubmit
-> MateHandler Int
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
if method == PrimaryPass
then do
salt <- liftIO randomString
let mhashstring = hash defaultOptions (encodeUtf8 aspayload) salt 64
case mhashstring of
CryptoPassed hashstring -> do
conn <- asks rsConnection
putUserAuthInfo uid asmethod ascomment salt hashstring conn
CryptoFailed err -> do
throwError $ err500
{ errBody = "Crypto Error: " <> fromString (show err)
}
else
throwUnauthAccess
authManageNewAuth Nothing _ =
throwUnauthAccess
authManageDeleteAuth
:: Maybe (Int, AuthMethod)
-> Int
-> MateHandler NoContent
authManageDeleteAuth (Just (uid, method)) adid =
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
ads <- selectAuthOverviews uid conn
let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
case authOverviewMethod currentad of
PrimaryPass -> if validateDeletion ads
then do
void (deleteAuthDataById adid conn)
return NoContent
else throwUnacceptableDeletionError
ChallengeResponse -> if validateDeletion ads
then do
void (deleteAuthDataById adid conn)
return NoContent
else throwUnacceptableDeletionError
_ -> do
void $ deleteAuthDataById adid conn
return NoContent
else
throwUnauthAccess
where
validateDeletion ads =
2 <= length (filter
(\ad -> authOverviewMethod ad == PrimaryPass ||
authOverviewMethod ad == ChallengeResponse)
ads
)
throwUnacceptableDeletionError =
throwError $ err406
{ errBody = "You need at least one primary password or challenge response authentication"
}
authManageDeleteAuth Nothing _ =
throwUnauthAccess