feat(csv-export): .xlsx

messages/uniworx/misc/de-de-formal.msg

@@ -1629,6 +1629,7 @@ CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
 CommTestSuccess: Nachricht wurde zu Testzwecken nur an Sie selbst versandt
 CommUndisclosedRecipients: Verborgene Empfänger
 CommAllRecipients: alle-empfaenger
+CommAllRecipientsSheet: Empfänger
 
 CommCourseHeading: Kursmitteilung
 CommTutorialHeading: Tutorium-Mitteilung
@@ -2148,10 +2149,15 @@ Proportion c@Text of'@Text prop@Rational: #{c}/#{of'} (#{rationalToFixed2 (100 *
 ProportionNoRatio c@Text of'@Text: #{c}/#{of'}
 
 CourseUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-teilnehmer
+CourseUserCsvSheetName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Teilnehmer
 ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer
+ExamUserCsvSheetName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn} Teilnehmer
 ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn}-teilnehmer
+ExternalExamUserCsvSheetName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn} Teilnehmer
 CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen
+CourseApplicationsTableCsvSheetName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Bewerbungen
 ParticipantsCsvName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-kursteilnehmer
+ParticipantsCsvSheetName tid@TermId ssh@SchoolId: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Kursteilnehmer
 
 CourseUserCsvIncludeSheets: Übungsblätter
 CourseUserCsvIncludeSheetsTip: Soll die exportierte CSV-Datei zusätzlich eine Spalte pro Übungsblatt enthalten?
@@ -2566,8 +2572,9 @@ CsvOptionsTip: Diese Einstellungen betreffen primär den CSV-Export; beim Import
 CsvFormatOptions: Dateiformat
 CsvTimestamp: Zeitstempel
 CsvTimestampTip: Soll an den Namen jeder exportierten CSV-Datei ein Zeitstempel vorne angehängt werden?
-CsvPresetRFC: Standard-Konform (RFC 4180)
+CsvPresetRFC: Standard-Konforme .csv Dateien (RFC 4180)
-CsvPresetExcel: Excel-Kompatibel
+CsvPresetExcel: Excel-Kompatible .csv Dateien (Excel <2010)
+CsvPresetXlsx: .xlsx Dateien (ECMA-376; Excel ≥2010)
 CsvCustom: Benutzerdefiniert
 CsvDelimiter: Trennzeichen
 CsvUseCrLf: Zeilenumbrüche
@@ -2592,6 +2599,9 @@ CsvQuoteMinimal: Nur wenn nötig
 CsvQuoteAll: Immer
 CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst
 CsvChangeOptionsLabel: Export-Optionen
+CsvFormatField: Dateiformat
+CsvFormatCsv: .csv (Comma-Separated Values)
+CsvFormatXlsx: .xlsx (Office Open XML)
 
 CourseNews: Aktuelles
 CourseNewsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand newsTitle@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle}
@@ -2844,6 +2854,7 @@ CsvColumnAllocationUserAssigned: Anzahl von Plätzen, die der Bewerber durch die
 CsvColumnAllocationUserNewAssigned: Anzahl von Plätzen, die der Bewerber, nach Akzeptieren der berechneten Verteilung, zusätzlich erhalten würde
 CsvColumnAllocationUserPriority: Zentrale Dringlichkeit des Bewerbers; entweder einzelne Zahl für Sortierungsbasierte Dringlichkeiten (höhere Dringlichkeit entspricht größerer Zahl) oder Komma-separierte Liste von numerischen Dringlichkeiten in eckigen Klammern (z.B. [1, 2, 3])
 AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-bewerber
+AllocationUsersCsvSheetName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash} Bewerber
 
 AllocationPrioritiesMode: Modus
 AllocationPrioritiesNumeric: Numerische Dringlichkeiten

messages/uniworx/misc/en-eu.msg

@@ -1629,6 +1629,7 @@ CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
 CommTestSuccess: Message was sent only to yourself for testing purposes
 CommUndisclosedRecipients: Undisclosed recipients
 CommAllRecipients: all-recipients
+CommAllRecipientsSheet: Recipients
 
 CommCourseHeading: Course message
 CommTutorialHeading: Tutorial message
@@ -2147,10 +2148,15 @@ Proportion c of' prop: #{c}/#{of'} (#{rationalToFixed2 (100 * prop)}%)
 ProportionNoRatio c of': #{c}/#{of'}
 
 CourseUserCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-participants
+CourseUserCsvSheetName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Participants
 ExamUserCsvName tid ssh csh examn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-participants
+ExamUserCsvSheetName tid ssh csh examn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn} Participants
 ExternalExamUserCsvName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn}-participants
+ExternalExamUserCsvSheetName tid@TermId ssh@SchoolId coursen@CourseName examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase coursen}-#{foldedCase examn} Participants
 CourseApplicationsTableCsvName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-applications
+CourseApplicationsTableCsvSheetName tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Applications
 ParticipantsCsvName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-participants
+ParticipantsCsvSheetName tid ssh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)} Participants
 
 CourseUserCsvIncludeSheets: Exercise sheets
 CourseUserCsvIncludeSheetsTip: Should the exportet CSV-file additionally contain one column per exercise sheet?
@@ -2566,8 +2572,9 @@ CsvOptionsTip: These settings primarily affect CSV export. During import most se
 CsvFormatOptions: File format
 CsvTimestamp: Timestamp
 CsvTimestampTip: Should the name of every exported csv file contain a timestamp?
-CsvPresetRFC: Standards-compliant (RFC 4180)
+CsvPresetRFC: Standards-compliant .csv files (RFC 4180)
-CsvPresetExcel: Excel compatible
+CsvPresetExcel: Excel compatible .csv files (Excel <2010)
+CsvPresetXlsx: .xlsx files (ECMA-376; Excel ≥2010)
 CsvCustom: User defined
 CsvDelimiter: Separator character
 CsvUseCrLf: Linebreaks
@@ -2592,6 +2599,9 @@ CsvQuoteMinimal: Only when necessary
 CsvQuoteAll: Always
 CsvOptionsUpdated: Successfully changed CSV options
 CsvChangeOptionsLabel: Export options
+CsvFormatField: File format
+CsvFormatCsv: .csv (comma-separated values)
+CsvFormatXlsx: .xlsx (Office Open XML)
 
 CourseNews: News
 CourseNewsArchiveName tid ssh csh newsTitle: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle}
@@ -2844,6 +2854,7 @@ CsvColumnAllocationUserAssigned: Number of assignments the applicant has already
 CsvColumnAllocationUserNewAssigned: Number of assignments the applicant would receive, if the calculated matching is accepted
 CsvColumnAllocationUserPriority: Central priority of this applicant; either a number based on the applicants position in the list sorted by priority (higher numbers mean a higher priority) or a comma-separated list of numerical priorities in square brackets (e.g. [1, 2, 3])
 AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-applicants
+AllocationUsersCsvSheetName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash} Applicants
 
 AllocationPrioritiesMode: Mode
 AllocationPrioritiesNumeric: Numeric priorities

package.yaml

@@ -163,6 +163,7 @@ dependencies:
   - IntervalMap
   - haskell-src-meta
   - either
+  - xlsx
 other-extensions:
   - GeneralizedNewtypeDeriving
   - IncoherentInstances

src/Application.hs

@@ -307,7 +307,7 @@ makeFoundation appSettings''@AppSettings{..} = do
         conn <- Minio.connect minioConf
         let isBucketExists Minio.BucketAlreadyOwnedByYou = True
             isBucketExists _ = False
-        either throwM return <=< Minio.runMinioWith conn $ do
+        throwLeft <=< Minio.runMinioWith conn $ do
           handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing
           handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing
         return conn

src/Auth/LDAP.hs

@@ -129,14 +129,14 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr
     _otherwise -> throwE CampusUserAmbiguous
 
 campusUserReTest  :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUserReTest pool doTest mode creds = either throwM return =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
+campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
 
 campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
 campusUserReTest' pool doTest mode User{userIdent}
   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
 
 campusUser :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUser pool mode creds = either throwM return =<< campusUserWith withLdapFailover pool mode creds
+campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
 
 campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
 campusUser' pool mode User{userIdent}

src/Data/Encoding/Instances.hs

@@ -32,3 +32,10 @@ instance Read DynEncoding where
 
 instance Ord DynEncoding where
   compare = comparing show
+
+instance Hashable DynEncoding where
+  hashWithSalt s = hashWithSalt s . show
+
+
+instance NFData DynEncoding where
+  rnf enc = rnf $ show enc

src/Foundation/Authorization.hs

@@ -259,7 +259,7 @@ isDryRun = $cachedHere . liftHandler $ orM
       let noTokenAuth :: AuthDNF -> AuthDNF
           noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
 
-      dnf <- either throwM return $ routeAuthTags currentRoute
+      dnf <- throwLeft $ routeAuthTags currentRoute
       let eval :: forall m'. MonadAP m' => AuthTagsEval m'
           eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
        in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
