Merge branch '705-csv-export-fur-abgaben' into 'master'

CSV-Export of correction tables

Closes #705

See merge request uni2work/uni2work!53

messages/uniworx/categories/courses/submission/de-de-formal.msg

@@ -68,6 +68,7 @@ Corrected: Korrigiert
 HeadingSubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
 SubmissionUsers: Studenten
 AssignedTime: Zuteilung
+SubmissionPseudonym !ident-ok: Pseudonym
 Pseudonyms: Pseudonyme
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
 SubmissionArchiveName: abgaben
@@ -228,3 +229,36 @@ SubmissionColumnAuthorshipStatementWording: Wortlaut
 SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut
 
 SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer!
+
+CsvColumnCorrectionTerm: Semester des Kurses der Abgabe
+CsvColumnCorrectionSchool: Institut des Kurses der Abgabe
+CsvColumnCorrectionCourse: Kürzel des Kurses der Abgabe
+CsvColumnCorrectionSheet: Name des Übungsblatts der Abgabe
+CsvColumnCorrectionSubmission: Nummer der Abgabe (uwa…)
+CsvColumnCorrectionSurname: Nachnamen der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionFirstName: Vornamen der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionName: Volle Namen der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionMatriculation: Matrikelnummern der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionEmail: E-Mail Adressen der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionPseudonym: Abgabe-Pseudonyme der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionSubmissionGroup: Feste Abgabegruppen der Abgebenden als Semikolon (;) separierte Liste
+CsvColumnCorrectionAuthorshipStatementState: Zustände der Eigenständigkeitserklärungen ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}" oder "#{toPathPiece ASExists}") als Semikolon (;) separierte Liste
+CsvColumnCorrectionCorrectorName: Voller Name des Korrektors der Abgabe
+CsvColumnCorrectionCorrectorEmail: E-Mail Adresse des Korrektors der Abgabe
+CsvColumnCorrectionRatingDone: Bewertung abgeschlossen ("t"/"f")
+CsvColumnCorrectionRatedAt: Zeitpunkt der Bewertung (ISO 8601)
+CsvColumnCorrectionAssigned: Zeitpunkt der Zuteilung des Korrektors (ISO 8601)
+CsvColumnCorrectionLastEdit: Zeitpunkt der letzten Änderung der Abgabe (ISO 8601)
+CsvColumnCorrectionRatingPoints: Erreichte Punktezahl (Für “_{MsgSheetGradingPassBinary}” entspricht 0 “_{MsgRatingNotPassed}” und alles andere “_{MsgRatingPassed}”)
+CsvColumnCorrectionRatingComment: Bewertungskommentar
+CorrectionCsvSingleSubmittors: Eine Zeile pro Abgebende:n
+CorrectionCsvSingleSubmittorsTip: Sollen Abgaben mit mehreren Abgebenden mehrfach vorkommen, sodass jeweils eine Zeile pro Abgebende:n enthalten ist, statt mehrere Abgebende in einer Zeile zusammenzufassen?
+
+CorrectionTableCsvNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-abgaben
+CorrectionTableCsvSheetNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Abgaben
+CorrectionTableCsvNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-abgaben
+CorrectionTableCsvSheetNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Abgaben
+CorrectionTableCsvNameCorrections: abgaben
+CorrectionTableCsvSheetNameCorrections: Abgaben
+CorrectionTableCsvNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-abgaben
+CorrectionTableCsvSheetNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Abgaben

messages/uniworx/categories/courses/submission/en-eu.msg

@@ -66,6 +66,7 @@ Corrected: Marked
 HeadingSubmissionEditHead tid ssh csh sheetName: #{tid}-#{ssh}-#{csh} #{sheetName}: Edit/Create submission
 SubmissionUsers: Submittors
 AssignedTime: Assigned
+SubmissionPseudonym !ident-ok: Pseudonym
 Pseudonyms: Pseudonyms
 CourseCorrectionsTitle: Corrections for this course
 SubmissionArchiveName: submissions
@@ -227,3 +228,36 @@ SubmissionColumnAuthorshipStatementWording: Wording
 SubmissionFilterAuthorshipStatementCurrent: Current wording
 
 SubmissionNoUsers: This submission has no associated users!
