refactor(workflows): better modularize workflow-workflow-list

src/Handler/Workflow/Workflow/List.hs

@@ -14,6 +14,9 @@ import Import
 import Utils.Workflow
 import Handler.Utils.Workflow.CanonicalRoute
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
 
 getGlobalWorkflowWorkflowListR :: Handler Html
 getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
@@ -22,25 +25,9 @@ getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
 getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
 
 workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
-workflowWorkflowListR rScope = do -- not implemented; TODO: FIXME
+workflowWorkflowListR rScope = do
-  wfRoutes <- runDB $ do
+  scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
-    scope <- maybeT notFound $ fromRouteWorkflowScope rScope
+  workflowWorkflowList $ \workflowWorkflow -> workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
-    wfs <- selectKeysList [ WorkflowWorkflowScope ==. view _DBWorkflowScope scope ] []
-    flip mapMaybeM wfs $ \wfId -> do
-      cID <- encrypt wfId
-      let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-      guardM $ hasReadAccessTo route
-      return (cID, route)
-
-  defaultLayout
-    [whamlet|
-      $newline never
-      <ul>
-        $forall (cID, route) <- wfRoutes
-          <li>
-            <a href=@{route}>
-              #{toPathPiece cID}
-    |]
 
 
 getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
@@ -50,56 +37,30 @@ getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
 getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
 
 workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceWorkflowsR rScope win = do -- not implemented; TODO: FIXME
+workflowInstanceWorkflowsR rScope win = do
-  wfRoutes <- runDB $ do
+  scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
-    scope <- maybeT notFound $ fromRouteWorkflowScope rScope
+  workflowWorkflowList $ \workflowWorkflow ->
-    wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
+    E.exists . E.from $ \workflowInstance ->
-    wfs <- selectList [ WorkflowWorkflowInstance ==. Just wiId ] []
+      E.where_ $ workflowInstance E.^. WorkflowInstanceName E.==. E.val win
-    flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
+           E.&&. workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
-      rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
+           E.&&. workflowWorkflow E.^. WorkflowWorkflowInstance E.==. E.just (workflowInstance E.^. WorkflowInstanceId)
-      cID <- encrypt wfId
-      let route = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
-      guardM $ hasReadAccessTo route
-      return (cID, route)
-
-  defaultLayout
-    [whamlet|
-      $newline never
-      <ul>
-        $forall (cID, route) <- wfRoutes
-          <li>
-            <a href=@{route}>
-              #{toPathPiece cID}
-    |]
 
 
 getAdminWorkflowWorkflowListR :: Handler Html
-getAdminWorkflowWorkflowListR = do -- not implemented; TODO: FIXME
+getAdminWorkflowWorkflowListR = workflowWorkflowList $ const E.true
-  wfRoutes <- runDB $ do
-    wfs <- selectList [] []
-    flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
-      rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
-      cID <- encrypt wfId
-      let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-      return (cID, route)
-
-  defaultLayout
-    [whamlet|
-      $newline never
-      <ul>
-        $forall (cID, route) <- wfRoutes
-          <li>
-            <a href=@{route}>
-              #{toPathPiece cID}
-    |]
-
 
 getTopWorkflowWorkflowListR :: Handler Html
-getTopWorkflowWorkflowListR = do -- not implemented; TODO: FIXME
+getTopWorkflowWorkflowListR = workflowWorkflowList $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
+
+
+workflowWorkflowList :: (E.SqlExpr (Entity WorkflowWorkflow) -> E.SqlExpr (E.Value Bool))
+                     -> Handler Html
+workflowWorkflowList sqlPred = do -- not implemented; TODO: FIXME
   wfRoutes <- runDB $ do
-    wfs <- selectList [] []
+    wfs <- E.select . E.from $ \workflowWorkflow -> do
+      E.where_ $ sqlPred workflowWorkflow
+      return workflowWorkflow
     flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
-      guard $ isTopWorkflowScope workflowWorkflowScope
       rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
       cID <- encrypt wfId
       let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)

src/Utils/Workflow.hs

@@ -7,7 +7,7 @@ module Utils.Workflow
   , DBWorkflowState, IdWorkflowState
   , _DBWorkflowState
   , decryptWorkflowStateIndex, encryptWorkflowStateIndex
-  , isTopWorkflowScope
+  , isTopWorkflowScope, isTopWorkflowScopeSql
   ) where
 
 import Import.NoFoundation
@@ -19,6 +19,9 @@ import qualified Data.Binary as Binary
 import Crypto.Hash.Algorithms (SHAKE256)
 import Language.Haskell.TH (nameBase)
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
 
 type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
 type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
@@ -105,3 +108,7 @@ decryptWorkflowStateIndex wwId cID = do
 
 isTopWorkflowScope :: WorkflowScope termid schoolid courseid -> Bool
 isTopWorkflowScope = (`elem` [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScope
+
+isTopWorkflowScopeSql :: E.SqlExpr (E.Value DBWorkflowScope) -> E.SqlExpr (E.Value Bool)
+isTopWorkflowScopeSql = (`E.in_` E.valList [WSGlobal', WSTerm', WSSchool', WSTermSchool']) . classifyWorkflowScopeSql
+  where classifyWorkflowScopeSql = (E.->. "tag")