Merge branch 'master' into datepicker-focusout

2019-11-14 12:26:22 +01:00 · 2019-11-14 12:26:22 +01:00 · d6305f5669
commit d6305f5669
parent 7fa0124fe2 8708ca4a02
9 changed files with 89 additions and 20 deletions
--- a/.gitlab-ci.yml
+++ b/.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
-    - chmod 700 ~/.ssh
+    - install -m 0700 -d ~/.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
        
--- a/CHANGELOG.md
+++ b/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)


--- a/messages/uniworx/de-de-formal.msg
+++ b/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.
--- a/messages/uniworx/en-eu.msg
+++ b/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
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "7.21.4",
+  "version": "7.22.0",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "7.21.4",
+  "version": "7.22.0",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 7.21.4
+version: 7.22.0

 dependencies:
  - base >=4.9.1.0 && <5
--- a/src/Database/Esqueleto/Utils.hs
+++ b/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
--- a/src/Handler/Corrections.hs
+++ b/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"
-      --   , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(pseudonym) -> do
-      --       E.where_ $ querySheet table E.^. SheetId E.==. pseudonym E.^. SheetPseudonymSheet
-      --       E.where_ $ E.mkContainsFilter -- DB only stores Pseudonym == Word24. Conversion not possible in DB.
-      --   )
+      , ( "rating-visible"
+        , FilterColumn $  \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
+            Nothing   -> E.val True :: E.SqlExpr (E.Value Bool)
+            Just True -> E.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")