feat(corrections-r): authorship statement state

src/Handler/Submission/Grade.hs

@@ -62,7 +62,7 @@ postCorrectionsGradeR = do
         & restrictAnonymous
         & restrictCorrector
         & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
-      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
+      unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
 
   (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
     { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR

src/Handler/Submission/Helper.hs

@@ -31,18 +31,6 @@ import Handler.Submission.SubmissionUserInvite
 import qualified Data.Conduit.Combinators as C
 
 
-data AuthorshipStatementSubmissionState
-  = ASExists
-  | ASOldStatement
-  | ASMissing
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
-
-embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
-
-
 makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m)
                    => CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId)
                    -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget))
@@ -606,28 +594,10 @@ submissionHelper tid ssh csh shn mcid = do
 
     subUsers <- maybeT (return []) $ do
       subId <- hoistMaybe msmid
-      let
-        getUserAuthorshipStatement :: UserId
-                                   -> DB AuthorshipStatementSubmissionState
-        getUserAuthorshipStatement uid = runConduit $
-               getStmts
-            .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
-          where
-            getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
-              E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
-                   E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
-              return authorshipStatementSubmission
-            toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
-            toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
-            toRes :: Maybe Any -> AuthorshipStatementSubmissionState
-            toRes = \case
-              Just (Any True) -> ASExists
-              Just (Any False) -> ASOldStatement
-              Nothing -> ASMissing
       lift $ buddies
         & bool id (maybe id (Set.insert . Right) muid) isOwner
         & Set.toList
-        & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid)
+        & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid)
         & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1)
 
     subUsersVisible <- orM

src/Handler/Submission/List.hs

@@ -8,8 +8,9 @@ module Handler.Submission.List
   , correctionsR'
   , restrictAnonymous, restrictCorrector
   , ratedBy, courseIs, sheetIs, userIs
-  , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups
+  , resultSubmission
-  , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym
+  , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState
+  , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState
   , makeCorrectionsTable
   , CorrectionTableData, CorrectionTableWhere
   , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
@@ -33,6 +34,8 @@ import Database.Esqueleto.Utils.TH
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 
+import qualified Data.Conduit.Combinators as C
+
 import Text.Hamlet (ihamletFile)
 
 import Database.Persist.Sql (updateWhereCount)
@@ -43,12 +46,14 @@ import Data.List (genericLength)
 data CorrectionTableFilterProj = CorrectionTableFilterProj
   { corrProjFilterSubmission :: Maybe (Set [CI Char])
   , corrProjFilterPseudonym  :: Maybe (Set [CI Char])
+  , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
   }
  
 instance Default CorrectionTableFilterProj where
   def = CorrectionTableFilterProj
     { corrProjFilterSubmission = Nothing
     , corrProjFilterPseudonym  = Nothing
+    , corrProjFilterAuthorshipStatementState = Last Nothing
     }
 
 makeLenses_ ''CorrectionTableFilterProj
@@ -70,6 +75,7 @@ type CorrectionTableData = DBRow ( Entity Submission
                                  , Map UserId CorrectionTableUserData
                                  , CryptoFileNameSubmission
                                  , Bool {- Access to non-anonymous submission data -}
+                                 , Maybe AuthorshipStatementSubmissionState
                                  )
 
 
@@ -135,6 +141,9 @@ resultCryptoID = _dbrOutput . _7
 resultNonAnonymousAccess :: Lens' CorrectionTableData Bool
 resultNonAnonymousAccess = _dbrOutput . _8
 
+resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState)
+resultASState = _dbrOutput . _9
+
 
 -- Where Clauses
 ratedBy :: UserId -> CorrectionTableWhere
@@ -291,6 +300,22 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce
 colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
 colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell
 
+colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
+colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x ->
+  let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a
+      heatC s c
+        = c
+        & cellAttrs %~ addAttrsClass "heated"
+        & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|])
+      tid = x ^. resultCourseTerm
+      ssh = x ^. resultCourseSchool
+      csh = x ^. resultCourseShorthand
+      shn = x ^. resultSheet . _entityVal . _sheetName
+      cID = x ^. resultCryptoID
+      
+      asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
+   in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
+
 
 filterUICourse :: Handler (OptionList Text) -> DBFilterUI
 filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
@@ -326,7 +351,7 @@ filterUIIsAssigned :: DBFilterUI
 filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
 
 filterUISubmissionGroup :: DBFilterUI
-filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submittors-group") $ aopt textField (fslI MsgTableSubmissionGroup)
+filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup)
 
 filterUIRating :: DBFilterUI
 filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
@@ -334,6 +359,9 @@ filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathP
 filterUIComment :: DBFilterUI
 filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
 
+filterUIAuthorshipStatementState :: DBFilterUI
+filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState)
+
 
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
                      => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
@@ -368,6 +396,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
             let haystack = map CI.mk . unpack $ toPathPiece cid
              in guard $ any (`isInfixOf` haystack) criteria
 
+          mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet
+          asState <- for mASDefinition $ \_ ->
+            lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId
+
+          forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion ->
+            guard $ asState == Just criterion
+
           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)
@@ -392,7 +427,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
             (return $ not sheetAnonymousCorrection)
             (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
 
-          return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
+          return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess, asState)
         dbtRowKey = views querySubmission (E.^. SubmissionId)
         dbtSorting = mconcat
           [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
@@ -418,7 +453,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
           , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x
           , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done
           , singletonMap "last-edit" . SortColumn $ view queryLastEdit
-          , singletonMap "submission" . SortProjected . comparing $ toPathPiece . view resultCryptoID
+          , singletonMap "submission" . SortProjected . comparing $ views resultCryptoID toPathPiece
+          , singletonMap "as-state" . SortProjected . comparing $ view resultASState
           ]
         dbtFilter = mconcat
           [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
@@ -461,6 +497,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams
           , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment)
           , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~)
           , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~)
+          , singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~)
           ]
         dbtFilterUI  = fromMaybe mempty dbtFilterUI'
         dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' }
@@ -742,31 +779,41 @@ postCorrectionsR = do
 getCCorrectionsR, postCCorrectionsR ::  TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
 getCCorrectionsR = postCCorrectionsR
 postCCorrectionsR tid ssh csh = do
-  Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
+  (Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
+    course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid]
+    doAuthorshipStatements <- runConduit $
+         (E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid))
+      .| C.mapM getSheetAuthorshipStatement
+      .| C.map (is _Just)
+      .| C.or
+    return (course, doSubmissionGroups, doAuthorshipStatements)
   let whereClause :: CorrectionTableWhere
       whereClause = courseIs cid
