Merge branch 'master' into course-teaser

.gitignore

@@ -35,3 +35,4 @@ src/Handler/Course.SnapCustom.hs
 tags
 test.log
 *.dump-splices
+/.stack-work.lock

CHANGELOG.md

@@ -2,6 +2,53 @@
 
 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.
 
+### [2.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v2.1.0...v2.1.1) (2019-07-10)
+
+
+### Bug Fixes
+
+* **assign correctors:** also show names of unenlisted correctors ([de49a77](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/de49a77))
+* **build:** fix build ([49dc413](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/49dc413))
+
+
+
+## [2.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v2.0.0...v2.1.0) (2019-07-10)
+
+
+### Bug Fixes
+
+* **corrector handling:** show correctors by a consistent order ([9c5ed5f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9c5ed5f))
+* **translation:** fix typos in translations; add bug to known bugs ([ac3f7bb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ac3f7bb))
+
+
+### Features
+
+* **csv:** introduce csv export ([631bbef](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/631bbef))
+
+
+
+## [2.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.4.1...v2.0.0) (2019-07-10)
+
+
+### Bug Fixes
+
+* **correction:** comment column made wide in online correction form ([d83b1f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d83b1f6)), closes [#373](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/373)
+* **number-input-fields:** number inputs made HTML5 compatible ([6098215](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/6098215)), closes [#412](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/412)
+* **ratings:** disallow ratings for graded sheets without point value ([c0b90c4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c0b90c4))
+* **tooltips:** fixes font-color when used in tableheaders ([f4bb70e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f4bb70e))
+
+
+### Features
+
+* **exams:** show study features of registered users ([04bea76](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/04bea76))
+
+
+### BREAKING CHANGES
+
+* **exams:** E.isInfixOf and E.hasInfix
+
+
+
 ### [1.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v1.4.0...v1.4.1) (2019-07-04)
 
 

build.sh

@@ -2,6 +2,8 @@
 
 set -e
 
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 echo "Building..."
 stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@
 echo "Done."

clean.sh

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 case $1 in
     "")
         exec -- stack clean

db.sh

@@ -1,6 +1,9 @@
 #!/usr/bin/env bash
 # Options: see /test/Database.hs (Main)
+
 set -e
 
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 stack build --fast --flag uniworx:-library-only --flag uniworx:dev
 stack exec uniworxdb -- $@

deploy.sh

@@ -1,21 +0,0 @@
-#!/usr/bin/env sh
-
-configFile=""
-
-case "$1" in
-    test)
-        ln -svf "keter_testworx.yml" config/keter.yml
-
-        yesod keter
-        ;;
-    production)
-        ln -svf "keter_uni2work.yml" config/keter.yml
-
-        yesod keter && git tag -f live && git push origin live
-        ;;
-    *)
-        echo "Usage: $0 (test|production)" >&2
-        exit 2
-        ;;
-esac
-

ghci.sh

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true

haddock.sh

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 move-back() {
     mv -v .stack-work .stack-work-doc
     [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work

hlint.sh

@@ -1,3 +1,7 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint

messages/uniworx/de.msg

@@ -705,7 +705,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
 NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
 NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen
 NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
-NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
+NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden
 NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
 
 CorrCreate: Abgaben erstellen
@@ -1171,3 +1171,10 @@ VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
 
 ExamUsersHeading: Klausurteilnehmer
+
+CsvFile: CSV-Datei
+CsvModifyExisting: Existierende Einträge angleichen
+CsvAddNew: Neue Einträge einfügen
+CsvDeleteMissing: Fehlende Einträge entfernen
+BtnCsvExport: CSV-Datei exportieren
+BtnCsvImport: CSV-Datei importieren

package-lock.json

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

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "1.4.1",
+  "version": "2.1.1",
   "description": "",
   "keywords": [],
   "author": "",
@@ -9,10 +9,12 @@
     "start": "run-p frontend:build:watch yesod:start",
     "test": "run-s frontend:test yesod:test",
     "lint": "run-s frontend:lint yesod:lint",
+    "build": "run-s frontend:build yesod:build",
     "yesod:db": "./db.sh",
     "yesod:start": "./start.sh",
     "yesod:lint": "./hlint.sh",
     "yesod:test": "./test.sh",
+    "yesod:build": "./build.sh",
     "frontend:lint": "eslint frontend/src",
     "frontend:test": "karma start --conf karma.conf.js",
     "frontend:test:watch": "karma start --conf karma.conf.js --single-run false",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 1.4.1
+version: 2.1.1
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage
@@ -32,6 +32,7 @@ dependencies:
   - data-default
   - aeson >=0.6 && <1.3
   - conduit >=1.0 && <2.0
+  - conduit-combinators
   - monad-logger >=0.3 && <0.4
   - fast-logger >=2.2 && <2.5
   - wai-logger >=2.2 && <2.4
@@ -129,6 +130,9 @@ dependencies:
   - hourglass
   - unix
   - stm-delay
+  - cassava
+  - cassava-conduit
+  - constraints
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Database/Esqueleto/Utils.hs

@@ -7,7 +7,7 @@ module Database.Esqueleto.Utils
   , any, all
   , SqlIn(..)
   , mkExactFilter, mkExactFilterWith
-  , mkContainsFilter
+  , mkContainsFilter, mkContainsFilterWith
   , mkExistsFilter
   , anyFilter, allFilter
   ) where
@@ -40,12 +40,18 @@ isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (M
 isJust = E.not_ . E.isNothing
 
 -- | Check if the first string is contained in the text derived from the second argument
-isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) =>
+isInfixOf :: ( E.Esqueleto query expr backend
-   Text -> expr (E.Value s2) -> expr (E.Value Bool)
+             , E.SqlString s1
-isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
+             , E.SqlString s2
+             )
+          => expr (E.Value s1) -> expr (E.Value s2) -> expr (E.Value Bool)
+isInfixOf needle strExpr = E.castString strExpr `E.ilike` (E.%) E.++. needle E.++. (E.%)
 
-hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) =>
+hasInfix :: ( E.Esqueleto query expr backend
-   expr (E.Value s2) -> Text -> expr (E.Value Bool)
+            , E.SqlString s1
+            , E.SqlString s2
+            )
+         => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool)
 hasInfix = flip isInfixOf
 
 -- | Given a test and a set of values, check whether anyone succeeds the test
