Merge branch 'master' into datepicker-focusout

.gitlab-ci.yml

@@ -2,7 +2,6 @@ default:
   image:
     name: fpco/stack-build:lts-13.21
   cache:
-    key: "${CI_COMMIT_REF_SLUG}"
     paths:
       - node_modules
       - .stack
@@ -216,7 +215,7 @@ yesod:test:
 deploy:uniworx4:
   stage: deploy
   script:
-    - ssh root@uniworx4.ifi.lmu.de <bin/uniworx
+    - ssh -i ~/.ssh/id root@uniworx4.ifi.lmu.de <bin/uniworx
   needs:
     - yesod:build
     - yesod:test # For sanity
@@ -224,12 +223,9 @@ deploy:uniworx4:
   before_script:
     - apt-get update -y
     - apt-get install -y --no-install-recommends openssh-client
-    - mkdir -p ~/.ssh
+    - install -m 0700 -d ~/.ssh
-    - chmod 700 ~/.ssh
     - install -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts
     - install -m 0400 ${SSH_PRIVATE_KEY_UNIWORX4} ~/.ssh/id
-    - eval $(ssh-agent -s)
-    - ssh-add ~/.ssh/id
   dependencies:
     - yesod:build
         

CHANGELOG.md

@@ -2,6 +2,28 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [7.22.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.21.5...v7.22.0) (2019-11-14)
+
+
+### Bug Fixes
+
+* **corrections-grade:** fix inFix ([2c2dd8d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2c2dd8d))
+
+
+### Features
+
+* **corrections:** added missing titles; small message fixes ([018082e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/018082e))
+* **corrections-grade:** additional column for sheetType ([4cb2d4f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4cb2d4f))
+* **corrections-grade:** basic filter UI with pseudonyms ([d03fd4b](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d03fd4b))
+* **corrections-grade:** sorting by sheetType ([702fb1d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/702fb1d))
+* **corrections-grade:** working additional filters ([c4eb2c0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c4eb2c0))
+
+
+
+### [7.21.5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.21.4...v7.21.5) (2019-11-13)
+
+
+
 ### [7.21.4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.21.3...v7.21.4) (2019-11-13)
 
 

messages/uniworx/de-de-formal.msg

@@ -347,6 +347,8 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs
 CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
 CorrectorAssignTitle: Korrektor zuweisen
 
+CorrectionsGrade: Abgaben online korrigieren
+
 MaterialName: Name
 MaterialType: Art
 MaterialTypePlaceholder: Folien, Code, Beispiel, ...
@@ -958,7 +960,7 @@ NotificationTriggerKindEvaluation: Für Vorlesungsumfragen
 NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten)
 NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen
 
-CorrCreate: Abgaben erstellen
+CorrCreate: Abgaben registrieren
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
 InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
 InvalidPseudonymSubmissionIgnored oPseudonyms@Text iPseudonym@Text: Abgabe mit Pseudonymen „#{oPseudonyms}“ wurde ignoriert, da „#{iPseudonym}“ nicht automatisiert zu einem validen Pseudonym korrigiert werden konnte.

messages/uniworx/en-eu.msg

@@ -346,6 +346,8 @@ CourseCorrectionsTitle: Corrections for this course
 CorrectorsHead sheetName: Correctors for #{sheetName}
 CorrectorAssignTitle: Assign corrector
 
+CorrectionsGrade: Grade submissions online
+
 MaterialName: Name
 MaterialType: Type
 MaterialTypePlaceholder: Slides, Code, Example, ...
@@ -955,7 +957,7 @@ NotificationTriggerKindEvaluation: For course evaluations
 NotificationTriggerKindAllocationStaff: For central allocations (lecturers)
 NotificationTriggerKindAllocationParticipant: For central allocations
 
-CorrCreate: Create submissions
+CorrCreate: Register submissions
 UnknownPseudonymWord pseudonymWord: Invalid pseudonym-word “#{pseudonymWord}”
 InvalidPseudonym pseudonym: Invalid pseudonym “#{pseudonym}”
 InvalidPseudonymSubmissionIgnored oPseudonyms iPseudonym: The submission with pseudonyms “#{oPseudonyms}” has been ignored since “#{iPseudonym}” could not be automatically corrected to be a valid pseudonym.
@@ -1114,7 +1116,7 @@ MenuSheetClone: Clone exercise sheet
 MenuCorrectionsUpload: Upload corrections
 MenuCorrectionsDownload: Download corrections
 MenuCorrectionsCreate: Register submissions
