diff --git a/messages/de.msg b/messages/de.msg index f6baedfea..9f1ddd03a 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -22,6 +22,8 @@ InvalidInput: Eingaben bitte korrigieren. Term: Semester TermPlaceholder: W/S + vierstellige Jahreszahl +LectureStart: Beginn Vorlesungen + Course: Kurs CourseSecret: Zugangspasswort CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt. @@ -70,6 +72,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung +Submission: Abgabenummer SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. @@ -79,11 +82,27 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt. +CorrectionsTitle: Zugewiesene Korrekturen +CourseCorrectionsTitle: Korrekturen für diesen Kurs EMail: E-Mail EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. NotAParticipant user@Text tk@TermId csh@Text: #{user} ist nicht im Kurs #{display tk}-#{csh} angemeldet. +AddCorrector: Zusätzlicher Korrektor +CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen +SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName} +CountTutProp: Tutorien zählen gegen Proportion +Corrector: Korrektor +Correctors: Korrektoren +CorByTut: Nach Tutorium +CorProportion: Anteil +DeleteRow: Zeile entfernen +ProportionNegative: Anteile dürfen nicht negativ sein +CorrectorsUpdated: Korrektoren erfolgreich aktualisiert +CorrectorsPlaceholder: Korrektoren... +CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert. + Users: Benutzer HomeHeading: Aktuelle Termine ProfileHeading: Benutzerprofil und Einstellungen @@ -107,4 +126,20 @@ SheetSolution: Lösung SheetMarking: Korrekturhinweise MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) + +NrColumn: Nr +SelectColumn: Auswahl + +CorrDownload: Herunterladen +CorrUploadField: Korrekturen +CorrUpload: Korrekturen hochladen +CorrSetCorrector: Korrektor zuweisen +CorrAutoSetCorrector: Korrekturen verteilen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! + +SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: +UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt. +NoCorrector: Kein Korrektor +RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. +UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt. +CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: \ No newline at end of file diff --git a/models b/models index 6cefc3f8e..070bc1a17 100644 --- a/models +++ b/models @@ -119,6 +119,7 @@ SheetCorrector sheet SheetId load Load UniqueSheetCorrector user sheet + deriving Show Eq Ord SheetFile sheet SheetId file FileId diff --git a/package.yaml b/package.yaml index bb217ec2b..ccfb37678 100644 --- a/package.yaml +++ b/package.yaml @@ -81,6 +81,7 @@ dependencies: - exceptions - lens - MonadRandom +- email-validate # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 6867160e2..fa34e27ae 100644 --- a/routes +++ b/routes @@ -51,26 +51,24 @@ /show CShowR GET !free /register CRegisterR POST !time /edit CEditR GET POST + /subs CourseCorrectionsR GET POST /ex SheetListR GET !registered !materials !/ex/new SheetNewR GET POST /ex/#Text SheetR: /show SShowR GET !timeANDregistered !timeANDmaterials !corrector - !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - !/sub/new SubmissionNewR GET POST !timeANDregistered - !/sub/own SubmissionOwnR GET !free + /sub/new SubmissionNewR GET POST !timeANDregistered + /sub/own SubmissionOwnR GET !free + !/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector + !/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector + /correctors SCorrR GET POST + /subs SSubsR GET POST + !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector +/corrections CorrectionsR GET POST !free --- TODO below -!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated -!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated - -/submission SubmissionListR GET !deprecated -/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated -/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated --- TODO above !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -!/*{CI FilePath} CryptoFileNameDispatchR GET !free +-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists diff --git a/src/Application.hs b/src/Application.hs index a671b5296..3f7d3139a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -48,6 +48,7 @@ import Handler.Term import Handler.Course import Handler.Sheet import Handler.Submission +import Handler.Corrections import Handler.CryptoIDDispatch diff --git a/src/Foundation.hs b/src/Foundation.hs index 700f0a2ca..c70a713c0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -39,6 +39,8 @@ import Data.ByteArray (convert) import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash.Conduit (sinkHash) +import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only + import qualified Data.ByteString.Base64.URL as Base64 (encode) import Data.ByteString (ByteString) @@ -72,13 +74,19 @@ import Handler.Utils.DateTime import Control.Lens import Utils.Lens --- -- TODO: Move me to appropriate Place + +-- -- TODO: Move the following to the appropriate place, if DisplayAble is kept instance DisplayAble TermId where display = termToText . unTermKey instance DisplayAble UTCTime where display = pack . formatTimeGerDT2 -- default Time Format to be used: 00.00.00 00:00 +instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where + display = toPathPiece -- requires import of Data.CryptoID here +-- -- MOVE ABOVE + + -- infixl 9 :$: -- pattern a :$: b = a b @@ -153,6 +161,9 @@ instance RenderMessage UniWorX TermIdentifier where Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX String where + renderMessage f ls str = renderMessage f ls $ Text.pack str + instance RenderMessage UniWorX SheetFileType where renderMessage foundation ls = \case SheetExercise -> renderMessage' MsgSheetExercise @@ -565,7 +576,6 @@ instance Yesod UniWorX where makeLogger = return . appLogger - -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb (AuthR _) = return ("Login" , Just HomeR) @@ -595,11 +605,11 @@ instance YesodBreadcrumbs UniWorX where -- (CSheetR tid csh shn SFileR) -- just for Downloads breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - -- Deprecated below - breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) -- Others breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all @@ -627,6 +637,12 @@ pageActions (CourseR tid csh CShowR) = return (sheets,lecturer) or2M (return lecturer) $ anyM sheets sheetRouteAccess } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh CourseCorrectionsR + , menuItemAccessCallback' = return True + } , PageActionSecondary $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing @@ -655,6 +671,18 @@ pageActions (CSheetR tid csh shn SShowR) = , menuItemRoute = CSheetR tid csh shn SubmissionOwnR , menuItemAccessCallback' = return True -- TODO: check that a submission already exists } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrektoren" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Abgaben" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SSubsR + , menuItemAccessCallback' = return True + } ] pageActions TermShowR = [ PageActionPrime $ MenuItem @@ -741,6 +769,8 @@ pageHeading (CourseR tid csh CShowR) = Just $ do Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh toWidget courseName +pageHeading CorrectionsR + = Just $ i18nHeading MsgCorrectionsTitle -- (CourseR tid csh CRegisterR) -- just for POST pageHeading (CourseR tid csh CEditR) = Just $ i18nHeading $ MsgCourseEditHeading tid csh diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs new file mode 100644 index 000000000..431d35fbb --- /dev/null +++ b/src/Handler/Corrections.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Handler.Corrections where + +import Import +-- import System.FilePath (takeFileName) + +import Handler.Utils +import Handler.Utils.Submission +-- import Handler.Utils.Zip + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map + +-- import Data.Time +-- import qualified Data.Text as T +-- import Data.Function ((&)) +-- +import Colonnade hiding (fromMaybe, singleton) +-- 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.Lens +-- import Control.Monad.Writer (MonadWriter(..), execWriterT) + +-- import Network.Mime + +import Web.PathPieces + +import Text.Hamlet (ihamletFile) +import Text.Blaze.Html (preEscapedToHtml) + +import Database.Persist.Sql (updateWhereCount) + +import Data.List (genericLength) + + + +type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) => + (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission)) + -> expr (E.Value Bool) + +ratedBy :: Key User -> CorrectionsWhere +ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + +courseIs :: Key Course -> CorrectionsWhere +courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid + +sheetIs :: Key Sheet -> CorrectionsWhere +sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid + + +type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User)) + +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 $ E.unValue $ course ^. _3 -- kurze Semsterkürzel + +colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colCourse = sortable (Just "course") (i18nCell MsgCourse) + $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $ + let tid = E.unValue $ course ^. _3 + csh = E.unValue $ course ^. _2 + in [whamlet|#{display csh}|] + +colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSheet = sortable (Just "sheet") (i18nCell MsgSheet) + $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $ + let tid = E.unValue $ course ^. _3 + csh = E.unValue $ course ^. _2 + shn = sheetName $ entityVal sheet + in [whamlet|#{display shn}|] + -- textCell $ sheetName $ 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 corr) } -> textCell . display . userDisplayName $ entityVal corr + +colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) + $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do + let tid = E.unValue $ course ^. _3 + csh = E.unValue $ course ^. _2 + shn = sheetName $ entityVal sheet + cid <- encrypt (entityKey submission :: SubmissionId) + [whamlet|#{display cid}|] + +colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) +colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId + +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)) + +makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h ) + => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) +makeCorrectionsTable whereClause colChoices psValidator = do + let tableData :: CorrectionTableExpr -> E.SqlQuery _ + tableData ((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 (course,sheet,submission) + let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value Text) + , course E.^. CourseShorthand + , course E.^. CourseTerm + , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) + ) + return (submission, sheet, crse, corrector) + dbTable psValidator $ DBTable + { dbtSQLQuery = tableData + , dbtColonnade = colChoices + , dbtSorting = [ ( "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.?. UserDisplayName + ) + ] + , dbtFilter = [ ( "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) + ) + , ( "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) + ) + ] + , dbtAttrs = tableDefault + , dbtIdent = "corrections" :: Text + } + +data ActionCorrections = CorrDownload + | CorrSetCorrector + | CorrAutoSetCorrector + deriving (Eq, Ord, Read, Show, Enum, Bounded) +instance PathPiece ActionCorrections where + fromPathPiece = readFromPathPiece + toPathPiece = showToPathPiece + +instance RenderMessage UniWorX ActionCorrections where + renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload + renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector + renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector + +data ActionCorrectionsData = CorrDownloadData + | CorrSetCorrectorData (Maybe UserId) + | CorrAutoSetCorrectorData SheetId + +correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent +correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator + ((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do + ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf + (actionRes, action) <- multiAction actions + return ((,) <$> actionRes <*> selectionRes, table <> action) + + Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler + case actionRes of + FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs + FormMissing -> return () + FormSuccess (CorrDownloadData, subs) -> do + ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable + addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\"" + sendResponse =<< submissionMultiArchive ids + FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do + subs <- mapM decrypt $ Set.toList subs' + runDB $ do + alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] + when (not $ null alreadyAssigned) $ do + mr <- (toHtml . ) <$> getMessageRender + alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) + addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) + let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) + when (not $ null unassigned) $ do + num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid] + addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num + redirect currentRoute + FormSuccess (CorrSetCorrectorData Nothing, subs') -> do + subs <- mapM decrypt $ Set.toList subs' + runDB $ do + num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing + , SubmissionRatingComment =. Nothing + , SubmissionRatingBy =. Nothing + , SubmissionRatingTime =. Nothing + ] + 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] [] + when (not $ null alreadyAssigned) $ do + mr <- (toHtml . ) <$> getMessageRender + alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) + addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) + let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) + when (not $ null unassigned) $ do + (assigned, unassigned) <- assignSubmissions shid (Just unassigned) + when (not $ null assigned) $ + addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) + when (not $ null unassigned) $ do + mr <- (toHtml . ) <$> getMessageRender + unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) + addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr) + redirect currentRoute + + fmap toTypedContent . defaultLayout $ do + setTitleI MsgCourseCorrectionsTitle + $(widgetFile "corrections") + + +type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) + +downloadAction :: ActionCorrections' +downloadAction = ( CorrDownload + , return (pure CorrDownloadData, Nothing) + ) + +assignAction :: Either CourseId SheetId -> ActionCorrections' +assignAction selId = ( CorrSetCorrector + , over (mapped._2) Just $ 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 + + return user + + mr <- getMessageRender + + correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey + + ($ mempty) . renderAForm FormStandard . wFormToAForm $ do + cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId + ) + +autoAssignAction :: SheetId -> ActionCorrections' +autoAssignAction shid = ( CorrAutoSetCorrector + , return (pure $ CorrAutoSetCorrectorData shid, Nothing) + ) + +getCorrectionsR, postCorrectionsR :: Handler TypedContent +getCorrectionsR = postCorrectionsR +postCorrectionsR = do + uid <- requireAuthId + let whereClause = ratedBy uid + colonnade = mconcat + [ colSelect + , dbRow + , colTerm + , colCourse + , colSheet + , colSubmissionLink + ] -- Continue here + 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") + correctionsR whereClause colonnade psValidator $ Map.fromList + [ downloadAction + ] + +getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent +getCourseCorrectionsR = postCourseCorrectionsR +postCourseCorrectionsR tid csh = do + Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh + let whereClause = courseIs cid + colonnade = mconcat + [ colSelect + , dbRow + , colSheet + , colCorrector + , colSubmissionLink + ] -- Continue here + psValidator = def + correctionsR whereClause colonnade psValidator $ Map.fromList + [ downloadAction + , assignAction (Left cid) + ] + +getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent +getSSubsR = postSSubsR +postSSubsR tid csh shn = do + shid <- runDB $ fetchSheetId tid csh shn + let whereClause = sheetIs shid + colonnade = mconcat + [ colSelect + , dbRow + , colCorrector + , colSubmissionLink + ] + psValidator = def + correctionsR whereClause colonnade psValidator $ Map.fromList + [ downloadAction + , assignAction (Right shid) + , autoAssignAction shid + ] diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index e8367a12c..079c703ee 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -24,7 +24,7 @@ import Data.Time -- import Control.Lens import Colonnade hiding (fromMaybe, singleton) -import Yesod.Colonnade +-- import Yesod.Colonnade import qualified Database.Esqueleto as E -- import qualified Data.UUID.Cryptographic as UUID @@ -68,10 +68,10 @@ homeAnonymous = do E.limit nrSheetDeadlines return course - colonnade :: Colonnade Sortable (DBRow (Entity Course)) (Cell UniWorX) + colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do + sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do let tid = courseTerm course csh = courseShorthand course cell [whamlet|#{display csh}|] @@ -134,17 +134,17 @@ homeUser uid = do , sheet E.^. SheetActiveTo ) - colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (Cell UniWorX) + colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (DBCell (WidgetT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } -> + sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } -> cell [whamlet|#{display csh}|] - , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } -> + , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } -> cell [whamlet|#{display shn}|] - , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } -> + , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } -> textCell $ display deadline - , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } -> - textCell $ "?" + , sortable (Just "done") (textCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } -> + textCell ("?" :: Text) ] sheetTable <- dbTable def $ DBTable { dbtSQLQuery = tableData diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9ceb30b25..ddf39d970 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -8,7 +8,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Handler.Sheet where @@ -22,9 +27,10 @@ import Handler.Utils.Zip import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton) -import Yesod.Colonnade --- +import Colonnade hiding (fromMaybe, singleton, bool) +import qualified Yesod.Colonnade as Yesod +import Text.Blaze (text) +-- import qualified Data.UUID.Cryptographic as UUID import qualified Data.Conduit.List as C @@ -32,12 +38,24 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E import Control.Monad.Writer (MonadWriter(..), execWriterT) +import Control.Monad.Trans.RWS.Lazy (RWST, local) + +import qualified Text.Email.Validate as Email + +import qualified Data.List as List import Network.Mime +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map +import Data.Map (Map, (!), (!?)) +import qualified Data.Map as Map + +import Control.Lens +import Utils.Lens + instance Eq (Unique Sheet) where (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = @@ -64,7 +82,6 @@ data SheetForm = SheetForm , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe FileInfo -- Keine SheetId im Formular! - , sfCorrectors :: [(UserId,Load)] } @@ -92,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <*> fileAFormOpt (fsb "Hinweis") <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) <*> fileAFormOpt (fsb "Lösung") - <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template)) <* submitButton return $ case result of FormSuccess sheetResult @@ -123,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do -- TODO: continue validation here!!! ] ] -correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX]) -correctorForm _msid templates = return mempty -- TODO deprecated - -- Datenbank UserId -> UserName - -- Eingabelist für Colonnade - -- enthält die benötigten Felder - -- FormResult konstruieren - -- Eingabebox für Korrektor hinzufügen - -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen - - -- List Sheets getSheetListCID :: CourseId -> Handler Html getSheetListCID cid = getSheetList =<< @@ -180,7 +186,7 @@ getSheetList courseEnt = do setTitle $ toHtml $ csh <> " Übungsblätter" if null sheets then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] - else encodeWidgetTable tableDefault colSheets sheets + else Yesod.encodeWidgetTable tableDefault colSheets sheets -- Show single sheet @@ -211,8 +217,8 @@ getSShowR tid csh shn = do E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) - let colonnadeFiles = mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> cell $ [whamlet| _{ftype}|] + let colonnadeFiles = widgetColonnade $ mconcat + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime) @@ -303,7 +309,6 @@ getSEditR tid csh shn = do , sfHintF = Nothing -- TODO , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Nothing -- TODO - , sfCorrectors = [] -- TODO read correctors from list } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -410,3 +415,201 @@ insertSheetFile' sid ftype fs = do finsert (Right file) = lift $ do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step + + +data CorrectorForm = CorrectorForm + { cfUserId :: UserId + , cfUserName :: Text + , cfResult :: FormResult Load + , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX + } + +type Loads = Map UserId Load + +defaultLoads :: SheetId -> DB Loads +-- ^ Generate `Loads` in such a way that minimal editing is required +-- +-- For every user, that ever was a corrector for this course, return their last `Load`. +-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit). +defaultLoads shid = do + cId <- sheetCourse <$> getJust shid + fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + + let creationTime = E.sub_select . E.from $ \sheetEdit -> do + E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.min_ $ sheetEdit E.^. SheetEditTime + + E.where_ $ sheet E.^. SheetCourse E.==. E.val cId + + E.orderBy [E.desc creationTime] + + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) + where + toMap :: [(E.Value UserId, E.Value Load)] -> Loads + toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load + + +correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX]) +correctorForm shid = do + cListIdent <- newFormIdent + let + guardNonDeleted :: UserId -> Handler (Maybe UserId) + guardNonDeleted uid = do + cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser + deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" + return $ bool Just (const Nothing) (isJust deleted) uid + formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) + let + currentLoads :: DB Loads + currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] + (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads + loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if + | Map.null currentLoads' + , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted) + | otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads' + + deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') + + let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) + didDelete = any (flip Set.member deletions) formCIDs + + (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' + let + tutorField :: Field Handler [Text] + tutorField = multiEmailField + { fieldView = \theId name attrs val isReq -> asWidgetT $ do + listIdent <- newIdent + userId <- handlerToWidget requireAuthId + previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId + return $ user E.^. UserEmail + [whamlet| + $newline never + + + $forall E.Value prev <- previousCorrectors +
+ ^{fvInput addTutView} +