refactor: improve dbTable performance

src/Data/CaseInsensitive/Instances.hs

@@ -88,6 +88,10 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
   fromPathPiece = fmap CI.mk . fromPathPiece
   toPathPiece = toPathPiece . CI.original
 
+instance PathPiece [CI Char] where
+  fromPathPiece = fmap (map CI.mk . (unpack :: Text -> [Char])) . fromPathPiece
+  toPathPiece = toPathPiece . (pack :: [Char] -> Text) . map CI.original
+
 instance ToHttpApiData s => ToHttpApiData (CI s) where
   toUrlPiece = toUrlPiece . CI.original
   toEncodedUrlPiece = toEncodedUrlPiece . CI.original

src/Foundation/Authorization.hs

@@ -1967,7 +1967,9 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
 
 evalWorkflowRoleFor' :: forall m backend.
                         ( HasCallStack
+                        , MonadHandler m, HandlerSite m ~ UniWorX
                         , MonadAP (ReaderT backend m), MonadIO m
+                        , MonadThrow m
                         , BackendCompatible SqlReadBackend backend
                         )
                      => (forall m'. MonadAP m' => AuthTagsEval m')
@@ -2006,7 +2008,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
     WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do
       uid <- maybeExceptT AuthenticationRequired $ return mAuthId
       wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
-      WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
+      Entity _ WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift $ getWorkflowWorkflowState wwId
+      -- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
       let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
       unless (uid `Set.member` uids) $ 
         throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
@@ -2015,6 +2018,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
 
 evalWorkflowRoleFor :: ( HasCallStack
                        , MonadAP (ReaderT backend m), MonadIO m
+                       , MonadHandler m, HandlerSite m ~ UniWorX
+                       , MonadThrow m
                        , BackendCompatible SqlReadBackend backend
                        )
                     => Maybe UserId
@@ -2038,8 +2043,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
  
 hasWorkflowRole :: ( HasCallStack
                    , MonadAP (ReaderT backend m)
-                   , BackendCompatible SqlReadBackend backend
                    , MonadHandler m, HandlerSite m ~ UniWorX
+                   , MonadThrow m
+                   , BackendCompatible SqlReadBackend backend
                    )
                 => Maybe WorkflowWorkflowId
                 -> WorkflowRole UserId
@@ -2065,7 +2071,7 @@ mayViewWorkflowAction' :: forall backend m fileid.
                        -> WorkflowAction fileid UserId
                        -> WriterT (Set AuthTag) (ReaderT backend m) Bool
 mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do
-  WorkflowWorkflow{..} <- MaybeT . lift $ get wwId
+  Entity _ WorkflowWorkflow{..} <- MaybeT . lift $ getWorkflowWorkflowState wwId
   rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
   cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId
   WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph

src/Handler/Admin/StudyFeatures.hs

@@ -326,7 +326,7 @@ postAdminFeaturesR = do
           dbtSQLQuery   :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree))
           dbtSQLQuery   = return
           dbtRowKey     = (E.^. StudyDegreeKey)
-          dbtProj       = return
+          dbtProj       = dbtProjId
           dbtColonnade  = formColonnade $ mconcat
             [ sortable (Just "key")   (i18nCell MsgGenericKey)  (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
             , sortable (Just "name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey))
@@ -356,7 +356,7 @@ postAdminFeaturesR = do
           dbtSQLQuery   :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms))
           dbtSQLQuery = return
           dbtRowKey = (E.^. StudyTermsKey)
-          dbtProj field@(view _dbrOutput -> Entity fId _) = do
+          dbtProj = dbtProjSimple $ \field@(Entity fId _) -> do
             fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
               E.where_ . E.exists . E.from $ \schoolTerms ->
                 E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
@@ -368,7 +368,7 @@ postAdminFeaturesR = do
                 E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId
                      E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId
               return terms
-            return $ field & _dbrOutput %~ (, fieldParents, fieldSchools)
+            return (field, fieldParents, fieldSchools)
           dbtColonnade  = formColonnade $ mconcat
             [ sortable (Just "key")   (i18nCell MsgGenericKey)         (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey))
             , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey')
@@ -416,7 +416,7 @@ postAdminFeaturesR = do
           dbtSQLQuery   :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate))
           dbtSQLQuery   = return
           dbtRowKey     = (E.^. StudyTermNameCandidateId)
-          dbtProj       = return
+          dbtProj       = dbtProjId
           dbtColonnade  = dbColonnade $ mconcat
             [ sortable (Just "key")       (i18nCell MsgStudyTermsKey)           (numCell  . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey))
             , sortable (Just "name")      (i18nCell MsgStudyTermsName)          (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName))
@@ -459,7 +459,7 @@ postAdminFeaturesR = do
             E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent)
             return (candidate, parent, child)
           dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId)
-          dbtProj       = return
+          dbtProj       = dbtProjId
           dbtColonnade  = dbColonnade $ mconcat
             [ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey)   (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey))
             , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName)  (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just))
@@ -502,7 +502,7 @@ postAdminFeaturesR = do
             E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey)
             return (candidate, sterm)
           dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId)
-          dbtProj       = return
+          dbtProj       = dbtProjId
           dbtColonnade  = formColonnade $ mconcat
             [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey))
             , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just))

src/Handler/Allocation/List.hs

@@ -77,8 +77,10 @@ getAllocationListR = do
                     <*> view (queryAvailable muid ata now)
                     <*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)
 
-    dbtProj :: DBRow _ -> DB AllocationTableData
+    dbtProj :: _ AllocationTableData
-    dbtProj = return . over (_dbrOutput . _2) (fromIntegral . E.unValue) . over (_dbrOutput . _3) (fromIntegral . E.unValue)
+    dbtProj = dbtProjId
+      <&> _dbrOutput . _2 %~ fromIntegral . E.unValue
+      <&> _dbrOutput . _3 %~ fromIntegral . E.unValue
 
     dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
 

src/Handler/Allocation/Users.hs

@@ -187,7 +187,7 @@ postAUsersR tid ssh ash = do
                    , assigned
                    , vetoed)
           dbtRowKey = views queryAllocationUser (E.^. AllocationUserId)
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+          dbtProj = dbtProjSimple . runReaderT $ do
             feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
             (,,,,,)
               <$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)

src/Handler/Course/Application/List.hs

@@ -271,8 +271,8 @@ postCApplicationsR tid ssh csh = do
                , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
                )
 
-      dbtProj :: DBRow _ -> DB CourseApplicationsTableData
+      dbtProj :: _ CourseApplicationsTableData
-      dbtProj = traverse $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do
+      dbtProj = dbtProjSimple $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do
         feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey)
         return (application, user, hasFiles, allocation, isParticipant, feats)
 

src/Handler/Course/List.hs

@@ -90,8 +90,8 @@ makeCourseTable whereClause colChoices psValidator = do
         return user
       isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
         E.&&. E.just (user E.^. UserId) E.==. E.val muid
-      dbtProj :: DBRow _ -> DB CourseTableData
+      dbtProj :: _ CourseTableData
-      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
+      dbtProj = dbtProjSimple $ \(course, E.Value participants, E.Value registered, school) -> do
         lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
         courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
                           >>= traverse (getJustEntity . allocationCourseAllocation . entityVal)

src/Handler/Course/Show.hs

@@ -169,7 +169,7 @@ getCShowR tid ssh csh = do
                    E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
           return (tutorial, showRoom)
         dbtRowKey = (E.^. TutorialId)
