{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Arrows #-} 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 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 = [ ( toFields (Nothing :: Maybe Int) , toFields ("Administrator" :: String) , toFields True , toFields True , toFields True , toFields True , toFields True , toFields True , toFields True , toFields True , toFields True , toFields True ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } b <- runInsert_ conn $ Insert { iTable = roleTable , iRows = [ ( toFields (Nothing :: Maybe Int) , toFields ("User" :: String) , toFields False , toFields False , toFields False , toFields False , toFields False , toFields False , toFields False , toFields False , toFields False , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing } return $ a ++ b selectAllRoles :: PGS.Connection -> MateHandler [Role] selectAllRoles conn = do liftIO $ map fromDatabase <$> runSelect conn ( selectTable roleTable ) :: MateHandler [Role] selectRoleList :: [Int] -> PGS.Connection -> MateHandler [Role] selectRoleList ids conn = do liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do stuff@(id_, _, _, _, _, _, _, _, _, _, _, _) <- selectTable roleTable -< () restrict -< in_ (map toFields ids) id_ returnA -< stuff ) :: 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 = [ ( toFields (Nothing :: Maybe Int) , toFields name , toFields c1 , toFields c2 , toFields c3 , toFields c4 , toFields c5 , toFields c6 , toFields c7 , toFields c8 , toFields c9 , toFields c10 ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iOnConflict = Nothing }) queryRoleIdByName :: T.Text -> PGS.Connection -> MateHandler Int queryRoleIdByName name conn = do liftIO $ roleID . fromDatabase . head <$> runSelect conn ( proc () -> do stuff@(_, rname, _, _, _, _, _, _, _, _, _, _) <- selectTable roleTable -< () restrict -< toFields name .== rname returnA -< stuff ) :: MateHandler Int queryRoleIdByCapabilities :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) -> PGS.Connection -> MateHandler Int queryRoleIdByCapabilities (pa1, pa2, pa3, pa4, pa5, pa6, pa7, pa8, pa9, pa10) conn = do liftIO $ roleID . fromDatabase . head <$> runSelect conn ( proc () -> do stuff@(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) <- selectTable roleTable -< () restrict -< toFields pa1 .== c1 .&& toFields pa2 .== c2 .&& toFields pa3 .== c3 .&& toFields pa4 .== c4 .&& toFields pa5 .== c5 .&& toFields pa6 .== c6 .&& toFields pa7 .== c7 .&& toFields pa8 .== c8 .&& toFields pa9 .== c9 .&& toFields pa10 .== c10 returnA -< stuff ) :: MateHandler Int selectAllRoleAssociations :: PGS.Connection -> MateHandler [RoleAssociation] selectAllRoleAssociations conn = do rawRoleAssocs <- liftIO $ runSelect conn ( selectTable userToRoleTable ) :: MateHandler [ ( Int , Int ) ] return $ map (uncurry RoleAssociation) rawRoleAssocs selectUserAssociations :: Int -> PGS.Connection -> MateHandler [RoleAssociation] selectUserAssociations uid conn = do rawAssocs <- liftIO $ runSelect conn( proc () -> do stuff@(auid, _) <- selectTable userToRoleTable -< () restrict -< auid .== toFields uid returnA -< stuff ) :: 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 = [ ( toFields uid , toFields 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 .== toFields uid .&& arid .== toFields rid , dReturning = rCount } updateRole :: Int -- ID of the updated role -> RoleSubmit -- The role with already updated info -> PGS.Connection -> MateHandler Int64 updateRole rid (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) conn = liftIO $ runUpdate_ conn $ Update { uTable = roleTable , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> ( id_ , toFields name , toFields c1 , toFields c2 , toFields c3 , toFields c4 , toFields c5 , toFields c6 , toFields c7 , toFields c8 , toFields c9 , toFields c10 ) ) , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== toFields rid , uReturning = rCount } deleteRole :: Int -> PGS.Connection -> MateHandler Int64 deleteRole rid conn = liftIO $ runDelete_ conn $ Delete { dTable = roleTable , dWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== toFields rid , dReturning = rCount }