clean up http error throwing

This commit is contained in:
nek0 2022-07-31 01:43:46 +02:00
parent aae87076b9
commit 97e6e7a9c7
8 changed files with 89 additions and 149 deletions

View file

@ -22,6 +22,7 @@ import Data.Text.Encoding
import Types
import Model
import Util.Crypto
import Util (throwUnauthAccess)
authGet
:: TicketRequest
@ -44,9 +45,7 @@ authLogout (Just (muid, _)) = do
processLogout muid =<< asks rsConnection
return NoContent
authLogout Nothing =
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
authManageList
:: Maybe (Int, AuthMethod)
@ -57,13 +56,9 @@ authManageList (Just (uid, method)) =
conn <- asks rsConnection
selectAuthOverviews uid conn
else
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
authManageList Nothing =
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
authManageNewAuth
:: Maybe (Int, AuthMethod)
@ -83,13 +78,9 @@ authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload)
{ errBody = "Crypto Error: " <> fromString (show err)
}
else
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
authManageNewAuth Nothing _ =
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
authManageDeleteAuth
:: Maybe (Int, AuthMethod)
@ -116,9 +107,7 @@ authManageDeleteAuth (Just (uid, method)) adid =
void $ deleteAuthDataById adid conn
return NoContent
else
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess
where
validateDeletion ads =
2 <= length (filter
@ -131,6 +120,4 @@ authManageDeleteAuth (Just (uid, method)) adid =
{ errBody = "You need at least one primary password or challenge response authentication"
}
authManageDeleteAuth Nothing _ =
throwError $ err401
{ errBody = "Unauthorized access"
}
throwUnauthAccess

View file

@ -27,6 +27,7 @@ import Network.HTTP.Types.Header (hETag)
import Types
import Model
import Util (throwMissingAuth)
avatarGet
:: Int
@ -56,9 +57,7 @@ avatarInsert (Just _) ad = do
conn <- asks rsConnection
insertAvatar ad (md5 $ BS.pack $ avatarDataData ad) conn
avatarInsert Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
avatarUpdate
:: Maybe (Int, AuthMethod)
@ -70,9 +69,7 @@ avatarUpdate (Just _) aid ad = do
void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn
return NoContent
avatarUpdate Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
avatarList
:: MateHandler [Avatar]

View file

@ -3,7 +3,7 @@ module Control.Journal where
import Servant
import Control.Monad (void)
import Control.Monad (void, unless)
import Control.Monad.Reader (asks)
-- internal imports
@ -19,18 +19,15 @@ journalShow
-> MateHandler [JournalEntry]
journalShow (Just (uid, method)) mlimit moffset = do
maySeeJournal <- checkCapability uid roleCanManageJournal
if method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal
unless maySeeJournal throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
selectJournalEntries mlimit moffset conn
else
throwError $ err401
{ errBody = "Wrong Authentication present"
}
throwWrongAuth
journalShow Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present"
}
throwMissingAuth
journalCheck
:: Maybe (Int, AuthMethod)
@ -38,16 +35,13 @@ journalCheck
-> MateHandler NoContent
journalCheck (Just (uid, method)) check = do
mayCheckJournal <- checkCapability uid roleCanManageJournal
if method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal
unless mayCheckJournal throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
void $ insertNewCashCheck check conn
return NoContent
else
throwError $ err401
{ errBody = "Wrong Authentication present"
}
throwWrongAuth
journalCheck Nothing _ =
throwError $ err401
{ errBody = "No Authentication present"
}
throwMissingAuth

View file

