module Handler.Corrections where import Import -- import System.FilePath (takeFileName) import Jobs import Handler.Utils import Handler.Utils.Submission import Handler.Utils.Table.Cells import Handler.Utils.SheetType import Handler.Utils.Delete -- import Handler.Utils.Zip import Utils.Lens import Data.List (nub) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import Data.Semigroup (Sum(..)) import Data.Monoid (All(..)) -- 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 qualified Database.Esqueleto as E -- 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 Control.Monad.Trans.Writer (WriterT(..), runWriter, execWriterT) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Trans.State (State, runState) import qualified Control.Monad.State.Class as State import Data.Foldable (foldrM) 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), 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 -- 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 submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode -- Columns colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel colSchool :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> let tid = course ^. _3 ssh = course ^. _4 csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] colSheetType :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet colCorrector :: IsDBTable m a => Colonnade _ 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 _ 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|#{display cid}|]) colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData))) colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId colSubmittors :: IsDBTable m a => Colonnade _ 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 _ CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId 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 in anchorCellM mkRoute $(widgetFile "widgets/rating") colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty timeCell submissionRatingAssigned colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } -> maybe mempty timeCell submissionRatingTime colPseudonyms :: IsDBTable m a => Colonnade _ 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 _ 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 _ 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 pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ 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)) 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) ) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> 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.^. UserDisplayName] return (user, pseudonym E.?. SheetPseudonymPseudonym) let submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, 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 ) , ( "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 ) , ( "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.sub_select . 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.limit 1 return (user E.^. UserSurname) ) ] , 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) ) , ( "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) ) , ( "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.not_ . E.isNothing $ submission E.^. SubmissionRatingTime Just False-> E.isNothing $ submission E.^. SubmissionRatingTime ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } , dbtParams , dbtIdent = "corrections" :: Text } 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 (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) dbtFilterUI psValidator actions = do Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) { drAbort = SomeRoute currentRoute , drSuccess = SomeRoute currentRoute } ((actionRes', table), statistics) <- runDB $ do -- Query for Table tableRes <- makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return def { dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAddSubmit = True , dbParamsFormAdditional = \frag -> do (actionRes, action) <- multiAction actions Nothing return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) } -- 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 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 $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet") unless (null unassignedAuth) $ do num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth] [ SubmissionRatingBy =. Just uid , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned ] addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num (E.Value selfCorrectors:_) <- 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 redirect currentRoute FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do subs <- mapM decrypt $ Set.toList subs' 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 $(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet") 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)] <- 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 SAssignR (== Authorized) <$> evalAccessDB route True type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction, deleteAction :: ActionCorrections' downloadAction = ( CorrDownload , pure CorrDownloadData ) deleteAction = ( CorrDelete , pure CorrDeleteData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector , wFormToAForm $ do correctors <- liftHandlerT . 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.distinct $ return user mr <- getMessageRender correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) 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 , colSchool , colTerm , colCourse , colSheet , colPseudonyms , colSubmissionLink , colAssigned , colRating , colRated ] -- Continue here filterUI = Just $ \mPrev -> mconcat [ Map.singleton "course" . maybeToList <$> aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) (Just <$> listToMaybe =<< Map.lookup "course" =<< mPrev) , Map.singleton "term" . maybeToList <$> aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) (Just <$> listToMaybe =<< Map.lookup "term" =<< mPrev) , Map.singleton "school" . maybeToList <$> aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) (Just <$> listToMaybe =<< Map.lookup "school" =<< mPrev) , Map.singleton "israted" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgRatingTime) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "israted" =<< mPrev) ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False) optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses termOptions = runDB $ do courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False) optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses schoolOptions = runDB $ do courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False) 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" ] 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 , colRating , colRated , colCorrector , colAssigned ] -- Continue here psValidator = def correctionsR whereClause colonnade Nothing 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 , colRating , colRated , colCorrector , colAssigned ] psValidator = def correctionsR whereClause colonnade Nothing 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 case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ 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 "Punktezahl") (Just submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm 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)) <* submitButton ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $ areq (zipFileField True) (fslI MsgRatingFiles) Nothing <* submitButton case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (rated, ratingPoints', ratingComment') -> do uid <- liftHandlerT 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 -> 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 case uploadResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess fileUploads -> do uid <- requireAuthId res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| 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 mr <- getMessageRender let sheetTypeDesc = mr sheetType defaultLayout $ do 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 . identForm FIDcorrectionsUpload . renderAForm FormStandard $ areq (zipFileField True) (fslI MsgCorrUploadField) Nothing <* submitButton 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 .| extractRatingsMsg .| sinkMultiSubmission uid True case mbSubs of Nothing -> return () (Just subs) | null subs -> addMessageI Warning MsgNoCorrectionsUploaded | otherwise -> do subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] mr <- (toHtml .) <$> getMessageRender addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) defaultLayout $ $(widgetFile "corrections-upload") getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId let sheetOptions = mkOptList <=< 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_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.&&. ( isCorrector E.||. isLecturer ) E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] return (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) } ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing) <* submitButton 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 . runDB . mapReaderT runWriterT $ do Sheet{..} <- get404 sid (sps, unknown) <- fmap partitionEithers' . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p) forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review _PseudonymText 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) $(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet") 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 :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers $(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet") 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 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } 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 insertMany_ . flip map (Set.toList groupUsers) $ \sheetUser -> SubmissionUser { submissionUserUser = sheetUser , submissionUserSubmission = subId } 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) tell $ All False | otherwise -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc NoGroups -> do subId <- insert submissionPrototype void . insert $ SubmissionEdit uid now subId insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId } when (length spGroup > 1) $ addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc when allDone $ redirect CorrectionsGradeR defaultLayout $ $(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 , colCommentField ] -- Continue here psValidator = def & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (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 mempty psValidator dbtProj' $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR , dbParamsFormAddSubmit = True } 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 -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints , SubmissionRatingComment =. mComment , SubmissionRatingBy =. Just uid , SubmissionRatingTime =. now <$ guard rated ] | otherwise -> return Nothing subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission] unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet") defaultLayout $ $(widgetFile "corrections-grade") getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn cID = do let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR sId <- decrypt cID (currentCorrector, sheetCorrectors) <- runDB $ do Submission{submissionRatingBy, submissionSheet} <- get404 sId sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] userCorrector <- traverse getJustEntity submissionRatingBy return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors) $logDebugS "SAssignR" $ tshow currentCorrector let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName ((corrResult, corrForm), corrEncoding) <- runFormPost . renderAForm FormStandard $ aopt correctorField (fslI MsgCorrector) (Just currentCorrector) <* submitButton formResult corrResult $ \(fmap entityKey -> mbUserId) -> do when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do now <- liftIO getCurrentTime update sId [ SubmissionRatingBy =. mbUserId , SubmissionRatingAssigned =. (now <$ mbUserId) ] addMessageI Success MsgCorrectorUpdated redirect actionUrl defaultLayout $ do setTitleI MsgCorrectorAssignTitle $(widgetFile "submission-assign")