{-# 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 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 () authLogout (Just (muid, _)) = processLogout muid =<< asks rsConnection authLogout Nothing = throwError $ err401 { errBody = "Unauthorized access" } authManageList :: Maybe (Int, AuthMethod) -> MateHandler [AuthOverview] authManageList (Just (uid, method)) = if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection selectAuthOverviews uid conn else throwError $ err401 { errBody = "Unauthorized access" } authManageList Nothing = throwError $ err401 { errBody = "Unauthorized access" } 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 = decodeUtf8 <$> hash defaultOptions (encodeUtf8 aspayload) salt 64 case mhashstring of CryptoPassed hashstring -> do conn <- asks rsConnection putUserAuthInfo uid asmethod ascomment hashstring conn CryptoFailed err -> do throwError $ err500 { errBody = "Crypto Error: " <> fromString (show err) } else throwError $ err401 { errBody = "Unauthorized access" } authManageNewAuth Nothing _ = throwError $ err401 { errBody = "Unauthorized access" } authManageDeleteAuth :: Maybe (Int, AuthMethod) -> Int -> MateHandler () 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 void (deleteAuthDataById adid conn) else throwUnacceptableDeletionError ChallengeResponse -> if validateDeletion ads then void (deleteAuthDataById adid conn) else throwUnacceptableDeletionError _ -> void $ deleteAuthDataById adid conn else throwError $ err401 { errBody = "Unauthorized access" } 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 _ = throwError $ err401 { errBody = "Unauthorized access" }