+
+CsvColumnCorrectionTerm: Term of the course of the submission
+CsvColumnCorrectionSchool: School of the course of the submission
+CsvColumnCorrectionCourse: Shorthand of the course of the submission
+CsvColumnCorrectionSheet: Name of the sheet of the submission
+CsvColumnCorrectionSubmission: Number of the submission (uwa…)
+CsvColumnCorrectionSurname: Submittor's surnames, separated by semicolon (;)
+CsvColumnCorrectionFirstName: Submittor's first names, separated by semicolon (;)
+CsvColumnCorrectionName: Submittor's full names, separated by semicolon (;)
+CsvColumnCorrectionMatriculation: Submittor's matriculations, separated by semicolon (;)
+CsvColumnCorrectionEmail: Submittor's email addresses, separated by semicolon (;)
+CsvColumnCorrectionPseudonym: Submittor's submission pseudonyms, separated by semicolon (;)
+CsvColumnCorrectionSubmissionGroup: Submittor's submisson groups, separated by semicolon (;)
+CsvColumnCorrectionAuthorshipStatementState: States of the statements of authorship ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}", or "#{toPathPiece ASExists}"), separated by semicolon (;)
+CsvColumnCorrectionCorrectorName: Full name of the corrector of the submission
+CsvColumnCorrectionCorrectorEmail: Email address of the corrector of the submission
+CsvColumnCorrectionRatingDone: Rating done ("t"/"f")
+CsvColumnCorrectionRatedAt: Timestamp of rating (ISO 8601)
+CsvColumnCorrectionAssigned: Timestamp of when corrector was assigned (ISO 8601)
+CsvColumnCorrectionLastEdit: Timestamp of the last edit of the submission (ISO 8601)
+CsvColumnCorrectionRatingPoints: Achieved points (for “_{MsgSheetGradingPassBinary}” 0 means “_{MsgRatingNotPassed}”, everything else means “_{MsgRatingPassed}”)
+CsvColumnCorrectionRatingComment: Rating comment
+CorrectionCsvSingleSubmittors: One row per submittor
+CorrectionCsvSingleSubmittorsTip: Should submissions with multiple submittors be split into multiple rows, such that there is one row per submittor instead of having multiple submittors within one row?
+
+CorrectionTableCsvNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-submissions
+CorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Submissions
+CorrectionTableCsvNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-submissions
+CorrectionTableCsvSheetNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Submissions
+CorrectionTableCsvNameCorrections: submissions
+CorrectionTableCsvSheetNameCorrections: Submissions
+CorrectionTableCsvNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-submissions
+CorrectionTableCsvSheetNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Submissions

package.yaml

@@ -121,6 +121,7 @@ dependencies:
   - http-types
   - jose-jwt
   - mono-traversable
+  - mono-traversable-keys
   - lens-aeson
   - systemd
   - streaming-commons

src/Data/Scientific/Instances.hs

@@ -9,7 +9,17 @@ import Data.Scientific
 
 import Web.PathPieces
 
+import Text.ParserCombinators.ReadP (readP_to_S)
+
+import Control.Monad.Fail
+
 
 instance PathPiece Scientific where
   toPathPiece = pack . formatScientific Fixed Nothing
-  fromPathPiece = readFromPathPiece
+
+  fromPathPiece = disambiguate . readP_to_S scientificP . unpack
+    where
+      disambiguate strs = case filter (\(_, rStr) -> null rStr) strs of
+        [(x, _)] -> pure x
+        _other   -> fail "fromPathPiece Scientific: Ambiguous parse"
+        

src/Data/Word/Word24/Instances.hs

@@ -12,6 +12,8 @@ import System.Random (Random(..))
 import Data.Aeson (FromJSON(..), ToJSON(..))
 import qualified Data.Aeson.Types as Aeson
 
+import Web.PathPieces
+
 import Data.Word.Word24
 
 import Control.Lens
@@ -19,6 +21,7 @@ import Control.Lens
 import Control.Monad.Fail
 
 import qualified Data.Scientific as Scientific
+import Data.Scientific.Instances ()
 
 import Data.Binary
 import Data.Bits
