diff --git a/mateamt.cabal b/mateamt.cabal index 855071e..fa565f6 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -84,6 +84,9 @@ library , Types.Avatar , Types.Meta , Types.Role + , Classes + , Classes.FromDatabase + , Classes.ToDatabase , Util -- other-extensions: build-depends: base >=4.12.0.0 && < 5 diff --git a/src/Classes.hs b/src/Classes.hs new file mode 100644 index 0000000..605762c --- /dev/null +++ b/src/Classes.hs @@ -0,0 +1,6 @@ +module Classes + ( module C + ) where + +import Classes.FromDatabase as C +import Classes.ToDatabase as C diff --git a/src/Classes/FromDatabase.hs b/src/Classes/FromDatabase.hs new file mode 100644 index 0000000..767095e --- /dev/null +++ b/src/Classes/FromDatabase.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +module Classes.FromDatabase where + +class FromDatabase a where + + type OutTuple a :: * + + fromDatabase :: OutTuple a -> a diff --git a/src/Classes/ToDatabase.hs b/src/Classes/ToDatabase.hs new file mode 100644 index 0000000..145f64c --- /dev/null +++ b/src/Classes/ToDatabase.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +module Classes.ToDatabase where + +class ToDatabase a where + + type InTuple a :: * + + toDatabase :: a -> InTuple a diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index b436d07..a234b70 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -19,10 +19,7 @@ journalShow -> Maybe Int -> MateHandler [JournalEntry] journalShow (Just (uid, method)) mlimit moffset = do - maySeeJournal <- anyM - (checkCapability uid) - [roleCanViewJournal, roleCanManageJournal] - if method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal + if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection selectJournalEntries mlimit moffset conn diff --git a/src/Control/Role.hs b/src/Control/Role.hs index 09f022f..bd9e3cd 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) = +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 then - insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 =<< asks rsConnection + 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." diff --git a/src/Control/User.hs b/src/Control/User.hs index c640daf..41f4d84 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) conn void $ associateUserToRole uid baseRoleId conn return uid diff --git a/src/Model/Role.hs b/src/Model/Role.hs index dcbc2ca..1f8dddd 100644 --- a/src/Model/Role.hs +++ b/src/Model/Role.hs @@ -5,7 +5,7 @@ module Model.Role where import qualified Database.PostgreSQL.Simple as PGS -import Data.Profunctor.Product (p2, p11) +import Data.Profunctor.Product (p2, p12) import qualified Data.Text as T @@ -22,6 +22,7 @@ import Control.Monad.IO.Class (liftIO) -- internal imports import Types +import Classes initRole :: PGS.Query initRole = mconcat @@ -29,15 +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_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_roles BOOLEAN NOT NULL," , "role_can_manage_suppliers BOOLEAN NOT NULL," + , "role_can_manage_avatars BOOLEAN NOT NULL," , "role_can_manage_settings BOOLEAN NOT NULL," , "PRIMARY KEY (role_id)," , "UNIQUE (role_name)" @@ -57,13 +56,12 @@ 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 @@ -71,31 +69,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 ) roleTable = table "role" ( - p11 + p12 ( tableField "role_id" , tableField "role_name" , tableField "role_can_refill_stock" - -- , 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_roles" , tableField "role_can_manage_suppliers" + , tableField "role_can_manage_avatars" , tableField "role_can_manage_settings" ) ) @@ -127,19 +123,18 @@ 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 ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } b <- runInsert_ conn $ Insert @@ -149,19 +144,18 @@ 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 ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } return $ a ++ b @@ -170,79 +164,36 @@ selectAllRoles :: PGS.Connection -> MateHandler [Role] selectAllRoles conn = do - rawRoles <- liftIO $ runSelect conn ( + liftIO $ map fromDatabase <$> runSelect conn ( queryTable roleTable - ) :: MateHandler - [ - ( Int - , T.Text - , Bool - -- , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - -- , Bool - , Bool - , Bool - , Bool - ) - ] - return $ map - (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> - Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9) - rawRoles - + ) :: MateHandler [Role] selectRoleList :: [Int] -> PGS.Connection -> MateHandler [Role] selectRoleList ids conn = do - rawRoles <- liftIO $ runSelect conn ( - keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _) -> + liftIO $ map fromDatabase <$> runSelect conn ( + keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> in_ (map C.constant ids) id_) <<< queryTable roleTable - ) :: MateHandler - [ - ( Int - , T.Text - , Bool - -- , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - -- , Bool - , Bool - , Bool - , Bool - ) - ] - return $ map - (\(id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> - Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9) - rawRoles - + ) :: MateHandler [Role] insertRole :: T.Text -> 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 conn = do +insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 conn = do head <$> liftIO (runInsert_ conn $ Insert { iTable = roleTable , iRows = @@ -258,9 +209,10 @@ insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 conn = do , C.constant c7 , C.constant c8 , C.constant c9 + , C.constant c10 ) ] - , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) + , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing }) @@ -270,34 +222,19 @@ queryRoleIdByName -> PGS.Connection -> MateHandler Int queryRoleIdByName name conn = do - roles <- liftIO $ runSelect conn ( - keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _) -> + liftIO $ roleID . fromDatabase . head <$> runSelect conn ( + keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) -> C.constant name .== rname) <<< queryTable roleTable - ) :: MateHandler - [ - ( Int - , T.Text - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - ) - ] - return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) + ) :: MateHandler Int queryRoleIdByCapabilities - :: (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) conn = +queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) conn = do - roles <- liftIO $ runSelect conn ( - keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> + liftIO $ roleID . fromDatabase . head <$> runSelect conn ( + keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) -> C.constant p1 .== c1 .&& C.constant p2 .== c2 .&& C.constant p3 .== c3 .&& @@ -306,25 +243,11 @@ queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9) conn = C.constant p6 .== c6 .&& C.constant p7 .== c7 .&& C.constant p8 .== c8 .&& - C.constant p9 .== c9 + C.constant p9 .== c9 .&& + C.constant p10 .== c10 ) <<< queryTable roleTable - ) :: MateHandler - [ - ( Int - , T.Text - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - , Bool - ) - ] - return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles) + ) :: MateHandler Int selectAllRoleAssociations @@ -399,10 +322,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) conn = +updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) conn = liftIO $ runUpdate_ conn $ Update { uTable = roleTable - , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _) -> + , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> ( id_ , C.constant name , C.constant c1 @@ -414,9 +337,10 @@ updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9) conn = , C.constant c7 , C.constant c8 , C.constant c9 + , C.constant c10 ) ) - , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _) -> + , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid , uReturning = rCount } @@ -429,6 +353,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/Meta.hs b/src/Types/Meta.hs index f6c2c5e..4b51c5f 100644 --- a/src/Types/Meta.hs +++ b/src/Types/Meta.hs @@ -10,6 +10,7 @@ import GHC.Generics data MetaInformation = MetaInformation { metaInfoVersion :: T.Text , metaInfoCurrency :: T.Text + , metaInfoDecimals :: Int } deriving (Show, Generic) diff --git a/src/Types/Role.hs b/src/Types/Role.hs index acef3d4..7dbe2e9 100644 --- a/src/Types/Role.hs +++ b/src/Types/Role.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module Types.Role where import qualified Data.Text as T @@ -6,12 +7,15 @@ import Data.Aeson import GHC.Generics +-- internal imports + +import Classes.ToDatabase +import Classes.FromDatabase + data Role = Role { roleID :: Int , roleName :: T.Text , roleCanRefillStock :: Bool - -- , roleCanAddProduct :: Bool - -- , roleCanViewJournal :: Bool -- | paying invoice only adds to user funds , roleCanPayInvoice :: Bool -- | paying out actually removes money from the cashier @@ -21,6 +25,7 @@ data Role = Role , roleCanManageUsers :: Bool , roleCanManageRoles :: Bool , roleCanManageSuppliers :: Bool + , roleCanManageAvatars :: Bool , roleCanManageSettings :: Bool } deriving (Generic, Show) @@ -30,11 +35,25 @@ instance ToJSON Role where instance FromJSON Role +instance ToDatabase Role where + + type InTuple Role = + (Int, T.Text, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) + + toDatabase (Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) = + (id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) + +instance FromDatabase Role where + + type OutTuple Role = + (Int, T.Text, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) + + fromDatabase (id_, name, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) = + Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + data RoleSubmit = RoleSubmit { roleSubmitName :: T.Text , roleSubmitCanRefillStock :: Bool - -- , roleSubmitCanAddProduct :: Bool - -- , roleSubmitCanViewJournal :: Bool , roleSubmitCanPayInvoice :: Bool , roleSubmitCanPayOut :: Bool , roleSubmitCanManageProducts :: Bool @@ -42,6 +61,7 @@ data RoleSubmit = RoleSubmit , roleSubmitCanManageUsers :: Bool , roleSubmitCanManageRoles :: Bool , roleSubmitCanManageSuppliers :: Bool + , roleSubmitCanManageAvatars :: Bool , roleSubmitCanManageSettings :: Bool } deriving (Generic, Show)