-MenuCorrectionsGrade: Mark submissions online
+MenuCorrectionsGrade: Grade submissions online
 MenuCorrectionsAssign: Assign corrections
 MenuCorrectionsAssignSheet name@Text: Assign corrections for #{name}
 MenuAuthPreds: Authorisation settings

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "7.21.4",
+  "version": "7.22.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "7.21.4",
+  "version": "7.22.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 7.21.4
+version: 7.22.0
 
 dependencies:
   - base >=4.9.1.0 && <5

src/Database/Esqueleto/Utils.hs

@@ -19,6 +19,7 @@ module Database.Esqueleto.Utils
   , sha256
   , maybe
   , SqlProject(..)
+  , (->.)
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -246,3 +247,6 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity v
 instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
   sqlProject = (E.?.)
   unSqlProject _ _ = Just
+
+(->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
+(->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t

src/Handler/Corrections.hs

@@ -217,6 +217,9 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
       _other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
   )
 
+colMaxPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
+colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgSheetType) $ i18nCell . (\DBRow{ dbrOutput=(_, Entity _ Sheet{sheetType}, _, _, _, _) } -> sheetType)
+
 colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
 colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ fmap (cellAttrs <>~ [("style","width:60%")]) $ formCell id
   (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
@@ -276,6 +279,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
       , ( "rating"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
         )
+      , ( "sheet-type"
+        , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> 
+          [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
+          , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value))
+          , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value))
+          ]
+        )
       , ( "israted"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
         )
@@ -369,11 +379,22 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
               E.where_ $ (\f -> f user $ Set.singleton needle) $
                 E.mkContainsFilter (E.^. UserMatrikelnummer)
         )
-      -- , ( "pseudonym"
+      , ( "rating-visible"
-      --   , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do
+        , FilterColumn $  \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
-      --       E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet
+            Nothing   -> E.val True :: E.SqlExpr (E.Value Bool)
-      --       E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB.
+            Just True -> E.isJust    $ submission E.^. SubmissionRatingTime
-      --   )
+            Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
+        )
+      , ( "rating"
+        , FilterColumn $  \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if
+            | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool)
+            | otherwise    -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints)
+        )
+      , ( "comment"
+        , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of
+            Nothing     -> E.val True :: E.SqlExpr (E.Value Bool)
+            Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
+        )
       ]
     , dbtFilterUI  = fromMaybe mempty dbtFilterUI
     , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
@@ -983,7 +1004,8 @@ postCorrectionsCreateR = do
         , formEncoding = pseudonymEncoding
         }
 
-  defaultLayout
+  siteLayoutMsg MsgCorrCreate $ do
+    setTitleI MsgCorrCreate
     $(widgetFile "corrections-create")
   where
     partitionEithers' :: [[Either a b]] -> ([[b]], [a])
@@ -1013,8 +1035,28 @@ postCorrectionsGradeR = do
         , colRated
         , colRatedField
         , colPointsField
+        , colMaxPointsField
         , colCommentField
         ] -- Continue here
+      filterUI = Just $ \mPrev -> mconcat
+        [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
+        , prismAForm (singletonFilter "term"   ) mPrev $ aopt (lift `hoistField` selectField termOptions)   (fslI MsgTerm)
+        , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
+        , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField)                 (fslI MsgSheet)        (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+        , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant)             (fslI MsgRatingTime)
+        , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
+        , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
+        , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
+        ]
+      courseOptions = runDB $ do
+        courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
+        optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
+      termOptions = runDB $ do
+        courses <- selectList [] [Asc CourseTerm]      >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
+        optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
+      schoolOptions = runDB $ do
+        courses <- selectList [] [Asc CourseSchool]    >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
+        optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
       psValidator = def
         & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
       unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
@@ -1023,7 +1065,7 @@ postCorrectionsGradeR = do
         void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
         return i
 
-  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns mempty psValidator dbtProj' $ def
+  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator dbtProj' $ def
     { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
     }
 
@@ -1048,7 +1090,8 @@ postCorrectionsGradeR = do
           content = Right $(widgetFile "messages/correctionsUploaded")
       unless (null subs') $ addMessageModal Success trigger content
 
-  defaultLayout $
+  siteLayoutMsg MsgCorrectionsGrade $ do
+    setTitleI MsgCorrectionsGrade
     $(widgetFile "corrections-grade")