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

started fixing roles and database communication

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

3
mateamt.cabal
View file

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

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

8
src/Classes/FromDatabase.hs Normal file
View file

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

8
src/Classes/ToDatabase.hs Normal file
View file

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

5
src/Control/Journal.hs
View file

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

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) =
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."

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)
conn
void $ associateUserToRole uid baseRoleId conn
return uid

146
src/Model/Role.hs
View file

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

1
src/Types/Meta.hs
View file

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

28
src/Types/Role.hs
View file

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