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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -156,10 +156,21 @@ sendNotification mail = do
print ("Warning: sending notification failed: Sendmail not present!" print ("Warning: sending notification failed: Sendmail not present!"
:: String) :: String)
err200 :: ServerError -- | throws a HTTP 401 error in case no auth token was provided when needed
err200 = ServerError throwMissingAuth :: MateHandler a
{ errHTTPCode = 200 throwMissingAuth = throwError $ err401
, errBody = "OK" { errBody = "No authentication present"
, errReasonPhrase = "RequestScceeded" }
, errHeaders = []
-- | 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"
} }