From 97e6e7a9c77d47fc59ab310318fb7ca22363785a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 31 Jul 2022 01:43:46 +0200 Subject: [PATCH] clean up http error throwing --- src/Control/Auth.hs | 29 ++++++--------------- src/Control/Avatar.hs | 9 +++---- src/Control/Journal.hs | 24 +++++++---------- src/Control/Product.hs | 35 ++++++++++--------------- src/Control/Role.hs | 57 +++++++++++++++-------------------------- src/Control/Settings.hs | 24 +++++++---------- src/Control/User.hs | 37 +++++++------------------- src/Util.hs | 23 ++++++++++++----- 8 files changed, 89 insertions(+), 149 deletions(-) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index fda0f45..e35cf64 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -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 diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs index 4cdc949..45750f4 100644 --- a/src/Control/Avatar.hs +++ b/src/Control/Avatar.hs @@ -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] diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index c958f4f..1fc20e5 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -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 diff --git a/src/Control/Product.hs b/src/Control/Product.hs index a1f4078..68d746b 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -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 diff --git a/src/Control/Role.hs b/src/Control/Role.hs index 2f047e7..7e950d1 100644 --- a/src/Control/Role.hs +++ b/src/Control/Role.hs @@ -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 diff --git a/src/Control/Settings.hs b/src/Control/Settings.hs index ecf5fbd..a767c19 100644 --- a/src/Control/Settings.hs +++ b/src/Control/Settings.hs @@ -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 diff --git a/src/Control/User.hs b/src/Control/User.hs index ea0495f..e490988 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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 diff --git a/src/Util.hs b/src/Util.hs index 7970543..f8210b8 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -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" }