diff --git a/mateamt.cabal b/mateamt.cabal index 47b1df6..855071e 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -110,6 +110,7 @@ library , stm , mtl , pureMD5 + , extra hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/shell.nix b/shell.nix index 24e7378..76eb327 100644 --- a/shell.nix +++ b/shell.nix @@ -6,8 +6,8 @@ let f = { mkDerivation, aeson, base, base16-bytestring , base64-bytestring, bytestring, case-insensitive, clock - , containers, HsYAML, http-api-data, http-types, iproute, mtl - , network, opaleye, optparse-applicative, postgresql-simple + , containers, extra, HsYAML, http-api-data, http-types, iproute + , mtl, network, opaleye, optparse-applicative, postgresql-simple , postgresql-simple-migration, product-profunctors, profunctors , pureMD5, random-bytestring, servant, servant-rawm, servant-server , stdenv, stm, text, time, wai, wai-logger, wai-middleware-throttle @@ -27,7 +27,7 @@ let ]; executableHaskellDepends = [ base base16-bytestring bytestring case-insensitive clock containers - HsYAML iproute mtl network opaleye optparse-applicative + extra HsYAML iproute mtl network opaleye optparse-applicative postgresql-simple postgresql-simple-migration servant servant-server stm text time wai wai-logger wai-middleware-throttle warp diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 23ea94e..f21a8f4 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -5,19 +5,24 @@ import Servant import Control.Monad (void) import Control.Monad.Reader (asks) +import Control.Monad.Extra (anyM) -- internal imports import Types import Model.Journal +import Control.Role (checkCapability) journalShow :: Maybe (Int, AuthMethod) -> Maybe Int -> Maybe Int -> MateHandler [JournalEntry] -journalShow (Just (_, method)) mlimit moffset = - if method `elem` [PrimaryPass, ChallengeResponse] +journalShow (Just (uid, method)) mlimit moffset = do + maySeeJournal <- anyM + (checkCapability uid) + [roleCanViewJournal, roleCanManageJournal] + if (method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal) then do conn <- asks rsConnection selectJournalEntries mlimit moffset conn @@ -34,8 +39,9 @@ journalCheck :: Maybe (Int, AuthMethod) -> JournalCashCheck -> MateHandler () -journalCheck (Just (_, method)) check = - if method `elem` [PrimaryPass, ChallengeResponse] +journalCheck (Just (uid, method)) check = do + mayCheckJournal <- checkCapability uid roleCanManageJournal + if (method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal) then do conn <- asks rsConnection void $ insertNewCashCheck check conn diff --git a/src/Control/Product.hs b/src/Control/Product.hs index 084b1f2..fd0682d 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -7,24 +7,36 @@ import Control.Monad (void) import Control.Monad.Reader (asks) +import Control.Monad.Extra (anyM) + import Data.Maybe (fromMaybe) -- internal imports import Types import Model +import Control.Role (checkCapability) productNew :: Maybe (Int, AuthMethod) -> ProductSubmit -> MateHandler Int -productNew (Just _) bevsub = do - conn <- asks rsConnection - bevid <- insertProduct bevsub conn - void $ insertNewEmptyAmount bevid bevsub conn - return bevid +productNew (Just (uid, auth)) bevsub = do + mayAddProduct <- checkCapability uid roleCanManageProducts + if (auth `elem` [PrimaryPass, ChallengeResponse] && mayAddProduct) + 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." + } productNew Nothing _ = - throwError err401 + throwError $ err401 + { errBody = "No Authentication present." + } productOverview :: Int @@ -37,29 +49,38 @@ productStockRefill :: Maybe (Int, AuthMethod) -> [AmountRefill] -> MateHandler () -productStockRefill (Just _) amorefs = do - conn <- asks rsConnection - prods <- mapM - (\refill -> productSelectSingle (amountRefillProductId refill) conn) - amorefs - if all (not . null) prods - then - if - all - (\refill -> - (>= 0) (amountRefillAmountSingles refill) && - (>= 0) (amountRefillAmountCrates refill) - ) - amorefs - then do - void $ manualProductAmountRefill amorefs conn +productStockRefill (Just (uid, auth)) amorefs = do + mayRefill <- anyM + (checkCapability uid) + [ roleCanRefillStock, roleCanManageProducts ] + if (auth `elem` [PrimaryPass, ChallengeResponse] && mayRefill) + then do + conn <- asks rsConnection + prods <- mapM + (\refill -> productSelectSingle (amountRefillProductId refill) conn) + amorefs + if all (not . null) prods + then + if + all + (\refill -> + (>= 0) (amountRefillAmountSingles refill) && + (>= 0) (amountRefillAmountCrates refill) + ) + amorefs + then do + void $ manualProductAmountRefill amorefs conn + else + throwError $ err400 + { errBody = "Amounts less than 0 are not acceptable." + } else throwError $ err400 - { errBody = "Amounts less than 0 are not acceptable." + { errBody = "Non-existent Products are non-refillable." } else - throwError $ err400 - { errBody = "Non-existent Products are non-refillable." + throwError $ err401 + { errBody = "You are not authorized for this action." } productStockRefill Nothing _ = throwError $ err401 @@ -70,8 +91,9 @@ productStockUpdate :: Maybe (Int, AuthMethod) -> [AmountUpdate] -> MateHandler () -productStockUpdate (Just (_, method)) amoups = - if method `elem` [PrimaryPass, ChallengeResponse] +productStockUpdate (Just (uid, method)) amoups = do + mayUpdateStock <- checkCapability uid roleCanManageProducts + if (method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock) then if all ((>= 0) . amountUpdateRealAmount) amoups then do diff --git a/src/Control/Role.hs b/src/Control/Role.hs index 275dfa2..d8be9b9 100644 --- a/src/Control/Role.hs +++ b/src/Control/Role.hs @@ -25,12 +25,12 @@ roleNew :: Maybe (Int, AuthMethod) -> RoleSubmit -> MateHandler Int -roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) = +roleNew (Just (uid, auth)) (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9) = do isRoleManager <- checkCapability uid roleCanManageRoles if (auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager) then - insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 =<< asks rsConnection + insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 =<< asks rsConnection else throwError $ err401 { errBody = "You are not authorized for this action." diff --git a/src/Control/User.hs b/src/Control/User.hs index fae1bba..c640daf 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -30,7 +30,7 @@ userNew (UserSubmit ident email passhash) = do uid <- insertUser ident email (utctDay now) conn void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn baseRoleId <- queryRoleIdByCapabilities - (False, False, False, False, False, False, False, False, False, False, False) + (False, False, False, False, False, False, False, False, False) conn void $ associateUserToRole uid baseRoleId conn return uid diff --git a/src/Model/Role.hs b/src/Model/Role.hs index c753c07..db979e3 100644 --- a/src/Model/Role.hs +++ b/src/Model/Role.hs @@ -6,7 +6,7 @@ module Model.Role where import qualified Database.PostgreSQL.Simple as PGS -import Data.Profunctor.Product (p2, p13) +import Data.Profunctor.Product (p2, p11) import qualified Data.Text as T @@ -30,13 +30,13 @@ initRole = mconcat , "role_id SERIAL NOT NULL," , "role_name TEXT NOT NULL," , "role_can_refill_stock BOOLEAN NOT NULL," - , "role_can_add_product BOOLEAN NOT NULL," + -- , "role_can_add_product BOOLEAN NOT NULL," , "role_can_view_journal BOOLEAN NOT NULL," , "role_can_pay_invoice BOOLEAN NOT NULL," , "role_can_pay_out BOOLEAN NOT NULL," , "role_can_manage_products BOOLEAN NOT NULL," , "role_can_manage_journal BOOLEAN NOT NULL," - , "role_can_manage_users BOOLEAN NOT NULL," + -- , "role_can_manage_users BOOLEAN NOT NULL," , "role_can_manage_roles BOOLEAN NOT NULL," , "role_can_manage_suppliers BOOLEAN NOT NULL," , "role_can_manage_settings BOOLEAN NOT NULL," @@ -58,13 +58,13 @@ roleTable :: Table ( Maybe (Field SqlInt4) , Field SqlText , Field SqlBool + -- , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool - , Field SqlBool - , Field SqlBool + -- , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool @@ -72,29 +72,29 @@ roleTable :: Table ( Field SqlInt4 , Field SqlText , Field SqlBool + -- , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool - , Field SqlBool - , Field SqlBool + -- , Field SqlBool , Field SqlBool , Field SqlBool , Field SqlBool ) roleTable = table "role" ( - p13 + p11 ( tableField "role_id" , tableField "role_name" , tableField "role_can_refill_stock" - , tableField "role_can_add_product" + -- , tableField "role_can_add_product" , tableField "role_can_view_journal" , tableField "role_can_pay_invoice" , tableField "role_can_pay_out" , tableField "role_can_manage_products" , tableField "role_can_manage_journal" - , tableField "role_can_manage_users" + -- , tableField "role_can_manage_users" , tableField "role_can_manage_roles" , tableField "role_can_manage_suppliers" , tableField "role_can_manage_settings" @@ -128,19 +128,19 @@ runInsertInitialRoles conn = do ( C.constant (Nothing :: Maybe Int) , C.constant ("Administrator" :: String) , C.constant True + -- , C.constant True , C.constant True , C.constant True , C.constant True , C.constant True , C.constant True - , C.constant True - , C.constant True + -- , C.constant True , C.constant True , C.constant True , C.constant True ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } b <- runInsert_ conn $ Insert @@ -150,19 +150,19 @@ runInsertInitialRoles conn = do ( C.constant (Nothing :: Maybe Int) , C.constant ("User" :: String) , C.constant False + -- , C.constant False , C.constant False , C.constant False , C.constant False , C.constant False , C.constant False - , C.constant False - , C.constant False + -- , C.constant False , C.constant False , C.constant False , C.constant False ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } return $ a ++ b @@ -178,21 +178,21 @@ selectAllRoles conn = do ( Int , T.Text , Bool + -- , Bool , Bool , Bool , Bool , Bool , Bool - , Bool - , Bool + -- , Bool , Bool , Bool , Bool ) ] return $ map - (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9 ,c10, c11) -> - Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) + (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> + Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9) rawRoles @@ -202,7 +202,7 @@ selectRoleList -> MateHandler [Role] selectRoleList ids conn = do rawRoles <- liftIO $ runSelect conn ( - (keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> + (keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _) -> in_ (map C.constant ids) id_)) <<< queryTable roleTable ) :: MateHandler @@ -210,40 +210,40 @@ selectRoleList ids conn = do ( Int , T.Text , Bool + -- , Bool , Bool , Bool , Bool , Bool , Bool - , Bool - , Bool + -- , Bool , Bool , Bool , Bool ) ] return $ map - (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9 ,c10, c11) -> - Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) + (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> + Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9) rawRoles insertRole :: T.Text -> Bool + -- -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool - -> Bool - -> Bool + -- -> Bool -> Bool -> Bool -> Bool -> PGS.Connection -> MateHandler Int -insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 conn = do +insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 conn = do head <$> liftIO (runInsert_ conn $ Insert { iTable = roleTable , iRows = @@ -259,11 +259,9 @@ insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11 conn = do , C.constant c7 , C.constant c8 , C.constant c9 - , C.constant c10 - , C.constant c11 ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing }) @@ -274,7 +272,7 @@ queryRoleIdByName -> MateHandler Int queryRoleIdByName name conn = do roles <- liftIO $ runSelect conn ( - keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) -> + keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _) -> C.constant name .== rname) <<< queryTable roleTable ) :: MateHandler [ @@ -289,20 +287,18 @@ queryRoleIdByName name conn = do , Bool , Bool , Bool - , Bool - , Bool ) ] - return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) + return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) queryRoleIdByCapabilities - :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) + :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) -> PGS.Connection -> MateHandler Int -queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn = +queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9) conn = do roles <- liftIO $ runSelect conn ( - keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) -> + keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> C.constant p1 .== c1 .&& C.constant p2 .== c2 .&& C.constant p3 .== c3 .&& @@ -311,9 +307,7 @@ queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn = C.constant p6 .== c6 .&& C.constant p7 .== c7 .&& C.constant p8 .== c8 .&& - C.constant p9 .== c9 .&& - C.constant p10 .== c10 .&& - C.constant p11 .== c11 + C.constant p9 .== c9 ) <<< queryTable roleTable ) :: MateHandler @@ -329,11 +323,9 @@ queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn = , Bool , Bool , Bool - , Bool - , Bool ) ] - return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) + return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) selectAllRoleAssociations @@ -408,10 +400,10 @@ updateRole -> RoleSubmit -- The role with already updated info -> PGS.Connection -> MateHandler Int64 -updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) conn = +updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9) conn = liftIO $ runUpdate_ conn $ Update { uTable = roleTable - , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> + , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _) -> ( id_ , C.constant name , C.constant c1 @@ -423,11 +415,9 @@ updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) conn = , C.constant c7 , C.constant c8 , C.constant c9 - , C.constant c10 - , C.constant c11 ) ) - , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> + , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid , uReturning = rCount } @@ -440,6 +430,6 @@ deleteRole rid conn = liftIO $ runDelete_ conn $ Delete { dTable = roleTable , dWhere = - (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid) + (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid) , dReturning = rCount } diff --git a/src/Types/Role.hs b/src/Types/Role.hs index b0e339b..30d61f1 100644 --- a/src/Types/Role.hs +++ b/src/Types/Role.hs @@ -10,13 +10,13 @@ data Role = Role { roleID :: Int , roleName :: T.Text , roleCanRefillStock :: Bool - , roleCanAddProduct :: Bool + -- , roleCanAddProduct :: Bool , roleCanViewJournal :: Bool , roleCanPayInvoice :: Bool , roleCanPayOut :: Bool , roleCanManageProducts :: Bool , roleCanManageJournal :: Bool - , roleCanManageUsers :: Bool + -- , roleCanManageUsers :: Bool , roleCanManageRoles :: Bool , roleCanManageSuppliers :: Bool , roleCanManageSettings :: Bool @@ -31,13 +31,13 @@ instance FromJSON Role data RoleSubmit = RoleSubmit { roleSubmitName :: T.Text , roleSubmitCanRefillStock :: Bool - , roleSubmitCanAddProduct :: Bool + -- , roleSubmitCanAddProduct :: Bool , roleSubmitCanViewJournal :: Bool , roleSubmitCanPayInvoice :: Bool , roleSubmitCanPayOut :: Bool , roleSubmitCanManageProducts :: Bool , roleSubmitCanManageJournal :: Bool - , roleSubmitCanManageUsers :: Bool + -- , roleSubmitCanManageUsers :: Bool , roleSubmitCanManageRoles :: Bool , roleSubmitCanManageSuppliers :: Bool , roleSubmitCanManageSettings :: Bool