From af40d86de952b4257f91bc212c5eb85014e0ef53 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 9 Nov 2018 17:45:06 +0100 Subject: [PATCH 1/8] Bugfix: assignAction no longer delivers duplicate actions --- src/Handler/Corrections.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index e97f93c9e..99d7510b5 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -366,13 +366,13 @@ 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 $ 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 + E.distinct $ return user mr <- getMessageRender From 05c4a5da2fa2f495d9f8dfeeb9d758366f1bc451 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Sun, 11 Nov 2018 23:13:57 +0100 Subject: [PATCH 2/8] updates to README --- README.md | 45 ++++++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/README.md b/README.md index e6b42fe4f..afa47f082 100644 --- a/README.md +++ b/README.md @@ -6,68 +6,75 @@ The following Description applies to Ubuntu or similar. Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`. ## LDAP - install: + install: `sudo apt-get install slapd ldap-utils` ## PostgreSQL - install: + install: `sudo apt-get install postgresql` - switch to user *postgres* (got created during installation): + switch to user *postgres* (got created during installation): `sudo -i -u postgres` - add db user *uniworx*: + add db user *uniworx*: `createuser --interactive` you'll get a prompt: ``` - Enter name of role to add:` - [enter 'uniworx'] + Enter name of role to add:` - uniworx Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?] + Password: uniworx + ... ``` - create database *uniworx*: + create database *uniworx*: `createdb uniworx` + after you added the database switch back to your own user with `Ctrl + D`. - to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*: + to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*. `sudo adduser uniworx` - log-in as new user *uniworx*: + log-in as new user *uniworx*: `sudo -i -u uniworx` you can now use `psql uniworx` to execute SQL-commands and such. ## stack - Install with: + Install with: `curl -sSL https://get.haskellstack.org/ | sh` - setup stack and install dependencies: + setup stack and install dependencies: `stack setup` - During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using + During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using `sudo apt-get install libsasl2-dev libldap2-dev` - If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* - Go ahead an install `libpq-dev` with + If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* + Go ahead an install `libpq-dev` with `sudo apt-get install libpq-dev` - Build the app: + Other packages you might need to install during this process: + `sudo apt-get install pkg-config` + `sudo apt-get install libsodium-dev` + + Build the app: `stack build` This might take a few minutes if not hours... be prepared. - install yesod: + install yesod: `stack install yesod-bin --install-ghc` ## Add Dumy-Data and run the app After building the app you can prepare the database and add some dummy data: - `./fill-db.hs` + `./db.sh -f` - Run the app: + Run the app: `./start.sh` - `Devel application launched: http://localhost:3000` + `Devel application launched: http://localhost:3000` means you are good to go. If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login. @@ -75,7 +82,7 @@ The following Description applies to Ubuntu or similar. *** # Sources and more infos - PostgreSQl: + PostgreSQl: https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04 stack: https://docs.haskellstack.org/en/stable/README/#how-to-install From 22ebc3d96ab62b4b8919575d2ad85af1aaa2b569 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Sun, 11 Nov 2018 23:24:18 +0100 Subject: [PATCH 3/8] more beautifully signalled shell commands in README --- README.md | 85 ++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 62 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index afa47f082..2d59db31a 100644 --- a/README.md +++ b/README.md @@ -3,26 +3,37 @@ The following Description applies to Ubuntu or similar. ## Clone repository - Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`. + Clone this repository and navigate into + ```sh + $ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX + ``` ## LDAP install: - `sudo apt-get install slapd ldap-utils` + ```sh + $ sudo apt-get install slapd ldap-utils + ``` ## PostgreSQL install: - `sudo apt-get install postgresql` + ```sh + $ sudo apt-get install postgresql + ``` switch to user *postgres* (got created during installation): - `sudo -i -u postgres` + ```sh + $ sudo -i -u postgres + ``` add db user *uniworx*: - `createuser --interactive` + ```sh + $ createuser --interactive + ``` you'll get a prompt: - ``` + ```sh Enter name of role to add:` - uniworx Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?] Password: uniworx @@ -30,52 +41,80 @@ The following Description applies to Ubuntu or similar. ``` create database *uniworx*: - `createdb uniworx` + ```sh + $ createdb uniworx + ``` + after you added the database switch back to your own user with `Ctrl + D`. to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*. - `sudo adduser uniworx` + ```sh + $ sudo adduser uniworx + ``` log-in as new user *uniworx*: - `sudo -i -u uniworx` + ```sh + $ sudo -i -u uniworx + ``` - you can now use `psql uniworx` to execute SQL-commands and such. + you can now use + ```sh + $ psql uniworx + ``` + to execute SQL-commands and such. ## stack Install with: - `curl -sSL https://get.haskellstack.org/ | sh` + ```sh + $ curl -sSL https://get.haskellstack.org/ | sh + ``` setup stack and install dependencies: - `stack setup` + ```sh + $ stack setup + ``` During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using - `sudo apt-get install libsasl2-dev libldap2-dev` + ```sh + $ sudo apt-get install libsasl2-dev libldap2-dev + ``` If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* Go ahead an install `libpq-dev` with - `sudo apt-get install libpq-dev` + ```sh + $ sudo apt-get install libpq-dev + ``` Other packages you might need to install during this process: - `sudo apt-get install pkg-config` - `sudo apt-get install libsodium-dev` + ```sh + $ sudo apt-get install pkg-config + sudo apt-get install libsodium-dev + ``` Build the app: - `stack build` + ```sh + $ stack build + ``` This might take a few minutes if not hours... be prepared. install yesod: - `stack install yesod-bin --install-ghc` + ```sh + $ stack install yesod-bin --install-ghc + ``` ## Add Dumy-Data and run the app After building the app you can prepare the database and add some dummy data: - `./db.sh -f` + ```sh + $ ./db.sh -f + ``` Run the app: - `./start.sh` - - `Devel application launched: http://localhost:3000` - means you are good to go. + ```sh + $ ./start.sh + ... + Devel application launched: http://localhost:3000 + ``` If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login. From 56d5da648aca7877194b022a7bf27b8ae41ffd9e Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Sun, 11 Nov 2018 23:34:47 +0100 Subject: [PATCH 4/8] dont text-align:right number inputs --- templates/standalone/inputs.lucius | 1 - 1 file changed, 1 deletion(-) diff --git a/templates/standalone/inputs.lucius b/templates/standalone/inputs.lucius index 54e6aa5a6..5f9d90206 100644 --- a/templates/standalone/inputs.lucius +++ b/templates/standalone/inputs.lucius @@ -91,7 +91,6 @@ input[type*="time"] { input[type="number"] { width: 100px; - text-align: right; } input[type*="date"], From 673d98ff91c0346c54ee3a81542a1bdd479480d8 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 12 Nov 2018 17:12:24 +0100 Subject: [PATCH 5/8] Single submission assign corrector --- .vscode/tasks.json | 3 +- messages/uniworx/de.msg | 10 ++-- models | 14 ++--- routes | 3 +- src/Foundation.hs | 41 ++++++++------ src/Handler/Corrections.hs | 87 +++++++++++++++++++++--------- templates/formPage.hamlet | 2 +- templates/formPageI18n.hamlet | 2 +- templates/submission-assign.hamlet | 2 + 9 files changed, 109 insertions(+), 55 deletions(-) create mode 100644 templates/submission-assign.hamlet diff --git a/.vscode/tasks.json b/.vscode/tasks.json index ac3e4e9ee..9f3625c7e 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -28,7 +28,8 @@ "focus": false, "panel": "dedicated", "showReuseMessage": false - } + }, + "problemMatcher": [] }, { "label": "test", diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5c7b3cfe6..14fff01cf 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -142,6 +142,8 @@ SubmissionGroupName: Gruppenname CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} +CorrectorAssignTitle: Korrektor zuweisen + Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) @@ -189,6 +191,7 @@ CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Ante DeleteRow: Zeile entfernen ProportionNegative: Anteile dürfen nicht negativ sein +CorrectorUpdated: Korrektor erfolgreich aktualisiert CorrectorsUpdated: Korrektoren erfolgreich aktualisiert CorrectorsPlaceholder: Korrektoren... CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert. @@ -258,7 +261,7 @@ RatingDone: Bewertung fertiggestellt RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein -PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein +PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist ColumnRatingPointsDone: Punktzahl/Abgeschlossen Pseudonyms: Pseudonyme @@ -366,7 +369,7 @@ SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten SheetGradingPassBinary: Bestanden/Nicht Bestanden -SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. +SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. SheetGradingPoints': Punkte SheetGradingPassPoints': Bestehen nach Punkten @@ -424,7 +427,7 @@ HelpUser: Meinen Benutzeraccount HelpAnonymous: Keine Antwort (Anonym) HelpEMail: E-Mail HelpRequest: Supportanfrage / Verbesserungsvorschlag -HelpProblemPage: Problematische Seite +HelpProblemPage: Problematische Seite HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. HelpSent: Ihre Supportanfrage wurde weitergeleitet. @@ -484,6 +487,7 @@ ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} ErrMsgHeading: Fehlermeldung entschlüsseln +ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten InvalidRoute: Konnte URL nicht interpretieren diff --git a/models b/models index 32dba863f..47e95f579 100644 --- a/models +++ b/models @@ -15,7 +15,7 @@ User json notificationSettings NotificationSettings UniqueAuthentication ident UniqueEmail email - deriving Show + deriving Show Eq UserAdmin user UserId school SchoolId @@ -46,9 +46,9 @@ Term json start Day -- TermKey :: TermIdentifier -> TermId end Day holidays [Day] - lectureStart Day - lectureEnd Day - active Bool + lectureStart Day + lectureEnd Day + active Bool Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } deriving Show -- type TermId = Key Term School json @@ -57,7 +57,7 @@ School json UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } - deriving Eq + deriving Eq DegreeCourse json course CourseId degree StudyDegreeId @@ -89,7 +89,7 @@ CourseFavourite course CourseId UniqueCourseFavourite user course deriving Show -Lecturer +Lecturer user UserId course CourseId UniqueLecturer user course @@ -135,7 +135,7 @@ SheetFile file FileId type SheetFileType UniqueSheetFile file sheet type -File +File title FilePath content ByteString Maybe -- Nothing iff this is a directory modified UTCTime diff --git a/routes b/routes index 399f3bf72..b4c90b0cd 100644 --- a/routes +++ b/routes @@ -23,7 +23,7 @@ -- !isWrite -- only if it is write access (i.e. POST only) why needed??? -- -- !deprecated -- like free, but logs and gives a warning; entirely disabled in production --- !development -- like free, but only for development builds +-- !development -- like free, but only for development builds /static StaticR Static appStatic !free /auth AuthR Auth getAuth !free @@ -79,6 +79,7 @@ /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: / SubShowR GET POST !ownerANDtime !ownerANDisRead /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner + /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner /correctors SCorrR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index a2d0f20ac..ee0c578d5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -208,7 +208,7 @@ instance RenderMessage UniWorX (SheetType) where renderMessage foundation ls sheetType = case sheetType of NotGraded -> mr $ SheetTypeHeader NotGraded other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other) - where + where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls @@ -432,12 +432,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req guard visible case subRoute of - SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SubmissionNewR -> guard active - SubmissionR _ _ -> guard active - _ -> return () + SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SubmissionNewR -> guard active + SubmissionR _ SAssignR -> guard $ not active -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change + SubmissionR _ _ -> guard active + _ -> return () return Authorized @@ -525,7 +526,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req SystemMessage{..} <- MaybeT $ get smId isAuthenticated <- isJust <$> liftHandlerT maybeAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized + return Authorized r -> $unsupportedAuthPredicate "authentication" r ) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) @@ -601,7 +602,7 @@ instance Yesod UniWorX where cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid - + $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] -- update Favourites void . lift $ upsertBy @@ -650,7 +651,7 @@ instance Yesod UniWorX where #{formatted} |] | otherwise -> plaintext - + errPage = case err of NotFound -> [whamlet|

