mateamt/src/Model/Role.hs

360 lines
8.7 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Model.Role where
import qualified Database.PostgreSQL.Simple as PGS
import Data.Profunctor.Product (p2, p12)
import qualified Data.Text as T
import Data.Int (Int64)
import Opaleye as O hiding (null, not)
import Opaleye.Constant as C
import Control.Arrow ((<<<))
import Control.Monad
import Control.Monad.IO.Class (liftIO)
-- internal imports
import Types
import Classes
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_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_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)"
, ")"
]
initUserToRole :: PGS.Query
initUserToRole = mconcat
[ "CREATE TABLE IF NOT EXISTS \"user_to_role\" ("
, "user_id INTEGER NOT NULL REFERENCES \"user\"(\"user_id\"),"
, "role_id INTEGER NOT NULL REFERENCES \"role\"(\"role_id\"),"
, "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 SqlInt4
, Field SqlText
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
, Field SqlBool
)
roleTable = table "role" (
p12
( 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"
, 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"
)
)
insertInitialRoles :: PGS.Connection -> MateHandler ()
insertInitialRoles conn =
void $ liftIO $ runInsertInitialRoles conn
runInsertInitialRoles :: PGS.Connection -> IO [Int]
runInsertInitialRoles conn = do
a <- runInsert_ conn $ Insert
{ iTable = roleTable
, iRows =
[
( 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
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
, iOnConflict = Nothing
}
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
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
, iOnConflict = Nothing
}
return $ a ++ b
selectAllRoles
:: PGS.Connection
-> MateHandler [Role]
selectAllRoles conn = do
liftIO $ map fromDatabase <$> runSelect conn (
queryTable roleTable
) :: MateHandler [Role]
selectRoleList
:: [Int]
-> PGS.Connection
-> MateHandler [Role]
selectRoleList ids conn = do
liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
in_ (map C.constant ids) id_)
<<< queryTable roleTable
) :: MateHandler [Role]
insertRole
:: T.Text
-> 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 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
)
]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
, iOnConflict = Nothing
})
queryRoleIdByName
:: T.Text
-> PGS.Connection
-> MateHandler Int
queryRoleIdByName name conn = do
liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) ->
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 =
do
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 .&&
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
)
<<< queryTable roleTable
) :: MateHandler Int
selectAllRoleAssociations
:: PGS.Connection
-> MateHandler [RoleAssociation]
selectAllRoleAssociations conn = do
rawRoleAssocs <- liftIO $ runSelect conn (
queryTable userToRoleTable
) :: MateHandler
[
( Int
, Int
)
]
return $ map
(uncurry RoleAssociation)
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
)
]
return $ map (uncurry RoleAssociation) rawAssocs
associateUserToRole
:: Int -- ^ User id
-> Int -- ^ Role id
-> PGS.Connection
-> MateHandler ()
associateUserToRole uid rid conn =
head <$> liftIO (runInsert_ conn $ Insert
{ iTable = userToRoleTable
, iRows =
[
( C.constant uid
, C.constant rid
)
]
, iReturning = rReturning (const ())
, iOnConflict = Nothing
})
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
}
updateRole
:: Int -- ID of the updated role
-> 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 c10) conn =
liftIO $ runUpdate_ conn $ Update
{ uTable = roleTable
, uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
( 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
)
)
, uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) ->
id_ .== C.constant rid
, 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
}