-        dbtProj = traverse $ return . over _2 E.unValue
+        dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId
         dbtColonnade = dbColonnade $ mconcat
           [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
           , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]

src/Handler/Course/User.hs

@@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
             ]
           return exam
         dbtRowKey = (E.^. ExamId)
-        dbtProj = traverse $ \exam@(Entity eId _) -> do
+        dbtProj = dbtProjSimple $ \exam@(Entity eId _) -> do
           registration <- getBy $ UniqueExamRegistration eId uid
           occurrence <- runMaybeT $ do
             Entity _ ExamRegistration{..} <- hoistMaybe registration
@@ -444,7 +444,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
                E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
           return (tutorial, tutorialParticipant)
         dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId
-        dbtProj = traverse $ \(tutorial, tutorialParticipant) -> do
+        dbtProj = dbtProjSimple $ \(tutorial, tutorialParticipant) -> do
           tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
             E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
             E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey)

src/Handler/Course/Users.hs

@@ -375,7 +375,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
         dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
         dbtRowKey    = queryUser >>> (E.^. UserId)
-        dbtProj      = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do
+        dbtProj      = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do
           tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
           exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
           subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do

src/Handler/Exam/List.hs

@@ -29,7 +29,7 @@ mkExamTable (Entity cid Course{..}) = do
           E.where_ $ exam E.^. ExamCourse E.==. E.val cid
           return exam
         dbtRowKey = (E.^. ExamId)
-        dbtProj = return
+        dbtProj = dbtProjFilteredPostId
         dbtColonnade = dbColonnade . mconcat $ catMaybes
           [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
           , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
@@ -61,7 +61,7 @@ mkExamTable (Entity cid Course{..}) = do
                     E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
             )
           ]
-        dbtFilter = singletonMap "may-read" . FilterProjected $
+        dbtFilter = singletonMap "may-read" . mkFilterProjectedPost $
           \(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
            -> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
         dbtFilterUI = const mempty

src/Handler/Exam/Users.hs

@@ -454,7 +454,7 @@ postEUsersR tid ssh csh examn = do
 
             return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote)
           dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+          dbtProj = dbtProjSimple . runReaderT $
             (,,,,,,,)
               <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
               <*> getExamParts

src/Handler/ExamOffice/Exam.hs

@@ -302,8 +302,8 @@ postEGradesR tid ssh csh examn = do
             return (examResult, user, occurrence, examRegistration, isSynced)
           dbtRowKey = views queryExamResult (E.^. ExamResultId)
 
-          dbtProj :: DBRow _ -> DB ExamUserTableData
+          dbtProj :: _ ExamUserTableData
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+          dbtProj = dbtProjSimple . runReaderT $
             (,,,,,,)
               <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
               <*> getSynchronised

src/Handler/ExamOffice/Exams.hs

@@ -18,6 +18,22 @@ import qualified Colonnade
 import qualified Data.Conduit.Combinators as C
 
 
+data ExamsTableFilterProj = ExamsTableFilterProj
+  { etProjFilterMayAccess :: Maybe Bool
+  , etProjFilterHasResults :: Maybe Bool
+  , etProjFilterIsSynced :: Maybe Bool
+  }
+
+instance Default ExamsTableFilterProj where
+  def = ExamsTableFilterProj
+    { etProjFilterMayAccess = Nothing
+    , etProjFilterHasResults = Nothing
+    , etProjFilterIsSynced = Nothing
+    }
+
+makeLenses_ ''ExamsTableFilterProj
+
+
 type ExamsTableExpr = (               E.SqlExpr (Maybe (Entity Exam))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity Course))
                         `E.InnerJoin` E.SqlExpr (Maybe (Entity School))
@@ -101,12 +117,33 @@ getEOExamsR = do
             return (exam, course, school, externalExam)
           dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
 
