clean up http error throwing

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
+  throwUnauthAccess
-    { errBody = "Unauthorized access"
-    }
 
 authManageList
   :: Maybe (Int, AuthMethod)
@@ -57,13 +56,9 @@ authManageList (Just (uid, method)) =
     conn <- asks rsConnection
     selectAuthOverviews uid conn
   else
-    throwError $ err401
+    throwUnauthAccess
-      { errBody = "Unauthorized access"
-      }
 authManageList Nothing =
-  throwError $ err401
+  throwUnauthAccess
-    { errBody = "Unauthorized access"
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "Unauthorized access"
-      }
 authManageNewAuth Nothing _ =
-  throwError $ err401
+  throwUnauthAccess
-    { errBody = "Unauthorized access"
-    }
 
 authManageDeleteAuth
   :: Maybe (Int, AuthMethod)
@@ -116,9 +107,7 @@ authManageDeleteAuth (Just (uid, method)) adid =
         void $ deleteAuthDataById adid conn
         return NoContent
   else
-    throwError $ err401
+    throwUnauthAccess
-      { errBody = "Unauthorized access"
-      }
   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
+  throwUnauthAccess
-    { errBody = "Unauthorized access"
-    }

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
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 avatarList
   :: MateHandler [Avatar]

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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present"
-      }
 journalShow Nothing _ _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present"
-    }
 
 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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present"
-      }
 journalCheck Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present"
-    }

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
+    throwWrongAuth
-      { errBody = "You are not authorized for this action."
-      }
 productNew Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "You are not authorized for this action."
-      }
 productStockRefill Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present."
-      }
 productStockUpdate Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 productList
   :: Maybe ProductRefine

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
+      throwUnauthAccess
-        { errBody = "You are not authorized for this action."
-        }
 roleNew Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "You are not authorized for this action."
-      }
 roleUpdate Nothing _ _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "You are not authorized for this action."
-      }
 roleDelete Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "You are not authorized for this action."
-      }
 roleAssociationSubmit Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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
+    throwUnauthAccess
-      { errBody = "You are not authorized for this action."
-      }
 roleAssociationDelete Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }

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
+  throwMissingAuth
-    { errBody = "No authentication present"
-    }
 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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present"
-      }
 
 updateSettings
   :: Maybe (Int, AuthMethod)
   -> Settings
   -> MateHandler NoContent
 updateSettings Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No authentication present"
-    }
 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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present"
-      }

src/Control/User.hs

@@ -64,9 +64,7 @@ userGet
   :: Maybe (Int, AuthMethod)
   -> MateHandler UserDetails
 userGet Nothing =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 userGet (Just (uid, _)) = do
   conn <- asks rsConnection
   userDetailsSelect uid conn
@@ -75,9 +73,7 @@ userGetAll
   :: Maybe (Int, AuthMethod)
   -> MateHandler [UserDetails]
 userGetAll Nothing =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 userGetAll (Just (_, _)) = do
   conn <- asks rsConnection
   userDetailsSelectAll conn
@@ -87,9 +83,7 @@ userUpdate
   -> UserDetailsSubmit
   -> MateHandler NoContent
 userUpdate Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 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
+    throwWrongAuth
-      { errBody = "Wrong Authentication present."
-      }
 
 userUpdateTimestamp
   :: Maybe (Int, AuthMethod)
@@ -111,9 +103,7 @@ userUpdateTimestamp (Just (aid, _)) = do
   void $ updateUserTimestamp aid (utctDay now) conn
   return NoContent
 userUpdateTimestamp Nothing =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 userList
   :: Maybe UserRefine
@@ -144,9 +134,7 @@ userRecharge (Just (auid, _)) (UserRecharge amount) = do
   void $ addToUserBalance auid amount conn
   return NoContent
 userRecharge Nothing _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 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]) $
+  when (method `notElem` [PrimaryPass, ChallengeResponse]) throwWrongAuth
-    throwError $ err401
-      { errBody = "No Authentication present."
-      }
   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
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }
 
 userNotify
   :: Maybe (Int, AuthMethod)
@@ -257,6 +240,4 @@ userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
     Nothing ->
       return NoContent
 userNotify Nothing _ _ =
-  throwError $ err401
+  throwMissingAuth
-    { errBody = "No Authentication present."
-    }

src/Util.hs

@@ -156,10 +156,21 @@ sendNotification mail = do
       print ("Warning: sending notification failed: Sendmail not present!"
         :: 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"
   }