mateamt/src/Model/Role.hs

360 lines
8.7 KiB
Haskell
Raw Normal View History

2020-05-10 06:35:32 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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, p12)
2020-05-16 08:02:26 +00:00
2020-07-19 10:27:28 +00:00
import qualified Data.Text as T
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
import Classes
2020-05-16 14:12:49 +00:00
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,"
2021-01-31 01:23:57 +00:00
, "role_can_view_journal BOOLEAN NOT NULL,"
2020-05-16 08:02:26 +00:00
, "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_roles BOOLEAN NOT NULL,"
, "role_can_manage_suppliers BOOLEAN NOT NULL,"
, "role_can_manage_avatars BOOLEAN NOT NULL,"
2020-05-16 08:02:26 +00:00
, "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
2020-05-16 08:02:26 +00:00
, Field SqlBool
, Field SqlBool
, Field SqlBool
)
( Field SqlInt4
, Field SqlText
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
2020-05-16 08:02:26 +00:00
, Field SqlBool
, Field SqlBool
, Field SqlBool
)
roleTable = table "role" (
p12
2020-05-16 08:02:26 +00:00
( tableField "role_id"
, tableField "role_name"
, tableField "role_can_refill_stock"
, 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_roles"
, tableField "role_can_manage_suppliers"
, tableField "role_can_manage_avatars"
2020-05-16 08:02:26 +00:00
, 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-07-19 04:24:22 +00:00
insertInitialRoles :: PGS.Connection -> MateHandler ()
insertInitialRoles conn =
void $ liftIO $ runInsertInitialRoles conn
2020-07-19 04:24:22 +00:00
runInsertInitialRoles :: PGS.Connection -> IO [Int]
runInsertInitialRoles conn = do
a <- runInsert_ conn $ Insert
{ iTable = roleTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
2020-05-16 14:12:49 +00:00
, 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
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
, 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
2020-07-19 04:24:22 +00:00
, C.constant False
, C.constant False
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
2020-07-19 04:24:22 +00:00
, iOnConflict = Nothing
}
return $ a ++ b
2020-07-19 06:27:15 +00:00
selectAllRoles
:: PGS.Connection
-> MateHandler [Role]
selectAllRoles conn = do
liftIO $ map fromDatabase <$> runSelect conn (
2020-07-19 06:27:15 +00:00
queryTable roleTable
) :: MateHandler [Role]
2020-07-19 06:27:15 +00:00
selectRoleList
:: [Int]
-> PGS.Connection
-> MateHandler [Role]
selectRoleList ids conn = do
liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
2020-08-24 07:43:22 +00:00
in_ (map C.constant ids) id_)
<<< queryTable roleTable
) :: MateHandler [Role]
2020-07-19 18:48:58 +00:00
insertRole
:: T.Text
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
-> Bool
2020-07-19 18:48:58 +00:00
-> Bool
-> Bool
-> Bool
-> PGS.Connection
-> MateHandler Int
insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 conn = do
2020-07-19 18:48:58 +00:00
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
2020-07-19 18:48:58 +00:00
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
2020-07-19 18:48:58 +00:00
, iOnConflict = Nothing
})
queryRoleIdByName
:: T.Text
-> PGS.Connection
-> MateHandler Int
2020-07-19 10:27:28 +00:00
queryRoleIdByName name conn = do
liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) ->
2020-07-19 10:27:28 +00:00
C.constant name .== rname) <<< queryTable roleTable
) :: MateHandler Int
queryRoleIdByCapabilities
:: (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) conn =
2020-07-19 10:27:28 +00:00
do
liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) ->
2020-07-19 10:27:28 +00:00
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
2020-07-19 10:27:28 +00:00
)
<<< queryTable roleTable
) :: MateHandler Int
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
2020-08-24 07:43:22 +00:00
(uncurry RoleAssociation)
2020-07-19 10:58:25 +00:00
rawRoleAssocs
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
)
]
2020-08-24 07:43:22 +00:00
return $ map (uncurry RoleAssociation) rawAssocs
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
{ iTable = userToRoleTable
, iRows =
[
2020-07-19 10:27:28 +00:00
( C.constant uid
, C.constant rid
)
]
2020-07-19 10:27:28 +00:00
, iReturning = rReturning (const ())
, iOnConflict = Nothing
2020-07-19 10:27:28 +00:00
})
2020-07-23 20:41:22 +00:00
deleteAssociation
:: Int -- ^ User id
-> Int -- ^ Role id
-> PGS.Connection
-> MateHandler Int64
deleteAssociation uid rid conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = userToRoleTable
, dWhere =
2020-08-24 07:43:22 +00:00
\(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid
, dReturning = rCount
}
2020-07-23 20:41:22 +00:00
updateRole
:: Int -- ID of the updated role
-> RoleSubmit -- The role with already updated info
2020-07-23 20:41:22 +00:00
-> PGS.Connection
-> MateHandler Int64
updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) conn =
2020-07-23 20:41:22 +00:00
liftIO $ runUpdate_ conn $ Update
{ uTable = roleTable
, 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
2020-07-23 20:41:22 +00:00
)
)
, uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) ->
id_ .== C.constant rid
2020-07-23 20:41:22 +00:00
, uReturning = rCount
}
deleteRole
:: Int
-> PGS.Connection
-> MateHandler Int64
deleteRole rid conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = roleTable
, dWhere =
\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid
, dReturning = rCount
}