@@ -340,7 +340,7 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
         guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
 
         authorityVal <- do
-          dnf <- either throwM return $ routeAuthTags route
+          dnf <- throwLeft $ routeAuthTags route
           lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
         guardExceptT (is _Authorized authorityVal) authorityVal
 
@@ -1807,7 +1807,7 @@ evalAccessWithFor assumptions mAuthId route isWrite = do
   tagActive <- if
     | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
     | otherwise -> return . AuthTagActive $ const True
-  dnf <- either throwM return $ routeAuthTags route
+  dnf <- throwLeft $ routeAuthTags route
   let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
       evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
       evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of

src/Foundation/I18n.hs

@@ -226,6 +226,7 @@ embedRenderMessage ''UniWorX ''SchoolFunction id
 embedRenderMessage ''UniWorX ''SystemFunction id
 embedRenderMessage ''UniWorX ''CsvPreset id
 embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
+embedRenderMessage ''UniWorX ''CsvFormat ("Csv" <>)
 embedRenderMessage ''UniWorX ''FavouriteReason id
 embedRenderMessage ''UniWorX ''Sex id
 embedRenderMessage ''UniWorX ''ExamGradingMode id

src/Handler/Admin/Test.hs

@@ -42,6 +42,7 @@ emailTestForm = (,)
                         <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
                         <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
                       )
+                  <*> pure def
                 )
   where
     toMailDateTimeFormat dt d t = \case

src/Handler/Allocation/Users.hs

@@ -165,8 +165,6 @@ postAUsersR tid ssh ash = do
       allocMatching <- fmap (view _4) . hoistMaybe $ allocMap !? (tid, ssh, ash)
       return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))
 
-    csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)
-
     let
       allocationUsersDBTable = DBTable{..}
         where
@@ -296,6 +294,8 @@ postAUsersR tid ssh ash = do
           dbtParams = def
           dbtIdent :: Text
           dbtIdent = "allocation-users"
+          dbtCsvName = MsgAllocationUsersCsvName tid ssh ash
+          dbtCsvSheetName = MsgAllocationUsersCsvSheetName tid ssh ash
           dbtCsvEncode = return DBTCsvEncode
             { dbtCsvExportForm = pure ()
             , dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $
@@ -311,7 +311,7 @@ postAUsersR tid ssh ash = do
                   <*> view (resultAssignedCourses . _Integral)
                   <*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching)
                   <*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
-            , dbtCsvName = unpack csvName
+            , dbtCsvName, dbtCsvSheetName
             , dbtCsvNoExportData = Just id
             , dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching
             , dbtCsvExampleData = Nothing

src/Handler/Course/Application/List.hs

@@ -232,7 +232,6 @@ postCApplicationsR tid ssh csh = do
     now <- liftIO getCurrentTime
     Entity cid Course{..} <- getBy404 $ TermSchoolCourseShort tid ssh csh
 
-    csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh)
     let
       allocationLink :: Allocation -> SomeRoute UniWorX
       allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
@@ -358,7 +357,9 @@ postCApplicationsR tid ssh csh = do
         }
       dbtParams = def
 
-      dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv
+      dbtCsvName = MsgCourseApplicationsTableCsvName tid ssh csh
+      dbtCsvSheetName = MsgCourseApplicationsTableCsvSheetName tid ssh csh
+      dbtCsvEncode = simpleCsvEncodeM dbtCsvName dbtCsvSheetName $ CourseApplicationsTableCsv
         <$> preview (resultAllocation . _entityVal . _allocationShorthand)
         <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt)
         <*> preview (resultUser . _entityVal . _userDisplayName)

src/Handler/Course/Users.hs

@@ -294,7 +294,6 @@ makeCourseUserTable :: forall h p cols act act'.
 makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
     currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
     Course{..} <- getJust cid
-    csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
     tutorials <- selectList [ TutorialCourse ==. cid ] []
     exams <- selectList [ ExamCourse ==. cid ] []
     sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
@@ -452,6 +451,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
           }
+        dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand
+        dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand
         dbtCsvEncode = do
           csvColumns' <- csvColumns
           return $ DBTCsvEncode
@@ -471,7 +472,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams)
                   <*> (over traverse (examName . entityVal) <$> view _userExams)
                   <*> views _userSheets (set (mapped . _1 . mapped) ())
-            , dbtCsvName = unpack csvName
+            , dbtCsvName, dbtCsvSheetName
             , dbtCsvNoExportData = Nothing
             , dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
             , dbtCsvExampleData = Nothing
@@ -482,7 +483,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
               CourseUserNote{..} <- lift . lift $ getJust noteId
               return courseUserNoteNote
         dbtCsvDecode = Nothing
-        dbtExtraReps = withCsvExtraRep (UserCsvExportData True) dbtCsvEncode []
+        dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode []
     over _1 postprocess <$> dbTable psValidator DBTable{..}
   where
     postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)

src/Handler/Exam/Users.hs

@@ -420,8 +420,6 @@ postEUsersR tid ssh csh examn = do
           | otherwise
             -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty)
 
-    csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
-
     let
       examUsersDBTable = DBTable{..}
         where
@@ -590,10 +588,12 @@ postEUsersR tid ssh csh examn = do
             }
           dbtIdent :: Text
           dbtIdent = "exam-users"
