mateamt/src/Control/Auth.hs
2023-07-08 00:16:05 +02:00

129 lines
3.3 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Control.Auth where
import Servant
import Control.Lens (re, view, review)
import Control.Monad (void)
import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO)
import Crypto.Error
import Crypto.JWT (SignedJWT, encodeCompact, base64url)
import Crypto.KDF.Argon2
import Data.Aeson (encode)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
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 String
authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< 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