@@ -51,6 +54,10 @@ instance FromJSON Word24 where
 instance ToJSON Word24 where
   toJSON = Aeson.Number . fromIntegral
 
+instance PathPiece Word24 where
+  toPathPiece p = toPathPiece (fromIntegral p :: Word32)
+  fromPathPiece = Scientific.toBoundedInteger <=< fromPathPiece
+
 
 -- | Big Endian
 instance Binary Word24 where

src/Foundation/I18n.hs

@@ -308,6 +308,8 @@ embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials"
 embedRenderMessage ''UniWorX ''SchoolAuthorshipStatementMode id
 embedRenderMessage ''UniWorX ''SheetAuthorshipStatementMode id
 
+embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
+
 newtype ShortSex = ShortSex Sex
 embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>)
 

src/Handler/Course/User.hs

@@ -240,10 +240,11 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
 
 
 courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
-courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
+courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do
   guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
 
-  let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
+  let whereClause :: CorrectionTableWhere
+      whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
       colonnade = mconcat -- should match getSSubsR for consistent UX
         [ colSelect
         , colSheet
@@ -256,18 +257,24 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
         , colCorrector
         , colAssigned
         ] -- Continue here
-      filterUI = Just $ \mPrev -> mconcat
+      filterUI = Just $ mconcat
-        [ prismAForm (singletonFilter "user-name-email")      mPrev $ aopt textField (fslI MsgCourseCourseMembers)
+        [ filterUIUserNameEmail
-        , prismAForm (singletonFilter "user-matriclenumber")  mPrev $ aopt textField (fslI MsgTableMatrikelNr)
+        , filterUIUserMatrikelnummer
-        -- "pseudonym" TODO DB only stores Word24
+        , filterUIPseudonym
-        , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet)        (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+        , filterUISheetSearch
-        , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector)
+        , filterUICorrectorNameEmail
-        , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
+        , filterUIIsAssigned
-        , prismAForm (singletonFilter "israted"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
+        , filterUIIsRated
-        , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
+        , filterUISubmission
         ]
       psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
-  (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList
+      csvSettings = Just CorrectionTableCsvSettings
+        { cTableCsvQualification = CorrectionTableCsvQualifySheet
+        , cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
+        , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
+        , cTableShowCorrector = True
+        }
+  (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
     [ downloadAction
     , assignAction (Left cid)
     , deleteAction

src/Handler/Course/Users.hs

@@ -197,17 +197,13 @@ instance Csv.ToNamedRecord UserTableCsv where
     , "email" Csv..= csvUserEmail
     , "study-features" Csv..= csvUserStudyFeatures
     , "submission-group" Csv..= csvUserSubmissionGroup
-    ] ++
+    , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1)
-    [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
-       in "tutorial" Csv..= tutsStr
     ] ++
     [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
     | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
     ] ++
-    [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams
+    [ "exams" Csv..= CsvSemicolonList csvUserExams
-       in "exams" Csv..= examsStr
+    , "registration" Csv..= csvUserRegistration
-    ] ++
-    [ "registration" Csv..= csvUserRegistration
     ] ++
     [ encodeUtf8 (CI.foldedCase shn) Csv..= res
     | (shn, res) <- Map.toList csvUserSheets

src/Handler/Submission/Grade.hs

@@ -19,7 +19,8 @@ getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
 getCorrectionsGradeR = postCorrectionsGradeR
 postCorrectionsGradeR = do
   uid <- requireAuthId
-  let whereClause = ratedBy uid
+  let whereClause :: CorrectionTableWhere
+      whereClause = ratedBy uid
       displayColumns = mconcat -- should match getSSubsR for consistent UX
         [ -- dbRow,
           colSchool
@@ -37,15 +38,16 @@ postCorrectionsGradeR = do
         , colMaxPointsField
         , colCommentField
         ] -- Continue here
-      filterUI = Just $ \mPrev -> mconcat
+      filterUI = Just $ mconcat
-        [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
+        [ filterUICourse courseOptions
-        , prismAForm (singletonFilter "term"   ) mPrev $ aopt (lift `hoistField` selectField termOptions)   (fslI MsgTableTerm)
+        , filterUITerm termOptions
-        , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool)
+        , filterUISchool schoolOptions
-        , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField)                 (fslI MsgTableSheet)        (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+        , filterUISheetSearch
-        , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant)             (fslI MsgTableRatingTime)
+        , filterUIPseudonym
-        , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
+        , filterUIIsRated
-        , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
+        -- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
-        , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
+        , filterUIRating
+        , filterUIComment
         ]
       courseOptions = runDB $ do
         courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
@@ -60,9 +62,9 @@ postCorrectionsGradeR = do
         & restrictAnonymous
         & restrictCorrector
         & 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)
+      unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
 
-  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
+  (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing psValidator $ def
     { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
     }
 

src/Handler/Submission/Helper.hs

@@ -31,18 +31,6 @@ import Handler.Submission.SubmissionUserInvite
 import qualified Data.Conduit.Combinators as C
 
 
-data AuthorshipStatementSubmissionState
-  = ASExists
-  | ASOldStatement
-  | ASMissing
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-  deriving anyclass (Universe, Finite)
-
-nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
-
-embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel
-
-
 makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m)
                    => CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId)
                    -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget))