+          dbtCsvName = MsgExamUserCsvName tid ssh csh examn
+          dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn
           dbtCsvEncode = Just DBTCsvEncode
             { dbtCsvExportForm   = pure ()
             , dbtCsvDoEncode     = \() -> C.map (doEncode' . view _2)
-            , dbtCsvName         = unpack csvName
+            , dbtCsvName, dbtCsvSheetName
             , dbtCsvNoExportData = Just id
             , dbtCsvHeader       = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
             , dbtCsvExampleData = Nothing

src/Handler/ExamOffice/Exam.hs

@@ -190,7 +190,6 @@ postEGradesR tid ssh csh examn = do
     exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
     Course{..} <- getJust examCourse
 
-    csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
     isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
     userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
 
@@ -386,6 +385,8 @@ postEGradesR tid ssh csh examn = do
             }
           dbtIdent :: Text
           dbtIdent = "exam-results"
+          dbtCsvName = MsgExamUserCsvName tid ssh csh examn
+          dbtCsvSheetName = MsgExamUserCsvSheetName tid ssh csh examn
           dbtCsvEncode = Just DBTCsvEncode
             { dbtCsvExportForm = ExamUserCsvExportData
               <$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv & setTooltip MsgExamUserMarkSynchronisedCsvTip) (Just False)
@@ -399,7 +400,7 @@ postEGradesR tid ssh csh examn = do
                   (row ^. resultStudyFeatures)
                   (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
                   (row ^. resultExamResult . _entityVal . _examResultResult)
-            , dbtCsvName = unpack csvName
+            , dbtCsvName, dbtCsvSheetName
             , dbtCsvNoExportData = Nothing
             , dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
             , dbtCsvExampleData = Nothing

src/Handler/Participants.hs

@@ -67,9 +67,8 @@ getParticipantsListR = do
 
 getParticipantsR :: TermId -> SchoolId -> Handler TypedContent
 getParticipantsR tid ssh = do
-  csvName <- timestampCsv <*> fmap ((flip addExtension `on` unpack) extensionCsv) (getMessageRender <*> pure (MsgParticipantsCsvName tid ssh))
+  setContentDispositionCsv $ MsgParticipantsCsvName tid ssh
-  setContentDisposition' $ Just csvName
+  respondDefaultOrderedCsvDB (MsgParticipantsCsvSheetName tid ssh) $ E.selectSource partQuery .| C.map toParticipantEntry
-  respondDefaultOrderedCsvDB $ E.selectSource partQuery .| C.map toParticipantEntry
   where
     partQuery = E.from $ \(course `E.InnerJoin` participant `E.InnerJoin` user) -> do
       E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser

src/Handler/Sheet/PersonalisedFiles.hs

@@ -260,7 +260,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
             suf <- lift . lift $ genSuffixes courseParticipantUser
             _sufCache %= Map.insert courseParticipantUser suf
             return suf
-      cID <- either throwM return . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
+      cID <- throwLeft . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
       let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID
       unlessM (uses _dirCache $ Set.member dirName) $ do
         yield $ Right File

src/Handler/Utils/Csv.hs

@@ -2,17 +2,20 @@
 
 module Handler.Utils.Csv
   ( decodeCsv, decodeCsvPositional
-  , timestampCsv
+  , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith
-  , encodeCsv
+  , csvRenderedToTypedContent, csvRenderedToTypedContentWith
+  , expectedCsvFormat, expectedCsvContentType
   , encodeDefaultOrderedCsv
   , respondCsv, respondCsvDB
   , respondDefaultOrderedCsv, respondDefaultOrderedCsvDB
   , fileSourceCsv, fileSourceCsvPositional
-  , partIsAttachmentCsv
+  , partIsAttachmentCsv, setContentDispositionCsv
+  , csvOptionsForFormat
   , CsvParseError(..)
   , ToNamedRecord(..), FromNamedRecord(..)
   , DefaultOrdered(..)
   , ToField(..), FromField(..)
+  , recodeCsv
   ) where
 
 import Import hiding (Header, mapM_)
@@ -21,14 +24,15 @@ import Data.Csv
 import Data.Csv.Conduit
 
 import Handler.Utils.Form (uploadContents)
+import Handler.Utils.ContentDisposition (setContentDisposition')
 
 import Control.Monad (mapM_)
 
 -- import qualified Data.Csv.Util as Csv
 import qualified Data.Csv.Parser as Csv
 
-import qualified Data.Conduit.List as C
+import qualified Data.Conduit.List as C (mapMaybe)
-import qualified Data.Conduit.Combinators as C (sourceLazy)
+import qualified Data.Conduit.Combinators as C
 
 import qualified Data.Map as Map
 import qualified Data.Vector as Vector
@@ -38,13 +42,18 @@ import qualified Data.ByteString.Lazy as LBS
 
 import qualified Data.Attoparsec.ByteString.Lazy as A
 
-import Handler.Utils.DateTime
 import Data.Time.Format (iso8601DateFormat)
 
 import qualified Data.Char as Char
 
 import Control.Monad.Error.Class (MonadError(..))
 
+import Data.Time.Clock.POSIX (getPOSIXTime)
+
+import qualified Data.Time.Format as Time
+
+-- import qualified Codec.Archive.Zip as Zip
+
 
 
 _haltingCsvParseError :: Prism' CsvParseError CsvStreamHaltParseError
@@ -82,19 +91,7 @@ decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (rev
 decodeCsv' :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString (MaybeEmptyRecord csv) (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m ()
 decodeCsv' fromCsv' = do
   encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth
-
+  recodeCsv encOpts False decodeCsv'' .| C.mapMaybe unMaybeEmptyRecord
-  let
-    recode'
-      | enc == "UTF8"
-      = id
-      | otherwise
-      = \act -> do
-          inp <- sinkLazy
-          let inp' = encodeLazyByteString UTF8 $ decodeLazyByteString enc inp
-          sourceLazy inp' .| act
-      where enc = encOpts ^. _csvFormat . _csvEncoding
-
-  recode' decodeCsv'' .| C.mapMaybe unMaybeEmptyRecord
   where
     decodeCsv'' = transPipe throwExceptT $ do
       testBuffer <- accumTestBuffer LBS.empty
@@ -160,78 +157,197 @@ decodeCsv' fromCsv' = do
 encodeCsv :: ( ToNamedRecord csv
              , MonadHandler m
              , HandlerSite m ~ UniWorX
+             , RenderMessage UniWorX msg
              )
-          => Header
+          => msg -- ^ Sheet name for .xlsx
-          -> ConduitT csv ByteString m ()
+          -> Header
+          -> ConduitT csv ByteString m CsvFormat
 -- ^ Encode a stream of records
 --
 -- Currently not streaming
-encodeCsv hdr = do
+encodeCsv sheetName hdr = do
-  csvOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth
+  encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth
-  let recode'
+  encodeCsvWith encOpts sheetName hdr
-        | enc == "UTF8"
+  
-        = id
+encodeCsvWith :: ( ToNamedRecord csv
-        | otherwise
+                 , MonadHandler m
-        = encodeLazyByteString enc . decodeLazyByteString UTF8
+                 , HandlerSite m ~ UniWorX
-        where enc = csvOpts ^. _csvFormat . _csvEncoding
+                 , RenderMessage UniWorX msg
-  C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr
+                 )
+              => CsvOptions
+              -> msg -- ^ Sheet name for .xlsx
+              -> Header
+              -> ConduitT csv ByteString m CsvFormat
+-- ^ Encode a stream of records
+--
+-- Currently not streaming
+encodeCsvWith encOpts sheetName hdr = transPipe liftHandler $ case encOpts ^. _csvFormat of
+  CsvFormatOptions{}
+    | Just csvOpts <- encOpts ^? _csvFormat . _CsvEncodeOptions, has (_csvFormat . _CsvFormat . _FormatCsv) encOpts -> do
+        (C.sourceLazy . encodeByNameWith csvOpts hdr =<< C.foldMap pure) .| recode'
+        return FormatCsv
+    | otherwise -> error "encOpts is CsvFormatOptions but cannot be converted via _CsvEncodeOptions or hasn't _FormatCsv"
+  CsvXlsxFormatOptions{}
+    | has (_csvFormat . _CsvFormat . _FormatXlsx) encOpts -> do
+        rendered <- toCsvRendered hdr <$> C.foldMap (pure @Seq)
+        sheetName' <- ($ sheetName) <$> getMessageRender
+        pNow <- liftIO getPOSIXTime
+        C.sourceLazy (fromXlsx pNow $ csvRenderedToXlsx sheetName' rendered) .| recode'
+        return FormatXlsx
+    | otherwise -> error "encOpts hasn't _FormatXlsx"
+  where recode' = recodeCsv encOpts True $ C.map id
+
+encodeCsvRendered :: ( MonadHandler m
+                     , HandlerSite m ~ UniWorX
+                     , RenderMessage UniWorX msg
+                     )
+                  => msg -- ^ Sheet name for .xlsx
+                  -> CsvRendered
+                  -> m (CsvFormat, LBS.ByteString)
+encodeCsvRendered sheetName CsvRendered{..} = runConduit $ yieldMany csvRenderedData .| (encodeCsv sheetName csvRenderedHeader `fuseBoth` C.sinkLazy)
+
+encodeCsvRenderedWith :: ( MonadHandler m
+                         , HandlerSite m ~ UniWorX
+                         , RenderMessage UniWorX msg
+                         )
+                      => CsvOptions
+                      -> msg -- ^ Sheet name for .xlsx
+                      -> CsvRendered
+                      -> m (CsvFormat, LBS.ByteString)
+encodeCsvRenderedWith encOpts sheetName CsvRendered{..} = runConduit $ yieldMany csvRenderedData .| (encodeCsvWith encOpts sheetName csvRenderedHeader `fuseBoth` C.sinkLazy)
+
+csvRenderedToTypedContent :: ( MonadHandler m
+                             , HandlerSite m ~ UniWorX
+                             , RenderMessage UniWorX msg
+                             )
+                          => msg -- ^ Sheet name for .xlsx
+                          -> CsvRendered
+                          -> m TypedContent
+csvRenderedToTypedContent sheetName csvRendered = do
+  encOpts <- maybe def (userCsvOptions . entityVal) <$> maybeAuth
+  csvRenderedToTypedContentWith encOpts sheetName csvRendered
+
+csvRenderedToTypedContentWith :: ( MonadHandler m
+                                 , HandlerSite m ~ UniWorX
+                                 , RenderMessage UniWorX msg
+                                 )
+                              => CsvOptions
+                              -> msg -- ^ Sheet name for .xlsx
+                              -> CsvRendered
+                              -> m TypedContent
+csvRenderedToTypedContentWith encOpts sheetName csvRendered = do
+  (csvFormat, resp) <- encodeCsvRenderedWith encOpts sheetName csvRendered
+  let cType = case csvFormat of
+        FormatCsv -> typeCsv'
+        FormatXlsx -> typeXlsx
+  return . TypedContent cType $ toContent resp
+
 
 timestampCsv :: ( MonadHandler m
                 , HandlerSite m ~ UniWorX
                 )
              => m (FilePath -> FilePath)
 timestampCsv = do
-  csvOpts <- maybe def (userCsvOptions . entityVal) <$> maybeAuth
+  csvOpts <- fmap (maybe def $ userCsvOptions . entityVal) maybeAuth
-  if
+  timestampCsv' csvOpts . review _Wrapped =<< languages
-    | csvOpts ^. _csvTimestamp -> do
-        ts <- formatTime' (iso8601DateFormat $ Just "%H%M") =<< liftIO getCurrentTime
-        return $ (<>) (unpack ts <> "-")
-    | otherwise -> return id
   
-partIsAttachmentCsv :: (Textual t, MonadMail m, HandlerSite m ~ UniWorX)
+
-                    => t
+timestampCsv' :: MonadIO m
+              => CsvOptions -> Languages -> m (FilePath -> FilePath)
+timestampCsv' csvOpts (Languages langs) = liftIO $ if
+  | csvOpts ^. _csvTimestamp -> do
+      ts <- getCurrentTime <&> Time.formatTime (getTimeLocale' langs) (iso8601DateFormat $ Just "%H%M")
+      return $ (<>) (ts <> "-")
+  | otherwise -> return id
+
+expectedCsvFormat :: ( MonadHandler m
+                     , HandlerSite m ~ UniWorX
+                     )
+                  => m CsvFormat
+expectedCsvFormat = view (_csvFormat . _CsvFormat) . maybe def (userCsvOptions . entityVal) <$> maybeAuth
+
+expectedCsvContentType :: ( MonadHandler m
+                          , HandlerSite m ~ UniWorX
+                          )
+                       => m ContentType
+expectedCsvContentType = expectedCsvFormat <&> \case
+  FormatCsv -> typeCsv'
+  FormatXlsx -> typeXlsx
+
+partIsAttachmentCsv :: (RenderMessage UniWorX msg, MonadMail m, HandlerSite m ~ UniWorX)
+                    => msg
                     -> StateT Part m ()
-partIsAttachmentCsv (repack -> fName) = do
+partIsAttachmentCsv fName' = do
-  ts <- timestampCsv
+  csvOpts <- lift askMailCsvOptions
-  partIsAttachment . ts $ fName `addExtension` unpack extensionCsv
+  langs <- lift askMailLanguages
+  fName <- ($ fName') <$> lift getMailMessageRender
+  ts <- timestampCsv' csvOpts langs
+  let ext = case csvOpts ^. _csvFormat . _CsvFormat of
+        FormatCsv -> extensionCsv
+        FormatXlsx -> extensionXlsx
+  partIsAttachment . ts $ unpack fName `addExtension` unpack ext
 
-encodeDefaultOrderedCsv :: forall csv m.
+setContentDispositionCsv :: (RenderMessage UniWorX msg, MonadHandler m, HandlerSite m ~ UniWorX)
+                         => msg
+                         -> m ()
+setContentDispositionCsv fName' = do
+  fName <- unpack . ($ fName') <$> getMessageRender
+  ts <- timestampCsv
+  fmt <- expectedCsvFormat
+  let ext = case fmt of
+        FormatCsv -> extensionCsv
+        FormatXlsx -> extensionXlsx
+  setContentDisposition' . Just $ ensureExtension (unpack ext) (ts fName)
+
+encodeDefaultOrderedCsv :: forall csv m msg.
                            ( ToNamedRecord csv
                            , DefaultOrdered csv
                            , MonadHandler m
                            , HandlerSite m ~ UniWorX
+                           , RenderMessage UniWorX msg
                            )
-                        => ConduitT csv ByteString m ()
+                        => msg -- ^ Sheet name for .xlsx
-encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv)
+                        -> ConduitT csv ByteString m CsvFormat
+encodeDefaultOrderedCsv sheetName = encodeCsv sheetName $ headerOrder (error "headerOrder" :: csv)
 
 
-respondCsv :: ToNamedRecord csv
+respondCsv :: ( ToNamedRecord csv
-           => Header
+              , RenderMessage UniWorX msg
+              )
+           => msg -- ^ Sheet name for .xlsx
+           -> Header
            -> ConduitT () csv Handler ()
            -> Handler TypedContent
-respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
+respondCsv sheetName hdr src = respondSource typeCsv' $ src .| void (encodeCsv sheetName hdr) .| awaitForever sendChunk
 
-respondDefaultOrderedCsv :: forall csv.
+respondDefaultOrderedCsv :: forall csv msg.
                             ( ToNamedRecord csv
                             , DefaultOrdered csv
+                            , RenderMessage UniWorX msg
                             )
-                         => ConduitT () csv Handler ()
+                         => msg -- ^ Sheet name for .xlsx
+                         -> ConduitT () csv Handler ()
                          -> Handler TypedContent
-respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
+respondDefaultOrderedCsv sheetName = respondCsv sheetName $ headerOrder (error "headerOrder" :: csv)
 
-respondCsvDB :: ToNamedRecord csv
+respondCsvDB :: ( ToNamedRecord csv
-             => Header
+                , RenderMessage UniWorX msg
+                )
+             => msg -- ^ Sheet name for .xlsx
+             -> Header
              -> ConduitT () csv DB ()
              -> Handler TypedContent
-respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk
+respondCsvDB sheetName hdr src = respondSourceDB typeCsv' $ src .| void (encodeCsv sheetName hdr) .| awaitForever sendChunk
 
-respondDefaultOrderedCsvDB :: forall csv.
+respondDefaultOrderedCsvDB :: forall csv msg.
                               ( ToNamedRecord csv
                               , DefaultOrdered csv
+                              , RenderMessage UniWorX msg
                               )
-                           => ConduitT () csv DB ()
+                           => msg -- ^ Sheet name for .xlsx
+                           -> ConduitT () csv DB ()
                            -> Handler TypedContent
-respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv)
+respondDefaultOrderedCsvDB sheetName = respondCsvDB sheetName $ headerOrder (error "headerOrder" :: csv)
 
 fileSourceCsv :: ( FromNamedRecord csv
                  , MonadThrow m
@@ -261,3 +377,15 @@ instance ToWidget UniWorX CsvRendered where
                 ]
 
       headers = decodeUtf8 <$> Vector.toList csvRenderedHeader
+
+
+csvOptionsForFormat :: ( MonadHandler m, HandlerSite m ~ UniWorX )
+                    => CsvFormat
+                    -> m CsvOptions
+csvOptionsForFormat fmt = do
+  csvOpts <- fmap (maybe def $ userCsvOptions . entityVal) maybeAuth
+  return $ if
+    | fmt == csvOpts ^. _csvFormat . _CsvFormat
+      -> csvOpts
+    | otherwise
+      -> csvOpts & _csvFormat .~ (csvPreset . _CsvFormatPreset # fmt)

src/Handler/Utils/ExternalExam/Users.hs

@@ -193,7 +193,6 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
       examn = externalExamExamName
 
   uid <- requireAuthId
-  csvName <- getMessageRender <*> pure (MsgExternalExamUserCsvName tid ssh coursen examn)
   isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR
   currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
   MsgRenderer mr <- getMsgRenderer
@@ -358,6 +357,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
       , dbParamsFormIdent    = def
       }
     dbtIdent = mode
+    dbtCsvName = MsgExternalExamUserCsvName tid ssh coursen examn
+    dbtCsvSheetName = MsgExternalExamUserCsvSheetName tid ssh coursen examn
     dbtCsvEncode = case mode of
       EEUMGrades -> Just DBTCsvEncode
         { dbtCsvExportForm = ExternalExamUserCsvExportDataGrades
@@ -365,13 +366,13 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
         , dbtCsvDoEncode = \ExternalExamUserCsvExportDataGrades{..} -> C.mapM $ \(E.Value k, row) -> do
             when csvEEUserMarkSynchronised $ externalExamResultMarkSynchronised k
             return $ encodeCsv' row
-        , dbtCsvName = unpack csvName
+        , dbtCsvName, dbtCsvSheetName
         , dbtCsvNoExportData = Nothing
         , dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: ExternalExamUserTableCsv)
         , dbtCsvExampleData = Nothing
         }
       EEUMUsers ->
-        let baseEncode = simpleCsvEncode csvName encodeCsv'
+        let baseEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName encodeCsv'
             csvEUserStudyFeatures = mempty
          in baseEncode <&> \enc -> enc
             { dbtCsvExampleData = Just

src/Handler/Utils/Form.hs

@@ -1964,11 +1964,16 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs
       CsvFormatOptionsPreset' preset
         -> pure $ csvPreset # preset
       CsvFormatOptionsCustom'
+        -> multiActionA csvFormatActs (fslI MsgCsvFormatField) $ view _CsvFormat <$> mPrev
+    csvFormatActs :: Map CsvFormat (AForm Handler CsvFormatOptions)
+    csvFormatActs = mapF $ \case
+      FormatCsv
         -> CsvFormatOptions
-             <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev)
+             <$> apreq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (preview _csvDelimiter =<< mPrev)
-             <*> areq (selectField lineEndOpts)   (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev)
+             <*> apreq (selectField lineEndOpts)   (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev)
-             <*> areq (selectField quoteOpts)     (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev)
+             <*> apreq (selectField quoteOpts)     (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev)
-             <*> areq (selectField encodingOpts)  (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (csvEncoding <$> mPrev)
+             <*> apreq (selectField encodingOpts)  (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev)
+      FormatXlsx -> pure CsvXlsxFormatOptions
 
     delimiterOpts :: Handler (OptionList Char)
     delimiterOpts = do

src/Handler/Utils/Mail.hs

@@ -53,6 +53,7 @@ userMailT uid mAct = do
     , userDateTimeFormat
     , userDateFormat
     , userTimeFormat
+    , userCsvOptions
     } <- liftHandler . runDB $ getJust uid
   let
     ctx = MailContext
@@ -61,6 +62,7 @@ userMailT uid mAct = do
           SelFormatDateTime -> userDateTimeFormat
           SelFormatDate -> userDateFormat
           SelFormatTime -> userTimeFormat
+      , mcCsvOptions = userCsvOptions
       }
   mailT ctx $ do
     _mailTo .= pure (userAddress user)

src/Handler/Utils/Minio.hs

@@ -17,7 +17,7 @@ runAppMinio :: ( MonadHandler m, HandlerSite m ~ UniWorX
             => Minio a -> m a
 runAppMinio act = do
   conn <- hoistMaybe =<< getsYesod appUploadCache
-  either throwM return <=< liftIO $ Minio.runMinioWith conn act
+  throwLeft <=< liftIO $ Minio.runMinioWith conn act
 
 minioIsDoesNotExist :: HttpException -> Bool
 minioIsDoesNotExist (HttpExceptionRequest _ (StatusCodeException resp _))

src/Handler/Utils/Table/Pagination.hs

@@ -53,7 +53,6 @@ import Handler.Utils.Table.Pagination.Types
 import Handler.Utils.Table.Pagination.CsvColumnExplanations
 import Handler.Utils.Form
 import Handler.Utils.Csv
-import Handler.Utils.ContentDisposition
 import Handler.Utils.I18n
 import Utils
 import Utils.Lens
@@ -581,24 +580,34 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
       fromOuter = Map.lookup key >=> listToMaybe
 
 
-data DBTCsvEncode r' k' csv = forall exportData.
+data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
   ( ToNamedRecord csv, CsvColumnsExplained csv
   , DBTableKey k'
   , Typeable exportData
+  , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
   ) => DBTCsvEncode
   { dbtCsvExportForm   :: AForm DB exportData
   , dbtCsvHeader       :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data
   , dbtCsvExampleData  :: Maybe [csv]
   , dbtCsvDoEncode     :: exportData -> ConduitT (k', r') csv DB ()
-  , dbtCsvName         :: FilePath
+  , dbtCsvName         :: filename
+  , dbtCsvSheetName    :: sheetName
   , dbtCsvNoExportData :: Maybe (AnIso' exportData ())
   }
-data DBTExtraRep r' k' = forall rep.
+data DBTExtraRep r' k'
-  ( HasContentType rep
+  = forall rep.
-  , DBTableKey k'
+    ( HasContentType rep
-  ) => DBTExtraRep
+    , DBTableKey k'
-  { dbtERepDoEncode :: ConduitT (k', r') Void DB rep
+    ) => DBTExtraRep
-  }
+    { dbtERepDoEncode :: ConduitT (k', r') Void DB rep
+    }
+  | forall rep.
+    ( ToContent rep
+    , DBTableKey k'
+    ) => DBTExtraRepFor
+    { dbtERepContentType :: ContentType
+    , dbtERepDoEncode :: ConduitT (k', r') Void DB rep
+    }
 data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
   ( FromNamedRecord csv, ToNamedRecord csv
   , DBTableKey k'
@@ -646,48 +655,58 @@ type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text]
 noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
 noCsvEncode = Nothing
 
-simpleCsvEncode :: forall fp r' k' csv.
+simpleCsvEncode :: forall filename sheetName r' k' csv.
                    ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                    , DBTableKey k'
-                   , Textual fp
+                   , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
                    )
-                => fp -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv)
+                => filename -> sheetName -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv)
-simpleCsvEncode fName f = Just DBTCsvEncode
+simpleCsvEncode fName sName f = Just DBTCsvEncode
   { dbtCsvExportForm   = pure ()
   , dbtCsvDoEncode     = \() -> C.map (f . view _2)
-  , dbtCsvName         = unpack fName
+  , dbtCsvName         = fName
+  , dbtCsvSheetName    = sName
   , dbtCsvNoExportData = Just id
   , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   , dbtCsvExampleData  = Nothing
   }
 
-simpleCsvEncodeM :: forall fp r' k' csv.
+simpleCsvEncodeM :: forall filename sheetName r' k' csv.
                     ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv
                     , DBTableKey k'
-                    , Textual fp
+                    , RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
                     )
-                 => fp -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv)
+                 => filename -> sheetName -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv)
-simpleCsvEncodeM fName f = Just DBTCsvEncode
+simpleCsvEncodeM fName sName f = Just DBTCsvEncode
   { dbtCsvExportForm   = pure ()
   , dbtCsvDoEncode     = \() -> C.mapM (runReaderT f . view _2)
-  , dbtCsvName         = unpack fName
+  , dbtCsvName         = fName
+  , dbtCsvSheetName    = sName
   , dbtCsvNoExportData = Just id
   , dbtCsvHeader       = const . return $ headerOrder (error "headerOrder" :: csv)
   , dbtCsvExampleData  = Nothing
   }
 
