Module.hs

-- | Utility module for importing scripted atom and database context functions.
module ProjectM36.Module where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.AccessControlList
import ProjectM36.DatabaseContext.Types as DBCT
import Control.Monad.Trans.Writer
import Control.Monad.RWS.Strict (RWST, get, put, ask, runRWST)
import Control.Monad.Except (ExceptT, throwError, runExceptT)
import Data.Functor.Identity

-- | Variant of ACLs which use roles to be later resolved to role ids used by user-facing ProjectM36.Module.
type DBCFunctionRoleNameAccessControlList = AccessControlList RoleName DBCFunctionPermission

declareAtomFunction :: FunctionName -> EntryPoints ()
declareAtomFunction nam = tell [DeclareAtomFunction nam]

declareDatabaseContextFunction :: FunctionName -> DBCFunctionRoleNameAccessControlList -> EntryPoints ()
declareDatabaseContextFunction nam acl' = tell [DeclareDatabaseContextFunction nam acl']

type EntryPoints = Writer [DeclareFunction]

runEntryPoints :: EntryPoints () -> [DeclareFunction]
runEntryPoints = execWriter

data DeclareFunctionBase a = DeclareAtomFunction a |
                             DeclareDatabaseContextFunction a DBCFunctionRoleNameAccessControlList
  deriving (Show)

type DeclareFunction = DeclareFunctionBase FunctionName

type DatabaseContextFunctionMonad a = RWST DatabaseContextFunctionMonadEnv () DatabaseContext (ExceptT RelationalError Identity) a

newtype DatabaseContextFunctionMonadEnv =
  DatabaseContextFunctionMonadEnv
  {
    utils :: DatabaseContextFunctionUtils
  }

executeRelationalExpr :: RelationalExpr -> DatabaseContextFunctionMonad Relation
executeRelationalExpr expr = do
  env <- ask
  ctx <- get
  case DBCT.executeRelationalExpr (utils env) ctx expr of
    Left err -> throwError err
    Right rel -> pure rel

executeDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextFunctionMonad ()
executeDatabaseContextExpr expr = do
  env <- ask
  ctx <- get
  case DBCT.executeDatabaseContextExpr (utils env) ctx expr of
    Left err -> throwError err
    Right ctx' ->
      put ctx'

runDatabaseContextFunctionMonad ::
  DatabaseContextFunctionMonadEnv ->
  DatabaseContext ->
  DatabaseContextFunctionMonad () ->
  Either RelationalError DatabaseContext
runDatabaseContextFunctionMonad env ctx m = do
  (_,ctx',_) <- runIdentity $ runExceptT $ runRWST m env ctx
  pure ctx'