-          dbtProj :: DBRow _ -> DB ExamsTableData
+            -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+            --     | Just exam <- r ^? resultExam . _entityVal
-            exam <- view _1
+            --     , Just course <- r ^? resultCourse . _entityVal
-            course <- view _2
+            --     -> hasReadAccessTo . urlRoute $ examLink course exam
-            school <- view _3
+            --     | Just eexam <- r ^? resultExternalExam . _entityVal
-            externalExam <- view _4
+            --     -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
+            --     | otherwise
+            --     -> return $ error "Got neither exam nor externalExam in result"
+            -- , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool)
+            -- , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool)
+            -- ]
+
+          dbtProj :: _ ExamsTableData
+          dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do
+            exam <- view $ _dbtProjRow . _dbrOutput . _1
+            course <- view $ _dbtProjRow . _dbrOutput . _2
+            school <- view $ _dbtProjRow . _dbrOutput . _3
+            externalExam <- view $ _dbtProjRow . _dbrOutput . _4
+
+            forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if
+              | Just (Entity _ exam') <- exam
+              , Just (Entity _ course') <- course
+                -> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ examLink course' exam'
+              | Just (Entity _ eexam) <- externalExam
+                -> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ externalExamLink eexam
+              | otherwise
+                -> error "Got neither exam nor externalExam in result"
 
             let
               getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do
@@ -119,7 +156,12 @@ getEOExamsR = do
                 return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult
               getResults = getExamResults >> getExternalExamResults
               foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1)
-            (Sum resultCount, Sum syncedCount) <- lift . runConduit $ getResults .| C.foldMap foldResult
+            (Sum resultCount, Sum syncedCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult
+
+            forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b ->
+              guard $ b == (resultCount > 0)
+            forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b ->
+              guard $ b == (syncedCount >= resultCount)
 
             case (exam, course, school, externalExam) of
               (Just exam', Just course', Just school', Nothing) -> return
@@ -189,16 +231,9 @@ getEOExamsR = do
             ]
 
           dbtFilter = mconcat
-            [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
+            [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny
-                | Just exam <- r ^? resultExam . _entityVal
+            , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny
-                , Just course <- r ^? resultCourse . _entityVal
+            , singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny
-                -> hasReadAccessTo . urlRoute $ examLink course exam
-                | Just eexam <- r ^? resultExternalExam . _entityVal
-                -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
-                | otherwise
-                -> return $ error "Got neither exam nor externalExam in result"
-            , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool)
-            , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool)
             ]
           dbtFilterUI = mconcat
             [ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised)

src/Handler/ExternalExam/List.hs

@@ -46,7 +46,7 @@ getEExamListR = do
 
           return (eexam, school)
         dbtRowKey = queryEExam >>> (E.^. ExternalExamId)
-        dbtProj = return
+        dbtProj = dbtProjFilteredPostId
         dbtColonnade = widgetColonnade $ mconcat
           [ sortable (Just "term") (i18nCell MsgTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm
           , sortable (Just "school") (i18nCell MsgSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName
@@ -60,7 +60,7 @@ getEExamListR = do
           , ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName))
           ]
         dbtFilter = mconcat
-          [ singletonMap "may-access" . FilterProjected $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
+          [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
               hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool
           ]
         dbtFilterUI = const mempty

src/Handler/Material.hs

@@ -111,7 +111,7 @@ getMaterialListR tid ssh csh = do
                 E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
           return (material, filesNum)
       , dbtRowKey    = (E.^. MaterialId)
-      , dbtProj      = return
+      , dbtProj      = dbtProjFilteredPostId
       , dbtColonnade = widgetColonnade $ mconcat
             [ -- dbRow,
               sortable (Just "type") (i18nCell MsgMaterialType)
@@ -138,7 +138,7 @@ getMaterialListR tid ssh csh = do
             , ( "last-edit"    , SortColumn (E.^. MaterialLastEdit)    )
             ]
       , dbtFilter    = mconcat
-        [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
+        [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr
             -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
         ]
       , dbtFilterUI  = mempty
@@ -237,7 +237,7 @@ getMShowR tid ssh csh mnm = do
                     in anchorCellM matLink wgt
             , materialModDateCol  (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
             ]
-      , dbtProj     = return
+      , dbtProj     = dbtProjId
       , dbtStyle    = def
       , dbtParams   = def
       , dbtFilter   = mempty

src/Handler/News.hs

@@ -161,7 +161,7 @@ newsUpcomingSheets uid = do
     { dbtSQLQuery  = tableData
     , dbtRowKey    = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
     , dbtColonnade = colonnade
-    , dbtProj      = return
+    , dbtProj      = dbtProjFilteredPostId
     , dbtSorting   = Map.fromList
                       [ ( "term"
                         , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
@@ -183,7 +183,7 @@ newsUpcomingSheets uid = do
                         )
                       ]
     , dbtFilter    =  mconcat
-          [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+          [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
               let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
                                                                                             , E.Value SchoolId
                                                                                             , E.Value CourseShorthand
@@ -252,7 +252,7 @@ newsUpcomingExams uid = do
                      E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden)
             return (course, exam, register, occurrence, showRoom)
           dbtRowKey = queryExam >>> (E.^. ExamId)
-          dbtProj = return
+          dbtProj = dbtProjFilteredPostId
           dbtColonnade = dbColonnade $ mconcat
             [ sortable (Just "term") (i18nCell MsgTerm)           $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
                 msgCell courseTerm
@@ -323,7 +323,7 @@ newsUpcomingExams uid = do
               ))
             ]
           dbtFilter = mconcat
-            [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+            [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
                 let Entity _ Exam{..}   = view lensExam   dbrOutput
                     Entity _ Course{..} = view lensCourse dbrOutput
                 in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool

src/Handler/Profile.hs

@@ -504,7 +504,7 @@ mkOwnedCoursesTable =
                  , course E.^. CourseShorthand
                  )
       dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
-      dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
+      dbtProj = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
 
       dbtColonnade = mconcat
           [ sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
@@ -556,7 +556,7 @@ mkEnrolledCoursesTable =
                E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
           return (course, participant E.^. CourseParticipantRegistration)
       , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
-      , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
+      , dbtProj      = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
       , dbtColonnade = mconcat
           [ sortable (Just "term") (i18nCell MsgTerm) $
               termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
@@ -620,10 +620,10 @@ mkSubmissionTable =
               E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val (Just uid)
           return . E.max_ $ subEdit E.^. SubmissionEditTime
 
-      dbtProj x = return $ x
+      dbtProj = dbtProjId
-        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+        <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
-        & _dbrOutput . _2 %~ E.unValue
+        <&> _dbrOutput . _2 %~ E.unValue
-        & _dbrOutput . _4 %~ E.unValue
+        <&> _dbrOutput . _4 %~ E.unValue
 
       dbtColonnade = mconcat
         [ sortable (Just "term") (i18nCell MsgTerm) $
@@ -697,8 +697,8 @@ mkSubmissionGroupTable =
         return (crse, sgroup)
       dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
 
-      dbtProj x = return $ x
+      dbtProj = dbtProjId
-        & _dbrOutput . _1 %~ $(E.unValueN 3)
+        <&> _dbrOutput . _1 %~ $(E.unValueN 3)
 
       dbtColonnade = mconcat
         [ sortable (Just "term") (i18nCell MsgTerm) $
@@ -764,9 +764,9 @@ mkCorrectionsTable =
         return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
       dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
 
-      dbtProj x = return $ x
+      dbtProj = dbtProjId
-        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+        <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
-        & _dbrOutput . _2 %~ E.unValue
+        <&> _dbrOutput . _2 %~ E.unValue
 
       dbtColonnade = mconcat
         [ sortable (Just "term") (i18nCell MsgTerm) $

src/Handler/School.hs

@@ -19,8 +19,7 @@ getSchoolListR = do
     dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
     dbtSQLQuery = return
 
-    dbtProj :: DBRow _ -> DB (DBRow (Entity School))
+    dbtProj = dbtProjId
-    dbtProj = return
 
     dbtRowKey = (E.^. SchoolId)
 

src/Handler/Sheet/List.hs

@@ -129,7 +129,7 @@ getSheetListR tid ssh csh = do
                                 )
                           return (sheet, lastSheetEdit sheet, submission, existFiles)
       , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
-      , dbtProj = return
+      , dbtProj = dbtProjFilteredPostId
       , dbtSorting   = Map.fromList
         [ ( "name"
           , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@@ -157,11 +157,11 @@ getSheetListR tid ssh csh = do
   --         )
         ]
       , dbtFilter    = mconcat
-        [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+        [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
             let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
              in (== b) <$> sheetFilter sheetName :: DB Bool
         , singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission
-        , singletonMap "is-exam" . FilterProjected $ \(Any b) DBRow{..} ->
+        , singletonMap "is-exam" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
             let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
              in return $ is _ExamPartPoints sheetType == b :: DB Bool
         ]

src/Handler/Sheet/Show.hs

@@ -71,12 +71,11 @@ getSShowR tid ssh csh shn = do
     { dbtSQLQuery = fileData
     , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
     , dbtColonnade = colonnadeFiles
-    , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
+    , dbtProj = (dbrOutput :: _ -> (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))) <$> dbtProjFilteredPostId
     , dbtStyle = def
     , dbtFilter = mconcat
-        [ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
+        [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{ dbrOutput = (E.Value fName, _ :: E.Value UTCTime, E.Value fType, _ :: E.Value (Maybe FileContentReference)) } ->
-            let (E.Value fName, _, E.Value fType, _) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
+            (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
-             in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
         ]
     , dbtFilterUI = mempty
     , dbtIdent = "files" :: Text

src/Handler/Submission/Helper.hs

@@ -545,7 +545,7 @@ submissionHelper tid ssh csh shn mcid = do
         { dbtSQLQuery = submissionFiles smid
         , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
         , dbtColonnade = colonnadeFiles cid
-        , dbtProj = return . dbrOutput
+        , dbtProj = dbrOutput <$> dbtProjId
         , dbtStyle = def
         , dbtIdent = "files" :: Text
         , dbtSorting = Map.fromList

src/Handler/Submission/List.hs

@@ -37,6 +37,17 @@ import Database.Persist.Sql (updateWhereCount)
 import Data.List (genericLength)
 
 
+newtype CorrectionTableFilterProj = CorrectionTableFilterProj
+  { corrProjFilterSubmission :: Maybe (Set [CI Char])
+  }
+
+instance Default CorrectionTableFilterProj where
+  def = CorrectionTableFilterProj
+    { corrProjFilterSubmission = Nothing
+    }
+
+makeLenses_ ''CorrectionTableFilterProj
+  
 type CorrectionTableExpr  = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
 type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
 type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
@@ -225,9 +236,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
                         )
             in (submission, sheet, crse, corrector, lastEditQuery submission)
           )
-      dbtProj :: DBRow _ -> DB CorrectionTableData
+      dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
-      dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector,  E.Value mbLastEdit) -> do
+        (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector,  E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput
-        submittors <- E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
+        cid <- encrypt sId
+        forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
+          let haystack = map CI.mk . unpack $ toPathPiece cid
+           in guard $ any (`isInfixOf` haystack) criteria
+
+        submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
           E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
            E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
@@ -238,13 +254,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
                 E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
                 E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
                 return . E.just $ submissionGroup E.^. SubmissionGroupName
+
           return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
         let
           submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
-        nonAnonymousAccess <- or2M
+        nonAnonymousAccess <- lift . lift $ or2M
           (return $ not sheetAnonymousCorrection)
           (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
-        cid <- encrypt sId
+
         return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
   dbTable psValidator DBTable
     { dbtSQLQuery
@@ -397,10 +414,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams
             Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
         )
       , ( "submission"
-        , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
+        , FilterProjected (_corrProjFilterSubmission ?~)
-            let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
+        -- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
-                criteria' = map CI.mk . unpack <$> Set.toList criteria
+        --     let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
-             in any (`isInfixOf` cid) criteria'
+        --         criteria' = map CI.mk . unpack <$> Set.toList criteria
+        --      in any (`isInfixOf` cid) criteria'
         )
       ]
     , dbtFilterUI  = fromMaybe mempty dbtFilterUI
@@ -662,7 +680,7 @@ postCorrectionsR = do
         courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
         optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
       termOptions = runDB $ do
-        courses <- selectList [] [Asc CourseTerm]      >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
+        courses <- selectList [] [Desc CourseTerm]      >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
         optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
       schoolOptions = runDB $ do
         courses <- selectList [] [Asc CourseSchool]    >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
@@ -671,8 +689,8 @@ postCorrectionsR = do
       psValidator = def
         & restrictCorrector
         & restrictAnonymous
-        & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
+        & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ]
-        -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
+        & defaultFilter (singletonMap "israted" [toPathPiece False])
   correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
     [ downloadAction
     ]

src/Handler/SystemMessage.hs

@@ -184,12 +184,8 @@ postMessageListR = do
               Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
             in cell . toWidget $ fromMaybe content summary
       ]
-    dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
+    dbtProj = dbtProjSimple $ \smE@(Entity smId _) ->
-      smT <- (>>= view _2) <$> getSystemMessage smId
+      (smE, ) . (>>= view _2) <$> getSystemMessage smId
-      return DBRow
-        { dbrOutput = (smE, smT)
-        , ..
-        }
     psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
   (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
     { dbtSQLQuery

src/Handler/Term.hs

@@ -76,7 +76,7 @@ getTermShowR = do
                           E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
                             E.&&. mayViewCourse muid ata now course Nothing
                 dbtRowKey = (E.^. TermId)
-                dbtProj = return . dbrOutput
+                dbtProj = dbrOutput <$> dbtProjId
                 dbtColonnade = widgetColonnade $ mconcat
                   [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
                       -> cell $ do

src/Handler/Tutorial/List.hs

@@ -38,7 +38,7 @@ getCTutorialListR tid ssh csh = do
                    E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
           return (tutorial, participants, showRoom)
         dbtRowKey = (E.^. TutorialId)
-        dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue
+        dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId
         dbtColonnade = dbColonnade $ mconcat
           [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
           , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]

src/Handler/Users.hs

@@ -143,7 +143,7 @@ postUsersR = do
       { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
       , dbtRowKey = (E.^. UserId)
       , dbtColonnade
-      , dbtProj      = return
+      , dbtProj      = dbtProjId
       , dbtSorting   = Map.fromList
           [ ( "name"
             , SortColumn $ \user -> user E.^. UserSurname

src/Handler/Utils/ExternalExam/Users.hs

@@ -215,8 +215,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
       return (result, user, isSynced)
     dbtRowKey = views queryResult (E.^. ExternalExamResultId)
 
-    dbtProj :: DBRow _ -> DB ExternalExamUserTableData
+    dbtProj :: _ ExternalExamUserTableData
-    dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+    dbtProj = dbtProjSimple . runReaderT $
       (,,,,)
         <$> view _1 <*> view _2 <*> view (_3 . _Value)
         <*> getSynchronised

src/Handler/Utils/Table/Columns.hs

@@ -70,10 +70,10 @@ type OpticSortColumn' focus
 type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
 
 type OpticFilterColumn' t inp focus
-  = forall r' filterMap.
+  = forall fs filterMap.
        ( IsMap filterMap
        , ContainerKey filterMap ~ FilterKey
-       , MapValue filterMap ~ FilterColumn t r'
+       , MapValue filterMap ~ FilterColumn t fs
        , IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
        )
     => (forall focus'. Getting focus' t focus)
@@ -500,37 +500,37 @@ defaultSortingByName =
   defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
 
 -- | Alias for sortUserName for consistency
-fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t r')
+fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs)
 fltrUserNameLink = fltrUserName
 
 fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t r')
+  -> (d, FilterColumn t fs)
 fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
   where
     queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t r')
+  -> (d, FilterColumn t fs)
 fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
   where
     queryName = queryUser >>> (E.^. UserDisplayName)
 
 fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t r')
+  -> (d, FilterColumn t fs)
 fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
 
 fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
   => (a -> E.SqlExpr (Entity User))
-  -> (d, FilterColumn t r')
+  -> (d, FilterColumn t fs)
 fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
 
 -- | Search all names, i.e. DisplayName, Surname, EMail
 fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
    => (a -> E.SqlExpr (Entity User))
-   -> (d, FilterColumn t r')
+   -> (d, FilterColumn t fs)
 fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
     [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
     , mkContainsFilter $ queryUser >>> (E.^. UserSurname)
@@ -579,7 +579,7 @@ fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo
                       , IsString d
                       )
                    => (a -> E.SqlExpr (Entity User))
-                   -> (d, FilterColumn t r')
+                   -> (d, FilterColumn t fs)
 fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
 
 fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -599,7 +599,7 @@ fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bo
                  , IsString d
                  )
               => (a -> E.SqlExpr (Entity User))
-              -> (d, FilterColumn t r')
+              -> (d, FilterColumn t fs)
 fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
 
 fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -724,7 +724,7 @@ fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value B
                         , IsString d
                         )
                      => (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
-                     -> (d, FilterColumn t r')
+                     -> (d, FilterColumn t fs)
 fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
 
 fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -742,7 +742,7 @@ fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
              , IsString d
              )
           => (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
-          -> (d, FilterColumn t r')
+          -> (d, FilterColumn t fs)
 fltrField queryFeatures = ( "terms"
                           , FilterColumn $ anyFilter
                             [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
@@ -763,10 +763,10 @@ sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -
 sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
 
 fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
-             , IsString d
+              , IsString d
-             )
+              )
-          => (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
+           => (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
-          -> (d, FilterColumn t r')
+           -> (d, FilterColumn t fs)
 fltrDegree queryFeatures = ( "degree"
                           , FilterColumn $ anyFilter
                             [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)

src/Handler/Utils/Table/Pagination.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Handler.Utils.Table.Pagination
   ( module Handler.Utils.Table.Pagination.Types
@@ -7,14 +8,19 @@ module Handler.Utils.Table.Pagination
   , SortColumn(..), SortDirection(..)
   , SortingSetting(..)
   , pattern SortAscBy, pattern SortDescBy
-  , FilterColumn(..), IsFilterColumn
+  , FilterColumn(..), IsFilterColumn, IsFilterProjected
+  , mkFilterProjectedPost
+  , DBTProjFilterPost(..)
   , DBRow(..), _dbrOutput, _dbrCount
   , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
   , module Handler.Utils.Table.Pagination.CsvColumnExplanations
   , DBCsvActionMode(..)
   , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
   , DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..)
+  , DBTProjCtx(..), _dbtProjFilter, _dbtProjRow, _dbtProjRow'
   , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..)
+  , dbtProjId, dbtProjSimple
+  , dbtProjFilteredPostId, dbtProjFilteredPostSimple
   , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM
   , withCsvExtraRep
   , singletonFilter
@@ -200,16 +206,50 @@ pattern SortDescBy :: SortingKey -> SortingSetting
 pattern SortDescBy key = SortingSetting key SortDesc
 
 
-data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a
+type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
-                       | forall a. IsFilterProjected r' a => FilterProjected a
+data DBRow r = forall k'. DBTableKey k' => DBRow
+  { dbrKey :: k'
+  , dbrOutput :: r
+  , dbrCount :: Int64
+  }
 
-filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
+makeLenses_ ''DBRow
+
+instance Functor DBRow where
+  fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
+
+instance Foldable DBRow where
+  foldMap f DBRow{..} = f dbrOutput
+
+instance Traversable DBRow where
+  traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount
+
+
+newtype DBTProjFilterPost r' = DBTProjFilterPost { unDBTProjFilterPost :: r' -> DB Bool }
+
+instance Default (DBTProjFilterPost r') where
+  def = mempty
+
+instance Semigroup (DBTProjFilterPost r') where
+  DBTProjFilterPost f <> DBTProjFilterPost g = DBTProjFilterPost $ \r' -> f r' `and2M` g r'
+
+instance Monoid (DBTProjFilterPost r') where
+  mempty = DBTProjFilterPost . const $ return True
+
+
+data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
+                       | forall a. IsFilterProjected fs a => FilterProjected a
+
+filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
 filterColumn (FilterColumn f) = Just $ filterColumn' f
 filterColumn  _               = Nothing
 
-filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
+filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs)
-filterProjected (FilterProjected f) = flip $ filterProjected' f
+filterProjected (FilterProjected f) = filterProjected' f
-filterProjected  _                  = \_ _ -> return True
+filterProjected  _                  = const id
+
+mkFilterProjectedPost :: forall r' a t. IsFilterProjectedPost r' a => a -> FilterColumn t (DBTProjFilterPost r')
+mkFilterProjectedPost fin = FilterProjected $ \(ts :: [Text]) -> (<> filterProjectedPost' @r' fin ts)
 
 class IsFilterColumn t a where
   filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
@@ -223,21 +263,33 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
 instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
   filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
   
-class IsFilterProjected r' a where
+class IsFilterProjected fs a where
-  filterProjected' :: a -> [Text] -> r' -> DB Bool
+  filterProjected' :: a -> [Text] -> (fs -> fs)
 
-instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
+instance IsFilterProjected fs (fs -> fs) where
-  filterProjected' fin _ _ = fin
+  filterProjected' fin _ = fin
 
-instance IsFilterProjected r' Bool where
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected fs cont, MonoPointed l, Monoid l) => IsFilterProjected fs (l -> cont) where
-  filterProjected' fin _ _ = return fin
-
-instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
-  filterProjected' cont is' r = filterProjected' (cont r) is' r
-
-instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
   filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
 
+class IsFilterProjectedPost r' a where
+  filterProjectedPost' :: a -> [Text] -> DBTProjFilterPost r'
+
+instance IsFilterProjectedPost r' Bool where
+  filterProjectedPost' fin _ = DBTProjFilterPost . const $ return fin
+
+instance IsFilterProjectedPost r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
+  filterProjectedPost' fin _ = DBTProjFilterPost $ const fin
+
+instance IsFilterProjectedPost r' (DBTProjFilterPost r') where
+  filterProjectedPost' fin _ = fin
+
+instance IsFilterProjectedPost r' cont => IsFilterProjectedPost r' (r' -> cont) where
+  filterProjectedPost' cont is' = DBTProjFilterPost $ \r' -> let DBTProjFilterPost cont' = filterProjectedPost' (cont r') is' in cont' r'
+
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjectedPost r' cont, MonoPointed l, Monoid l) => IsFilterProjectedPost r' (l -> cont) where
+  filterProjectedPost' cont is' = filterProjectedPost' (cont $ is' ^. mono' _PathPiece) is'
+
 
 data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
   deriving (Eq, Ord, Read, Show, Generic)
@@ -431,24 +483,17 @@ makeLenses_ ''DBCsvException
 
 instance (Typeable k', Show k') => Exception (DBCsvException k')
 
-
+  
-type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k')
+data DBTProjCtx fs r = DBTProjCtx
-data DBRow r = forall k'. DBTableKey k' => DBRow
+  { dbtProjFilter :: fs
-  { dbrKey :: k'
+  , dbtProjRow :: DBRow r
-  , dbrOutput :: r
-  , dbrCount :: Int64
   }
 
-makeLenses_ ''DBRow
+makeLenses_ ''DBTProjCtx
 
-instance Functor DBRow where
+_dbtProjRow' :: Lens' (DBTProjCtx () r) (DBRow r)
-  fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
+_dbtProjRow' = _dbtProjRow
 
-instance Foldable DBRow where
-  foldMap f DBRow{..} = f dbrOutput
-
-instance Traversable DBRow where
-  traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount
 
 newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
 
@@ -579,7 +624,7 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
       fromInner = maybe Map.empty $ Map.singleton key . pure
       fromOuter = Map.lookup key >=> listToMaybe
 
-
+  
 data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
   ( ToNamedRecord csv, CsvColumnsExplained csv
   , DBTableKey k'
@@ -628,19 +673,20 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
   , dbtCsvRenderException :: csvException -> DB Text
   }
 
-data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar).
+data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar) fs.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
   , E.From t
   , AsCornice h p r' (DBCell m x) colonnade
+  , Default fs
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
-  , dbtProj :: DBRow r -> DB r'
+  , dbtProj :: ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
   , dbtColonnade :: colonnade
   , dbtSorting :: Map SortingKey (SortColumn t r')
-  , dbtFilter :: Map FilterKey (FilterColumn t r')
+  , dbtFilter :: Map FilterKey (FilterColumn t fs)
   , dbtFilterUI :: DBFilterUI
   , dbtStyle :: DBStyle r'
   , dbtParams :: DBParams m x
@@ -652,6 +698,50 @@ data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar).
 
 type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
 
+dbtProjId' :: forall fs r r'.
+              DBRow r ~ r'
+           => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjId' = view _dbtProjRow
+
+dbtProjId :: forall fs r r'.
+             ( fs ~ (), DBRow r ~ r' )
+          => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjId = dbtProjId'
+  
+dbtProjSimple' :: forall fs r r' r''.
+                  DBRow r'' ~ r'
+               => (r -> DB r'')
+               -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask
+
+dbtProjSimple :: forall fs r r' r''.
+                 ( fs ~ (), DBRow r'' ~ r' )
+              => (r -> DB r'')
+              -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjSimple = dbtProjSimple'
+
+withFilteredPost :: forall fs r r'.
+                    fs ~ DBTProjFilterPost r'
+                 => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+                 -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+withFilteredPost proj = do
+  r' <- proj
+  p <- views _dbtProjFilter unDBTProjFilterPost
+  guardM . lift . lift $ p r'
+  return r'
+
+dbtProjFilteredPostId :: forall fs r r'.
+                         ( fs ~ DBTProjFilterPost r', DBRow r ~ r' )
+                      => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjFilteredPostId = withFilteredPost dbtProjId'
+
+dbtProjFilteredPostSimple :: forall fs r r' r''.
+                             ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
+                          => (r -> DB r'')
+                          -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
+dbtProjFilteredPostSimple = withFilteredPost . dbtProjSimple'
+
+
 noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
 noCsvEncode = Nothing
 
@@ -1115,7 +1205,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
         | otherwise
         = id
 
-      allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'
+      dbtProjFilter = ala Endo foldMap (psFilter' <&> \(f, args) -> filterProjected f args) def
 
       sortProjected
         | is _Just previousKeys
@@ -1130,7 +1220,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           adjustOrder SortDesc EQ = EQ
           adjustOrder SortDesc GT = LT
 
-  (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
+  (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (\dbtProjRow -> runReaderT dbtProj DBTProjCtx{..}) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
 
   csvExample <- runMaybeT $ do
     DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode

src/Handler/Utils/Workflow/EdgeForm.hs

@@ -73,6 +73,7 @@ workflowEdgeForm :: ( MonadHandler m
                     , MonadHandler m'
                     , HandlerSite m' ~ UniWorX
                     , MonadUnliftIO m'
+                    , MonadThrow m'
                     )
                  => Either WorkflowInstanceId WorkflowWorkflowId
                  -> Maybe WorkflowEdgeForm
@@ -80,7 +81,7 @@ workflowEdgeForm :: ( MonadHandler m
 workflowEdgeForm mwwId mPrev = runMaybeT $ do
   MsgRenderer mr <- getMsgRenderer
 
-  ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
+  ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getWorkflowWorkflowState) mwwId
   let (scope, sharedGraphId) = case ctx' of
         Left  (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope
                                                  , workflowInstanceGraph

src/Handler/Utils/Workflow/Workflow.hs

@@ -97,4 +97,3 @@ sourceWorkflowActionInfos wwId wState = do
   let authCheck WorkflowActionInfo{..}
         = mayViewWorkflowAction mAuthId wwId waiAction
   yieldMany (workflowActionInfos wState) .| C.filterM authCheck
-    

src/Handler/Workflow/Definition/List.hs

@@ -66,7 +66,7 @@ getAdminWorkflowDefinitionListR = do
 
             return (workflowDefinition, workflowInstanceCount, workflowCount)
           dbtRowKey = (E.^. WorkflowDefinitionId)
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+          dbtProj = dbtProjFilteredPostSimple . runReaderT $ do
             wd@(Entity wdId _) <- view _1
             descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do
               E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId
@@ -116,8 +116,8 @@ getAdminWorkflowDefinitionListR = do
           dbtFilter = mconcat
             [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName)
             , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope)
-            , singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
+            , singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
-            , singletonMap "instance-title" . FilterProjected $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
+            , singletonMap "instance-title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts
             ]
           dbtFilterUI mPrev = mconcat
             [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName)

src/Handler/Workflow/Instance/List.hs

@@ -75,11 +75,8 @@ getAdminWorkflowInstanceListR = do
           
               return (workflowInstance, workflowCount)
             dbtRowKey = (E.^. WorkflowInstanceId)
-            dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+            dbtProj = dbtProjFilteredPostSimple $ \(wi@(Entity wiId _), E.Value iCount) ->
-              wi@(Entity wiId _) <- view _1
+              (wi, , iCount) <$> selectWorkflowInstanceDescription wiId
-              desc <- lift $ selectWorkflowInstanceDescription wiId
-              (wi, desc,)
-                <$> view (_2 . _Value)
             dbtColonnade :: Colonnade Sortable WorkflowInstanceData _
             dbtColonnade = mconcat
               [ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n
@@ -105,7 +102,7 @@ getAdminWorkflowInstanceListR = do
             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
+              , singletonMap "title" . mkFilterProjectedPost $ \(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)

src/Handler/Workflow/Workflow/List.hs

@@ -35,10 +35,28 @@ import Data.Semigroup (Last(..))
 import qualified Data.Monoid as Monoid (Last(..))
 
 import Control.Monad.Trans.Writer.Strict (WriterT)
-import Control.Monad.Trans.State.Strict (execStateT)
+-- import Control.Monad.Trans.State.Strict (execStateT)
-import qualified Control.Monad.State.Class as State
+-- import qualified Control.Monad.State.Class as State
 
-import qualified Data.RFC5051 as RFC5051
+-- import qualified Data.RFC5051 as RFC5051
+
+
+data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj 
+  { wwProjFilterMayAccess :: Maybe Bool
+  , wwProjFilterWorkflowWorkflow :: Maybe [[CI Char]]
+  , wwProjFilterCurrentState :: Maybe [[CI Char]]
+  , wwProjFilterFinal :: Maybe Bool
+  }
+
+instance Default WorkflowWorkflowListFilterProj where
+  def = WorkflowWorkflowListFilterProj 
+    { wwProjFilterMayAccess = Nothing
+    , wwProjFilterWorkflowWorkflow = Nothing
+    , wwProjFilterCurrentState = Nothing
+    , wwProjFilterFinal = Nothing
+    }
+
+makeLenses_ ''WorkflowWorkflowListFilterProj 
 
 
 getGlobalWorkflowWorkflowListR :: Handler Html
@@ -186,8 +204,8 @@ resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescrip
 resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData)
 resultLastAction = _dbrOutput . _6
 
-resultPersons :: Traversal' WorkflowWorkflowData (Entity User)
+-- resultPersons :: Traversal' WorkflowWorkflowData (Entity User)
-resultPersons = _dbrOutput . _7 . traverse
+-- resultPersons = _dbrOutput . _7 . traverse
 
 actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text)
 actionTo = _1
@@ -231,15 +249,24 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
             lift <=< asks $ E.where_ . sqlPred
             return (workflowWorkflow, workflowInstance)
           dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId)
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
+          dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
-            ww@(Entity wwId WorkflowWorkflow{..}) <- view _1
+            ww@(Entity wwId WorkflowWorkflow{..}) <- view $ _dbtProjRow . _dbrOutput . _1
-            mwi <- view _2
+            mwi <- view $ _dbtProjRow . _dbrOutput . _2
-            wiDesc <- lift . runMaybeT $ do
+
+            cID <- encrypt wwId
+            forMM_ (view $ _dbtProjFilter . _wwProjFilterWorkflowWorkflow) $ \criteria ->
+              let haystack = map CI.mk . unpack $ toPathPiece cID
+               in guard $ any (`isInfixOf` haystack) criteria
+  
+            rScope <- lift . lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
+            forMM_ (view $ _dbtProjFilter . _wwProjFilterMayAccess) $ \needle -> do
+              rScope' <- hoistMaybe rScope
+              guardM . lift . lift $ (== needle) . is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)) False
+  
+            wiDesc <- lift . lift . $cachedHereBinary (entityKey <$> mwi) . runMaybeT $ do
               Entity wiId _ <- hoistMaybe mwi
               MaybeT $ selectWorkflowInstanceDescription wiId
-            cID <- encrypt wwId
+            WorkflowGraph{..} <- lift . lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
-            rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
-            WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph
             let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool
                 hasWorkflowRole' role = maybeT (return False) $ do
                   rScope' <- hoistMaybe rScope
@@ -247,7 +274,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
                   lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False
 
             let
-              goAction p w = lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
+              goAction p w = lift . lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p
                 where
                   go Nothing = return Nothing
                   go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do
@@ -264,7 +291,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
                       | otherwise -> maybeT (return WHIAHidden) $ do
                           viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
                           guardM . lift $ anyM (otoList viewActors) hasWorkflowRole'
-                          resUser <- lift $ traverse getEntity wpUser'
+                          resUser <- lift . for wpUser' $ \uid -> $cachedHereBinary uid $ getEntity uid
                           return $ case resUser of
                             Nothing          -> WHIAOther Nothing
                             Just Nothing     -> WHIAGone
@@ -280,52 +307,53 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
                       <*> pure actFinal
             lastAct <- descAction $ re _nullable . _Snoc . swapped
 
-            persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do
+            -- persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do
-              let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes
+            --   let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes
-              guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act
+            --   guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act
-              lift . maybeT_ . hoist (zoom _1) $ do
+            --   lift . maybeT_ . hoist (zoom _1) $ do
-                viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
+            --     viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia
-                guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole'
+            --     guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole'
-                State.modify' $ Set.insert wpUser'
+            --     State.modify' $ Set.insert wpUser'
-              iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do
+            --   iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do
-                let users = setOf (typesCustom @WorkflowChildren) ps
+            --     let users = setOf (typesCustom @WorkflowChildren) ps
-                guard . not $ null users
+            --     guard . not $ null users
-                WorkflowPayloadView{..} <- hoistMaybe $ do
+            --     WorkflowPayloadView{..} <- hoistMaybe $ do
-                  WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes
+            --       WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes
-                  Map.lookup pLbl wgnPayloadView
+            --       Map.lookup pLbl wgnPayloadView
-                guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole'
+            --     guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole'
-                at pLbl ?= users
+            --     at pLbl ?= users
 
-            persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons'
+            -- persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons'
 
-            return (cID, rScope, ww, mwi, wiDesc, lastAct, persons)
+            -- return (cID, rScope, ww, mwi, wiDesc, lastAct, persons)
+            return (cID, rScope, ww, mwi, wiDesc, lastAct, error "persons")
           dbtColonnade :: Colonnade Sortable _ _
           dbtColonnade = mconcat -- TODO: columns
-            [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . toPathPiece
+            [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . (toPathPiece :: CryptoFileNameWorkflowWorkflow -> Text)
-            , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
+            -- , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x
-            , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
+            -- , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x
-            , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x ->
+            -- , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x ->
-                let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname)
+            --     let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname)
-                 in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+            --      in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
-            , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell
+            -- , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell
-            , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell
+            -- , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell
-            , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell
+            -- , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell
             ]
             where
-              personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded)))
+            --   personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded)))
-                       <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded)))
+            --            <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded)))
               
-              stateCell = \case
+            --   stateCell = \case
-                (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text)
+            --     (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text)
-                (Just n, Nothing) -> textCell n
+            --     (Just n, Nothing) -> textCell n
-                (Just n, Just fin) -> cell [whamlet|#{icon fin}&nbsp;#{n}|]
+            --     (Just n, Just fin) -> cell [whamlet|#{icon fin}&nbsp;#{n}|]
-              actorCell = \case
+            --   actorCell = \case
-                Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text)
+            --     Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text)
-                Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text)
+            --     Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text)
-                Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text)
+            --     Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text)
-                Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text)
+            --     Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text)
-                Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text)
+            --     Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text)
-                Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname
+            --     Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname
               
               anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _
               anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f
@@ -333,15 +361,15 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
                         cID <- view resultWorkflowWorkflowId
                         rScope <- hoistMaybe =<< view resultRouteScope
                         return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
-              anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f
+            -- anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f
-                where mkLink = runReaderT $ do
+            --   where mkLink = runReaderT $ do
-                        rScope <- hoistMaybe =<< view resultRouteScope
+            --           rScope <- hoistMaybe =<< view resultRouteScope
-                        return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
+            --           return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR)
-              anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f
+            -- anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f
-                where mkLink = runReaderT $ do
+            --   where mkLink = runReaderT $ do
-                        rScope <- hoistMaybe =<< view resultRouteScope
+            --           rScope <- hoistMaybe =<< view resultRouteScope
-                        win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName)
+            --           win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName)
-                        return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
+            --           return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
           dbtSorting = mconcat
             [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId
             , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope
@@ -352,23 +380,37 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
             , singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just)
             ]
           dbtFilter = mconcat
