nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

make capability quersies throughout whoel project

Browse source
This commit is contained in:
nek0 2020-07-31 23:01:57 +02:00
parent b3cb5114ae
commit e599e02b13
8 changed files with 110 additions and 91 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
mateamt.cabal
View file

@ -110,6 +110,7 @@ library
, stm
, mtl
, pureMD5
, extra
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

6
shell.nix
View file

@ -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

14
src/Control/Journal.hs
View file

@ -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

32
src/Control/Product.hs
View file

@ -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
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,7 +49,12 @@ productStockRefill
:: Maybe (Int, AuthMethod)
-> [AmountRefill]
-> MateHandler ()
productStockRefill (Just _) amorefs = do
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)
@ -61,6 +78,10 @@ productStockRefill (Just _) amorefs = do
throwError $ err400
{ errBody = "Non-existent Products are non-refillable."
}
else
throwError $ err401
{ errBody = "You are not authorized for this action."
}
productStockRefill Nothing _ =
throwError $ err401
{ errBody = "No Authentication present."
@ -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

4
src/Control/Role.hs
View file

@ -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."

2
src/Control/User.hs
View file

@ -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

90
src/Model/Role.hs
View file

@ -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
}

8
src/Types/Role.hs
View file

@ -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