clean up http error throwing

2022-07-31 01:43:46 +02:00 · 2022-07-31 01:43:46 +02:00 · 97e6e7a9c7
commit 97e6e7a9c7
parent aae87076b9
8 changed files with 89 additions and 149 deletions
--- 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
--- 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]
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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"
  }