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.CaseInsensitive (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 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 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), 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 query expr backend (expr (Entity SubmissionEdit)) => expr (Entity Submission) -> expr (E.Value (Maybe UTCTime)) lastEditQuery submission = E.sub_select $ 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|#{display 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|#{display 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) (maybe mempty toWidget 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 pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints) ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) colCommentField = sortable (Just "comment") (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)) 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 (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, 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 = 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 ) , ( "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.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) ) , ( "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 ) , ( "corrector-name-email" -- corrector filter does not work for text-filtering , FilterColumn $ E.anyFilter [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname) , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName) , E.mkContainsFilter $ 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.mkContainsFilter (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) ) -- , ( "pseudonym" -- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do -- E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet -- E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB. -- ) ] , 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 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', 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 = liftHandlerT . 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 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' 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 $(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 SubAssignR (== 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 correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) 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 -- 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 (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) , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) -- "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 "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (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) -- "pseudonym" TODO DB only stores Word24 , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (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 (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 . 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 } 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 . 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 .| 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) 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) } ((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,) <$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing <*> (textToList <$> areq textareaField (fslpI MsgCorrectionPseudonyms "Pseudonyme" & 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 . 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 let pseudonymForm = wrapForm pseudonymWidget def { formAction = Just $ SomeRoute CorrectionsCreateR , formEncoding = pseudonymEncoding } 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 } 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") 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] -- | 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 shids <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] assignHandler tid ssh csh shids getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn = do shid <- runDB $ fetchSheetId tid ssh csh shn assignHandler tid ssh csh [shid] assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html assignHandler tid ssh csh rawSids = do -- gather data openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $ \acc sid -> maybeT (return acc) $ do Just Sheet{sheetName=saiName} <- lift $ get sid guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR -- we must check, whether the submission is already closed and thus assignable saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing] guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid] saiCorrectorNr <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal] -- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets return $ Map.insert sid SubAssignInfo{..} acc let sids = Map.keys openSubs -- process form currentRoute <- getCurrentRoute ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm let headingShort = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign case btnResult of FormSuccess BtnSubmissionsAssign -> do -- Button was pressed, assign and report -- Assign submissions status <- runDB $ (\f -> foldM f Map.empty sids) $ \acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing -- Too much important information for an alert. Display proper info page instead -- TODO: following convenience links available via breadcrumbs already? Or as PrimaryActions? link <- case sids of [sid] -> do Sheet{sheetName} <- runDB $ getJust sid return $ CSheetR tid ssh csh sheetName SSubsR _ -> return $ CourseR tid ssh csh CCorrectionsR siteLayoutMsg headingShort $ do setTitleI headingLong $(widgetFile "corrections-assign-result") simpleLinkI (SomeMessage MsgGenericBack) link other -> do -- all other cases, show what can be done formFailure2Alerts other -- show info about assignments let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } status = Map.empty -- allows reuse of widget siteLayoutMsg headingShort $ do setTitleI headingLong $(widgetFile "corrections-assign-result") btnForm