-            [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
+            [ singletonMap "workflow-workflow" . FilterProjected $ \(criteria :: Set Text) ->
-                let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
-                    criteria' = map CI.mk . unpack <$> Set.toList criteria
-                 in any (`isInfixOf` cid) criteria'
-            , singletonMap "may-access" . FilterProjected $ \x (Any b) -> fmap (== b) . maybeT (return False) $ do
-                let cID = x ^. resultWorkflowWorkflowId
-                rScope <- hoistMaybe $ x ^. resultRouteScope
-                lift . lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
-            , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
                 let criteria' = map CI.mk . unpack <$> Set.toList criteria
-                 in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
+                 in _wwProjFilterWorkflowWorkflow ?~ criteria'
-            , singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of
+            , singletonMap "current-state" . FilterProjected $ \(criteria :: Set Text) -> -- TODO
-                Nothing -> True
+                let criteria' = map CI.mk . unpack <$> Set.toList criteria
-                Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
+                 in _wwProjFilterCurrentState ?~ criteria'
-                                      && has (resultLastAction . _Just . actionFinal . _Just) x
+            , singletonMap "final" . FilterProjected $ \(criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of -- TODO
-                                in needle == val
+                Nothing -> id
+                Just needle -> _wwProjFilterFinal ?~ needle
+            , singletonMap "may-access" . FilterProjected $ \(Any criterion) -> _wwProjFilterMayAccess ?~ criterion
             ]
+            -- [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) ->
+            --     let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId
+            --         criteria' = map CI.mk . unpack <$> Set.toList criteria
+            --      in any (`isInfixOf` cid) criteria'
+            -- , 
+            
+            -- , singletonMap "may-access" . FilterPreProjected $ \(x :: DBRow (Entity WorkflowWorkflow, Maybe (Entity WorkflowInstance))) (Any b) -> fmap (== b) . maybeT (return False) $ do
+            --     let Entity wwId WorkflowWorkflow{..} = x ^. _dbrOutput . _1
+            --     cID <- encrypt wwId
+            --     rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
+            --     lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool
+            -- , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) ->
+            --     let criteria' = map CI.mk . unpack <$> Set.toList criteria
+            --      in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack)
+            -- , singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of
+            --     Nothing -> True
+            --     Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x
+            --                           && has (resultLastAction . _Just . actionFinal . _Just) x
+            --                     in needle == val
+            -- ]
           dbtFilterUI = mconcat
             [ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber)
             , flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState)
