mateamt/src/Control/Auth.hs

129 lines
3.3 KiB
Haskell
Raw Normal View History

2019-08-14 16:04:16 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Control.Auth where
import Servant
2023-07-07 22:16:05 +00:00
import Control.Lens (re, view, review)
2019-09-16 06:59:57 +00:00
import Control.Monad (void)
2019-10-14 21:34:45 +00:00
import Control.Monad.Reader (asks)
2019-09-15 12:59:22 +00:00
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO)
import Crypto.Error
2023-07-07 22:16:05 +00:00
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
2019-08-14 16:04:16 +00:00
-- internal imports
import Types
import Model
2022-04-17 11:50:18 +00:00
import Util.Crypto
2022-07-30 23:43:46 +00:00
import Util (throwUnauthAccess)
2019-08-14 16:04:16 +00:00
2019-09-15 12:59:22 +00:00
authGet
:: TicketRequest
-> MateHandler AuthInfo
2019-10-14 20:50:42 +00:00
authGet (TicketRequest uid method) =
2019-10-14 21:34:45 +00:00
getUserAuthInfo uid method =<< asks rsConnection
2019-09-15 12:59:22 +00:00
authSend
:: AuthRequest
2023-07-07 22:16:05 +00:00
-> MateHandler String
authSend req = B8.unpack . BL.toStrict . encodeCompact <$> (processAuthRequest req =<< asks rsConnection)
2019-09-15 12:59:22 +00:00
authLogout
:: Maybe (Int, AuthMethod)
2022-07-17 19:28:22 +00:00
-> MateHandler NoContent
authLogout (Just (muid, _)) = do
2019-10-14 21:34:45 +00:00
processLogout muid =<< asks rsConnection
2022-07-17 19:28:22 +00:00
return NoContent
2019-10-14 20:50:42 +00:00
authLogout Nothing =
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
authManageList
:: Maybe (Int, AuthMethod)
-> MateHandler [AuthOverview]
authManageList (Just (uid, method)) =
2019-10-14 21:34:45 +00:00
if method `elem` [PrimaryPass, ChallengeResponse]
2019-09-16 06:59:57 +00:00
then do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-16 06:59:57 +00:00
selectAuthOverviews uid conn
else
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
authManageList Nothing =
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
authManageNewAuth
:: Maybe (Int, AuthMethod)
-> AuthSubmit
-> MateHandler Int
2019-10-14 20:50:42 +00:00
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
if method == PrimaryPass
2019-09-16 06:59:57 +00:00
then do
salt <- liftIO randomString
2022-04-17 14:38:48 +00:00
let mhashstring = hash defaultOptions (encodeUtf8 aspayload) salt 64
case mhashstring of
CryptoPassed hashstring -> do
conn <- asks rsConnection
2022-04-17 14:38:48 +00:00
putUserAuthInfo uid asmethod ascomment salt hashstring conn
CryptoFailed err -> do
throwError $ err500
{ errBody = "Crypto Error: " <> fromString (show err)
}
2019-09-16 06:59:57 +00:00
else
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
authManageNewAuth Nothing _ =
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
authManageDeleteAuth
:: Maybe (Int, AuthMethod)
-> Int
2022-07-17 19:28:22 +00:00
-> MateHandler NoContent
2019-10-14 20:50:42 +00:00
authManageDeleteAuth (Just (uid, method)) adid =
2019-10-14 21:34:45 +00:00
if method `elem` [PrimaryPass, ChallengeResponse]
2019-09-16 06:59:57 +00:00
then do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-16 06:59:57 +00:00
ads <- selectAuthOverviews uid conn
let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
case authOverviewMethod currentad of
PrimaryPass -> if validateDeletion ads
2022-07-17 19:28:22 +00:00
then do
void (deleteAuthDataById adid conn)
return NoContent
2019-10-14 15:39:38 +00:00
else throwUnacceptableDeletionError
2019-09-16 06:59:57 +00:00
ChallengeResponse -> if validateDeletion ads
2022-07-17 19:28:22 +00:00
then do
void (deleteAuthDataById adid conn)
return NoContent
2019-10-14 15:39:38 +00:00
else throwUnacceptableDeletionError
2022-07-17 19:28:22 +00:00
_ -> do
void $ deleteAuthDataById adid conn
return NoContent
2019-09-16 06:59:57 +00:00
else
2022-07-30 23:43:46 +00:00
throwUnauthAccess
2019-09-16 06:59:57 +00:00
where
validateDeletion ads =
2 <= length (filter
(\ad -> authOverviewMethod ad == PrimaryPass ||
authOverviewMethod ad == ChallengeResponse)
ads
)
2019-10-14 15:39:38 +00:00
throwUnacceptableDeletionError =
throwError $ err406
{ errBody = "You need at least one primary password or challenge response authentication"
}
2019-10-14 20:50:42 +00:00
authManageDeleteAuth Nothing _ =
2022-07-30 23:43:46 +00:00
throwUnauthAccess