218 lines
11 KiB
Haskell
218 lines
11 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Workflow.Instance.List
|
|
( getAdminWorkflowInstanceListR
|
|
, getGlobalWorkflowInstanceListR
|
|
, getSchoolWorkflowInstanceListR
|
|
, workflowInstanceListR
|
|
, getTopWorkflowInstanceListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Utils.Workflow
|
|
import Handler.Utils.Workflow.CanonicalRoute
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
|
|
type WorkflowInstanceTableExpr = E.SqlExpr (Entity WorkflowInstance)
|
|
|
|
queryWorkflowInstance :: Equality' WorkflowInstanceTableExpr (E.SqlExpr (Entity WorkflowInstance))
|
|
queryWorkflowInstance = id
|
|
|
|
queryWorkflowCount :: Getter WorkflowInstanceTableExpr (E.SqlExpr (E.Value Int64))
|
|
queryWorkflowCount = to $ \(view queryWorkflowInstance -> workflowInstance) ->
|
|
E.subSelectCount . E.from $ \workflow ->
|
|
E.where_ $ workflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
|
|
|
|
|
|
type WorkflowInstanceData = DBRow
|
|
( Entity WorkflowInstance
|
|
, Maybe (Entity WorkflowInstanceDescription)
|
|
, Int64
|
|
)
|
|
|
|
resultWorkflowInstance :: Lens' WorkflowInstanceData (Entity WorkflowInstance)
|
|
resultWorkflowInstance = _dbrOutput . _1
|
|
|
|
resultDescription :: Traversal' WorkflowInstanceData (Entity WorkflowInstanceDescription)
|
|
resultDescription = _dbrOutput . _2 . _Just
|
|
|
|
resultWorkflowCount :: Lens' WorkflowInstanceData Int64
|
|
resultWorkflowCount = _dbrOutput . _3
|
|
|
|
|
|
getAdminWorkflowInstanceListR :: Handler Html
|
|
getAdminWorkflowInstanceListR = do
|
|
instancesTable <- runDB $ do
|
|
scopeOptions <- do
|
|
scopes <- fmap (map $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
|
|
return $ workflowInstance E.^. WorkflowInstanceScope
|
|
fmap mkOptionList . for scopes $ \scope -> do
|
|
eScope <- traverseOf _wisCourse encrypt scope :: DB (WorkflowScope TermId SchoolId CryptoUUIDCourse)
|
|
wScope <- maybeT notFound $ toRouteWorkflowScope scope
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return Option
|
|
{ optionDisplay = mr wScope
|
|
, optionInternalValue = scope
|
|
, optionExternalValue = toPathPiece eScope
|
|
}
|
|
|
|
let workflowInstancesDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery = runReaderT $ do
|
|
workflowInstance <- view queryWorkflowInstance
|
|
workflowCount <- view queryWorkflowCount
|
|
|
|
return (workflowInstance, workflowCount)
|
|
dbtRowKey = (E.^. WorkflowInstanceId)
|
|
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
|
|
wi@(Entity wiId _) <- view _1
|
|
descLangs <- lift . E.select . E.from $ \workflowInstanceDescription -> do
|
|
E.where_ $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionInstance E.==. E.val wiId
|
|
return $ workflowInstanceDescription E.^. WorkflowInstanceDescriptionLanguage
|
|
descLang <- traverse selectLanguage . nonEmpty $ E.unValue <$> descLangs
|
|
desc <- lift . fmap join . for descLang $ \descLang' -> getBy $ UniqueWorkflowInstanceDescription wiId descLang'
|
|
(wi, desc,)
|
|
<$> view (_2 . _Value)
|
|
dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
|
|
dbtColonnade = mconcat
|
|
[ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18nCell
|
|
, sortable (Just "scope") (i18nCell MsgWorkflowScope) . views (resultWorkflowInstance . _entityVal . _workflowInstanceScope . re _DBWorkflowScope) $
|
|
sqlCell . maybeT (return mempty) . fmap i18n . toRouteWorkflowScope
|
|
, sortable (Just "title") (i18nCell MsgWorkflowInstanceDescriptionTitle) $ maybe mempty i18nCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionTitle)
|
|
, sortable (Just "workflows") (i18nCell MsgWorkflowInstanceWorkflowCount) $ maybe mempty i18nCell . views resultWorkflowCount (assertM' (> 0))
|
|
, sortable (Just "description") (i18nCell MsgWorkflowInstanceDescription) $ maybe mempty modalCell . preview (resultDescription . _entityVal . _workflowInstanceDescriptionDescription . _Just)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "name" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceName)
|
|
, singletonMap "scope" . SortColumn $ views queryWorkflowInstance (E.^. WorkflowInstanceScope)
|
|
, singletonMap "title" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle
|
|
, singletonMap "description" . SortProjected . comparing . view $ resultDescription . _entityVal . _workflowInstanceDescriptionDescription
|
|
, singletonMap "workflows" . SortColumn $ view queryWorkflowCount
|
|
]
|
|
dbtFilter = mconcat
|
|
[ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName)
|
|
, singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope)
|
|
, singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName)
|
|
, prismAForm (singletonFilter "scope" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ return scopeOptions) (fslI MsgWorkflowScope)
|
|
, prismAForm (singletonFilter "title") mPrev $ aopt textField (fslI MsgWorkflowInstanceDescriptionTitle)
|
|
]
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "workflow-instances"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
workflowInstancesDBTableValidator = def
|
|
& defaultSorting [SortAscBy "scope", SortAscBy "name"]
|
|
in dbTableDB' workflowInstancesDBTableValidator workflowInstancesDBTable
|
|
|
|
siteLayoutMsg MsgWorkflowInstanceListTitle $ do
|
|
setTitleI MsgWorkflowInstanceListTitle
|
|
|
|
instancesTable
|
|
|
|
|
|
getGlobalWorkflowInstanceListR :: Handler Html
|
|
getGlobalWorkflowInstanceListR = workflowInstanceListR WSGlobal
|
|
|
|
getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
|
|
getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
|
|
|
|
|
|
workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html
|
|
workflowInstanceListR rScope = do
|
|
instances <- runDB $ do
|
|
dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope
|
|
|
|
wis <- selectList [ WorkflowInstanceScope ==. dbScope ] []
|
|
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
|
|
descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
|
desc <- lift . runMaybeT $ do
|
|
langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
|
lang <- selectLanguage langs
|
|
hoistMaybe . preview _head $ do
|
|
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
|
guard $ workflowInstanceDescriptionLanguage == lang
|
|
return desc
|
|
mayInitiate <- hasWriteAccessTo $ toInitiateRoute workflowInstanceName
|
|
mayEdit <- hasReadAccessTo $ toEditRoute workflowInstanceName
|
|
mayList <- hasReadAccessTo $ toListRoute workflowInstanceName
|
|
guard $ mayInitiate || mayEdit || mayList
|
|
return (wi, desc)
|
|
|
|
return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc)
|
|
-> ( NTop workflowInstanceCategory
|
|
, workflowInstanceDescriptionTitle <$> mDesc
|
|
, workflowInstanceName
|
|
)
|
|
|
|
(heading, title) <- case rScope of
|
|
WSGlobal -> return (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
|
|
WSSchool ssh -> return (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
|
|
_other -> error "not implemented"
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI title
|
|
$(widgetFile "workflows/instances")
|
|
where
|
|
toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
|
toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
|
toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|
|
|
|
getTopWorkflowInstanceListR :: Handler Html
|
|
getTopWorkflowInstanceListR = do
|
|
gInstances <- runDB $ do
|
|
wis <- selectList [] []
|
|
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
|
|
guard $ isTopWorkflowScope workflowInstanceScope
|
|
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
|
descs <- lift $ selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
|
|
desc <- lift . runMaybeT $ do
|
|
langs <- hoistMaybe . NonEmpty.nonEmpty $ map (workflowInstanceDescriptionLanguage . entityVal) descs
|
|
lang <- selectLanguage langs
|
|
hoistMaybe . preview _head $ do
|
|
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
|
guard $ workflowInstanceDescriptionLanguage == lang
|
|
return desc
|
|
mayInitiate <- hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
|
|
mayEdit <- hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
|
|
mayList <- hasReadAccessTo $ toListRoute' rScope workflowInstanceName
|
|
guard $ mayInitiate || mayEdit || mayList
|
|
return (rScope, [(wi, desc)])
|
|
|
|
let iSortProj (Entity _ WorkflowInstance{..}, mDesc)
|
|
= ( NTop workflowInstanceCategory
|
|
, workflowInstanceDescriptionTitle <$> mDesc
|
|
, workflowInstanceName
|
|
)
|
|
return $ sortOn iSortProj <$> Map.fromListWith (<>) wis'
|
|
|
|
siteLayoutMsg MsgTopWorkflowInstancesHeading $ do
|
|
setTitleI MsgTopWorkflowInstancesTitle
|
|
let instanceList rScope instances = $(widgetFile "workflows/instances")
|
|
where
|
|
toInitiateRoute = toInitiateRoute' rScope
|
|
toEditRoute = toEditRoute' rScope
|
|
toListRoute = toListRoute' rScope
|
|
showHeadings = Map.keys gInstances /= [WSGlobal]
|
|
$(widgetFile "workflows/top-instances")
|
|
|
|
where
|
|
toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
|
|
toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
|
|
toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
|