2019-08-14 16:04:16 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Control.Auth where
|
|
|
|
|
|
|
|
import Servant
|
|
|
|
|
2019-09-16 06:59:57 +00:00
|
|
|
import Control.Monad (void)
|
|
|
|
|
2019-10-14 20:50:42 +00:00
|
|
|
import Control.Monad.Reader (asks, ask)
|
2019-09-15 12:59:22 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
|
|
|
import Control.Concurrent.STM (readTVarIO)
|
|
|
|
|
2019-08-14 16:04:16 +00:00
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
import Model
|
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
authGet
|
|
|
|
:: TicketRequest
|
|
|
|
-> MateHandler AuthInfo
|
2019-10-14 20:50:42 +00:00
|
|
|
authGet (TicketRequest uid method) =
|
|
|
|
getUserAuthInfo uid method =<< (asks rsConnection)
|
2019-09-15 12:59:22 +00:00
|
|
|
|
|
|
|
authSend
|
|
|
|
:: AuthRequest
|
|
|
|
-> MateHandler AuthResult
|
|
|
|
authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
|
|
|
|
(liftIO . readTVarIO =<< rsTicketStore <$> ask) <*>
|
2019-10-14 20:50:42 +00:00
|
|
|
(asks rsConnection)
|
2019-09-15 12:59:22 +00:00
|
|
|
)
|
|
|
|
|
|
|
|
authLogout
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler ()
|
2019-10-14 20:50:42 +00:00
|
|
|
authLogout (Just (muid, _)) =
|
|
|
|
processLogout muid =<< (asks rsConnection)
|
|
|
|
authLogout Nothing =
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
2019-09-16 06:59:57 +00:00
|
|
|
|
|
|
|
authManageList
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler [AuthOverview]
|
|
|
|
authManageList (Just (uid, method)) =
|
2019-10-14 20:50:42 +00:00
|
|
|
if elem method [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
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|
|
|
|
authManageList Nothing =
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|
|
|
|
|
|
|
|
authManageNewAuth
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> AuthSubmit
|
|
|
|
-> MateHandler Int
|
2019-10-14 20:50:42 +00:00
|
|
|
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
|
|
|
|
if elem method [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
|
|
|
putUserAuthInfo uid asmethod ascomment aspayload conn
|
|
|
|
else
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|
|
|
|
authManageNewAuth Nothing _ =
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|
|
|
|
|
|
|
|
authManageDeleteAuth
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> Int
|
|
|
|
-> MateHandler ()
|
2019-10-14 20:50:42 +00:00
|
|
|
authManageDeleteAuth (Just (uid, method)) adid =
|
|
|
|
if elem method [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
|
|
|
|
then void (deleteAuthDataById adid conn)
|
2019-10-14 15:39:38 +00:00
|
|
|
else throwUnacceptableDeletionError
|
2019-09-16 06:59:57 +00:00
|
|
|
ChallengeResponse -> if validateDeletion ads
|
|
|
|
then void (deleteAuthDataById adid conn)
|
2019-10-14 15:39:38 +00:00
|
|
|
else throwUnacceptableDeletionError
|
2019-09-16 06:59:57 +00:00
|
|
|
_ -> void $ deleteAuthDataById adid conn
|
|
|
|
else
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|
|
|
|
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 _ =
|
2019-09-16 06:59:57 +00:00
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "Unauthorized access"
|
|
|
|
}
|