@@ -606,28 +594,10 @@ submissionHelper tid ssh csh shn mcid = do
 
     subUsers <- maybeT (return []) $ do
       subId <- hoistMaybe msmid
-      let
-        getUserAuthorshipStatement :: UserId
-                                   -> DB AuthorshipStatementSubmissionState
-        getUserAuthorshipStatement uid = runConduit $
-               getStmts
-            .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
-          where
-            getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
-              E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
-                   E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
-              return authorshipStatementSubmission
-            toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
-            toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
-            toRes :: Maybe Any -> AuthorshipStatementSubmissionState
-            toRes = \case
-              Just (Any True) -> ASExists
-              Just (Any False) -> ASOldStatement
-              Nothing -> ASMissing
       lift $ buddies
         & bool id (maybe id (Set.insert . Right) muid) isOwner
         & Set.toList
-        & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement uid)
+        & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid)
         & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1)
 
     subUsersVisible <- orM

src/Handler/Utils/StudyFeatures.hs

@@ -22,8 +22,6 @@ import Handler.Utils.StudyFeatures.Parse
 
 import qualified Data.Csv as Csv
 
-import qualified Data.ByteString as ByteString
-
 import qualified Data.Set as Set
 
 import Data.RFC5051 (compareUnicode)
@@ -65,7 +63,7 @@ instance Csv.ToField UserTableStudyFeature where
             [] $ ShortStudyFieldType userTableFieldType
 
 instance Csv.ToField UserTableStudyFeatures where
-  toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures
+  toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures
 
 userTableStudyFeatureSort :: UserTableStudyFeature
                           -> UserTableStudyFeature

src/Handler/Utils/Submission.hs

@@ -11,6 +11,8 @@ module Handler.Utils.Submission
   , submissionMatchesSheet
   , submissionDeleteRoute
   , correctionInvisibleWidget
+  , AuthorshipStatementSubmissionState(..)
+  , getUserAuthorshipStatement, getSubmissionAuthorshipStatement
   ) where
 
 import Import hiding (joinPath)
@@ -36,6 +38,7 @@ import Handler.Utils
 import qualified Handler.Utils.Rating as Rating (extractRatings)
 import Handler.Utils.Delete
 
+import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils.TH as E
 
@@ -976,3 +979,44 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d
         tellPoint CorrectionInvisibleExamUnfinished
 
   return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")