-withCsvExtraRep :: forall exportData csv r' k'.
+withCsvExtraRep :: forall exportData csv sheetName r' k'.
-                   Typeable exportData
+                   ( Typeable exportData
-                => exportData
+                   , RenderMessage UniWorX sheetName
+                   )
+                => sheetName
+                -> exportData
                 -> Maybe (DBTCsvEncode r' k' csv)
                 -> [DBTExtraRep r' k'] -> [DBTExtraRep r' k']
-withCsvExtraRep exportData mEncode = maybe id (flip snoc) csvExtraRep
+withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv) <> maybe id (flip snoc) (csvExtraRep FormatXlsx)
-  where csvExtraRep = do
+  where
-          DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode
+    csvExtraRep fmt = do
-          Refl <- eqT @exportData @exportData'
+      DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode
-          return DBTExtraRep
+      Refl <- eqT @exportData @exportData'
-            { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[]))
+      return DBTExtraRepFor
-            }
+        { dbtERepContentType = typeCsv'
+        , dbtERepDoEncode = do
+            csvRendered <- toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[]))
+            encOpts <- csvOptionsForFormat fmt
+            csvRenderedToTypedContentWith encOpts sheetName csvRendered
+        }
 
 
 class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where
@@ -1125,14 +1144,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just exData <- dbtCsvExampleData -> do
         hdr <- dbtCsvHeader Nothing