-      colonnade = mconcat -- should match getSSubsR for consistent UX
+      colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX
-        [ colSelect
+        [ pure colSelect
-        , colSheet
+        , pure colSheet
-        , colSMatrikel
+        , pure colSMatrikel
-        , colSubmittors
+        , pure colSubmittors
-        , colSGroups
+        , guardOn doSubmissionGroups colSGroups
-        , colSubmissionLink
+        , pure colSubmissionLink
-        , colLastEdit
+        , pure colLastEdit
-        , colRating
+        , guardOn doAuthorshipStatements colAuthorshipStatementState
-        , colRated
+        , pure colRating
-        , colCorrector
+        , pure colRated
-        , colAssigned
+        , pure colCorrector
+        , pure colAssigned
         ] -- Continue here
       filterUI = Just $ mconcat
-        [ filterUIUserNameEmail
+        [ filterUISheetSearch
+        , filterUIUserNameEmail
         , filterUIUserMatrikelnummer
         , filterUIPseudonym
-        , filterUISheetSearch
+        , filterUISubmissionGroup
+        , filterUIAuthorshipStatementState
         , filterUICorrectorNameEmail
         , filterUIIsAssigned
         , filterUIIsRated
-        , filterUISubmissionGroup
         , filterUISubmission
         ]
       psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
@@ -779,28 +826,35 @@ postCCorrectionsR tid ssh csh = do
 getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
 getSSubsR = postSSubsR
 postSSubsR tid ssh csh shn = do
-  shid <- runDB $ fetchSheetId tid ssh csh shn
+  (shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
+    sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
+    doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse]
+    doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet
+    return (shid, doSubmissionGroups, doAuthorshipStatements)
   let whereClause :: CorrectionTableWhere
       whereClause = sheetIs shid
-      colonnade = mconcat -- should match getCCorrectionsR for consistent UX
+      colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX
-        [ colSelect
+        [ pure colSelect
-        , colSMatrikel
+        , pure colSMatrikel
-        , colSubmittors
+        , pure colSubmittors
-        , colSubmissionLink
+        , guardOn doSubmissionGroups colSGroups
-        , colLastEdit
+        , pure colSubmissionLink
-        , colRating
+        , pure colLastEdit
-        , colRated
+        , guardOn doAuthorshipStatements colAuthorshipStatementState
-        , colCorrector
+        , pure colRating
-        , colAssigned
+        , pure colRated
+        , pure colCorrector
+        , pure colAssigned
         ]
       filterUI = Just $ mconcat
         [ filterUIUserNameEmail
         , filterUIUserMatrikelnummer
         , filterUIPseudonym
+        , filterUISubmissionGroup
+        , filterUIAuthorshipStatementState
         , filterUICorrectorNameEmail
         , filterUIIsAssigned
         , filterUIIsRated
-        , filterUISubmissionGroup
         , filterUISubmission
         ]
       psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway

src/Handler/Utils/Submission.hs

@@ -11,6 +11,8 @@ module Handler.Utils.Submission
   , submissionMatchesSheet
   , submissionDeleteRoute
   , correctionInvisibleWidget
+  , AuthorshipStatementSubmissionState(..)
+  , getUserAuthorshipStatement, getSubmissionAuthorshipStatement
   ) where
 
 import Import hiding (joinPath)
@@ -36,6 +38,7 @@ import Handler.Utils
 import qualified Handler.Utils.Rating as Rating (extractRatings)
 import Handler.Utils.Delete
 
+import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils.TH as E
 
@@ -976,3 +979,58 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d
         tellPoint CorrectionInvisibleExamUnfinished
 
   return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")
+
+
+data AuthorshipStatementSubmissionState
+  = ASMissing
+  | ASOldStatement
+  | ASExists
+  deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max`
+
+nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
+
+embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
+
+
+getUserAuthorshipStatement :: ( MonadResource m
+                              , IsSqlBackend backend, SqlBackendCanRead backend
+                              )
+                           => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+                           -> SubmissionId
+                           -> UserId
+                           -> ReaderT backend m AuthorshipStatementSubmissionState
+getUserAuthorshipStatement mASDefinition subId uid = runConduit $
+       getStmts
+    .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
+  where
+    getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
+      E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
+           E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
+      return authorshipStatementSubmission
+    toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
+    toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
+    toRes :: Maybe Any -> AuthorshipStatementSubmissionState
+    toRes = \case
+      Just (Any True) -> ASExists
+      Just (Any False) -> ASOldStatement
+      Nothing -> ASMissing
+
+getSubmissionAuthorshipStatement :: ( MonadResource m
+                                    , IsSqlBackend backend, SqlBackendCanRead backend
+                                    )
+                                 => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+                                 -> SubmissionId
+                                 -> ReaderT backend m AuthorshipStatementSubmissionState
+getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $
+       sourceSubmissionUsers
+    .| C.map E.unValue
+    .| C.mapM getUserAuthorshipStatement'
+    .| C.maximum
+  where
+    getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId
+    sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
+      return $ submissionUser E.^. SubmissionUserUser