+
+
+getUserAuthorshipStatement :: ( MonadResource m
+                              , IsSqlBackend backend, SqlBackendCanRead backend
+                              )
+                           => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+                           -> SubmissionId
+                           -> UserId
+                           -> ReaderT backend m AuthorshipStatementSubmissionState
+getUserAuthorshipStatement mASDefinition subId uid = runConduit $
+       getStmts
+    .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
+  where
+    getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
+      E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
+           E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
+      return authorshipStatementSubmission
+    toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
+    toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
+    toRes :: Maybe Any -> AuthorshipStatementSubmissionState
+    toRes = \case
+      Just (Any True) -> ASExists
+      Just (Any False) -> ASOldStatement
+      Nothing -> ASMissing
+
+getSubmissionAuthorshipStatement :: ( MonadResource m
+                                    , IsSqlBackend backend, SqlBackendCanRead backend
+                                    )
+                                 => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+                                 -> SubmissionId
+                                 -> ReaderT backend m AuthorshipStatementSubmissionState
+getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $
+       sourceSubmissionUsers
+    .| C.map E.unValue
+    .| C.mapM getUserAuthorshipStatement'
+    .| C.maximum
+  where
+    getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId
+    sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do
+      E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
+      return $ submissionUser E.^. SubmissionUserUser

src/Handler/Utils/Table/Pagination.hs

@@ -45,7 +45,8 @@ module Handler.Utils.Table.Pagination
   , maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
   , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
   , cellTooltip
-  , listCell, listCell'
+  , listCell, listCell', listCellOf, listCellOf'
+  , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
   , formCell, DBFormResult(..), getDBFormResult
   , dbSelect
   , (&)
@@ -1171,7 +1172,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
     psLimit' = bool PagesizeAll psLimit selectPagesize
 
-
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
     E.orderBy $ sortSql t
@@ -1183,10 +1183,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           Nothing
             | PagesizeLimit l <- psLimit'
             , selectPagesize
+            , hasn't (_FormSuccess . _DBCsvExport) csvMode
               -> do
-                unless (has (_FormSuccess . _DBCsvExport) csvMode) $
+                   E.limit l
-                  E.limit l
+                   E.offset $ psPage * l
-                E.offset (psPage * l)
           Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
           _other  -> return ()
         Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
@@ -1793,12 +1793,30 @@ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCel
 listCell = listCell' . return
   
 listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
-listCell' mkXS mkCell = review dbCell . ([], ) $ do
+listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
+
+ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistCell = ilistCell' . return
+
+ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistCell' mkXS mkCell = review dbCell . ([], ) $ do
   xs <- mkXS
-  cells <- forM (toList xs) $
+  cells <- forM (otoKeyedList xs) $
-    \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+    \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
   return $(widgetFile "table/cell/list")
 
+listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a'
+listCellOf l x = listCell (x ^.. l)
+
+listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a'
+listCellOf' l mkX = listCell' (toListOf l <$> mkX)
+
+ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a'
+ilistCellOf l x = listCell (itoListOf l x) . uncurry
+
+ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a'
+ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry
+
 newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
 
 instance Functor (DBFormResult i a) where

src/Import/NoModel.hs

@@ -24,6 +24,7 @@ import ClassyPrelude.Yesod    as Import
          , authorizationCheck
          , mkMessage, mkMessageFor, mkMessageVariant
          , YesodBreadcrumbs(..)
+         , MonoZip(..), ozipWith
          )
 
 import UnliftIO.Async.Utils as Import
@@ -235,6 +236,8 @@ import Data.Scientific as Import (Scientific, formatScientific)
 
 import Data.MultiSet as Import (MultiSet)
 
+import Data.MonoTraversable.Keys as Import
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Model/Types/DateTime.hs

@@ -133,6 +133,8 @@ instance ToJSON TermIdentifier where
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
 