@@ -453,11 +495,11 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
   
               return JsonWorkflowWorkflow{..}
       workflowWorkflowDBTableValidator = def
-        & defaultSorting defSort
+        -- & defaultSorting defSort
         & forceFilter "may-access" (Any True)
-      defSort | wwListColumnInstance = SortAscBy "instance" : defSort'
+      -- defSort | wwListColumnInstance = SortAscBy "instance" : defSort'
-              | otherwise = defSort'
+      --         | otherwise = defSort'
-        where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"]
+      --   where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"]
      in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable
 
   siteLayoutMsg heading $ do

src/Model/Types/Workflow.hs

@@ -67,6 +67,8 @@ import Data.List (inits)
 
 import Data.RFC5051 (compareUnicode)
 
+import qualified Data.Binary as Binary
+
 
 -----  WORKFLOW GRAPH  -----
 
@@ -474,7 +476,7 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work
           (WFPBool{}, _) -> LT
           (WFPDay{}, WFPText{}) -> GT
           (WFPDay{}, WFPNumber{}) -> GT
-          (WFPDay{}, WFPDay{}) -> GT
+          (WFPDay{}, WFPBool{}) -> GT
           (WFPDay{}, _) -> LT
           (WFPFile{}, WFPText{}) -> GT
           (WFPFile{}, WFPNumber{}) -> GT
