129 lines
3.3 KiB
Haskell
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
|