@@ -101,14 +107,23 @@ mkExactFilterWith cast lenslike row criterias
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
 --   (Keep Set here to ensure that there are no duplicates)
-mkContainsFilter :: (E.SqlString a)
+mkContainsFilter :: E.SqlString a
-  =>  (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
+                 => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
-  -> t                             -- ^ query row
+                 -> t                             -- ^ query row
-  -> Set.Set Text                  -- ^ needle collection
+                 -> Set.Set a                     -- ^ needle collection
-  -> E.SqlExpr (E.Value Bool)
+                 -> E.SqlExpr (E.Value Bool)
-mkContainsFilter lenslike row criterias
+mkContainsFilter = mkContainsFilterWith id
+  
+-- | like `mkContainsFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
+mkContainsFilterWith :: E.SqlString b
+                     => (a -> b)
+                     -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
+                     -> t                             -- ^ query row
+                     -> Set.Set a                     -- ^ needle collection
+                     -> E.SqlExpr (E.Value Bool)
+mkContainsFilterWith cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = any (hasInfix $ lenslike row) criterias
+  | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
 
 mkExistsFilter :: PathPiece a
                => (t -> a -> E.SqlQuery ())

src/Foundation.hs

@@ -689,7 +689,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
       _          -> return ()
 
     return Authorized
-  
+
   CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
     now <- liftIO getCurrentTime
     course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@@ -2374,6 +2374,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuCorrectionsAssign
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType  = PageActionSecondary
       , menuItemLabel = MsgMenuSheetEdit

src/Handler/Admin.hs

@@ -388,6 +388,8 @@ postAdminFeaturesR = do
                               }
           psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
                         & defaultSorting [SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 
     mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
@@ -421,6 +423,8 @@ postAdminFeaturesR = do
           psValidator   = def
                         -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
                         & defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 
     mkCandidateTable =
@@ -454,5 +458,7 @@ postAdminFeaturesR = do
             ]
           dbtParams     = def
           psValidator   = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 

src/Handler/Corrections.hs

@@ -348,9 +348,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
         )
       , ( "corrector-name-email" -- corrector filter does not work for text-filtering
         , FilterColumn $ E.anyFilter
-            [ E.mkContainsFilter $ queryCorrector >>> (E.?. UserSurname)
+            [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname)
-            , E.mkContainsFilter $ queryCorrector >>> (E.?. UserDisplayName)
+            , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName)
-            , E.mkContainsFilter $ queryCorrector >>> (E.?. UserEmail)
+            , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail)
             ]
         )
       , ( "user-name-email"
@@ -360,7 +360,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
               E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter
                 [ E.mkContainsFilter (E.^. UserSurname)
                 , E.mkContainsFilter (E.^. UserDisplayName)
-                , E.mkContainsFilter (E.^. UserEmail)
+                , E.mkContainsFilterWith CI.mk (E.^. UserEmail)
                 ]
         )
       , ( "user-matriclenumber"
@@ -380,6 +380,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
     , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
     , dbtParams
     , dbtIdent     = "corrections" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
 data ActionCorrections = CorrDownload
@@ -564,6 +566,8 @@ assignAction selId = ( CorrSetCorrector
 
                            E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
 
+                           E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+
                            E.distinct $ return user
 
                          correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
@@ -1136,17 +1140,24 @@ assignHandler tid ssh csh cid assignSids = do
           E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
           E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
           return (corrector, user)
-      let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
+      let correctorMap' :: Map UserId (User, Map SheetName SheetCorrector)
-          correctorMap = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
+          correctorMap' = (\f -> foldl f Map.empty correctors)
-              let shn = sheetName $ sheets ! sheetCorrectorSheet
+            (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
-              in  Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb))  uid (user, Map.singleton shn sheetcorr) acc
+                let shn = sheetName $ sheets ! sheetCorrectorSheet
+                in  Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb))  uid (user, Map.singleton shn sheetcorr) acc
+            )
+      -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names
+      act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do
+          E.on $ submission E.^. SubmissionRatingBy E.==. (E.just $ user E.^. UserId)
+          E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
+          return (submission E.^. SubmissionSheet, user)
+      let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
+          correctorMap = (\f -> foldl f correctorMap' act_correctors)
+            (\acc (E.Value sheetCorrectorSheet, Entity uid user) ->
+                let shn = sheetName $ sheets ! sheetCorrectorSheet
+                    scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused
+                in  Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged
             )
-
-      -- -- lecturerNames :: Map UserId User
-      -- lecturerNames <- fmap entities2map $ E.select $ E.from $ \(user `E.InnerJoin` lecturer) -> do
-      --     E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
-      --     E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
-      --     return user
 
       submissions <- E.select . E.from $ \submission -> do
           E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds

src/Handler/Course.hs

@@ -205,6 +205,8 @@ makeCourseTable whereClause colChoices psValidator = do
     , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
     , dbtParams = def
     , dbtIdent = "courses" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
 getCourseListR :: Handler Html
@@ -402,6 +404,8 @@ getCShowR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "tutorials"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     tutorialDBTableValidator = def
       & defaultSorting [SortAscBy "type", SortAscBy "name"]
@@ -459,6 +463,8 @@ getCShowR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
@@ -1140,13 +1146,13 @@ makeCourseUserTable cid restrict colChoices psValidator = do
           , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
           , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
           , ("field"       , FilterColumn $ E.anyFilter
-                                 [ E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsName)
+                                 [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
-                                 , E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
+                                 , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
                                  , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
                                  ] )
           , ("degree"      , FilterColumn $ E.anyFilter
-                                 [ E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
+                                 [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
-                                 , E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
+                                 , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
                                  , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
                                  ] )
           , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
@@ -1154,7 +1160,7 @@ makeCourseUserTable cid restrict colChoices psValidator = do
                 E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
                   E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
                   E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
-                       E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion
+                       E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
                        E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
             )
           -- , ("course-registration", error "TODO") -- TODO
@@ -1181,6 +1187,8 @@ makeCourseUserTable cid restrict colChoices psValidator = do
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
           }
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
     over _1 postprocess <$> dbTable psValidator DBTable{..}
   where
     postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)

src/Handler/Exam.hs

@@ -9,6 +9,7 @@ import Handler.Utils.Exam
 import Handler.Utils.Invitations
 import Handler.Utils.Table.Columns
 import Handler.Utils.Table.Cells
+import Handler.Utils.Csv
 import Jobs.Queue
 
 import Utils.Lens hiding (parts)
@@ -29,6 +30,10 @@ import qualified Data.CaseInsensitive as CI
 
 import qualified Control.Monad.State.Class as State
 
+import qualified Data.Csv as Csv
+
+import qualified Data.Conduit.List as C
+
 
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
@@ -74,6 +79,8 @@ getCExamListR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
@@ -733,8 +740,8 @@ getEShowR tid ssh csh examn = do
       examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
     $(widgetFile "exam-show")
 
-type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))))
-type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence))
+type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms))
 
 instance HasEntity ExamUserTableData User where
   hasEntity = _dbrOutput . _2
@@ -746,47 +753,124 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
 _userTableOccurrence = _dbrOutput . _3
 
 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
   
 queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
-queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+
+queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
+queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
+  
+queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
+queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
+
+resultUser :: Lens' ExamUserTableData (Entity User)
+resultUser = _dbrOutput . _2
+
+resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
+resultStudyFeatures = _dbrOutput . _4 . _Just
+
+resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
+resultStudyDegree = _dbrOutput . _5 . _Just
+  
+resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
+resultStudyField = _dbrOutput . _6 . _Just
+
+resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
+resultExamOccurrence = _dbrOutput . _3 . _Just
+
+data ExamUserTableCsv = ExamUserTableCsv
+  { csvUserSurname :: Text
+  , csvUserName :: Text
+  , csvUserMatriculation :: Maybe Text
+  , csvUserField :: Maybe Text
+  , csvUserDegree :: Maybe Text
+  , csvUserSemester :: Maybe Int
+  , csvUserRoom :: Maybe Text
+  }
+  deriving (Generic)
+
+examUserTableCsvOptions :: Csv.Options
+examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToNamedRecord ExamUserTableCsv where
+  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+
+instance FromNamedRecord ExamUserTableCsv where
+  parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions
+
+instance DefaultOrdered ExamUserTableCsv where
+  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
 
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
-  eid <- runDB $ fetchExamId tid ssh csh examn
+  Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn
   
   let
     examUsersDBTable = DBTable{..}
       where
-        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence) = do
+        dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
+          E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+          E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+          E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+          E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+           E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
           E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
            E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
           E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
           E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
-          return (examRegistration, user, occurrence)
+          return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
         dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
         dbtProj = return
         dbtColonnade = dbColonnade $ mconcat
           [ colUserNameLink (CourseR tid ssh csh . CUserR)
           , colUserMatriclenr
-          -- , colUserDegreeShort
+          , colField            resultStudyField
-          -- , colUserField
+          , colDegreeShort      resultStudyDegree
-          -- , colUserSemester
+          , colFeaturesSemester resultStudyFeatures
           , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence)
           ] 
         dbtSorting = Map.fromList
-          [ sortUserNameLink    queryUser
+          [ sortUserNameLink     queryUser
-          , sortUserSurname     queryUser
+          , sortUserSurname      queryUser
-          , sortUserDisplayName queryUser
+          , sortUserDisplayName  queryUser
-          , sortUserMatriclenr  queryUser
+          , sortUserMatriclenr   queryUser
+          , sortField            queryStudyField
+          , sortDegreeShort      queryStudyDegree
+          , sortFeaturesSemester queryStudyFeatures
           ]
-        dbtFilter = Map.empty
+        dbtFilter = Map.fromList
-        dbtFilterUI = const mempty
+          [ fltrUserNameEmail    queryUser
-        dbtStyle = def
+          , fltrUserMatriclenr   queryUser
+          , fltrField            queryStudyField
+          , fltrDegree           queryStudyDegree
+          , fltrFeaturesSemester queryStudyFeatures
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailUI    mPrev
+          , fltrUserMatriclenrUI   mPrev
+          , fltrFieldUI            mPrev
+          , fltrDegreeUI           mPrev
+          , fltrFeaturesSemesterUI mPrev
+          ]
+        dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exam-users"
+        dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
+        dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
+          <$> view (resultUser . _entityVal . _userSurname)
+          <*> view (resultUser . _entityVal . _userDisplayName)
+          <*> view (resultUser . _entityVal . _userMatrikelnummer)
+          <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+          <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+          <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+          <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom)
+        dbtCsvDecode = Nothing
 
     examUsersDBTableValidator = def
   ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable

src/Handler/Home.hs

@@ -80,6 +80,8 @@ homeOpenCourses = do
     , dbtStyle     = def
     , dbtParams    = def
     , dbtIdent     = "open-courses" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   $(widgetFile "home/openCourses")
 
@@ -179,6 +181,8 @@ homeUpcomingSheets uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtParams    = def
     , dbtIdent     = "upcoming-sheets" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   $(widgetFile "home/upcomingSheets")
 
@@ -286,6 +290,8 @@ homeUpcomingExams uid = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]

src/Handler/Material.hs

@@ -149,6 +149,8 @@ getMaterialListR tid ssh csh = do
             ]
       , dbtFilter    = mempty
       , dbtFilterUI  = mempty
+      , dbtCsvEncode  = noCsvEncode
+      , dbtCsvDecode  = Nothing
       }
 
   let headingLong  = prependCourseTitle tid ssh csh MsgMaterialListHeading
@@ -219,6 +221,8 @@ getMShowR tid ssh csh mnm = do
             [ sortFilePath         $(sqlIJproj 2 2)
             , sortFileModification $(sqlIJproj 2 2)
             ]
+      , dbtCsvEncode  = noCsvEncode
+      , dbtCsvDecode  = Nothing
       }
     return (matEnt,fileTable')
 

src/Handler/Profile.hs

@@ -258,6 +258,8 @@ mkOwnedCoursesTable =
           ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
@@ -308,6 +310,8 @@ mkEnrolledCoursesTable =
       , dbtFilterUI  = mempty
       , dbtStyle     = def
       , dbtParams = def
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
 
 
@@ -387,6 +391,8 @@ mkSubmissionTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
               in  dbTableWidget' validator DBTable{..}
@@ -459,6 +465,8 @@ mkSubmissionGroupTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 
@@ -535,6 +543,8 @@ mkCorrectionsTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 

src/Handler/Sheet.hs

@@ -310,6 +310,8 @@ getSheetListR tid ssh csh = do
       , dbtStyle     = def
       , dbtParams    = def
       , dbtIdent     = "sheets" :: Text
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
     -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
     --   -- Collect summary over all Sheets, not just the ones shown due to pagination:
@@ -404,6 +406,8 @@ getSShowR tid ssh csh shn = do
         )
       ]
     , dbtParams = def
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   (hasHints, hasSolution) <- runDB $ do
     hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
@@ -731,6 +735,7 @@ correctorForm shid = wFormToAForm $ do
       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
+      E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
       return user
 
     miAdd :: ListPosition

src/Handler/Submission.hs

@@ -520,6 +520,8 @@ submissionHelper tid ssh csh shn mcid = do
         , dbtFilter = mempty
         , dbtFilterUI = mempty
         , dbtParams = def
+        , dbtCsvEncode = noCsvEncode
+        , dbtCsvDecode = Nothing
         }
   mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 

src/Handler/SystemMessage.hs

@@ -224,6 +224,8 @@ postMessageListR = do
       , dbParamsFormIdent = def
       }
     , dbtIdent = "messages" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
   let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)

src/Handler/Term.hs

@@ -145,6 +145,8 @@ getTermShowR = do
         , dbtStyle = def
         , dbtParams = def
         , dbtIdent = "terms" :: Text
+        , dbtCsvEncode = noCsvEncode
+        , dbtCsvDecode = Nothing
         }
       defaultLayout $ do
         setTitleI MsgTermsHeading

src/Handler/Tutorial.hs

@@ -93,6 +93,8 @@ getCTutorialListR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "tutorials"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     tutorialDBTableValidator = def
       & defaultSorting [SortAscBy "type", SortAscBy "name"]

src/Handler/Users.hs

@@ -108,14 +108,14 @@ getUsersR = do
             )
           ]
       , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
-          [ ( "user-search", FilterColumn $ \user criterion ->
+          [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
-              if Set.null criterion then E.true else -- TODO: why is this condition not needed?
+              if Set.null criteria then E.true else -- TODO: why is this condition not needed?
                   -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
-                  E.any (user E.^. UserDisplayName `E.hasInfix`) criterion
+                  E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
             )
-          , ( "matriculation", FilterColumn $ \user (criterion :: Set.Set Text) -> if
+          , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
-                 | Set.null criterion -> E.true -- TODO: why can this be eFalse and work still?
+                 | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
-                 | otherwise          -> E.any (user E.^. UserMatrikelnummer `E.hasInfix`) criterion
+                 | otherwise         -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
             )
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
@@ -140,6 +140,8 @@ getUsersR = do
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = def
       , dbtIdent     = "users" :: Text
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
 
   defaultLayout $ do

src/Handler/Utils.hs

@@ -31,6 +31,7 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 -- import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Mail       as Handler.Utils
+import Handler.Utils.ContentDisposition as Handler.Utils
 
 import System.Directory (listDirectory)
 import System.FilePath.Posix (takeBaseName, takeFileName)
@@ -41,21 +42,6 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Control.Monad.Logger
 
 
--- | Check whether the user's preference for files is inline-viewing or downloading
-downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
-downloadFiles = do
-  mauth <- liftHandlerT maybeAuth
-  case mauth of
-    Just (Entity _ User{..}) -> return userDownloadFiles
-    Nothing -> do
-      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
-      return userDefaultDownloadFiles
-
-setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
-setContentDisposition' mFileName = do
-  wantsDownload <- downloadFiles
-  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
-
 -- | Simply send a `File`-Value
 sendThisFile :: File -> Handler TypedContent
 sendThisFile File{..}

src/Handler/Utils/ContentDisposition.hs

@@ -0,0 +1,24 @@
+module Handler.Utils.ContentDisposition
+  ( downloadFiles
+  , setContentDisposition'
+  ) where
+
+import Import
+
+import Utils.Lens
+
+-- | Check whether the user's preference for files is inline-viewing or downloading
+downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
+downloadFiles = do
+  mauth <- liftHandlerT maybeAuth
+  case mauth of
+    Just (Entity _ User{..}) -> return userDownloadFiles
+    Nothing -> do
+      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+      return userDefaultDownloadFiles
+
+setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
+setContentDisposition' mFileName = do
+  wantsDownload <- downloadFiles
+  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
+

src/Handler/Utils/Csv.hs

@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Utils.Csv
+  ( typeCsv, extensionCsv
+  , decodeCsv
+  , encodeCsv
+  , respondCsv, respondCsvDB
+  , fileSourceCsv
+  , CsvParseError(..)
+  , ToNamedRecord(..), FromNamedRecord(..)
+  , DefaultOrdered(..)
+  , ToField(..), FromField(..)
+  ) where
+
+import Import
+
+import Data.Csv
+import Data.Csv.Conduit
+
+import qualified Data.Conduit.List as C
+import qualified Data.Conduit.Combinators as C (sourceLazy)
+
+import qualified Data.Map as Map
+
+
+deriving instance Typeable CsvParseError
+instance Exception CsvParseError
+
+
+typeCsv :: ContentType
+typeCsv = "text/csv"
+
+extensionCsv :: Extension
+extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
+
+
+decodeCsv :: (MonadThrow m, FromNamedRecord csv) => Conduit ByteString m csv
+decodeCsv = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions
+
+encodeCsv :: ( ToNamedRecord csv
+             , DefaultOrdered csv
+             , Monad m
+             )
+          => Conduit csv m ByteString
+-- ^ Encode a stream of records
+--
+-- Currently not streaming
+encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy
+
+  
+respondCsv :: ( ToNamedRecord csv
+              , DefaultOrdered csv
+              )
+           => Source (HandlerT site IO) csv
+           -> HandlerT site IO TypedContent
+respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+
+respondCsvDB :: ( ToNamedRecord csv
+                , DefaultOrdered csv
+                , YesodPersistRunner site
+                )
+             => Source (YesodDB site) csv
+             -> HandlerT site IO TypedContent
+respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+
+fileSourceCsv :: ( FromNamedRecord csv
+                 , MonadResource m
+                 )
+              => FileInfo
+              -> Source m csv
+fileSourceCsv = (.| decodeCsv) . fileSource

src/Handler/Utils/Table/Cells.hs

@@ -194,6 +194,18 @@ cellHasEMail :: (IsDBTable m a, HasUser u) => u -> DBCell m a
 cellHasEMail = emailCell . view _userEmail
 
 
+cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c
+cellHasSemester = numCell . view _studyFeaturesSemester
+
+  
+cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c
+cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand
+
+  
+cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c
+cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName
+
+
 
 -- Just for documentation purposes; inline this code instead:
 maybeDateTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a

src/Handler/Utils/Table/Columns.hs

@@ -11,7 +11,6 @@ import Import
 
 -- import Text.Blaze (ToMarkup(..))
 
-import Data.Monoid (Any(..))
 import qualified Database.Esqueleto as E
 import Database.Esqueleto.Utils as E
 
@@ -19,6 +18,8 @@ import Utils.Lens
 import Handler.Utils
 import Handler.Utils.Table.Cells
 
+import qualified Data.CaseInsensitive as CI
+
 
 --------------------------------
 -- Generic Columns
@@ -121,7 +122,7 @@ sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>>
 defaultSortingByName :: PSValidator m x -> PSValidator m x
 defaultSortingByName =
   -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters
-  defaultSorting [SortAscBy "user-name"] -- new way, untested, working with single sorter
+  defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
 
 -- | Alias for sortUserName for consistency
 fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
@@ -156,9 +157,9 @@ fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool
    => (a -> E.SqlExpr (Entity User))
    -> (d, FilterColumn t)
 fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
-    [ mkContainsFilter  $ queryUser >>> (E.^. UserDisplayName)
+    [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
-    , mkContainsFilter  $ queryUser >>> (E.^. UserSurname)
+    , mkContainsFilter $ queryUser >>> (E.^. UserSurname)
-    , mkContainsFilter  $ queryUser >>> (E.^. UserEmail)
+    , mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail)
     ]
   )
 
@@ -179,12 +180,14 @@ colUserMatriclenr ::  (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell
 colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
 
 sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
-sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
+sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
 
-fltrUserMatriclenr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
-  => (a -> E.SqlExpr (Entity User))
+                      , IsString d
-  -> (d, FilterColumn t)
+                      )
-fltrUserMatriclenr queryUser = ( "user-matriclenumber", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserMatrikelnummer))
+                   => (a -> E.SqlExpr (Entity User))
+                   -> (d, FilterColumn t)
+fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
 
 fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
 fltrUserMatriclenrUI mPrev =
@@ -199,13 +202,83 @@ colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
 sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
 sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
 
-fltrUserEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
+fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))
-  => (a -> E.SqlExpr (Entity User))
+                 , IsString d
-  -> (d, FilterColumn t)
+                 )
-fltrUserEmail queryUser = ( "user-email", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserEmail))
+              => (a -> E.SqlExpr (Entity User))
+              -> (d, FilterColumn t)
+fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
 
 fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
 fltrUserEmailUI mPrev =
   prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgEMail)
 
 
+--------------------
+-- Study features --
+--------------------
+
+colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
+colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
+
+sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t)
+sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester))
+
+fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))
+                        , IsString d
+                        )
+                     => (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
+                     -> (d, FilterColumn t)
+fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
+
+fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrFeaturesSemesterUI mPrev =
+  prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field (YesodDB UniWorX) Int) (fslI MsgStudyFeatureAge)
+
+
+colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
+colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms
+
+sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t)
+sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName))
+
+fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
+             , IsString d
+             )
+          => (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
+          -> (d, FilterColumn t)
+fltrField queryFeatures = ( "terms"
+                          , FilterColumn $ anyFilter
+                            [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
+                            , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsShorthand)
+                            , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyTermsKey)
+                            ]
+                          )
+
+fltrFieldUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrFieldUI mPrev =
+  prismAForm (singletonFilter "terms") mPrev $ aopt textField (fslI MsgStudyTerm)
+
+
+colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
+colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms
+
+sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t)
+sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
+
+fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
+             , IsString d
+             )
+          => (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
+          -> (d, FilterColumn t)
+fltrDegree queryFeatures = ( "degree"
+                          , FilterColumn $ anyFilter
+                            [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)
+                            , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeShorthand)
+                            , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyDegreeKey)
+                            ]
+                          )
+
+fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrDegreeUI mPrev =
+  prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)

src/Handler/Utils/Table/Pagination.hs

@@ -6,7 +6,8 @@ module Handler.Utils.Table.Pagination
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
   , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
-  , DBTable(..), IsDBTable(..), DBCell(..)
+  , DBTCsvEncode, DBTCsvDecode
+  , DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
   , singletonFilter
   , DBParams(..)
   , cellAttrs, cellContents
@@ -35,6 +36,8 @@ module Handler.Utils.Table.Pagination
 import Handler.Utils.Table.Pagination.Types
 import Handler.Utils.Table.Pagination.Utils (getTableWidget)
 import Handler.Utils.Form
+import Handler.Utils.Csv
+import Handler.Utils.ContentDisposition
 import Utils
 import Utils.Lens.TH
 
@@ -68,7 +71,8 @@ import Text.Hamlet (hamletFile)
 
 import Data.Ratio ((%))
 
-import Control.Lens
+import Control.Lens hiding ((<.>))
+import Control.Lens.Extras (is)
 
 import Data.List (elemIndex)
 
@@ -90,6 +94,8 @@ import qualified Data.ByteString.Lazy as LBS
 
 import Data.Semigroup as Sem (Semigroup(..))
 
+import qualified Data.Conduit.List as C
+
 
 #if MIN_VERSION_base(4,11,0)
 type Monoid' = Monoid
@@ -155,12 +161,12 @@ instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
   filterColumn' fin _ _ = fin
 
 instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
-  filterColumn' cont is t = filterColumn' (cont t) is t
+  filterColumn' cont is' t = filterColumn' (cont t) is' t
 
 instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
-  filterColumn' cont is = filterColumn' (cont input) is'
+  filterColumn' cont is0 = filterColumn' (cont input) is'
     where
-      (input, ($ []) -> is') = go (mempty, id) is
+      (input, ($ []) -> is') = go (mempty, id) is0
       go acc [] = acc
       go (acc, is3) (i:is2)
         | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
@@ -264,6 +270,37 @@ piIsUnset PaginationInput{..} = and
   , isNothing piPage
   ]
 
+
+data ButtonCsvMode = BtnCsvExport | BtnCsvImport
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCsvMode
+instance Finite ButtonCsvMode
+
+embedRenderMessage ''UniWorX ''ButtonCsvMode id
+
+nullaryPathPiece ''ButtonCsvMode $ camelToPathPiece' 1
+
+instance Button UniWorX ButtonCsvMode where
+  btnLabel BtnCsvExport
+    = [whamlet|
+        $newline never
+        #{iconCSV}
+        \ _{BtnCsvExport}
+      |]
+  btnLabel BtnCsvImport
+    = [whamlet|
+        $newline never
+        _{BtnCsvImport}
+      |]
+
+data DBCsvMode = DBCsvNormal
+               | DBCsvExport
+               | DBCsvImport
+                 { _dbCsvFiles :: [FileInfo]
+                 , _dbCsvModifyExisting, _dbCsvAddNew, _dbCsvDeleteMissing :: Bool
+                 }
+
+
 type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
 data DBRow r = forall k'. DBTableKey k' => DBRow
   { dbrKey :: k'
@@ -405,7 +442,10 @@ instance PathPiece x => PathPiece (WithIdent x) where
     WithIdent <$> pure ident <*> fromPathPiece rest
 
 
-data DBTable m x = forall a r r' h i t k k'.
+type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv) (Conduit r' (YesodDB UniWorX) csv)
+type DBTCsvDecode csv = DictMaybe (FromNamedRecord csv) (Sink csv (YesodDB UniWorX) ())
+
+data DBTable m x = forall a r r' h i t k k' csv.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
@@ -413,16 +453,21 @@ data DBTable m x = forall a r r' h i t k k'.
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
-  , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
+  , dbtProj :: DBRow r -> MaybeT (YesodDB UniWorX) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map SortingKey (SortColumn t)
   , dbtFilter :: Map FilterKey (FilterColumn t)
-  , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
+  , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
   , dbtStyle :: DBStyle
   , dbtParams :: DBParams m x
+  , dbtCsvEncode :: DBTCsvEncode r' csv
+  , dbtCsvDecode :: DBTCsvDecode csv
   , dbtIdent :: i
   }
 
+noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void) (Conduit r' (YesodDB UniWorX) Void)
+noCsvEncode = Nothing
+
 class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
   data DBParams m x :: *
   type DBResult m x :: *
@@ -694,18 +739,68 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   mapM_ (addMessageI Warning) errs
 
+  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
+  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  let
+    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
+    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
+    substPi = foldr (.) id
+      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
+      , foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
+      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
+      , setParam (wIdent "page") $ fmap toPathPiece piPage
+      , setParam (wIdent "pagination") Nothing
+      ]
+    tblLink' :: (QueryText -> QueryText) -> Widget
+    tblLink' = toWidget <=< toTextUrl . tblLink
+
+  ((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport]
+  ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport
+    <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
+    <*> apopt checkBoxField (fslI MsgCsvModifyExisting) (Just True)
+    <*> apopt checkBoxField (fslI MsgCsvAddNew) (Just True)
+    <*> apopt checkBoxField (fslI MsgCsvDeleteMissing) (Just False)
+
+  let
+    csvMode = asum
+      [ csvExportRes <* guard (is _Just dbtCsvEncode)
+      , csvImportRes <* guard (is _Just dbtCsvDecode)
+      , FormSuccess DBCsvNormal
+      ]
+    csvExportWdgt' = wrapForm csvExportWdgt FormSettings
+      { formMethod = GET
+      , formAction = Just $ tblLink id
+      , formEncoding = csvExportEnctype
+      , formAttrs = [("target", "_blank")]
+      , formSubmit = FormNoSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+    csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings
+      { formMethod = POST
+      , formAction = Just $ tblLink id
+      , formEncoding = csvImportEnctype
+      , formAttrs = []
+      , formSubmit = FormSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+
+
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
     E.orderBy (map (sqlSortDirection t) psSorting')
-    case previousKeys of
+    case csvMode of
-      Nothing
+      FormSuccess DBCsvExport -> return ()
-        | PagesizeLimit l <- psLimit
+      FormSuccess DBCsvImport{} -> return ()
-          -> do
+      _other -> do
-            E.limit l
+        case previousKeys of
-            E.offset (psPage * l)
+          Nothing
-      Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
+            | PagesizeLimit l <- psLimit
-      _other  -> return ()
+              -> do
-    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
+                E.limit l
+                E.offset (psPage * l)
+          Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
+          _other  -> return ()
+        Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
     return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
   let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
@@ -723,20 +818,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
 
-  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
+
-  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  formResult csvMode $ \case
-  let
+    DBCsvExport
-    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
+      | Just (Dict, dbtCsvEncode') <- dbtCsvEncode
-    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
+        -> do
-    substPi = foldr (.) id
+          setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv
-      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
+          sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode'
-      , foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
+    DBCsvImport{}
-      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
+      | Just (Dict, _dbtCsvDecode) <- dbtCsvDecode
-      , setParam (wIdent "page") $ fmap toPathPiece piPage
+        -> error "dbCsvImport"
-      , setParam (wIdent "pagination") Nothing
+    _other      -> return ()
-      ]
-    tblLink' :: (QueryText -> QueryText) -> Widget
-    tblLink' = toWidget <=< toTextUrl . tblLink
 
   let
     rowCount
@@ -791,6 +883,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , formSubmit = FormAutoSubmit
       , formAnchor = Just $ wIdent "pagesize-form"
       }
+
+    csvWdgt = $(widgetFile "table/csv-transcode")
+
     uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
 
     dbInvalidateResult' = foldr (<=<) return . catMaybes $

src/Import/NoModel.hs

@@ -74,6 +74,9 @@ import Network.Mime as Import
 import Data.Aeson.TH as Import
 import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
 
+import Data.Constraint as Import (Dict(..))
+import Data.Void as Import (Void)
+
 import Language.Haskell.TH.Instances as Import ()
 import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()

src/Utils.hs

@@ -77,6 +77,8 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty)
 
 import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
 
+import Data.Constraint (Dict(..))
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -164,6 +166,10 @@ fileDownload = fontAwesomeIcon "file-download"
 zipDownload :: Markup
 zipDownload = fontAwesomeIcon "file-archive"
 
+iconCSV :: Markup
+iconCSV = fontAwesomeIcon "file-csv"
+
+
 -- Conditional icons
 
 isVisible :: Bool -> Markup
@@ -983,3 +989,12 @@ foldJoin = foldr (\/) bottom
 
 foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
 foldMeet = foldr (/\) top
+
+-----------------
+-- Constraints --
+-----------------
+
+type DictMaybe constr a = Maybe (Dict constr, a)
+
+pattern DictJust :: constr => a -> DictMaybe constr a
+pattern DictJust a = Just (Dict, a)

src/Utils/Form.hs

@@ -8,6 +8,7 @@ import Yesod.Core.Instances ()
 import Settings
 
 import Utils.Parameters
+import Utils.Lens
 
 import Text.Blaze (Markup)
 import qualified Text.Blaze.Internal as Blaze (null)
@@ -32,8 +33,6 @@ import Control.Monad.Morph (MFunctor(..))
 
 import Data.List ((!!))
 
-import Control.Lens
-
 import Web.PathPieces
 
 import Data.UUID
@@ -197,6 +196,8 @@ data FormIdentifier
   | FIDDBTableFilter
   | FIDDBTablePagesize
   | FIDDBTable
+  | FIDDBTableCsvExport
+  | FIDDBTableCsvImport
   | FIDDelete
   | FIDCourseRegister
   | FIDuserRights
@@ -591,6 +592,19 @@ htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
     sanitize :: Text -> m (Either FormMessage Html)
     sanitize = return . Right . preEscapedText . sanitizeBalance
 
+fileFieldMultiple :: Monad m => Field m [FileInfo]
+fileFieldMultiple = Field
+  { fieldParse = \_ files -> return $ case files of
+      [] -> Right Nothing
+      fs -> Right $ Just fs
+  , fieldView = \id' name attrs _ isReq ->
+      [whamlet|
+        $newline never
+        <input type="file" uw-file-input id=#{id'} name=#{name} *{attrs} multiple :isReq:required="required">
+      |]                                  
+  , fieldEnctype = Multipart
+  }
+
 -----------
 -- Forms --
 -----------
@@ -635,7 +649,7 @@ wrapForm' btn formWidget FormSettings{..} = do
 -------------------
 
 -- | Use this type to pass information to the form template
-data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
+data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport
 
 renderAForm :: Monad m => FormLayout -> FormRender m a
 renderAForm formLayout aform fragment = do
@@ -932,3 +946,20 @@ apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx
 wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
 wpreq f fs mx = mFormToWForm $ mpreq f fs mx
+
+
+mpopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
+-- ^ Pseudo optional
+--
+-- `FieldView` has `fvRequired` set to `False`
+-- Otherwise acts exactly like `mreq`.
+mpopt f fs mx = set (_2 . _fvRequired) False <$> mreq f fs mx
+
+apopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+apopt f fs mx = formToAForm $ over _2 pure <$> mpopt f fs mx
+
+wpopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpopt f fs mx = mFormToWForm $ mpopt f fs mx

src/Utils/Lens.hs

@@ -41,13 +41,13 @@ _nullable = prism' toNullable fromNullable
 
 
 -- makeLenses_ ''Course
-makeClassyFor_ "HasCourse" "hasCourse" ''Course
+makeClassyFor_ ''Course
 -- class HasCourse c where
 --   hasCourse :: Lens' c Course
 
 
 -- makeLenses_ ''User
-makeClassyFor_ "HasUser" "hasUser" ''User
+makeClassyFor_ ''User
 -- > :info HasUser
 -- class HasUser c where
 --   hasUser :: Lens' c User -- MINIMAL
@@ -56,8 +56,24 @@ makeClassyFor_ "HasUser" "hasUser" ''User
 --   _user...
 --
 
+makeClassyFor_ ''StudyFeatures
+
+makeClassyFor_ ''StudyDegree
+
+makeClassyFor_ ''StudyTerms
+
 
 makeLenses_ ''Entity
+
+instance HasStudyFeatures a => HasStudyFeatures (Entity a) where
+  hasStudyFeatures = _entityVal . hasStudyFeatures
+
+instance HasStudyTerms a => HasStudyTerms (Entity a) where
+  hasStudyTerms = _entityVal . hasStudyTerms
+  
+instance HasStudyDegree a => HasStudyDegree (Entity a) where
+  hasStudyDegree = _entityVal . hasStudyDegree
+
 -- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW:
 -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity
 -- class HasEntity c record | c -> record where
@@ -96,12 +112,6 @@ makePrisms ''AuthResult
 
 makePrisms ''FormResult
 
-makeLenses_ ''StudyFeatures
-
-makeLenses_ ''StudyDegree
-
-makeLenses_ ''StudyTerms
-
 makeLenses_ ''StudyTermCandidate
 
 makeLenses_ ''FieldView
@@ -133,6 +143,8 @@ makeLenses_ ''ExamGradingRule
 
 makeLenses_ ''UTCTime
 
+makeLenses_ ''ExamOccurrence
+
 
 -- makeClassy_ ''Load
 

src/Utils/Lens/TH.hs

@@ -1,6 +1,6 @@
 module Utils.Lens.TH where
 
-import ClassyPrelude (String, Maybe(..))
+import ClassyPrelude (Maybe(..), (<>))
 import Control.Lens
 import Control.Lens.Internal.FieldTH
 import Language.Haskell.TH
@@ -56,9 +56,12 @@ makeLenses_ = makeFieldOptics lensRules_
 
 -- | like makeClassyFor but only specifies names for class and its function,
 --   otherwise lenses are created with underscore like `makeLenses_`
-makeClassyFor_ :: String -> String -> Name -> DecsQ
+makeClassyFor_ :: Name -> DecsQ
-makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer)
+makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName
     where
-        clNamer :: ClassyNamer
+      clsName = "Has" <> nameBase recName
-        -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17
+      funName = "has" <> nameBase recName
-        clNamer _ = Just (mkName clsName, mkName funName)
+      
+      clNamer :: ClassyNamer
+      -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17
+      clNamer _ = Just (mkName clsName, mkName funName)

start.sh

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 unset HOST
 export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
 export LOG_ALL=${LOG_ALL:-false}

static/fonts/fonts.css

@@ -1,8 +1,8 @@
 /*!
- * Font Awesome Free 5.1.0 by @fontawesome - https://fontawesome.com
+ * Font Awesome Free 5.9.0 by @fontawesome - https://fontawesome.com
  * License - https://fontawesome.com/license (Icons: CC BY 4.0, Fonts: SIL OFL 1.1, Code: MIT License)
  */
- @font-face{
+@font-face{
   font-family:"Font Awesome 5 Free";
   font-style:normal;
   font-weight:900;

templates/corrections-overview.hamlet

@@ -130,6 +130,16 @@
             <td .table__th>#{getLoadSum shn}
             <td .table__th>#{ciSubmissions}
             <td .table__td colspan=3>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
+
+      <tr .table__row .table__row--head>
+        <th>
+        <th colspan=2>
+        <th>
+        <th colspan=3>
+        $#  Always iterate over orderedSheetNames for consistent sorting! Newest first, except in this table
+        $forall shn <- orderedSheetNames
+          <th .table__th colspan=5>#{shn}
+
   ^{btnWdgt}
  <div>
   <p>_{MsgAssignSubmissionsRandomWarning}

templates/i18n/knownBugs/de.hamlet

@@ -1,6 +1,8 @@
 $newline never
 <p>
-  Stand: Mai 2019
+  Stand: July 2019
 <ul>
+  <li>
+    Benachrichtigungen per eMail treffen manchmal mit mehreren Tagen Verzögerung ein.
   <li>
     Format von Bewertungsdateien ist noch provisorisch

templates/table/csv-transcode.hamlet

@@ -0,0 +1,7 @@
+$newline never
+$if is _Just dbtCsvDecode
+  <div .csv-import>
+    ^{csvImportWdgt'}
+$if is _Just dbtCsvEncode
+  <div .csv-export>
+    ^{csvExportWdgt'}

templates/table/layout.hamlet

@@ -5,6 +5,7 @@ $else
   <div .table-header>
     <div .table__row-count>
       _{MsgRowCount rowCount}
+    ^{csvWdgt}
 
   ^{table}
 

test.sh

@@ -1,5 +1,9 @@
 #!/usr/bin/env bash
 
+set -e
+
+[ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || :
+
 move-back() {
     mv -v .stack-work .stack-work-test
     [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work