-        sendResponse <=< liftHandler . respondCsv hdr $ C.sourceList exData
+        setContentDispositionCsv dbtCsvName
+        sendResponse <=< liftHandler . respondCsv dbtCsvSheetName hdr $ C.sourceList exData
     DBCsvExport{..}
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just exportData <- fromDynamic dbCsvExportData -> do
         hdr <- dbtCsvHeader $ Just exportData
-        dbtCsvName' <- timestampCsv <*> pure dbtCsvName
+        setContentDispositionCsv dbtCsvName
-        setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName'
+        sendResponse <=< liftHandler . respondCsvDB dbtCsvSheetName hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
-        sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave
     DBCsvImport{..}
       | Just DBTCsvEncode{..} <- dbtCsvEncode
       , Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass
@@ -1290,15 +1309,16 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
           ]
     _other      -> return ()
 
-  let extraReps = maybe id (flip snoc) csvRep dbtExtraReps
+  let extraReps = maybe id ($) addCSVReps dbtExtraReps
-        where csvRep = do
+        where addCSVReps = do
                 DBTCsvEncode{..} <- dbtCsvEncode
                 noExportData' <- cloneIso <$> dbtCsvNoExportData
                 let exportData = noExportData' # ()
-                return DBTExtraRep
+                return $ withCsvExtraRep dbtCsvSheetName exportData dbtCsvEncode
-                  { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[]))
+      extraRepContentType = \case
-                  }
+        DBTExtraRep{..} -> getContentType dbtERepDoEncode
-      extraReps' = (typeHtml, Nothing) : map ((,) <$> (\DBTExtraRep{..} -> getContentType dbtERepDoEncode) <*> Just) extraReps
+        DBTExtraRepFor{..} -> dbtERepContentType
+      extraReps' = (typeHtml, Nothing) : map ((,) <$> extraRepContentType <*> Just) extraReps
       doAltRep = maybe True (== dbtIdent) <$> lookupGlobalGetParam GetSelectTable
 
   maybeT (return ()) $ do
@@ -1308,7 +1328,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
     
     altRep <- hoistMaybe <=< asum $ do
       mRep <- hoistMaybe . selectRep' extraReps' =<< cts
-      return . return $ mRep <&> \DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode
+      return . return $ mRep <&> \case
+        DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode
+        DBTExtraRepFor{..} -> fmap (TypedContent dbtERepContentType . toContent) . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode
 
     lift $ sendResponse =<< altRep
 

src/Handler/Utils/Zip.hs

@@ -212,7 +212,7 @@ decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath
 -- Throws 'Data.Encoding.Exception.DecodingException's.
 decodeZipEntryName = \case
   Left  t     -> return $ unpack t
-  Right cp437 -> either throwM return $ decodeStrictByteStringExplicit CP437 cp437
+  Right cp437 -> throwLeft $ decodeStrictByteStringExplicit CP437 cp437
 
 encodeZipEntryName :: FilePath -> Either Text ByteString
 -- ^ Encode a filename for use in a 'ZipEntry', encodes as

src/Import.hs

@@ -11,5 +11,6 @@ import Utils.SystemMessage   as Import
 import Utils.Metrics         as Import
 import Utils.Files           as Import
 import Utils.PersistentTokenBucket as Import
+import Utils.Csv.Mail        as Import
 
 import Jobs.Types            as Import (JobHandler(..))