@ -3,7 +3,7 @@ module Control.Product where
import Servant
import Control.Monad (void)
import Control.Monad
import Control.Monad.Reader (asks)
@ -23,20 +23,17 @@ productNew
-> MateHandler Int
productNew (Just (uid, auth)) bevsub = do
mayAddProduct <- checkCapability uid roleCanManageProducts
if auth `elem` [PrimaryPass, ChallengeResponse] && mayAddProduct
unless mayAddProduct throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid bevsub conn
return bevid
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwWrongAuth
productNew Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
productOverview
:: Int
@ -53,7 +50,8 @@ productStockRefill (Just (uid, auth)) amorefs = do
mayRefill <- anyM
(checkCapability uid)
[ roleCanRefillStock, roleCanManageProducts ]
if auth `elem` [PrimaryPass, ChallengeResponse] && mayRefill
unless mayRefill throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
let prods = map
@ -81,13 +79,9 @@ productStockRefill (Just (uid, auth)) amorefs = do
{ errBody = "Non-existent Products are non-refillable."
}
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
productStockRefill Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
productStockUpdate
:: Maybe (Int, AuthMethod)
@ -95,7 +89,8 @@ productStockUpdate
-> MateHandler NoContent
productStockUpdate (Just (uid, method)) amoups = do
mayUpdateStock <- checkCapability uid roleCanManageProducts
if method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock
unless mayUpdateStock throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
then
if all ((>= 0) . amountUpdateRealAmount) amoups
then do
@ -107,13 +102,9 @@ productStockUpdate (Just (uid, method)) amoups = do
{ errBody = "Amounts less than 0 are not acceptable."
}
else
throwError $ err401
{ errBody = "Wrong Authentication present."
}
throwWrongAuth
productStockUpdate Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
productList
:: Maybe ProductRefine

View file

@ -3,7 +3,7 @@ module Control.Role where
import Servant
import Control.Monad (void)
import Control.Monad
import Control.Monad.Reader (asks)
@ -25,17 +25,14 @@ roleNew
roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) =
do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
unless isRoleManager throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then
insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 =<< asks rsConnection
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
roleNew Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
roleUpdate
:: Maybe (Int, AuthMethod)
@ -44,18 +41,15 @@ roleUpdate
-> MateHandler NoContent
roleUpdate (Just (uid, auth)) id_ roleSubmit = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
unless isRoleManager throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
void $ updateRole id_ roleSubmit =<< asks rsConnection
return NoContent
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
roleUpdate Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
roleDelete
:: Maybe (Int, AuthMethod)
@ -63,18 +57,15 @@ roleDelete
-> MateHandler NoContent
roleDelete (Just (uid, auth)) id_ = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
unless isRoleManager throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
void $ deleteRole id_ =<< asks rsConnection
return NoContent
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
roleDelete Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
roleAssociationList
:: MateHandler [RoleAssociation]
@ -87,18 +78,15 @@ roleAssociationSubmit
-> MateHandler NoContent
roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
unless isRoleManager throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
associateUserToRole auid arid =<< asks rsConnection
return NoContent
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
roleAssociationSubmit Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
roleAssociationDelete
:: Maybe (Int, AuthMethod)
@ -106,15 +94,12 @@ roleAssociationDelete
-> MateHandler NoContent
roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
unless isRoleManager throwUnauthAccess
if auth `elem` [PrimaryPass, ChallengeResponse]
then do
void $ deleteAssociation auid arid =<< asks rsConnection
return NoContent
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
throwUnauthAccess
roleAssociationDelete Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth

View file

@ -9,42 +9,36 @@ import Servant
import Types
import Model.Settings as Model
import Util (checkCapability)
import Util (checkCapability, throwMissingAuth, throwWrongAuth, throwUnauthAccess)
getSettings
:: Maybe (Int, AuthMethod)
-> MateHandler Settings
getSettings Nothing = do
throwError $ err401
{ errBody = "No authentication present"
}
throwMissingAuth
getSettings (Just (uid, method)) = do
isManager <- checkCapability uid roleCanManageSettings
if method `elem` [PrimaryPass, ChallengeResponse] && isManager
unless isManager throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
selectSettings conn
else
throwError $ err401
{ errBody = "Wrong Authentication present"
}
throwWrongAuth
updateSettings
:: Maybe (Int, AuthMethod)
-> Settings
-> MateHandler NoContent
updateSettings Nothing _ =
throwError $ err401
{ errBody = "No authentication present"
}
throwMissingAuth
updateSettings (Just (uid, method)) newSettings = do
isManager <- checkCapability uid roleCanManageSettings
if method `elem` [PrimaryPass, ChallengeResponse] && isManager
unless isManager throwUnauthAccess
if method `elem` [PrimaryPass, ChallengeResponse]
then do
conn <- asks rsConnection
void $ Model.updateSettings newSettings conn
return NoContent
else
throwError $ err401
{ errBody = "Wrong Authentication present"
}
throwWrongAuth

