started fixing roles and database communication

This commit is contained in:
nek0 2020-08-24 18:52:17 +02:00
parent b69acb3dbf
commit dc2a1018b1
10 changed files with 89 additions and 122 deletions

View file

@ -84,6 +84,9 @@ library
, Types.Avatar , Types.Avatar
, Types.Meta , Types.Meta
, Types.Role , Types.Role
, Classes
, Classes.FromDatabase
, Classes.ToDatabase
, Util , Util
-- other-extensions: -- other-extensions:
build-depends: base >=4.12.0.0 && < 5 build-depends: base >=4.12.0.0 && < 5

6
src/Classes.hs Normal file
View file

@ -0,0 +1,6 @@
module Classes
( module C
) where
import Classes.FromDatabase as C
import Classes.ToDatabase as C

View file

@ -0,0 +1,8 @@
{-# LANGUAGE TypeFamilies #-}
module Classes.FromDatabase where
class FromDatabase a where
type OutTuple a :: *
fromDatabase :: OutTuple a -> a

View file

@ -0,0 +1,8 @@
{-# LANGUAGE TypeFamilies #-}
module Classes.ToDatabase where
class ToDatabase a where
type InTuple a :: *
toDatabase :: a -> InTuple a

View file

@ -19,10 +19,7 @@ journalShow
-> Maybe Int -> Maybe Int
-> MateHandler [JournalEntry] -> MateHandler [JournalEntry]
journalShow (Just (uid, method)) mlimit moffset = do journalShow (Just (uid, method)) mlimit moffset = do
maySeeJournal <- anyM if method `elem` [PrimaryPass, ChallengeResponse]
(checkCapability uid)
[roleCanViewJournal, roleCanManageJournal]
if method `elem` [PrimaryPass, ChallengeResponse] && maySeeJournal
then do then do
conn <- asks rsConnection conn <- asks rsConnection
selectJournalEntries mlimit moffset conn selectJournalEntries mlimit moffset conn

View file

@ -25,12 +25,12 @@ roleNew
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> RoleSubmit -> RoleSubmit
-> MateHandler Int -> 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 do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then 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 else
throwError $ err401 throwError $ err401
{ errBody = "You are not authorized for this action." { errBody = "You are not authorized for this action."

View file

@ -30,7 +30,7 @@ userNew (UserSubmit ident email passhash) = do
uid <- insertUser ident email (utctDay now) conn uid <- insertUser ident email (utctDay now) conn
void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn
baseRoleId <- queryRoleIdByCapabilities baseRoleId <- queryRoleIdByCapabilities
(False, False, False, False, False, False, False, False, False) (False, False, False, False, False, False, False, False, False, False)
conn conn
void $ associateUserToRole uid baseRoleId conn void $ associateUserToRole uid baseRoleId conn
return uid return uid

View file

@ -5,7 +5,7 @@ module Model.Role where
import qualified Database.PostgreSQL.Simple as PGS 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 import qualified Data.Text as T
@ -22,6 +22,7 @@ import Control.Monad.IO.Class (liftIO)
-- internal imports -- internal imports
import Types import Types
import Classes
initRole :: PGS.Query initRole :: PGS.Query
initRole = mconcat initRole = mconcat
@ -29,15 +30,13 @@ initRole = mconcat
, "role_id SERIAL NOT NULL," , "role_id SERIAL NOT NULL,"
, "role_name TEXT NOT NULL," , "role_name TEXT NOT NULL,"
, "role_can_refill_stock BOOLEAN 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_invoice BOOLEAN NOT NULL,"
, "role_can_pay_out BOOLEAN NOT NULL," , "role_can_pay_out BOOLEAN NOT NULL,"
, "role_can_manage_products BOOLEAN NOT NULL," , "role_can_manage_products BOOLEAN NOT NULL,"
, "role_can_manage_journal 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_roles BOOLEAN NOT NULL,"
, "role_can_manage_suppliers BOOLEAN NOT NULL," , "role_can_manage_suppliers BOOLEAN NOT NULL,"
, "role_can_manage_avatars BOOLEAN NOT NULL,"
, "role_can_manage_settings BOOLEAN NOT NULL," , "role_can_manage_settings BOOLEAN NOT NULL,"
, "PRIMARY KEY (role_id)," , "PRIMARY KEY (role_id),"
, "UNIQUE (role_name)" , "UNIQUE (role_name)"
@ -57,13 +56,12 @@ roleTable :: Table
( Maybe (Field SqlInt4) ( Maybe (Field SqlInt4)
, Field SqlText , 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
-- , 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 SqlInt4
, Field SqlText , 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
-- , Field SqlBool , Field SqlBool
, Field SqlBool , Field SqlBool
, Field SqlBool , Field SqlBool
, Field SqlBool , Field SqlBool
) )
roleTable = table "role" ( roleTable = table "role" (
p11 p12
( tableField "role_id" ( tableField "role_id"
, tableField "role_name" , tableField "role_name"
, tableField "role_can_refill_stock" , tableField "role_can_refill_stock"
-- , tableField "role_can_add_product"
, tableField "role_can_view_journal" , tableField "role_can_view_journal"
, tableField "role_can_pay_invoice" , tableField "role_can_pay_invoice"
, tableField "role_can_pay_out" , tableField "role_can_pay_out"
, tableField "role_can_manage_products" , tableField "role_can_manage_products"
, tableField "role_can_manage_journal" , tableField "role_can_manage_journal"
-- , tableField "role_can_manage_users"
, tableField "role_can_manage_roles" , tableField "role_can_manage_roles"
, tableField "role_can_manage_suppliers" , tableField "role_can_manage_suppliers"
, tableField "role_can_manage_avatars"
, tableField "role_can_manage_settings" , tableField "role_can_manage_settings"
) )
) )
@ -127,19 +123,18 @@ runInsertInitialRoles conn = do
( C.constant (Nothing :: Maybe Int) ( C.constant (Nothing :: Maybe Int)
, C.constant ("Administrator" :: String) , 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
-- , 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 , iOnConflict = Nothing
} }
b <- runInsert_ conn $ Insert b <- runInsert_ conn $ Insert
@ -149,19 +144,18 @@ runInsertInitialRoles conn = do
( C.constant (Nothing :: Maybe Int) ( C.constant (Nothing :: Maybe Int)
, C.constant ("User" :: String) , 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
-- , 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 , iOnConflict = Nothing
} }
return $ a ++ b return $ a ++ b
@ -170,79 +164,36 @@ selectAllRoles
:: PGS.Connection :: PGS.Connection
-> MateHandler [Role] -> MateHandler [Role]
selectAllRoles conn = do selectAllRoles conn = do
rawRoles <- liftIO $ runSelect conn ( liftIO $ map fromDatabase <$> runSelect conn (
queryTable roleTable queryTable roleTable
) :: MateHandler ) :: MateHandler [Role]
[
( 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
selectRoleList selectRoleList
:: [Int] :: [Int]
-> PGS.Connection -> PGS.Connection
-> MateHandler [Role] -> MateHandler [Role]
selectRoleList ids conn = do selectRoleList ids conn = do
rawRoles <- liftIO $ runSelect conn ( liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _) -> keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
in_ (map C.constant ids) id_) in_ (map C.constant ids) id_)
<<< queryTable roleTable <<< queryTable roleTable
) :: MateHandler ) :: MateHandler [Role]
[
( 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
insertRole insertRole
:: T.Text :: T.Text
-> Bool -> Bool
-- -> Bool
-> Bool -> Bool
-> Bool -> Bool
-> Bool -> Bool
-> Bool -> Bool
-> Bool -> Bool
-- -> Bool -> Bool
-> Bool -> Bool
-> Bool -> Bool
-> Bool -> Bool
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> 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 head <$> liftIO (runInsert_ conn $ Insert
{ iTable = roleTable { iTable = roleTable
, iRows = , iRows =
@ -258,9 +209,10 @@ insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 conn = do
, C.constant c7 , C.constant c7
, C.constant c8 , C.constant c8
, C.constant c9 , C.constant c9
, C.constant c10
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
, iOnConflict = Nothing , iOnConflict = Nothing
}) })
@ -270,34 +222,19 @@ queryRoleIdByName
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
queryRoleIdByName name conn = do queryRoleIdByName name conn = do
roles <- liftIO $ runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _) -> keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) ->
C.constant name .== rname) <<< queryTable roleTable C.constant name .== rname) <<< queryTable roleTable
) :: MateHandler ) :: MateHandler Int
[
( Int
, T.Text
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
)
]
return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
queryRoleIdByCapabilities queryRoleIdByCapabilities
:: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> 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 do
roles <- liftIO $ runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9) -> keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) ->
C.constant p1 .== c1 .&& C.constant p1 .== c1 .&&
C.constant p2 .== c2 .&& C.constant p2 .== c2 .&&
C.constant p3 .== c3 .&& 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 p6 .== c6 .&&
C.constant p7 .== c7 .&& C.constant p7 .== c7 .&&
C.constant p8 .== c8 .&& C.constant p8 .== c8 .&&
C.constant p9 .== c9 C.constant p9 .== c9 .&&
C.constant p10 .== c10
) )
<<< queryTable roleTable <<< queryTable roleTable
) :: MateHandler ) :: MateHandler Int
[
( Int
, T.Text
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
, Bool
)
]
return $ (\(rid, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
selectAllRoleAssociations selectAllRoleAssociations
@ -399,10 +322,10 @@ updateRole
-> RoleSubmit -- The role with already updated info -> RoleSubmit -- The role with already updated info
-> PGS.Connection -> PGS.Connection
-> MateHandler Int64 -> 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 liftIO $ runUpdate_ conn $ Update
{ uTable = roleTable { uTable = roleTable
, uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _) -> , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
( id_ ( id_
, C.constant name , C.constant name
, C.constant c1 , 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 c7
, C.constant c8 , C.constant c8
, C.constant c9 , C.constant c9
, C.constant c10
) )
) )
, uWhere = \(id_, _, _, _, _, _, _, _, _, _, _) -> , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) ->
id_ .== C.constant rid id_ .== C.constant rid
, uReturning = rCount , uReturning = rCount
} }
@ -429,6 +353,6 @@ deleteRole rid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = roleTable { dTable = roleTable
, dWhere = , dWhere =
\(id_, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid
, dReturning = rCount , dReturning = rCount
} }