src/Jobs/Handler/SendCourseCommunication.hs

@@ -38,5 +38,5 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
     when (jRecipientEmail == Right jSender) $
       addPart' $ do
-        partIsAttachmentCsv $ mr MsgCommAllRecipients
+        partIsAttachmentCsv MsgCommAllRecipients
-        toMailPart (toDefaultOrderedCsvRendered jAllRecipientAddresses, userCsvOptions sender)
+        toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses)

src/Jobs/Types.hs

@@ -170,6 +170,7 @@ type family ChildrenJobChildren a where
   ChildrenJobChildren (Key a) = '[]
   ChildrenJobChildren (CI a) = '[]
   ChildrenJobChildren (Set a) = '[]
+  ChildrenJobChildren MailContext = '[]
 
   ChildrenJobChildren a = Children ChGeneric a
   

src/Mail.hs

@@ -41,6 +41,7 @@ import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFi
 import Data.Kind (Type)
 
 import Model.Types.Languages
+import Model.Types.Csv
 
 import Network.Mail.Mime hiding (addPart, addAttachment)
 import qualified Network.Mail.Mime as Mime (addPart)
@@ -171,6 +172,7 @@ _MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
 data MailContext = MailContext
   { mcLanguages :: Languages
   , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
+  , mcCsvOptions :: CsvOptions
   } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
@@ -183,6 +185,7 @@ instance Default MailContext where
   def = MailContext
     { mcLanguages = def
     , mcDateTimeFormat = def
+    , mcCsvOptions = def
     }
 
 makeLenses_ ''MailContext
@@ -192,11 +195,13 @@ makeLenses_ ''MailSmtpData
 class (MonadHandler m, MonadState Mail m) => MonadMail m where
   askMailLanguages :: m Languages
   askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
+  askMailCsvOptions :: m CsvOptions
   tellMailSmtpData :: MailSmtpData -> m ()
 
 instance MonadHandler m => MonadMail (MailT m) where
   askMailLanguages = view _mcLanguages
   askMailDateTimeFormat = (view _mcDateTimeFormat ??)
+  askMailCsvOptions = view _mcCsvOptions
   tellMailSmtpData = tell
 
 getMailMessageRender :: ( MonadMail m

src/Model/Types.hs

@@ -21,3 +21,4 @@ import Model.Types.Workflow as Types
 import Model.Types.Changelog as Types
 import Model.Types.Markup as Types
 import Model.Types.Room as Types
+import Model.Types.Csv as Types

src/Model/Types/Csv.hs

@@ -0,0 +1,191 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Types.Csv
+  ( Quoting(..)
+  , CsvOptions(..), _csvFormat, _csvTimestamp
+  , CsvFormatOptions(..), _csvDelimiter, _csvUseCrLf, _csvQuoting, _csvEncoding
+  , CsvPreset(..)
+  , csvPreset
+  , _CsvEncodeOptions
+  , CsvFormat(..), _FormatCsv, _FormatXlsx
+  , _CsvFormat, _CsvFormatPreset
+  ) where
+
+import ClassyPrelude
+
+import Data.Csv (Quoting(..))
+import qualified Data.Csv as Csv
+
+import Model.Types.TH.JSON
+import Utils.PathPiece
+import Data.Universe.TH
+import Data.Aeson.TH
+
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as JSON
+
+import Data.Encoding (DynEncoding)
+
+import Data.Encoding.Instances ()
+
+import Control.Lens
+
+import Utils.Lens.TH
+
+import Data.Default
+import Data.Universe
+
+
+deriving stock instance Generic Quoting
+deriving stock instance Ord Quoting
+deriving stock instance Read Quoting
+deriving anyclass instance Hashable Quoting
+deriving anyclass instance NFData Quoting
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  } ''Quoting
+deriveFinite ''Quoting
+nullaryPathPiece ''Quoting $ \q -> if
+  | q == "QuoteNone" -> "never"
+  | otherwise -> camelToPathPiece' 1 q
+
+data CsvOptions
+  = CsvOptions
+    { csvFormat    :: CsvFormatOptions
+    , csvTimestamp :: Bool
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, NFData)
+
+data CsvFormatOptions
+  = CsvFormatOptions
+    { csvDelimiter :: Char
+    , csvUseCrLf   :: Bool
+    , csvQuoting   :: Csv.Quoting
+    , csvEncoding  :: DynEncoding
+    }
+  | CsvXlsxFormatOptions
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Hashable, NFData)
+
+makeLenses_ ''CsvOptions
+makeLenses_ ''CsvFormatOptions
+
+instance Default CsvOptions where
+  def = CsvOptions
+    { csvFormat    = def
+    , csvTimestamp = False
+    }
+
+instance Default CsvFormatOptions where
+  def = csvPreset # CsvPresetRFC
+
+data CsvPreset = CsvPresetRFC
+               | CsvPresetXlsx
+               | CsvPresetExcel
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe CsvPreset
+instance Finite CsvPreset
+
+csvPreset :: Prism' CsvFormatOptions CsvPreset
+csvPreset = prism' fromPreset toPreset
+  where
+    fromPreset :: CsvPreset -> CsvFormatOptions
+    fromPreset CsvPresetRFC   = CsvFormatOptions
+      { csvDelimiter = ','
+      , csvUseCrLf   = True
+      , csvQuoting   = QuoteMinimal
+      , csvEncoding  = "UTF8"
+      }
+    fromPreset CsvPresetExcel = CsvFormatOptions
+      { csvDelimiter = ';'
+      , csvUseCrLf   = True
+      , csvQuoting   = QuoteAll
+      , csvEncoding  = "CP1252"
+      }
+    fromPreset CsvPresetXlsx = CsvXlsxFormatOptions
+
+    toPreset :: CsvFormatOptions -> Maybe CsvPreset
+    toPreset opts = case filter (\p -> fromPreset p == opts) universeF of
+      [p]    -> Just p
+      _other -> Nothing
+
+_CsvEncodeOptions :: Prism' CsvFormatOptions Csv.EncodeOptions
+_CsvEncodeOptions = prism' fromEncode toEncode
+  where
+    toEncode CsvFormatOptions{..} = Just $ Csv.defaultEncodeOptions
+      { Csv.encDelimiter     = fromIntegral $ fromEnum csvDelimiter
+      , Csv.encUseCrLf       = csvUseCrLf
+      , Csv.encQuoting       = csvQuoting
+      , Csv.encIncludeHeader = True
+      }
+    toEncode CsvXlsxFormatOptions{} = Nothing
+    fromEncode encOpts = def
+      { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts
+      , csvUseCrLf   = Csv.encUseCrLf encOpts
+      , csvQuoting   = Csv.encQuoting encOpts
+      }
+
+instance ToJSON CsvOptions where
+  toJSON CsvOptions{..} = JSON.object
+    [ "format"    JSON..= csvFormat
+    , "timestamp" JSON..= csvTimestamp
+    ]
+
+instance FromJSON CsvOptions where
+  parseJSON = JSON.withObject "CsvOptions" $ \o -> do
+    csvFormat    <- o JSON..:? "format" JSON..!= csvFormat def
+    csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def
+    return CsvOptions{..}
+
+data CsvFormat = FormatCsv | FormatXlsx
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''CsvFormat $ camelToPathPiece' 1
+pathPieceJSON ''CsvFormat
+makePrisms ''CsvFormat
+
+_CsvFormat :: forall r. Getting r CsvFormatOptions CsvFormat
+_CsvFormat = to $ \case
+  CsvFormatOptions{}     -> FormatCsv
+  CsvXlsxFormatOptions{} -> FormatXlsx
+
+_CsvFormatPreset :: Prism' CsvPreset CsvFormat
+_CsvFormatPreset = prism' toPreset fromPreset
+  where
+    toPreset = \case
+      FormatCsv -> CsvPresetRFC
+      FormatXlsx -> CsvPresetXlsx
+    fromPreset = \case
+      CsvPresetRFC -> Just FormatCsv
+      CsvPresetXlsx -> Just FormatXlsx
+      _other -> Nothing
+
+instance ToJSON CsvFormatOptions where
+  toJSON CsvFormatOptions{..} = JSON.object
+    [ "format"    JSON..= FormatCsv
+    , "delimiter" JSON..= fromEnum csvDelimiter
+    , "use-cr-lf" JSON..= csvUseCrLf
+    , "quoting"   JSON..= csvQuoting
+    , "encoding"  JSON..= csvEncoding
+    ]
+  toJSON CsvXlsxFormatOptions = JSON.object
+    [ "format"   JSON..= FormatXlsx
+    ]
+instance FromJSON CsvFormatOptions where
+  parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do
+    formatTag <- o JSON..:? "format" JSON..!= FormatCsv
+    
+    case formatTag of
+      FormatCsv -> do
+        csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
+        csvUseCrLf   <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf  def
+        csvQuoting   <- o JSON..:? "quoting"   JSON..!= csvQuoting  def
+        csvEncoding  <- o JSON..:? "encoding"  JSON..!= csvEncoding def
+        return CsvFormatOptions{..}
+      FormatXlsx -> return CsvXlsxFormatOptions
+
+derivePersistFieldJSON ''CsvOptions
+
+nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2

