module Handler.Corrections where import Import hiding (link) -- import System.FilePath (takeFileName) import Jobs import Handler.Utils hiding (colSchool) import Handler.Utils.Corrections import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete -- import Handler.Utils.Zip import Data.List as List (foldl, foldr) import qualified Data.Set as Set import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -- import Data.Time -- import Data.Function ((&)) -- -- import Colonnade hiding (fromMaybe, singleton, bool) -- import Yesod.Colonnade -- -- import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.Conduit.List as C import Database.Esqueleto.Utils.TH import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Language (From) -- import qualified Database.Esqueleto.Internal.Sql as E -- import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import Network.Mime import Text.Hamlet (ihamletFile) import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) import qualified Control.Monad.State.Class as State import qualified Data.Conduit.List as C 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)) correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ whereClause t return $ returnStatement t lastEditQuery :: Database.Esqueleto.Internal.Language.From (E.SqlExpr (Entity SubmissionEdit)) => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime)) lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId return $ E.max_ $ edit E.^. SubmissionEditTime queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) querySheet :: CorrectionTableExpr -> E.SqlExpr (Entity Sheet) querySheet = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission) querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User)) queryCorrector = $(sqlLOJproj 2 2) -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) courseIs :: CourseId -> CorrectionTableWhere courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput } -> textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _) } -> courseCellCL (tid,sid,csh) colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row -> let sheet = row ^. _dbrOutput . _2 course= row ^. _dbrOutput . _3 tid = course ^. _3 ssh = course ^. _4 csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|] colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $ i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal) -- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) $ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 shn = sheetName $ entityVal sheet mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkRoute = do cid <- mkCid return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{cid}|]) colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary)) colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 link cid = CourseR tid ssh csh $ CUserR cid protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) -> anchorCellM (link <$> encrypt userId) $ case mPseudo of Nothing -> nameWidget userDisplayName userSurname Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _) } -> let csh = course ^. _2 tid = course ^. _3 ssh = course ^. _4 -- shn = sheetName mkRoute = do cid <- encrypt subId return $ CSubmissionR tid ssh csh sheetName cid CorrectionR mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this in mconcat [ anchorCellM mkRoute $(widgetFile "widgets/rating/rating") , writerCell $ do let summary :: SheetTypeSummary summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub) scribe (_2 :: Lens' (a, SheetTypeSummary) SheetTypeSummary) summary ] colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } -> maybe mempty dateTimeCell submissionRatingAssigned colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } -> maybe mempty dateTimeCell submissionRatingTime colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo -> cell [whamlet|#{review _PseudonymText pseudo}|] in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData))) colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done)) colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty) _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData))) colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _) } -> maybe mempty dateTimeCell mbLastEdit 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) makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' dbtParams = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery = correctionsTableQuery whereClause (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName) , course E.^. CourseShorthand , course E.^. CourseTerm , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) ) in (submission, sheet, crse, corrector, lastEditQuery submission) ) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerFor UniWorX)) CorrectionTableData dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do submittors <- 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 E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap) dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId , dbtColonnade , dbtProj , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) , ( "school" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool ) , ( "course" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) , ( "sheet" , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName ) , ( "corrector" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname ) , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints ) , ( "sheet-type" , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value)) , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value)) , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value)) ] ) , ( "israted" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime ) , ( "ratingtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime ) , ( "assignedtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned ) , ( "submittors" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.subSelectUnsafe . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.limit 1 return (user E.^. UserSurname) ) , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment ) , ( "last-edit" , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission ) ] , dbtFilter = Map.fromList [ ( "term" , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) , ( "school" , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) sids -> if | Set.null sids -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseSchool `E.in_` E.valList (Set.toList sids) ) , ( "course" , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) ) , ( "sheet" , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) ) , ( "sheet-search" , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) ) , ( "corrector" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) , ( "isassigned" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just True -> E.isJust $ submission E.^. SubmissionRatingBy Just False-> E.isNothing $ submission E.^. SubmissionRatingBy ) , ( "israted" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just True -> E.isJust $ submission E.^. SubmissionRatingTime Just False-> E.isNothing $ submission E.^. SubmissionRatingTime ) , ( "corrector-name-email" -- corrector filter does not work for text-filtering , FilterColumn $ E.anyFilter [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname) , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName) , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail) ] ) , ( "user-name-email" , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter [ E.mkContainsFilter (E.^. UserSurname) , E.mkContainsFilter (E.^. UserDisplayName) , E.mkContainsFilterWith CI.mk (E.^. UserEmail) ] ) , ( "user-matriclenumber" , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.where_ $ (\f -> f user $ Set.singleton needle) $ E.mkContainsFilter (E.^. UserMatrikelnummer) ) , ( "rating-visible" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just True -> E.isJust $ submission E.^. SubmissionRatingTime Just False-> E.isNothing $ submission E.^. SubmissionRatingTime ) , ( "rating" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints) ) , ( "comment" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment) ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } , dbtParams , dbtIdent = "corrections" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } data ActionCorrections = CorrDownload | CorrSetCorrector | CorrAutoSetCorrector | CorrDelete deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe ActionCorrections instance Finite ActionCorrections nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ActionCorrections id data ActionCorrectionsData = CorrDownloadData | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId | CorrDeleteData correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } ((actionRes', statistics), table) <- runDB $ makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = _1 , dbParamsFormIdent = def } -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown) -- gradingSummary <- do -- let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime) -- points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints -- -- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn [] -- return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points -- let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary -- return (tableRes, statistics) let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) & mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast auditAllSubEdit = mapM_ $ \sId -> getJust sId >>= \sub -> audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet case actionRes of FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs FormMissing -> return () FormSuccess (CorrDownloadData, subs) -> do ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|] sendResponse =<< submissionMultiArchive ids FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do subs <- mapM decrypt $ Set.toList subs' now <- liftIO getCurrentTime runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned unless (null unassignedUnauth) $ do let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth let numUnassignedUnauth = fromIntegral $ length unassignedUnauth' trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|] content = Right $(widgetFile "messages/submissionsAssignUnauthorized") addMessageModal Warning trigger content unless (null unassignedAuth) $ do let sIds = Set.toList unassignedAuth num <- updateWhereCount [SubmissionId <-. sIds] [ SubmissionRatingBy =. Just uid , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num auditAllSubEdit sIds selfCorrectors <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) . E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs E.&&. submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser) return (E.countRows :: E.SqlExpr (E.Value Int64)) when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections subs <- mapM decrypt $ Set.toList subs' runDB $ do num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingBy =. Nothing , SubmissionRatingAssigned =. Nothing , SubmissionRatingTime =. Nothing -- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector -- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector ] addMessageI Success $ MsgRemovedCorrections num auditAllSubEdit subs redirect currentRoute FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' let assignExceptions :: AssignSubmissionException -> Handler () assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion assignExceptions (SubmissionsNotFound subIds) = do subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission] let errorModal = msgModal [whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|] (Right $(widgetFile "messages/submissionsAssignNotFound")) addMessageWidget Error errorModal handle assignExceptions . runDB $ do alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned unless (null unassignedUnauth) $ do let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth let numUnassignedUnauth = fromIntegral $ length unassignedUnauth' trigger = [whamlet|_{MsgSubmissionsAssignUnauthorized numUnassignedUnauth}|] content = Right $(widgetFile "messages/submissionsAssignUnauthorized") addMessageModal Warning trigger content unless (null unassignedAuth) $ do (assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth) unless (null assigned) $ addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) unless (null stillUnassigned) $ do mr <- (toHtml . ) <$> getMessageRender unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) redirect currentRoute FormSuccess (CorrDeleteData, subs) -> do subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable getDeleteR (submissionDeleteRoute subs') { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") where authorizedToAssign :: SubmissionId -> DB Bool authorizedToAssign sId = do (E.Value tid, E.Value ssh, E.Value csh, E.Value shn) <- maybe notFound return . listToMaybe <=< E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ submission E.^. SubmissionId E.==. E.val sId return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName) cID <- encrypt sId let route = CSubmissionR tid ssh csh shn cID SubAssignR (== Authorized) <$> evalAccessDB route True type ActionCorrections' = (ActionCorrections, AForm (HandlerFor UniWorX) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload , pure CorrDownloadData ) deleteAction = ( CorrDelete , pure CorrDeleteData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do correctors <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] E.distinct $ return user correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey cId <- wopt (selectFieldList correctors' :: Field (HandlerFor UniWorX) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) autoAssignAction :: SheetId -> ActionCorrections' autoAssignAction shid = ( CorrAutoSetCorrector , pure $ CorrAutoSetCorrectorData shid ) getCorrectionsR, postCorrectionsR :: Handler TypedContent getCorrectionsR = postCorrectionsR postCorrectionsR = do uid <- requireAuthId let whereClause = ratedBy uid colonnade = mconcat [ colSelect , dbRow -- very useful, since correction statistics are still missing. , colSchool , colTerm , colCourse , colSheet , colPseudonyms , colSubmissionLink , colAssigned , colRating , colRated ] -- Continue here filterUI = Just $ \mPrev -> mconcat [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) ] courseOptions = runDB $ 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) 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) optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction ] getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR postCCorrectionsR tid ssh csh = do Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let whereClause = courseIs cid colonnade = mconcat -- should match getSSubsR for consistent UX [ colSelect , dbRow , colSheet , colSMatrikel , colSubmittors , colSubmissionLink , colLastEdit , colRating , colRated , colCorrector , colAssigned ] -- Continue here filterUI = Just $ \mPrev -> mconcat [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) -- "pseudonym" TODO DB only stores Word24 , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector) , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction ] getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR postSSubsR tid ssh csh shn = do shid <- runDB $ fetchSheetId tid ssh csh shn let whereClause = sheetIs shid colonnade = mconcat -- should match getCCorrectionsR for consistent UX [ colSelect , dbRow , colSMatrikel , colSubmittors , colSubmissionLink , colLastEdit , colRating , colRated , colCorrector , colAssigned ] filterUI = Just $ \mPrev -> mconcat [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector) , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) -- "pseudonym" TODO DB only stores Word24 ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid , deleteAction ] correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. submission E.^. SubmissionId E.==. E.val sub return (course, sheet, submission, corrector) getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getCorrectionR tid ssh csh shn cid = do mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid postCorrectionR tid ssh csh shn cid = do sub <- decrypt cid results <- runDB $ correctionData tid ssh csh shn sub MsgRenderer mr <- getMsgRenderer case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of NotGraded -> pure Nothing _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType) (Just submissionRatingPoints) ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) <*> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) let corrForm = wrapForm' BtnSave corrForm' def { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR , formEncoding = corrEncoding } ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $ areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing let uploadForm = wrapForm uploadForm' def { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR , formEncoding = uploadEncoding } formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do uid <- liftHandler requireAuthId now <- liftIO getCurrentTime if | errs <- validateRating sheetType Rating' { ratingPoints = ratingPoints' , ratingComment = ratingComment' , ratingTime = (now <$ guard rated) } , not $ null errs -> mapM_ (addMessageI Error) errs | otherwise -> do runDBJobs $ do update sub [ SubmissionRatingBy =. Just uid , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints' , SubmissionRatingComment =. ratingComment' ] addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated when (rated && isNothing submissionRatingTime) $ do $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub redirect $ CSubmissionR tid ssh csh shn cid CorrectionR formResult uploadResult $ \fileUploads -> do uid <- requireAuthId res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True case res of Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors (Just _) -> do addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR let sheetTypeDesc = mr sheetType heading = MsgCorrectionHead tid ssh csh shn cid headingWgt = [whamlet| $newline never _{heading} $if not (submissionRatingDone subm) \ ^{isVisibleWidget False} |] siteLayout headingWgt $ do setTitleI heading let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound getCorrectionUserR tid ssh csh shn cid = do sub <- decrypt cid results <- runDB $ correctionData tid ssh csh shn sub case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do mr <- getMessageRender let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) sheetTypeDesc = mr sheetType defaultLayout $ $(widgetFile "correction-user") _ -> notFound getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing case uploadRes of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True case mbSubs of Nothing -> return () (Just subs) | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) $ Set.toList subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)] let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|] content = Right $(widgetFile "messages/correctionsUploaded") addMessageModal Success trigger content let uploadForm = wrapForm upload def { formAction = Just $ SomeRoute CorrectionsUploadR , formEncoding = uploadEncoding } maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings' defaultLayout $ do let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") $(widgetFile "corrections-upload") getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ isCorrector E.||. isLecturer E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList opts = do opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts MsgRenderer mr <- getMsgRenderer return . mkOptionList $ do (cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts' let tid' = mr $ ShortTermIdentifier (unTermKey tid) return Option { optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn , optionInternalValue = sid , optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet) } MsgRenderer mr <- getMsgRenderer ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms (mr MsgPseudonyms) & setTooltip MsgCorrectionPseudonymsTip) Nothing) case pseudonymRes of FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do allDone <- fmap getAll . execWriterT $ do forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") tell . All $ null invalids WriterT . runDBJobs . mapReaderT (mapWriterT $ fmap ((,) <$> ((,) <$> view (_1 . _1) <*> view _2) <*> view (_1 . _2)) . runWriterT) $ do Sheet{..} <- get404 sid :: ReaderT SqlBackend (WriterT (Set QueuedJobId) (WriterT All (HandlerFor UniWorX))) Sheet (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText lift . lift . tell . All $ null unknown now <- liftIO getCurrentTime let sps' :: [[SheetPseudonym]] duplicate :: Set Pseudonym ( sps' , Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate ) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do known <- State.gets $ Map.member sheetPseudonymPseudonym State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1) return $ bool (p :) id known ps submissionPrototype = Submission { submissionSheet = sid , submissionRatingPoints = Nothing , submissionRatingComment = Nothing , submissionRatingBy = Just uid , submissionRatingAssigned = Just now , submissionRatingTime = Nothing } unless (null duplicate) $ addMessageModal Warning [whamlet|_{MsgSheetDuplicatePseudonym}|] $ Right $(widgetFile "messages/submissionCreateDuplicates") existingSubUsers <- E.select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps') E.&&. submission E.^. SubmissionSheet E.==. E.val sid return submissionUser unless (null existingSubUsers) . mapReaderT lift $ do (Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: _ CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers let trigger = [whamlet|_{MsgSheetCreateExisting}|] content = Right $(widgetFile "messages/submissionCreateExisting") addMessageModal Warning trigger content let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps' forM_ sps'' $ \spGroup -> let sheetGroupDesc = Text.intercalate ", " $ map (review _PseudonymText . sheetPseudonymPseudonym) spGroup in case sheetGrouping of Arbitrary maxSize -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit uid now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (genericLength spGroup > maxSize) $ addMessageI Warning $ MsgSheetGroupTooLarge sheetGroupDesc RegisteredGroups -> do let spGroup' = Map.fromList $ map (sheetPseudonymUser &&& id) spGroup groups <- E.select . E.from $ \submissionGroup -> do E.where_ . E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup) return $ submissionGroup E.^. SubmissionGroupId groupUsers <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup `E.in_` E.valList (map E.unValue groups) return $ submissionGroupUser E.^. SubmissionGroupUserUser if | [_] <- groups , Map.keysSet spGroup' `Set.isSubsetOf` groupUsers -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit uid now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser { submissionUserUser = sheetUser , submissionUserSubmission = subId } forM_ groupUsers $ \subUid -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid subId audit $ TransactionSubmissionUserEdit subId subUid when (null groups) $ addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc | length groups < 2 -> do forM_ (Set.toList (Map.keysSet spGroup' `Set.difference` groupUsers)) $ \((spGroup' !) -> SheetPseudonym{sheetPseudonymPseudonym}) -> do addMessageI Error $ MsgSheetNoRegisteredGroup (review _PseudonymText sheetPseudonymPseudonym) lift . lift . tell $ All False | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc NoGroups -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit uid now subId audit $ TransactionSubmissionEdit subId sid insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } forM_ spGroup $ \SheetPseudonym{sheetPseudonymUser} -> do hoist (hoist lift) . queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated sheetPseudonymUser subId audit $ TransactionSubmissionUserEdit subId sheetPseudonymUser when (length spGroup > 1) $ addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc when allDone $ redirect CorrectionsGradeR let pseudonymForm = wrapForm pseudonymWidget def { formAction = Just $ SomeRoute CorrectionsCreateR , formEncoding = pseudonymEncoding } siteLayoutMsg MsgCorrCreate $ do setTitleI MsgCorrCreate $(widgetFile "corrections-create") where partitionEithers' :: [[Either a b]] -> ([[b]], [a]) partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) textToList :: Textarea -> ([[Pseudonym]], Map (Text, Text) [Pseudonym]) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . map Text.strip . Text.lines . unTextarea -> ws) = runWriter . fmap (mapMaybe sequence) $ mapM (\ws' -> mapM (toPseudonym ws') ws') ws where toPseudonym w' w | Just res <- w ^? _PseudonymText = return $ Just res | otherwise = Nothing <$ tell (Map.singleton (Text.intercalate ", " w', w) $ w ^.. pseudonymFragments . _PseudonymWords) getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html getCorrectionsGradeR = postCorrectionsGradeR postCorrectionsGradeR = do uid <- requireAuthId let whereClause = ratedBy uid displayColumns = mconcat -- should match getSSubsR for consistent UX [ -- dbRow, colSchool , colTerm , colCourse , colSheet , colPseudonyms , colSubmissionLink , colRated , colRatedField , colPointsField , colMaxPointsField , colCommentField ] -- Continue here filterUI = Just $ \mPrev -> mconcat [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime) , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone) , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints) , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev)) ] courseOptions = runDB $ 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) 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) optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses psValidator = def & 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) dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do cID <- encrypt subId void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True return i (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR } case tableRes of FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess resMap -> do now <- liftIO getCurrentTime subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do s@Submission{..} <- get404 subId if | submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s -> do audit $ TransactionSubmissionEdit subId $ s ^. _submissionSheet Just subId <$ update subId [ SubmissionRatingPoints =. mPoints , SubmissionRatingComment =. mComment , SubmissionRatingBy =. Just uid , SubmissionRatingTime =. now <$ guard rated ] | otherwise -> return Nothing subs' <- traverse (\x -> (,) <$> encrypt x <*> encrypt x) subs :: Handler [(CryptoFileNameSubmission, CryptoUUIDSubmission)] let trigger = [whamlet|_{MsgCorrectionsUploaded (genericLength subs')}|] content = Right $(widgetFile "messages/correctionsUploaded") unless (null subs') $ addMessageModal Success trigger content siteLayoutMsg MsgCorrectionsGrade $ do setTitleI MsgCorrectionsGrade $(widgetFile "corrections-grade") data ButtonSubmissionsAssign = BtnSubmissionsAssign deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonSubmissionsAssign instance Finite ButtonSubmissionsAssign nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id instance Button UniWorX ButtonSubmissionsAssign where btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary] -- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int } getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh assignHandler tid ssh csh cid [] getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn = do (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn assignHandler tid ssh csh cid [shid] {- TODO: Feature: make distivt buttons for each sheet, so that users see which sheet will be assigned. Currently this information is available within the page heading! Stub: data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Button UniWorX ButtonCorrectionsAssign -- Are those needed any more? instance Universe ButtonCorrectionsAssign instance Finite ButtonCorrectionsAssign nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id instance Button UniWorX ButtonCorrectionsAssign where btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary] -- use runButtonForm' instead later on -} assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html assignHandler tid ssh csh cid assignSids = do -- evaluate form first, since it affects DB action (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions -- gather data (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList sheets = entities2map sheetList sheetIds = Map.keys sheets groupsPossible :: Bool groupsPossible = let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups in List.foldr foldFun False sheetList assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids -- plan or assign unassigned submissions for given sheets let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) buildA acc sid = maybeT (return acc) $ do let shn = sheetName $ sheets ! sid -- is sheet closed? guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable -- ask for assignment plan let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections ignoreExceptions NoCorrectors = return mempty ignoreExceptions NoCorrectorsByProportion = return mempty ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing guard $ not $ null plan -- only proceed if there is a plan for this sheet -- implement assignment plan status <- lift $ case btnResult of Nothing -> return (Set.empty, Set.empty) (Just BtnSubmissionsAssign) -> do status@(sub_ok,sub_fail) <- writeSubmissionPlan plan let nr_ok = olength sub_ok nr_fail = olength sub_fail alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail msg_status = bool Success Error $ nr_fail > 0 msg_header = SomeMessage $ shn <> ":" when (nr_ok > 0 || nr_fail > 0) $ addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] return status return $ Map.insert shn (status, countMapElems plan, deficit) acc assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] else return assignSids assignment <- foldM buildA Map.empty assignSids' correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds return (corrector, user) let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector) correctorMap' = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) -> let shn = sheetName $ sheets ! sheetCorrectorSheet in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc ) -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId) E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds return (submission E.^. SubmissionSheet, user) let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) correctorMap = (\f -> foldl f correctorMap' act_correctors) (\acc (E.Value sheetCorrectorSheet, Entity uid user) -> let shn = sheetName $ sheets ! sheetCorrectorSheet scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged ) submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds let numSubmittors = E.subSelectCount . E.from $ \subUser -> E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission return (submission, numSubmittors) -- prepare map let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) infoMap = List.foldl (flip buildS) emptySheets submissions -- ensure that all sheets are shown, including those without any submissions emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds emptyCorrs = foldl (\m uid -> let cic = Just uid in Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m = let shnm = sheetName $ sheets ! submissionSheet corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned cinf = Map.singleton submissionRatingBy $ CorrectionInfo { ciSubmittors = fromIntegral nrSbmtrs , ciSubmissions = 1 , ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap , ciCorrected = maybe 0 (const 1) submissionRatingTime , ciCorrector = submissionRatingBy , ciMin = corTime , ciTot = corTime , ciMax = corTime } in Map.insertWith (Map.unionWith (<>)) shnm cinf m return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps -- Always iterate over orderedSheetNames for consistent sorting! sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap sheetLoad :: Map SheetName Load sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap) let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal} = Map.insertWith (<>) s l acc buildL acc _ _ = acc in Map.foldl buildSL Map.empty correctorMap deficitMap :: Map UserId Rational deficitMap = foldMap (view _3) assignment corrMap :: Map (Maybe UserId) CorrectionInfo corrMap = Map.unionsWith (<>) $ Map.elems infoMap corrInfos :: [CorrectionInfo] corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap where byName Nothing = Nothing byName (Just uid) = Map.lookup uid correctorMap corrMapSum :: CorrectionInfo corrMapSum = fold corrMap let -- whamlet convenience functions -- avoid nestes hamlet $maybe with duplicated $nothing getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text) getCorrector (Just uid) | Just (User{..},loadMap) <- Map.lookup uid correctorMap = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName) -- | Just (User{..} ) <- Map.lookup uid lecturerNames -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty) -- avoid nestes hamlet $maybe with duplicated $nothing getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo getCorrSheetStatus corr shn | (Just smap) <- Map.lookup shn infoMap = Map.lookup corr smap getCorrSheetStatus _ _ = Nothing -- avoid nestes hamlet $maybe with duplicated $nothing getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int getCorrNewAssignment corr shn | (Just (_,cass,_)) <- Map.lookup shn assignment = Map.lookup corr cass getCorrNewAssignment _ _ = Nothing -- avoid nestes hamlet $maybe with duplicated $nothing getCorrDeficit :: Maybe UserId -> Maybe Rational getCorrDeficit (Just uid) = Map.lookup uid deficitMap getCorrDeficit _ = Nothing getLoadSum :: SheetName -> Text getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad = showCompactCorrectorLoad load CorrectorNormal getLoadSum _ = mempty showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays = foldMap formatDiffDays showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n let headingShort | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | otherwise = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets siteLayoutMsg headingShort $ do setTitleI headingLong $(widgetFile "corrections-overview")