View file

@ -10,6 +10,7 @@ import GHC.Generics
data MetaInformation = MetaInformation data MetaInformation = MetaInformation
{ metaInfoVersion :: T.Text { metaInfoVersion :: T.Text
, metaInfoCurrency :: T.Text , metaInfoCurrency :: T.Text
, metaInfoDecimals :: Int
} }
deriving (Show, Generic) deriving (Show, Generic)

View file

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Role where module Types.Role where
import qualified Data.Text as T import qualified Data.Text as T
@ -6,12 +7,15 @@ import Data.Aeson
import GHC.Generics import GHC.Generics
-- internal imports
import Classes.ToDatabase
import Classes.FromDatabase
data Role = Role data Role = Role
{ roleID :: Int { roleID :: Int
, roleName :: T.Text , roleName :: T.Text
, roleCanRefillStock :: Bool , roleCanRefillStock :: Bool
-- , roleCanAddProduct :: Bool
-- , roleCanViewJournal :: Bool
-- | paying invoice only adds to user funds -- | paying invoice only adds to user funds
, roleCanPayInvoice :: Bool , roleCanPayInvoice :: Bool
-- | paying out actually removes money from the cashier -- | paying out actually removes money from the cashier
@ -21,6 +25,7 @@ data Role = Role
, roleCanManageUsers :: Bool , roleCanManageUsers :: Bool
, roleCanManageRoles :: Bool , roleCanManageRoles :: Bool
, roleCanManageSuppliers :: Bool , roleCanManageSuppliers :: Bool
, roleCanManageAvatars :: Bool
, roleCanManageSettings :: Bool , roleCanManageSettings :: Bool
} }
deriving (Generic, Show) deriving (Generic, Show)
@ -30,11 +35,25 @@ instance ToJSON Role where
instance FromJSON Role 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 data RoleSubmit = RoleSubmit
{ roleSubmitName :: T.Text { roleSubmitName :: T.Text
, roleSubmitCanRefillStock :: Bool , roleSubmitCanRefillStock :: Bool
-- , roleSubmitCanAddProduct :: Bool
-- , roleSubmitCanViewJournal :: Bool
, roleSubmitCanPayInvoice :: Bool , roleSubmitCanPayInvoice :: Bool
, roleSubmitCanPayOut :: Bool , roleSubmitCanPayOut :: Bool
, roleSubmitCanManageProducts :: Bool , roleSubmitCanManageProducts :: Bool
@ -42,6 +61,7 @@ data RoleSubmit = RoleSubmit
, roleSubmitCanManageUsers :: Bool , roleSubmitCanManageUsers :: Bool
, roleSubmitCanManageRoles :: Bool , roleSubmitCanManageRoles :: Bool
, roleSubmitCanManageSuppliers :: Bool , roleSubmitCanManageSuppliers :: Bool
, roleSubmitCanManageAvatars :: Bool
, roleSubmitCanManageSettings :: Bool , roleSubmitCanManageSettings :: Bool
} }
deriving (Generic, Show) deriving (Generic, Show)