View file

@ -64,9 +64,7 @@ userGet
:: Maybe (Int, AuthMethod)
-> MateHandler UserDetails
userGet Nothing =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userGet (Just (uid, _)) = do
conn <- asks rsConnection
userDetailsSelect uid conn
@ -75,9 +73,7 @@ userGetAll
:: Maybe (Int, AuthMethod)
-> MateHandler [UserDetails]
userGetAll Nothing =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userGetAll (Just (_, _)) = do
conn <- asks rsConnection
userDetailsSelectAll conn
@ -87,9 +83,7 @@ userUpdate
-> UserDetailsSubmit
-> MateHandler NoContent
userUpdate Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userUpdate (Just (aid, method)) uds =
if method `elem` [PrimaryPass, ChallengeResponse]
then do
@ -98,9 +92,7 @@ userUpdate (Just (aid, method)) uds =
void $ updateUserDetails aid uds (utctDay now) conn
return NoContent
else
throwError $ err401
{ errBody = "Wrong Authentication present."
}
throwWrongAuth
userUpdateTimestamp
:: Maybe (Int, AuthMethod)
@ -111,9 +103,7 @@ userUpdateTimestamp (Just (aid, _)) = do
void $ updateUserTimestamp aid (utctDay now) conn
return NoContent
userUpdateTimestamp Nothing =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userList
:: Maybe UserRefine
@ -144,9 +134,7 @@ userRecharge (Just (auid, _)) (UserRecharge amount) = do
void $ addToUserBalance auid amount conn
return NoContent
userRecharge Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userTransfer
:: Maybe (Int, AuthMethod)
@ -161,10 +149,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do
throwError $ err400
{ errBody = "You can not transfer yourself money."
}
when (method `notElem` [PrimaryPass, ChallengeResponse]) $
throwError $ err401
{ errBody = "No Authentication present."
}
when (method `notElem` [PrimaryPass, ChallengeResponse]) throwWrongAuth
conn <- asks rsConnection
user <- userDetailsSelect auid conn
when (amount > userDetailsBalance user) $
@ -181,9 +166,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do
void $ addToUserBalance target amount conn
return NoContent
userTransfer Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth
userNotify
:: Maybe (Int, AuthMethod)
@ -257,6 +240,4 @@ userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
Nothing ->
return NoContent
userNotify Nothing _ _ =
throwError $ err401
{ errBody = "No Authentication present."
}
throwMissingAuth

View file

@ -156,10 +156,21 @@ sendNotification mail = do
print ("Warning: sending notification failed: Sendmail not present!"
:: String)
err200 :: ServerError
err200 = ServerError
{ errHTTPCode = 200
, errBody = "OK"
, errReasonPhrase = "RequestScceeded"
, errHeaders = []
-- | throws a HTTP 401 error in case no auth token was provided when needed
throwMissingAuth :: MateHandler a
throwMissingAuth = throwError $ err401
{ errBody = "No authentication present"
}
-- | throws a HHTP 401 error in case the provided token does not match the required authentication
-- Method (e.g.: 'PrimaryPass')
throwWrongAuth :: MateHandler a
throwWrongAuth = throwError $ err401
{ errBody = "Wrong authentication present"
}
-- | throws a HTTP 401 error in case the user Role does not have the required capabilities.
throwUnauthAccess :: MateHandler a
throwUnauthAccess = throwError $ err401
{ errBody = "Unauthorized Access"
}