src/Model/Types/Misc.hs

@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 {-|
 Module: Model.Types.Misc
 Description: Additional uncategorized types
@@ -7,7 +5,6 @@ Description: Additional uncategorized types
 
 module Model.Types.Misc
   ( module Model.Types.Misc
-  , Quoting(..)
   ) where
 
 import Import.NoModel
@@ -18,17 +15,10 @@ import Data.Maybe (fromJust)
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
 
-import qualified Data.ByteString.Lazy as LBS
-
-import Data.Csv (Quoting(..))
 import qualified Data.Csv as Csv
 
-import qualified Data.Aeson as JSON
-
 import Database.Persist.Sql (PersistFieldSql(..))
 
-import Utils.Lens.TH
-
 import Web.HttpApiData
 
 
@@ -66,135 +56,6 @@ $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate "
 derivePersistField "Theme"
 
 
-deriving instance Generic Quoting
-deriving instance Ord Quoting
-deriving instance Read Quoting
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  } ''Quoting
-deriveFinite ''Quoting
-nullaryPathPiece ''Quoting $ \q -> if
-  | q == "QuoteNone" -> "never"
-  | otherwise -> camelToPathPiece' 1 q
-
-data CsvOptions
-  = CsvOptions
-    { csvFormat    :: CsvFormatOptions
-    , csvTimestamp :: Bool
-    }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-data CsvFormatOptions
-  = CsvFormatOptions
-    { csvDelimiter :: Char
-    , csvUseCrLf   :: Bool
-    , csvQuoting   :: Csv.Quoting
-    , csvEncoding  :: DynEncoding
-    }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
-
-makeLenses_ ''CsvOptions
-makeLenses_ ''CsvFormatOptions
-
-instance Default CsvOptions where
-  def = CsvOptions
-    { csvFormat    = def
-    , csvTimestamp = False
-    }
-
-instance Default CsvFormatOptions where
-  def = csvPreset # CsvPresetRFC
-
-data CsvPreset = CsvPresetRFC
-               | CsvPresetExcel
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-instance Universe CsvPreset
-instance Finite CsvPreset
-
-csvPreset :: Prism' CsvFormatOptions CsvPreset
-csvPreset = prism' fromPreset toPreset
-  where
-    fromPreset :: CsvPreset -> CsvFormatOptions
-    fromPreset CsvPresetRFC   = CsvFormatOptions
-      { csvDelimiter = ','
-      , csvUseCrLf   = True
-      , csvQuoting   = QuoteMinimal
-      , csvEncoding  = "UTF8"
-      }
-    fromPreset CsvPresetExcel = CsvFormatOptions
-      { csvDelimiter = ';'
-      , csvUseCrLf   = True
-      , csvQuoting   = QuoteAll
-      , csvEncoding  = "CP1252"
-      }
-
-    toPreset :: CsvFormatOptions -> Maybe CsvPreset
-    toPreset opts = case filter (\p -> fromPreset p == opts) universeF of
-      [p]    -> Just p
-      _other -> Nothing
-
-_CsvEncodeOptions :: Iso' CsvFormatOptions Csv.EncodeOptions
-_CsvEncodeOptions = iso toEncode fromEncode
-  where
-    toEncode CsvFormatOptions{..} = Csv.defaultEncodeOptions
-      { Csv.encDelimiter     = fromIntegral $ fromEnum csvDelimiter
-      , Csv.encUseCrLf       = csvUseCrLf
-      , Csv.encQuoting       = csvQuoting
-      , Csv.encIncludeHeader = True
-      }
-    fromEncode encOpts = def
-      { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts
-      , csvUseCrLf   = Csv.encUseCrLf encOpts
-      , csvQuoting   = Csv.encQuoting encOpts
-      }
-
-instance ToJSON CsvOptions where
-  toJSON CsvOptions{..} = JSON.object
-    [ "format"    JSON..= csvFormat
-    , "timestamp" JSON..= csvTimestamp
-    ]
-
-instance FromJSON CsvOptions where
-  parseJSON = JSON.withObject "CsvOptions" $ \o -> do
-    csvFormat    <- o JSON..:? "format" JSON..!= csvFormat def
-    csvTimestamp <- o JSON..:? "timestamp" JSON..!= csvTimestamp def
-    return CsvOptions{..}
-
-instance ToJSON CsvFormatOptions where
-  toJSON CsvFormatOptions{..} = JSON.object
-    [ "delimiter" JSON..= fromEnum csvDelimiter
-    , "use-cr-lf" JSON..= csvUseCrLf
-    , "quoting"   JSON..= csvQuoting
-    , "encoding"  JSON..= csvEncoding
-    ]
-instance FromJSON CsvFormatOptions where
-  parseJSON = JSON.withObject "CsvFormatOptions" $ \o -> do
-    csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
-    csvUseCrLf   <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf   def
-    csvQuoting   <- o JSON..:? "quoting"   JSON..!= csvQuoting   def
-    csvEncoding  <- o JSON..:? "encoding"   JSON..!= csvEncoding   def
-    return CsvFormatOptions{..}
-
-derivePersistFieldJSON ''CsvOptions
-
-nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2
-
-instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where
-  toMailPart (CsvRendered{..}, encOpts) = do
-    _partType .= decodeUtf8 typeCsv'
-    _partEncoding .= QuotedPrintableText
-    _partContent .= PartContent (recode' $ Csv.encodeByNameWith (encOpts ^. _csvFormat . _CsvEncodeOptions) csvRenderedHeader csvRenderedData)
-    where
-      recode' :: LBS.ByteString -> LBS.ByteString
-      recode'
-        | enc == "UTF8"
-        = id
-        | otherwise
-        = encodeLazyByteString enc . decodeLazyByteString UTF8
-        where enc = encOpts ^. _csvFormat . _csvEncoding
-
-instance YesodMail site => ToMailPart site CsvRendered where
-  toMailPart = toMailPart . (, def :: CsvOptions)
 
 
 data FavouriteReason
@@ -210,7 +71,6 @@ deriveJSON defaultOptions
   } ''FavouriteReason
 derivePersistFieldJSON ''FavouriteReason
 
-
 data Sex
   = SexNotKnown
   | SexMale

src/Utils.hs

@@ -774,6 +774,8 @@ whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
 whenIsRight (Right x) f = f x
 whenIsRight (Left  _) _ = return ()
 
+throwLeft :: (MonadThrow m, Exception exc) => Either exc a -> m a
+throwLeft = either throwM return
 
 ---------------
 -- Exception --

src/Utils/Csv.hs

@@ -2,11 +2,13 @@
 
 module Utils.Csv
   ( typeCsv, typeCsv', extensionCsv
+  , typeXlsx, extensionXlsx
   , pathPieceCsv
   , (.:??)
   , CsvRendered(..)
   , toCsvRendered
   , toDefaultOrderedCsvRendered
+  , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx
   ) where
 
 import ClassyPrelude hiding (lookup)
@@ -14,7 +16,6 @@ import Settings.Mime
 
 import Data.Csv hiding (Name)
 import Data.Csv.Conduit (CsvParseError)
-import qualified Data.Csv.Incremental as Incremental
 
 import Language.Haskell.TH (Name)
 import Language.Haskell.TH.Lib
@@ -22,6 +23,16 @@ import Language.Haskell.TH.Lib
 import Yesod.Core.Content
 
 import qualified Data.Map as Map
+import qualified Data.HashMap.Strict as HashMap
+
+import Codec.Xlsx (Xlsx)
+import qualified Codec.Xlsx as Xlsx
+
+import Data.Monoid (Endo(..))
+
+import Control.Lens
+
+import Data.Default
 
 
 deriving instance Typeable CsvParseError
@@ -30,10 +41,14 @@ instance Exception CsvParseError
 
 typeCsv, typeCsv' :: ContentType
 typeCsv = simpleContentType typeCsv'
-typeCsv' = "text/csv; charset=UTF-8; header=present"
+typeCsv' = "text/csv; header=present"
 
-extensionCsv :: Extension
+typeXlsx :: ContentType
+typeXlsx = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
+
+extensionCsv, extensionXlsx :: Extension
 extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
+extensionXlsx = fromMaybe "xlsx" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeXlsx ]
 
 
 pathPieceCsv :: Name -> DecsQ
@@ -55,17 +70,6 @@ data CsvRendered = CsvRendered
   , csvRenderedData :: [NamedRecord]
   } deriving (Eq, Read, Show, Generic, Typeable)
 