_{MsgErrorResponseNotFound}|] InternalError err' -> encrypted err' [whamlet|

#{err'}|] @@ -938,7 +939,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the } , do mCurrentRoute <- getCurrentRoute - + return MenuItem { menuItemType = NavbarRight , menuItemLabel = MsgMenuHelp @@ -1226,6 +1227,14 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgCorrectorAssignTitle + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR + , menuItemModal = True + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem @@ -1455,7 +1464,7 @@ routeNormalizers = hasChanged shn sheetName return $ CSheetR tid ssh csh sheetName subRoute - + -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend @@ -1525,7 +1534,7 @@ instance YesodAuth UniWorX where userEmail' = lookup (Attr "mail") ldapData userDisplayName' = lookup (Attr "displayName") ldapData userSurname' = lookup (Attr "sn") ldapData - + userAuthentication | isPWHash = error "PWHash should only work for users that are already known" | otherwise = AuthLDAP @@ -1631,13 +1640,13 @@ instance YesodMail UniWorX where mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act - mailT ctx mail = defMailT ctx $ do + mailT ctx mail = defMailT ctx $ do void setMailObjectId setDateCurrent replaceMailHeader "Auto-Submitted" $ Just "auto-generated" - + ret <- mail - + setMailSmtpData return ret diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 99d7510b5..a64605446 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -83,11 +83,7 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let tid = course ^. _3 - ssh = course ^. _4 - csh = course ^. _2 - in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] + $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) @@ -135,7 +131,7 @@ 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 @@ -181,7 +177,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell 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, ToSortable h, Functor h ) => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do @@ -303,9 +299,10 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender - alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) + 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) + unless (null unassigned) $ do num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [ SubmissionRatingBy =. Just uid @@ -337,7 +334,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] unless (null alreadyAssigned) $ do mr <- (toHtml . ) <$> getMessageRender - alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) + 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) unless (null unassigned) $ do @@ -356,7 +353,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) - + downloadAction :: ActionCorrections' downloadAction = ( CorrDownload , pure CorrDownloadData @@ -483,8 +480,8 @@ postCorrectionR tid ssh csh shn cid = 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") + _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) + (fslpI MsgRatingPoints "Punktezahl") (Just submissionRatingPoints) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) @@ -500,7 +497,7 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (rated, ratingPoints', ratingComment') + FormSuccess (rated, ratingPoints', ratingComment') | errs <- validateRating sheetType Rating' { ratingPoints=ratingPoints' , ratingComment=ratingComment' @@ -511,7 +508,7 @@ postCorrectionR tid ssh csh shn cid = do runDBJobs $ do uid <- liftHandlerT requireAuthId now <- liftIO getCurrentTime - + update sub [ SubmissionRatingBy =. Just uid , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints' @@ -522,7 +519,7 @@ postCorrectionR tid ssh csh shn cid = do when (rated && isNothing submissionRatingTime) $ do $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] - queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub redirect $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -531,7 +528,7 @@ postCorrectionR tid ssh csh shn cid = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess fileUploads -> do uid <- requireAuthId - + void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI Success MsgRatingFilesUpdated @@ -545,7 +542,7 @@ postCorrectionR tid ssh csh shn cid = do _ -> notFound getCorrectionUserR tid ssh csh shn cid = do sub <- decrypt cid - + results <- runDB $ correctionData tid ssh csh shn sub case results of @@ -557,7 +554,7 @@ getCorrectionUserR tid ssh csh shn cid = do $(widgetFile "correction-user") _ -> notFound - + getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do @@ -577,7 +574,7 @@ postCorrectionsUploadR = 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") @@ -692,17 +689,17 @@ postCorrectionsCreateR = do insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser { submissionUserUser = sheetPseudonymUser , submissionUserSubmission = subId - } + } addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc redirect CorrectionsGradeR - - + + defaultLayout $ $(widgetFile "corrections-create") where partitionEithers' :: [[Either a b]] -> ([[b]], [a]) - partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) - + partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) + textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) = let @@ -735,7 +732,7 @@ postCorrectionsGradeR = do psValidator = def & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) - + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \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 @@ -762,3 +759,43 @@ postCorrectionsGradeR = do 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 + -- Beginn Verify that CryptoId matches ordinary prameters + -- Necessarry, since authorisation checks those parameters only, but can be changed by user! + Sheet{sheetCourse, sheetName} <- get404 submissionSheet + Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse + let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName] + unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] + -- End Verification + 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") + + + + diff --git a/templates/formPage.hamlet b/templates/formPage.hamlet index f75289e29..c0b36d13f 100644 --- a/templates/formPage.hamlet +++ b/templates/formPage.hamlet @@ -1,2 +1,2 @@ -

+ ^{formWidget} diff --git a/templates/formPageI18n.hamlet b/templates/formPageI18n.hamlet index 34c3bd3f9..bf8b877ca 100644 --- a/templates/formPageI18n.hamlet +++ b/templates/formPageI18n.hamlet @@ -1,5 +1,5 @@ $maybe text <- formText

_{text} - + ^{formWidget} diff --git a/templates/submission-assign.hamlet b/templates/submission-assign.hamlet new file mode 100644 index 000000000..0c6d86757 --- /dev/null +++ b/templates/submission-assign.hamlet @@ -0,0 +1,2 @@ + + ^{corrForm} \ No newline at end of file From b27fb8f391800f195f6434bf96ce0fd9f4f30ea6 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 13 Nov 2018 14:23:43 +0100 Subject: [PATCH 6/8] Bugfix: SAssignR time attribute --- src/Foundation.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index ee0c578d5..239cc33cc 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -427,7 +427,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req cTime <- liftIO getCurrentTime let visible = NTop sheetVisibleFrom <= NTop (Just cTime) - active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo + active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo + marking = cTime > sheetActiveTo guard visible @@ -436,7 +437,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SubmissionNewR -> guard active - SubmissionR _ SAssignR -> guard $ not active -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change + SubmissionR _ SAssignR -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change SubmissionR _ _ -> guard active _ -> return () From dc4f37c921d9c1fcbee8af2e300a37aed57f0652 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 13 Nov 2018 15:36:59 +0100 Subject: [PATCH 7/8] Subtask for #233. Rights checked for Corrector assignment --- messages/uniworx/de.msg | 1 + routes | 4 +- src/Handler/Corrections.hs | 44 ++++++++++++++----- src/Utils.hs | 20 ++++++++- .../submissionsAssignUnauthorized.hamlet | 5 +++ 5 files changed, 58 insertions(+), 16 deletions(-) create mode 100644 templates/messages/submissionsAssignUnauthorized.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 14fff01cf..f28a96c9c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -231,6 +231,7 @@ 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: +SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist): 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. diff --git a/routes b/routes index b4c90b0cd..406500f4d 100644 --- a/routes +++ b/routes @@ -77,10 +77,10 @@ /subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions /subs/own SubmissionOwnR GET !free -- just redirect /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: - / SubShowR GET POST !ownerANDtime !ownerANDisRead + / SubShowR GET POST !ownerANDtime !ownerANDisRead /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner /assign SAssignR GET POST !lecturerANDtime - /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated + /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner /correctors SCorrR GET POST /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index a64605446..06cc76545 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -302,9 +302,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = 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) - - unless (null unassigned) $ do - num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] + (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 ] @@ -316,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = return (E.countRows :: E.SqlExpr (E.Value Int64)) when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors redirect currentRoute - FormSuccess (CorrSetCorrectorData Nothing, subs') -> do + FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections subs <- mapM decrypt $ Set.toList subs' runDB $ do num <- updateWhereCount [SubmissionId <-. subs] - [ SubmissionRatingPoints =. Nothing - , SubmissionRatingComment =. Nothing - , SubmissionRatingBy =. Nothing + [ 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 @@ -337,8 +341,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = 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) - unless (null unassigned) $ do - (assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned) + (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 @@ -350,7 +359,18 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = 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) @@ -768,12 +788,12 @@ postSAssignR tid ssh csh shn cID = do sId <- decrypt cID (currentCorrector, sheetCorrectors) <- runDB $ do Submission{submissionRatingBy, submissionSheet} <- get404 sId - -- Beginn Verify that CryptoId matches ordinary prameters + -- Beginn Verify that CryptoId matches ordinary prameters, see #233 -- Necessarry, since authorisation checks those parameters only, but can be changed by user! Sheet{sheetCourse, sheetName} <- get404 submissionSheet Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName] - unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] + unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored -- End Verification sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] userCorrector <- traverse getJustEntity submissionRatingBy diff --git a/src/Utils.hs b/src/Utils.hs index 23dc860ff..c035e8d93 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if maybePositive a | a > 0 = Just a - | otherwise = Nothing + | otherwise = Nothing -positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive +positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive positiveSum (Sum x) = maybePositive x maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b @@ -443,6 +443,22 @@ orM = Fold.foldr or2M (return False) anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool anyM xs f = orM $ fmap f xs +partitionM :: forall mono m . + ( MonoFoldable mono + , Monoid mono + , MonoPointed mono + , Monad m) + => (Element mono -> m Bool) -> mono -> m (mono, mono) +partitionM crit = ofoldlM dist mempty + where + dist :: (mono,mono) -> Element mono -> m (mono,mono) + dist acc x = do + okay <- crit x + return $ if + | okay -> acc `mappend` (opoint x, mempty) + | otherwise -> acc `mappend` (mempty, opoint x) + + -------------- -- Sessions -- -------------- diff --git a/templates/messages/submissionsAssignUnauthorized.hamlet b/templates/messages/submissionsAssignUnauthorized.hamlet new file mode 100644 index 000000000..f0002faed --- /dev/null +++ b/templates/messages/submissionsAssignUnauthorized.hamlet @@ -0,0 +1,5 @@ +_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))} + +
    + $forall cID <- unassignedUnauth' +
  • #{toPathPiece cID}
    
    From 94ee06d3c7c3b3cbba1ee92edd5165714bde4937 Mon Sep 17 00:00:00 2001
    From: SJost 
    Date: Tue, 13 Nov 2018 16:03:13 +0100
    Subject: [PATCH 8/8] All routes with CryptoIds are verified now, see #233
    
    ---
     src/Foundation.hs          | 10 ++++++++++
     src/Handler/Corrections.hs |  7 -------
     2 files changed, 10 insertions(+), 7 deletions(-)
    
    diff --git a/src/Foundation.hs b/src/Foundation.hs
    index 239cc33cc..92049906e 100644
    --- a/src/Foundation.hs
    +++ b/src/Foundation.hs
    @@ -1427,6 +1427,7 @@ routeNormalizers =
       , ncSchool
       , ncCourse
       , ncSheet
    +  , verifySubmission
       ]
       where
         normalizeRender route = route <$ do
    @@ -1464,6 +1465,15 @@ routeNormalizers =
           Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
           hasChanged shn sheetName
           return $ CSheetR tid ssh csh sheetName subRoute
    +    verifySubmission = maybeOrig $ \route -> do
    +      CSubmissionR _tid _ssh _csh _shn cID sr <- return route
    +      sId <- decrypt cID
    +      Submission{submissionSheet}   <- lift . lift $ get404 sId
    +      Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
    +      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
    +      let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
    +      tell . Any $ route /= newRoute
    +      return newRoute
     
     
     -- How to run database actions.
    diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
    index 06cc76545..73f0df665 100644
    --- a/src/Handler/Corrections.hs
    +++ b/src/Handler/Corrections.hs
    @@ -788,13 +788,6 @@ postSAssignR tid ssh csh shn cID = do
       sId <- decrypt cID
       (currentCorrector, sheetCorrectors) <- runDB $ do
         Submission{submissionRatingBy, submissionSheet} <- get404 sId
    -    -- Beginn Verify that CryptoId matches ordinary prameters, see #233
    -    -- Necessarry, since authorisation checks those parameters only, but can be changed by user!
    -    Sheet{sheetCourse, sheetName} <- get404 submissionSheet
    -    Course{courseTerm, courseSchool, courseShorthand} <- get404 sheetCourse
    -    let cidMatches = and [tid==courseTerm, ssh==courseSchool, csh==courseShorthand, shn==sheetName]
    -    unless cidMatches $ invalidArgsI [MsgErrorCryptoIdMismatch] -- maybe remove message if refactored
    -    -- End Verification
         sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
         userCorrector <- traverse getJustEntity submissionRatingBy
         return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)