Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

.vscode/tasks.json

@@ -28,7 +28,8 @@
         "focus": false,
         "panel": "dedicated",
         "showReuseMessage": false
-      }      
+      },
+      "problemMatcher": []
     },
     {
       "label": "test",

README.md

@@ -3,72 +3,118 @@
 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:` - [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*:
-  `createdb uniworx`
+  ```sh
+  $ createdb uniworx
+  ```
 
-  to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:  
+  after you added the database switch back to your own user with `Ctrl + D`.
-  `sudo adduser 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*.
+  ```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:
+  ```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:
-  `./fill-db.hs`
+  ```sh
+  $ ./db.sh -f
+  ```
 
   Run the app:
-  `./start.sh`
+  ```sh
-
+  $ ./start.sh
-  `Devel application launched: http://localhost:3000`  
+  ...
-  means you are good to go.
+  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.
 

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})
@@ -192,6 +194,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.
@@ -231,6 +234,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.
@@ -489,6 +493,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
 

models

@@ -15,7 +15,7 @@ User json
     notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
-    deriving Show
+    deriving Show Eq
 UserAdmin
     user   UserId
     school SchoolId

routes

@@ -79,9 +79,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
-      /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
+      /assign                   SAssignR      GET POST	      !lecturerANDtime
+      /correction               CorrectionR   GET POST        !corrector !ownerANDisReadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
     /correctors                 SCorrR        GET POST
     /pseudonym                  SPseudonymR   GET POST        !registeredANDcorrector-submissions

src/Foundation.hs

@@ -425,6 +425,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
     let
       visible = NTop sheetVisibleFrom <= NTop (Just cTime)
       active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+      marking = cTime > sheetActiveTo
 
     guard visible
 
@@ -434,6 +435,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
       SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
       SubmissionNewR         -> guard   active
       SubmissionR _ _        -> guard   active
+      SubmissionR _ SAssignR -> guard $ marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
       _                      -> return ()
 
     return Authorized
@@ -1262,6 +1264,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
@@ -1453,6 +1463,7 @@ routeNormalizers =
   , ncSchool
   , ncCourse
   , ncSheet
+  , verifySubmission
   ]
   where
     normalizeRender route = route <$ do
@@ -1490,6 +1501,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.

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, _, _) } ->
+        $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
-          let tid = course ^. _3
-              ssh = course ^. _4
-              csh = course ^. _2
-          in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
 
 colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@@ -306,8 +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
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-          num <- updateWhereCount [SubmissionId <-. Set.toList 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
                     ]
@@ -319,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
+                  [ SubmissionRatingBy       =. Nothing
-                  , SubmissionRatingComment  =. 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
@@ -340,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
+        (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
-          (assigned, stillUnassigned) <- assignSubmissions shid (Just 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
@@ -353,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)
 
@@ -366,13 +383,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 $   user E.^. UserId   E.==. sheetCorrector E.^. SheetCorrectorUser
-                           E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+                           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
 
@@ -762,3 +779,36 @@ 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
+    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")
+
+
+
+

src/Utils.hs

@@ -441,6 +441,22 @@ ofoldr1M _ _ = error "otoList of NonNull is empty"
 ofoldl1M f (otoList -> x:xs) = foldlM f x xs
 ofoldl1M _ _ = error "otoList of NonNull is empty"
 
+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 --
 --------------

templates/formPage.hamlet

@@ -1,2 +1,2 @@
-<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
+<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
   ^{formWidget}

templates/formPageI18n.hamlet

@@ -1,5 +1,5 @@
 $maybe text <- formText
   <h3>
     _{text}
-<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
+<form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
    ^{formWidget}

templates/messages/submissionsAssignUnauthorized.hamlet

@@ -0,0 +1,5 @@
+_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
+
+<ul>
+  $forall cID <- unassignedUnauth'
+    <li><pre>#{toPathPiece cID}

templates/standalone/inputs.lucius

@@ -91,7 +91,6 @@ input[type*="time"] {
 
 input[type="number"] {
   width: 100px;
-  text-align: right;
 }
 
 input[type*="date"],

templates/submission-assign.hamlet

@@ -0,0 +1,2 @@
+<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
+   ^{corrForm}