@@ -488,6 +490,7 @@ workflowPayloadSort
      (fileid -> fileid -> Ordering)
   -> (userid -> userid -> Ordering)
   -> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering)
+-- ^ @workflowPayloadSort compare compare /= compare@
 workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
   (WFPText a',   WFPText b'  ) -> compareUnicode a' b'
   (WFPText{},    _           ) -> LT
@@ -545,7 +548,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW
 
 data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser'
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable)
-  deriving anyclass (Universe, Finite, NFData)
+  deriving anyclass (Universe, Finite, NFData, Binary)
 
 type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload
 
@@ -1127,6 +1130,38 @@ instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowSc
 
 instance Binary userid => Binary (WorkflowRole userid)
 
+instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowAction fileid userid)
+instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowFieldPayloadW fileid userid) where
+  get = do
+    tag <- Binary.get
+    case tag of
+      WFPText' -> do
+        t <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPText t
+      WFPNumber' -> do
+        n <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPNumber n
+      WFPBool' -> do
+        b <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPBool b
+      WFPDay' -> do
+        d <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPDay d
+      WFPFile' -> do
+        fid <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPFile fid
+      WFPUser' -> do
+        uid <- Binary.get
+        return $ WorkflowFieldPayloadW $ WFPUser uid
+  put = \case
+    WorkflowFieldPayloadW (WFPText   t  ) -> Binary.put WFPText'   >> Binary.put t
+    WorkflowFieldPayloadW (WFPNumber n  ) -> Binary.put WFPNumber' >> Binary.put n
+    WorkflowFieldPayloadW (WFPBool   b  ) -> Binary.put WFPBool'   >> Binary.put b
+    WorkflowFieldPayloadW (WFPDay    d  ) -> Binary.put WFPDay'    >> Binary.put d
+    WorkflowFieldPayloadW (WFPFile   fid) -> Binary.put WFPFile'   >> Binary.put fid
+    WorkflowFieldPayloadW (WFPUser   uid) -> Binary.put WFPUser'   >> Binary.put uid
+    
+
 -----  TH Jail  -----
 
 makeWrapped ''WorkflowGraphReference