+pathPieceCsv ''TermIdentifier
+
 {- Must be defined in a later module:
     termField :: Field (HandlerT UniWorX IO) TermIdentifier
     termField = checkMMap (return . termFromText) termToText textField

src/Model/Types/Submission.hs

@@ -130,3 +130,27 @@ pseudonymWords = folding
 pseudonymFragments :: Fold Text [PseudonymWord]
 pseudonymFragments = folding
   $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
+
+
+instance PathPiece Pseudonym where
+  toPathPiece = review _PseudonymText
+  fromPathPiece t
+    | Just p <- t ^? _PseudonymText = Just p
+    | Just n <- fromPathPiece t = Just $ Pseudonym n
+    | otherwise = Nothing
+
+pathPieceCsv ''Pseudonym
+
+  
+data AuthorshipStatementSubmissionState
+  = ASMissing
+  | ASOldStatement
+  | ASExists
+  deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max`
+
+nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
+pathPieceCsv ''AuthorshipStatementSubmissionState
+pathPieceJSON ''AuthorshipStatementSubmissionState

src/Utils/Csv.hs

@@ -10,6 +10,7 @@ module Utils.Csv
   , toCsvRendered
   , toDefaultOrderedCsvRendered
   , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx
+  , CsvSemicolonList(..)
   ) where
 
 import ClassyPrelude hiding (lookup)
@@ -39,6 +40,19 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Binary.Builder as Builder
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Attoparsec.ByteString as Attoparsec
+
+import qualified Data.Csv.Parser as Csv
+import qualified Data.Csv.Builder as Csv
+
+import qualified Data.Vector as Vector
+
+import Data.Char (ord)
+
+import Control.Monad.Fail
+
 
 deriving instance Typeable CsvParseError
 instance Exception CsvParseError
@@ -114,3 +128,27 @@ csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (d
     addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of
       Nothing -> mempty
       Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS)
+
+
+newtype CsvSemicolonList a = CsvSemicolonList { unCsvSemicolonList :: [a] }
+  deriving stock (Read, Show, Generic, Typeable)
+  deriving newtype (Eq, Ord)
+
+instance ToField a => ToField (CsvSemicolonList a) where
+  toField (CsvSemicolonList xs) = dropEnd 2 . LBS.toStrict . Builder.toLazyByteString $ Csv.encodeRecordWith encOpts fs
+    where
+      fs = map toField xs
+      encOpts = defaultEncodeOptions
+        { encDelimiter = fromIntegral $ ord ';'
+        , encQuoting = case fs of
+            [fStr] | null fStr -> QuoteAll
+            _other             -> QuoteMinimal
+        , encUseCrLf = True
+        }
+
+instance FromField a => FromField (CsvSemicolonList a) where
+  parseField f
+    | null f = pure $ CsvSemicolonList []
+    | otherwise = fmap CsvSemicolonList . mapM parseField . Vector.toList <=< either fail return $ Attoparsec.parseOnly (Csv.record sep) f
+    where
+      sep = fromIntegral $ ord ';'

templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Tabellen von Übungsblattabgaben können nun als CSV exportiert werden

templates/i18n/changelog/corrections-csv-export.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Tables of exercise sheet submissions can now be exported as CSV

test/Data/Scientific/InstancesSpec.hs

@@ -0,0 +1,10 @@
+module Data.Scientific.InstancesSpec where
+
+import TestImport
+import Data.Scientific
+
+
+spec :: Spec
+spec = modifyMaxSuccess (* 10) $
+  lawsCheckHspec (Proxy @Scientific)
+    [ pathPieceLaws ]

test/Utils/CsvSpec.hs

@@ -0,0 +1,38 @@
+module Utils.CsvSpec where
+
+import TestImport
+
+import Utils.Csv
+
+import Data.Csv (toField, runParser, parseField)
+
+import Data.Char (ord)
+import qualified Data.ByteString as BS
+
+
+deriving newtype instance Arbitrary a => Arbitrary (CsvSemicolonList a)
+  
+
+spec :: Spec
+spec = modifyMaxSuccess (* 10) . parallel $ do
+  lawsCheckHspec (Proxy @(CsvSemicolonList ByteString))
+    [ csvFieldLaws ]
+  describe "CsvSemicolonList" $ do
+    let
+      test :: [ByteString] -> ByteString -> Expectation
+      test (CsvSemicolonList -> x) t = do
+        toField x `shouldBe` t
+        runParser (parseField t) `shouldBe` Right x
+    it "is transparent" . property $ \(bs :: ByteString)
+      -> let expectTransparent = BS.all (`notElem` [34, 10, 13, fromIntegral $ ord ';']) bs
+                              && not (BS.null bs)
+          in expectTransparent ==> test [bs] bs
+    it "behaves as expected on some examples" $ do
+      test ["foo"] "foo"
+      test ["foo", "bar"] "foo;bar"
+      test [] ""
+      test [""] "\"\""
+      test ["", ""] ";"
+      test ["foo", ""] "foo;"
+      test ["", "foo"] ";foo"
+      test ["", "", "foo", ""] ";;foo;"