-instance ToContent CsvRendered where
-  toContent CsvRendered{..} = toContent . Incremental.encodeByName csvRenderedHeader $ foldr ((<>) . Incremental.encodeNamedRecord) mempty csvRenderedData
-
-instance ToTypedContent CsvRendered where
-  toTypedContent = TypedContent
-    <$> getContentType . Identity
-    <*> toContent
-
-instance HasContentType CsvRendered where
-  getContentType _ = typeCsv'
-
 toCsvRendered :: forall mono.
                  ( ToNamedRecord (Element mono)
                  , MonoFoldable mono
@@ -83,3 +87,13 @@ toDefaultOrderedCsvRendered :: forall mono.
                                )
                             => mono -> CsvRendered
 toDefaultOrderedCsvRendered = toCsvRendered $ headerOrder (error "headerOrder" :: Element mono)
+
+
+csvRenderedToXlsx :: Text -- ^ Name of worksheet
+                  -> CsvRendered -> Xlsx
+csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (def & appEndo (addHeader <> addValues))
+  where
+    addHeader = flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, bs) -> Endo $ Xlsx.cellValueAtRC (1, c) ?~ Xlsx.CellText (decodeUtf8 bs)
+    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)

src/Utils/Csv/Mail.hs

@@ -0,0 +1,69 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utils.Csv.Mail
+  ( recodeCsv
+  ) where
+
+import Import.NoModel
+import Model.Types.Csv
+
+import qualified Data.Csv as Csv
+
+import Data.Time.Clock.POSIX (getPOSIXTime)
+
+import qualified Data.Conduit.Combinators as C
+
+import Data.Encoding (encodeLazyByteStringExplicit, decodeLazyByteStringExplicit)
+
+
+instance (RenderMessage site msg, YesodMail site) => ToMailPart site (msg, CsvRendered) where
+  toMailPart (sheetName, csvRendered@CsvRendered{..}) = do
+    encOpts <- lift askMailCsvOptions
+
+    case encOpts ^. _csvFormat of
+      CsvFormatOptions{}
+        | Just csvOpts <- encOpts ^? _csvFormat . _CsvEncodeOptions -> do
+            _partType .= decodeUtf8 typeCsv'
+            _partEncoding .= QuotedPrintableText
+            _partContent <~ fmap PartContent (liftHandler . runConduit $ C.sourceLazy (Csv.encodeByNameWith csvOpts csvRenderedHeader csvRenderedData) .| recodeCsv encOpts True C.sinkLazy)
+        | otherwise -> error "encOpts is CsvFormatOptions but cannot be converted via _CsvEncodeOptions"
+      CsvXlsxFormatOptions{} -> do
+        pNow <- liftIO getPOSIXTime
+        sheetName' <- lift $ ($ sheetName) <$> getMailMessageRender
+        _partType .= decodeUtf8 typeXlsx
+        _partEncoding .= Base64
+        _partContent .= PartContent (fromXlsx pNow $ csvRenderedToXlsx sheetName' csvRendered)
+
+recodeCsv :: MonadThrow m
+          => CsvOptions
+          -> Bool -- ^ recode from (internal) utf8 to user chosen coding?
+          -> ConduitT ByteString o m a -> ConduitT ByteString o m a
+recodeCsv encOpts toUser act = fromMaybe act $ do
+  enc <- encOpts ^? _csvFormat . _csvEncoding
+
+  let
+    recode
+      | toUser    = either throwM return . encodeLazyByteStringExplicit enc <=< either throwM return . decodeLazyByteStringExplicit UTF8
+      | otherwise = either throwM return . encodeLazyByteStringExplicit UTF8 <=< either throwM return . decodeLazyByteStringExplicit enc
+
+  return $ if
+    | enc == "UTF8" -> act
+    | FormatCsv <- fmt -> do
+        inp <- C.sinkLazy
+        inp' <- recode inp
+        sourceLazy inp' .| act
+    -- | FormatXlsx <- fmt -> do
+    --     inp <- C.sinkLazy
+    --     archive <- throwLeft $ Zip.toArchiveOrFail inp
+    --     archive' <- traverseOf (_zEntries . traverse . _Entrty . _3) recode archive
+    --     sourceLazy (Zip.fromArchive inp') .| act
+    | otherwise -> act
+  where
+    
+    fmt = encOpts ^. _csvFormat . _CsvFormat
+
+    -- _zEntries :: Lens' Zip.Archive [Zip.Entry]
+    -- _zEntries = lens (\Zip.Archive{..} -> zEntries) (\archive entries -> archive { zEntries = entries })
+
+    -- _Entry :: Lens' Zip.Entry (FilePath, Integer, Lazy.ByteString)
+    -- _Entry = lens (\entry@Zip.Entry{..} -> (eRelativePath, eLastModified, Zip.fromEntry entry)) (uncurry3 Zip.toEntry)

src/Utils/Metrics.hs

@@ -507,7 +507,7 @@ withJobWorkerStateLbls newLbls act = do
 
   liftIO . withLabel jobWorkerStateDuration newLbls . flip observe . realToFrac $ end - start
 
-  either throwM return res
+  throwLeft res
 
 observeYesodCacheSize :: MonadHandler m => m ()
 observeYesodCacheSize = do
@@ -525,7 +525,7 @@ observeFavouritesQuickActionsDuration act = do
 
   liftIO . observe favouritesQuickActionsDuration . realToFrac $ end - start
 
-  either throwM return res
+  throwLeft res
 
 data LoginOutcome
   = LoginSuccessful

src/Utils/Tokens.hs

@@ -94,7 +94,7 @@ encodeBearer token = do
   payload <- Jose.Claims . toStrict . JSON.encode <$> bearerToJSON token
   JwkSet jwks <- getsYesod $ view jsonWebKeySet
   jwtEncoding <- getsYesod $ view _appBearerEncoding
-  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+  throwLeft =<< liftIO (Jose.encode jwks jwtEncoding payload)
 
 
 data BearerTokenException

src/Web/ServerSession/Frontend/Yesod/Jwt.hs

@@ -160,7 +160,7 @@ encodeSession :: MonadIO m
               -> SessionToken sess
               -> m Jwt
 encodeSession ServerSessionJwtConfig{..} token = liftIO $
-    either throwM return =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload
+    throwLeft =<< Jose.encode (Jose.keys sJwtJwkSet) sJwtEncoding payload
   where payload = Jose.Claims . toStrict $ JSON.encode token
 
 

templates/i18n/changelog/xlsx.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Tabellen können nun auch als .xlsx exportiert werden

templates/i18n/changelog/xlsx.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Tables can now also be exported as .xlsx

test/MailSpec.hs

@@ -2,7 +2,7 @@ module MailSpec where
 
 import TestImport
 import Utils.DateTimeSpec ()
-import Model.Types.LanguagesSpec ()
+import Model.TypesSpec ()
 
 import Mail
 

test/Model/TypesSpec.hs

@@ -11,7 +11,6 @@ import Data.Aeson (Value)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 
-import MailSpec ()
 import Model.Types.LanguagesSpec ()
 
 import System.IO.Unsafe
@@ -278,11 +277,14 @@ instance Arbitrary Quoting where
   shrink = genericShrink
 
 instance Arbitrary CsvFormatOptions where
-  arbitrary = CsvFormatOptions
+  arbitrary = oneof
-    <$> suchThat arbitrary validDelimiter
+    [ CsvFormatOptions
-    <*> arbitrary
+        <$> suchThat arbitrary validDelimiter
-    <*> arbitrary
+        <*> arbitrary
-    <*> elements ["UTF8", "CP1252"]
+        <*> arbitrary
+        <*> elements ["UTF8", "CP1252"]
+    , pure CsvXlsxFormatOptions
+    ]
     where
       validDelimiter c = and
         [ Char.isLatin1 c
@@ -300,6 +302,13 @@ instance Arbitrary CsvOptions where
 instance Arbitrary CsvPreset where
   arbitrary = genericArbitrary
   shrink = genericShrink
+instance CoArbitrary CsvPreset
+instance Function CsvPreset
+
+instance Arbitrary CsvFormat where
+  arbitrary = genericArbitrary
+instance CoArbitrary CsvFormat
+instance Function CsvFormat
 
 instance Arbitrary Sex where
   arbitrary = genericArbitrary
@@ -415,6 +424,8 @@ spec = do
       [ eqLaws, ordLaws, jsonLaws, showReadLaws, finiteLaws, pathPieceLaws ]
     lawsCheckHspec (Proxy @CsvOptions)
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @CsvFormatOptions)
+      [ eqLaws, ordLaws, showReadLaws, jsonLaws ]
     lawsCheckHspec (Proxy @CsvPreset)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
     lawsCheckHspec (Proxy @Word24)
@@ -465,6 +476,10 @@ spec = do
   describe "CsvOptions" $
     it "json-decodes from empty object" . example $
       Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions)
+  describe "csvPreset" $
+    it "is a prism" . property $ isPrism csvPreset
+  describe "_CsvFormatPreset" $
+    it "is a prism" . property $ isPrism _CsvFormatPreset
   describe "Word24" $ do
     it "encodes to the expected length" . property $
       \w -> olength (Binary.encode (w :: Word24)) == 3