{-# 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