2020-05-10 06:35:32 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE Arrows #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Model.Role where
|
2020-05-16 08:02:26 +00:00
|
|
|
|
|
|
|
import qualified Database.PostgreSQL.Simple as PGS
|
|
|
|
|
|
|
|
import Data.Profunctor.Product (p2, p13)
|
|
|
|
|
2020-07-19 10:27:28 +00:00
|
|
|
import qualified Data.Text as T
|
|
|
|
|
2020-07-24 05:47:35 +00:00
|
|
|
import Data.Int (Int64)
|
|
|
|
|
2020-05-16 08:02:26 +00:00
|
|
|
import Opaleye as O hiding (null, not)
|
|
|
|
import Opaleye.Constant as C
|
|
|
|
|
2020-07-19 10:27:28 +00:00
|
|
|
import Control.Arrow ((<<<))
|
|
|
|
|
2020-07-19 04:24:22 +00:00
|
|
|
import Control.Monad
|
2020-05-16 14:12:49 +00:00
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
|
2020-05-16 08:02:26 +00:00
|
|
|
initRole :: PGS.Query
|
|
|
|
initRole = mconcat
|
|
|
|
[ "CREATE TABLE IF NOT EXISTS \"role\" ("
|
|
|
|
, "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_settings BOOLEAN NOT NULL,"
|
2020-07-23 20:41:22 +00:00
|
|
|
, "PRIMARY KEY (role_id),"
|
2020-07-19 04:31:35 +00:00
|
|
|
, "UNIQUE (role_name)"
|
2020-05-16 08:02:26 +00:00
|
|
|
, ")"
|
|
|
|
]
|
|
|
|
|
|
|
|
initUserToRole :: PGS.Query
|
|
|
|
initUserToRole = mconcat
|
|
|
|
[ "CREATE TABLE IF NOT EXISTS \"user_to_role\" ("
|
2020-07-19 10:58:25 +00:00
|
|
|
, "user_id INTEGER NOT NULL REFERENCES \"user\"(\"user_id\"),"
|
|
|
|
, "role_id INTEGER NOT NULL REFERENCES \"role\"(\"role_id\"),"
|
2020-05-16 08:02:26 +00:00
|
|
|
, "PRIMARY KEY (user_id, role_id)"
|
|
|
|
, ")"
|
|
|
|
]
|
|
|
|
|
|
|
|
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 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
|
|
|
|
)
|
|
|
|
roleTable = table "role" (
|
|
|
|
p13
|
|
|
|
( 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_settings"
|
|
|
|
)
|
|
|
|
)
|
|
|
|
|
|
|
|
userToRoleTable :: Table
|
|
|
|
( Field SqlInt4
|
|
|
|
, Field SqlInt4
|
|
|
|
)
|
|
|
|
( Field SqlInt4
|
|
|
|
, Field SqlInt4
|
|
|
|
)
|
|
|
|
userToRoleTable = table "user_to_role" (
|
|
|
|
p2
|
|
|
|
( tableField "user_id"
|
|
|
|
, tableField "role_id"
|
|
|
|
)
|
|
|
|
)
|
2020-05-16 13:33:27 +00:00
|
|
|
|
2020-07-19 04:24:22 +00:00
|
|
|
insertInitialRoles :: PGS.Connection -> MateHandler ()
|
|
|
|
insertInitialRoles conn =
|
|
|
|
void $ liftIO $ runInsertInitialRoles conn
|
2020-05-16 13:33:27 +00:00
|
|
|
|
2020-07-19 04:24:22 +00:00
|
|
|
runInsertInitialRoles :: PGS.Connection -> IO [Int]
|
|
|
|
runInsertInitialRoles conn = do
|
|
|
|
a <- runInsert_ conn $ Insert
|
2020-05-16 13:33:27 +00:00
|
|
|
{ iTable = roleTable
|
|
|
|
, iRows =
|
|
|
|
[
|
|
|
|
( C.constant (Nothing :: Maybe Int)
|
2020-05-16 14:12:49 +00:00
|
|
|
, C.constant ("Administrator" :: String)
|
2020-05-16 13:33:27 +00:00
|
|
|
, 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
|
|
|
|
)
|
|
|
|
]
|
2020-07-19 04:24:22 +00:00
|
|
|
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
|
2020-05-16 13:33:27 +00:00
|
|
|
, iOnConflict = Nothing
|
|
|
|
}
|
2020-07-19 04:24:22 +00:00
|
|
|
b <- runInsert_ conn $ Insert
|
|
|
|
{ iTable = roleTable
|
|
|
|
, iRows =
|
|
|
|
[
|
|
|
|
( 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
|
|
|
|
)
|
|
|
|
]
|
|
|
|
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
|
|
|
|
, iOnConflict = Nothing
|
|
|
|
}
|
|
|
|
return $ a ++ b
|
2020-07-19 05:01:53 +00:00
|
|
|
|
2020-07-19 06:27:15 +00:00
|
|
|
selectAllRoles
|
|
|
|
:: PGS.Connection
|
|
|
|
-> MateHandler [Role]
|
|
|
|
selectAllRoles conn = do
|
|
|
|
rawRoles <- liftIO $ runSelect conn (
|
|
|
|
queryTable roleTable
|
2020-07-19 10:27:28 +00:00
|
|
|
) :: MateHandler
|
2020-07-19 06:27:15 +00:00
|
|
|
[
|
|
|
|
( 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 ,c10, c11) ->
|
|
|
|
Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11)
|
|
|
|
rawRoles
|
|
|
|
|
|
|
|
|
2020-07-24 05:47:35 +00:00
|
|
|
selectRoleList
|
|
|
|
:: [Int]
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler [Role]
|
|
|
|
selectRoleList ids conn = do
|
|
|
|
rawRoles <- liftIO $ 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 ,c10, c11) ->
|
|
|
|
Role id_ name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11)
|
|
|
|
rawRoles
|
|
|
|
|
|
|
|
|
2020-07-19 18:48:58 +00:00
|
|
|
insertRole
|
|
|
|
:: T.Text
|
|
|
|
-> 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
|
|
|
|
head <$> liftIO (runInsert_ conn $ Insert
|
|
|
|
{ iTable = roleTable
|
|
|
|
, iRows =
|
|
|
|
[
|
|
|
|
( C.constant (Nothing :: Maybe Int)
|
|
|
|
, C.constant name
|
|
|
|
, C.constant c1
|
|
|
|
, C.constant c2
|
|
|
|
, C.constant c3
|
|
|
|
, C.constant c4
|
|
|
|
, C.constant c5
|
|
|
|
, C.constant c6
|
|
|
|
, C.constant c7
|
|
|
|
, C.constant c8
|
|
|
|
, C.constant c9
|
|
|
|
, C.constant c10
|
|
|
|
, C.constant c11
|
|
|
|
)
|
|
|
|
]
|
|
|
|
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
|
|
|
|
, iOnConflict = Nothing
|
|
|
|
})
|
|
|
|
|
|
|
|
|
2020-07-19 05:01:53 +00:00
|
|
|
queryRoleIdByName
|
|
|
|
:: T.Text
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int
|
2020-07-19 10:27:28 +00:00
|
|
|
queryRoleIdByName name conn = do
|
2020-07-19 05:01:53 +00:00
|
|
|
roles <- liftIO $ runSelect conn (
|
|
|
|
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _, _) ->
|
2020-07-19 10:27:28 +00:00
|
|
|
C.constant name .== rname) <<< queryTable roleTable
|
2020-07-19 05:01:53 +00:00
|
|
|
) :: MateHandler
|
2020-07-19 06:27:15 +00:00
|
|
|
[
|
|
|
|
( Int
|
|
|
|
, T.Text
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
)
|
|
|
|
]
|
2020-07-19 05:01:53 +00:00
|
|
|
return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
|
|
|
|
|
|
|
|
queryRoleIdByCapabilities
|
|
|
|
:: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int
|
2020-07-19 10:27:28 +00:00
|
|
|
queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11) conn =
|
|
|
|
do
|
|
|
|
roles <- liftIO $ runSelect conn (
|
|
|
|
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11) ->
|
|
|
|
C.constant p1 .== c1 .&&
|
|
|
|
C.constant p2 .== c2 .&&
|
|
|
|
C.constant p3 .== c3 .&&
|
|
|
|
C.constant p4 .== c4 .&&
|
|
|
|
C.constant p5 .== c5 .&&
|
|
|
|
C.constant p6 .== c6 .&&
|
|
|
|
C.constant p7 .== c7 .&&
|
|
|
|
C.constant p8 .== c8 .&&
|
|
|
|
C.constant p9 .== c9 .&&
|
|
|
|
C.constant p10 .== c10 .&&
|
|
|
|
C.constant p11 .== c11
|
|
|
|
)
|
|
|
|
<<< queryTable roleTable
|
|
|
|
) :: MateHandler
|
|
|
|
[
|
|
|
|
( Int
|
|
|
|
, T.Text
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
, Bool
|
|
|
|
)
|
|
|
|
]
|
|
|
|
return $ (\(rid, _, _, _, _, _, _, _, _, _, _, _, _) -> rid) (head roles)
|
2020-07-19 05:01:53 +00:00
|
|
|
|
2020-07-19 10:58:25 +00:00
|
|
|
|
|
|
|
selectAllRoleAssociations
|
|
|
|
:: PGS.Connection
|
|
|
|
-> MateHandler [RoleAssociation]
|
|
|
|
selectAllRoleAssociations conn = do
|
|
|
|
rawRoleAssocs <- liftIO $ runSelect conn (
|
|
|
|
queryTable userToRoleTable
|
|
|
|
) :: MateHandler
|
|
|
|
[
|
|
|
|
( Int
|
|
|
|
, Int
|
|
|
|
)
|
|
|
|
]
|
|
|
|
return $ map
|
|
|
|
(\(uid, rid) -> RoleAssociation uid rid)
|
|
|
|
rawRoleAssocs
|
|
|
|
|
|
|
|
|
2020-07-24 05:47:35 +00:00
|
|
|
selectUserAssociations
|
|
|
|
:: Int
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler [RoleAssociation]
|
|
|
|
selectUserAssociations uid conn = do
|
|
|
|
rawAssocs <- liftIO $ runSelect conn(
|
|
|
|
keepWhen (\(auid, _) -> auid .== C.constant uid)
|
|
|
|
<<< queryTable userToRoleTable
|
|
|
|
) :: MateHandler
|
|
|
|
[
|
|
|
|
( Int
|
|
|
|
, Int
|
|
|
|
)
|
|
|
|
]
|
|
|
|
return $ map (\(auid, arid) -> RoleAssociation auid arid) rawAssocs
|
|
|
|
|
|
|
|
|
2020-07-19 05:01:53 +00:00
|
|
|
associateUserToRole
|
|
|
|
:: Int -- ^ User id
|
2020-07-19 09:10:00 +00:00
|
|
|
-> Int -- ^ Role id
|
|
|
|
-> PGS.Connection
|
2020-07-23 20:41:22 +00:00
|
|
|
-> MateHandler ()
|
2020-07-19 10:27:28 +00:00
|
|
|
associateUserToRole uid rid conn =
|
|
|
|
head <$> liftIO (runInsert_ conn $ Insert
|
2020-07-19 05:01:53 +00:00
|
|
|
{ iTable = userToRoleTable
|
|
|
|
, iRows =
|
|
|
|
[
|
2020-07-19 10:27:28 +00:00
|
|
|
( C.constant uid
|
2020-07-19 05:01:53 +00:00
|
|
|
, C.constant rid
|
|
|
|
)
|
|
|
|
]
|
2020-07-19 10:27:28 +00:00
|
|
|
, iReturning = rReturning (const ())
|
2020-07-19 05:01:53 +00:00
|
|
|
, iOnConflict = Nothing
|
2020-07-19 10:27:28 +00:00
|
|
|
})
|
2020-07-23 20:41:22 +00:00
|
|
|
|
|
|
|
|
2020-07-31 20:31:27 +00:00
|
|
|
deleteAssociation
|
|
|
|
:: Int -- ^ User id
|
|
|
|
-> Int -- ^ Role id
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int64
|
|
|
|
deleteAssociation uid rid conn =
|
|
|
|
liftIO $ runDelete_ conn $ Delete
|
|
|
|
{ dTable = userToRoleTable
|
|
|
|
, dWhere =
|
|
|
|
(\(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid)
|
|
|
|
, dReturning = rCount
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2020-07-23 20:41:22 +00:00
|
|
|
updateRole
|
2020-07-24 05:47:35 +00:00
|
|
|
:: Int -- ID of the updated role
|
|
|
|
-> RoleSubmit -- The role with already updated info
|
2020-07-23 20:41:22 +00:00
|
|
|
-> PGS.Connection
|
2020-07-24 05:47:35 +00:00
|
|
|
-> MateHandler Int64
|
|
|
|
updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 c11) conn =
|
2020-07-23 20:41:22 +00:00
|
|
|
liftIO $ runUpdate_ conn $ Update
|
|
|
|
{ uTable = roleTable
|
2020-07-24 05:47:35 +00:00
|
|
|
, uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
|
2020-07-23 20:41:22 +00:00
|
|
|
( id_
|
|
|
|
, C.constant name
|
|
|
|
, C.constant c1
|
|
|
|
, C.constant c2
|
|
|
|
, C.constant c3
|
|
|
|
, C.constant c4
|
|
|
|
, C.constant c5
|
|
|
|
, C.constant c6
|
|
|
|
, C.constant c7
|
|
|
|
, C.constant c8
|
|
|
|
, C.constant c9
|
|
|
|
, C.constant c10
|
|
|
|
, C.constant c11
|
|
|
|
)
|
|
|
|
)
|
2020-07-24 05:47:35 +00:00
|
|
|
, uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
|
|
|
|
id_ .== C.constant rid
|
2020-07-23 20:41:22 +00:00
|
|
|
, uReturning = rCount
|
|
|
|
}
|
2020-07-31 20:31:27 +00:00
|
|
|
|
|
|
|
deleteRole
|
|
|
|
:: Int
|
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int64
|
|
|
|
deleteRole rid conn =
|
|
|
|
liftIO $ runDelete_ conn $ Delete
|
|
|
|
{ dTable = roleTable
|
|
|
|
, dWhere =
|
|
|
|
(\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid)
|
|
|
|
, dReturning = rCount
|
|
|
|
}
|