src/Utils.hs

@@ -7,6 +7,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
 
 -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
 import qualified Data.Foldable as Fold
+import qualified Data.Traversable as Trav
 import Data.Foldable as Utils (foldlM, foldrM)
 import Data.Monoid (First, Sum(..), Endo)
 import Data.Proxy
@@ -975,6 +976,20 @@ sortOnM :: (Ord b, Monad m)
         -> m [a]
 sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x)
 
+-- Stolen from Agda...
+
+mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b)
+mapMM f mxs = Trav.mapM f =<< mxs
+
+forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b)
+forMM = flip mapMM
+
+mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m ()
+mapMM_ f mxs = Fold.mapM_ f =<< mxs
+
+forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m ()
+forMM_ = flip mapMM_
+
 --------------
 -- Foldable --
 --------------

src/Utils/Workflow.hs

@@ -12,9 +12,12 @@ module Utils.Workflow
   , selectWorkflowInstanceDescription
   , SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph
   , insertSharedWorkflowGraph
+  , getWorkflowWorkflowState', getWorkflowWorkflowState
+  , WorkflowWorkflowStateParseException(..)
   ) where
 
 import Import.NoFoundation
+import Foundation.Type
 
 import qualified Data.CryptoID.Class.ImplicitNamespace as I
 import qualified Crypto.MAC.KMAC as Crypto
@@ -25,8 +28,11 @@ import qualified Crypto.Hash as Crypto
 import Language.Haskell.TH (nameBase)
 import qualified Data.Aeson as Aeson
 
+import Handler.Utils.Memcached
+
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Internal as E
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
@@ -49,19 +55,19 @@ _DBWorkflowScope = iso toScope' toScope
       & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey
       & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey)
 
-fromRouteWorkflowScope :: ( MonadIO m
+fromRouteWorkflowScope :: ( MonadHandler m
                           , BackendCompatible SqlReadBackend backend
                           )
                        => RouteWorkflowScope
                        -> MaybeT (ReaderT backend m) IdWorkflowScope
-fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+fromRouteWorkflowScope rScope = $cachedHereBinary rScope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
 
-toRouteWorkflowScope :: ( MonadIO m
+toRouteWorkflowScope :: ( MonadHandler m
                         , BackendCompatible SqlReadBackend backend
                         )
                      => IdWorkflowScope
                      -> MaybeT (ReaderT backend m) RouteWorkflowScope
-toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
+toRouteWorkflowScope scope = $cachedHereBinary scope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
 
 
 type IdWorkflowGraph = WorkflowGraph FileReference UserId
@@ -168,3 +174,51 @@ insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $
   where
     swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph
     swgId' = SharedWorkflowGraphKey swgId
+    
+
+newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue
+  deriving stock (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Binary)
+
+newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text
+  deriving stock (Show, Generic, Typeable)
+  deriving anyclass (Exception)
+  
+getWorkflowWorkflowState' :: forall backend m.
+                             ( MonadHandler m, HandlerSite m ~ UniWorX
+                             , BackendCompatible SqlReadBackend backend
+                             , MonadThrow m
+                             )
+                          => WorkflowWorkflowId
+                          -> Maybe WorkflowWorkflow
+                          -> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
+getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do
+  res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do
+    E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId
+    return
+      ( workflowWorkflow E.^. WorkflowWorkflowInstance
+      , workflowWorkflow E.^. WorkflowWorkflowScope
+      , workflowWorkflow E.^. WorkflowWorkflowGraph
+      , E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState
+      )
+  let
+    (   E.Value workflowWorkflowInstance
+      , E.Value workflowWorkflowScope
+      , E.Value workflowWorkflowGraph
+      , E.Value (wwState :: PersistValue) -- Don't parse
+      ) = res
+  wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState
+  case wwState' of
+    Left err -> lift . throwM $ WorkflowWorkflowStateParseException err
+    Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..}
+getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do
+  memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState
+
+getWorkflowWorkflowState :: forall backend m.
+                            ( MonadHandler m, HandlerSite m ~ UniWorX
+                            , BackendCompatible SqlReadBackend backend
+                            , MonadThrow m
+                            )
+                         => WorkflowWorkflowId
+                         -> ReaderT backend m (Maybe (Entity WorkflowWorkflow))
+getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing

test/Model/Types/WorkflowSpec.hs

@@ -160,3 +160,5 @@ spec = do
       [ eqLaws, ordLaws, jsonLaws ]
     lawsCheckHspec (Proxy @WorkflowScope')
       [ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ]
+    lawsCheckHspec (Proxy @(WorkflowFieldPayloadW FileReference SqlBackendKey))
+      [ eqLaws, ordLaws, showLaws, jsonLaws, binaryLaws ]