diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index cd3b87a3b..1ba093fcb 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/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) -CsvPresetExcel: Excel-Kompatibel +CsvPresetRFC: Standard-Konforme .csv Dateien (RFC 4180) +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 diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index beae162cc..4780888cd 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/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) -CsvPresetExcel: Excel compatible +CsvPresetRFC: Standards-compliant .csv files (RFC 4180) +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 diff --git a/package.yaml b/package.yaml index 4af686432..9419c5290 100644 --- a/package.yaml +++ b/package.yaml @@ -163,6 +163,7 @@ dependencies: - IntervalMap - haskell-src-meta - either + - xlsx other-extensions: - GeneralizedNewtypeDeriving - IncoherentInstances diff --git a/src/Application.hs b/src/Application.hs index caa3902bc..a14c41403 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 597163cd4..e4fee5cb2 100644 --- a/src/Auth/LDAP.hs +++ b/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} diff --git a/src/Data/Encoding/Instances.hs b/src/Data/Encoding/Instances.hs index d9bf3748d..0d332c1aa 100644 --- a/src/Data/Encoding/Instances.hs +++ b/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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 8ea01d228..6cbe5bcf0 100644 --- a/src/Foundation/Authorization.hs +++ b/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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index fa5a52c2b..dab0fc346 100644 --- a/src/Foundation/I18n.hs +++ b/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 diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 3ca061080..2de4ec9f2 100644 --- a/src/Handler/Admin/Test.hs +++ b/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 diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index b3db4fca5..2b3acfc92 100644 --- a/src/Handler/Allocation/Users.hs +++ b/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 diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index d942999e5..2007e8327 100644 --- a/src/Handler/Course/Application/List.hs +++ b/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) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index fb0e4c859..22ad69811 100644 --- a/src/Handler/Course/Users.hs +++ b/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) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index a870d9bbd..4abbac251 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 5e7a7cdc8..0c8391fc1 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/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 diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs index 1bd09384c..e04cf9496 100644 --- a/src/Handler/Participants.hs +++ b/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)) - setContentDisposition' $ Just csvName - respondDefaultOrderedCsvDB $ E.selectSource partQuery .| C.map toParticipantEntry + setContentDispositionCsv $ MsgParticipantsCsvName tid ssh + respondDefaultOrderedCsvDB (MsgParticipantsCsvSheetName tid ssh) $ 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 diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs index 6e97c10d8..67291d64c 100644 --- a/src/Handler/Sheet/PersonalisedFiles.hs +++ b/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 diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index cf090e171..ee1725c98 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -2,17 +2,20 @@ module Handler.Utils.Csv ( decodeCsv, decodeCsvPositional - , timestampCsv - , encodeCsv + , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith + , 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.Combinators as C (sourceLazy) +import qualified Data.Conduit.List as C (mapMaybe) +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 - - 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 + recodeCsv encOpts False 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 - -> ConduitT csv ByteString m () + => msg -- ^ Sheet name for .xlsx + -> Header + -> ConduitT csv ByteString m CsvFormat -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv hdr = do - csvOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth - let recode' - | enc == "UTF8" - = id - | otherwise - = encodeLazyByteString enc . decodeLazyByteString UTF8 - where enc = csvOpts ^. _csvFormat . _csvEncoding - C.foldMap pure >>= (C.sourceLazy . recode') . encodeByNameWith (csvOpts ^. _csvFormat . _CsvEncodeOptions) hdr +encodeCsv sheetName hdr = do + encOpts <- maybe def (userCsvOptions . entityVal) <$> lift maybeAuth + encodeCsvWith encOpts sheetName hdr + +encodeCsvWith :: ( ToNamedRecord csv + , MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX msg + ) + => 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 - if - | csvOpts ^. _csvTimestamp -> do - ts <- formatTime' (iso8601DateFormat $ Just "%H%M") =<< liftIO getCurrentTime - return $ (<>) (unpack ts <> "-") - | otherwise -> return id + csvOpts <- fmap (maybe def $ userCsvOptions . entityVal) maybeAuth + timestampCsv' csvOpts . review _Wrapped =<< languages + -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 - ts <- timestampCsv - partIsAttachment . ts $ fName `addExtension` unpack extensionCsv +partIsAttachmentCsv fName' = do + csvOpts <- lift askMailCsvOptions + 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 () -encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) + => msg -- ^ Sheet name for .xlsx + -> ConduitT csv ByteString m CsvFormat +encodeDefaultOrderedCsv sheetName = encodeCsv sheetName $ headerOrder (error "headerOrder" :: csv) -respondCsv :: ToNamedRecord csv - => Header +respondCsv :: ( ToNamedRecord csv + , 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 - => Header +respondCsvDB :: ( ToNamedRecord csv + , 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) diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 329ebf88e..f1d2984bb 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 57b69c503..818824c03 100644 --- a/src/Handler/Utils/Form.hs +++ b/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) - <*> areq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev) - <*> areq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev) - <*> areq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (csvEncoding <$> mPrev) + <$> apreq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (preview _csvDelimiter =<< mPrev) + <*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev) + <*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev) + <*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev) + FormatXlsx -> pure CsvXlsxFormatOptions delimiterOpts :: Handler (OptionList Char) delimiterOpts = do diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 18785044c..b4e32ed32 100644 --- a/src/Handler/Utils/Mail.hs +++ b/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) diff --git a/src/Handler/Utils/Minio.hs b/src/Handler/Utils/Minio.hs index 5d85ff633..92fdb0089 100644 --- a/src/Handler/Utils/Minio.hs +++ b/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 _)) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 6c345303d..5754ee7b9 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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. - ( HasContentType rep - , DBTableKey k' - ) => DBTExtraRep - { dbtERepDoEncode :: ConduitT (k', r') Void DB rep - } +data DBTExtraRep r' k' + = forall rep. + ( HasContentType rep + , DBTableKey k' + ) => 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) -simpleCsvEncode fName f = Just DBTCsvEncode + => filename -> sheetName -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv) +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) -simpleCsvEncodeM fName f = Just DBTCsvEncode + => filename -> sheetName -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv) +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'. - Typeable exportData - => exportData +withCsvExtraRep :: forall exportData csv sheetName r' k'. + ( Typeable 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 - where csvExtraRep = do - DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode - Refl <- eqT @exportData @exportData' - return DBTExtraRep - { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) - } +withCsvExtraRep sheetName exportData mEncode = maybe id (flip snoc) (csvExtraRep FormatCsv) <> maybe id (flip snoc) (csvExtraRep FormatXlsx) + where + csvExtraRep fmt = do + DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode + Refl <- eqT @exportData @exportData' + 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 - setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName' - sendResponse <=< liftHandler . respondCsvDB hdr $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave + setContentDispositionCsv dbtCsvName + sendResponse <=< liftHandler . respondCsvDB dbtCsvSheetName 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 - where csvRep = do + let extraReps = maybe id ($) addCSVReps dbtExtraReps + where addCSVReps = do DBTCsvEncode{..} <- dbtCsvEncode noExportData' <- cloneIso <$> dbtCsvNoExportData let exportData = noExportData' # () - return DBTExtraRep - { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) - } - extraReps' = (typeHtml, Nothing) : map ((,) <$> (\DBTExtraRep{..} -> getContentType dbtERepDoEncode) <*> Just) extraReps + return $ withCsvExtraRep dbtCsvSheetName exportData dbtCsvEncode + extraRepContentType = \case + DBTExtraRep{..} -> getContentType dbtERepDoEncode + 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 diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 3638a98dc..cf3e15faa 100644 --- a/src/Handler/Utils/Zip.hs +++ b/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 diff --git a/src/Import.hs b/src/Import.hs index 3cfcb3057..ac410e50d 100644 --- a/src/Import.hs +++ b/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(..)) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index cff458364..712fd4beb 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/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 - toMailPart (toDefaultOrderedCsvRendered jAllRecipientAddresses, userCsvOptions sender) + partIsAttachmentCsv MsgCommAllRecipients + toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses) diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 7ebb4bf4c..23402d381 100644 --- a/src/Jobs/Types.hs +++ b/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 diff --git a/src/Mail.hs b/src/Mail.hs index 01b062cee..827467b8e 100644 --- a/src/Mail.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index e36765375..9ee14e263 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Model/Types/Csv.hs b/src/Model/Types/Csv.hs new file mode 100644 index 000000000..88f183de9 --- /dev/null +++ b/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 diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 108a89a4a..d2a0faf12 100644 --- a/src/Model/Types/Misc.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index b76a9b669..c980269dd 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index c2fc930fa..27103fbc2 100644 --- a/src/Utils/Csv.hs +++ b/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) diff --git a/src/Utils/Csv/Mail.hs b/src/Utils/Csv/Mail.hs new file mode 100644 index 000000000..d79c77331 --- /dev/null +++ b/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) diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index a3ac39ab7..97d26cbac 100644 --- a/src/Utils/Metrics.hs +++ b/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 diff --git a/src/Utils/Tokens.hs b/src/Utils/Tokens.hs index 51d56e2f5..d26f22ec0 100644 --- a/src/Utils/Tokens.hs +++ b/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 diff --git a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs b/src/Web/ServerSession/Frontend/Yesod/Jwt.hs index b25814e90..0dc2f1109 100644 --- a/src/Web/ServerSession/Frontend/Yesod/Jwt.hs +++ b/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 diff --git a/templates/i18n/changelog/xlsx.de-de-formal.hamlet b/templates/i18n/changelog/xlsx.de-de-formal.hamlet new file mode 100644 index 000000000..48172e006 --- /dev/null +++ b/templates/i18n/changelog/xlsx.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Tabellen können nun auch als .xlsx exportiert werden diff --git a/templates/i18n/changelog/xlsx.en-eu.hamlet b/templates/i18n/changelog/xlsx.en-eu.hamlet new file mode 100644 index 000000000..2d604387b --- /dev/null +++ b/templates/i18n/changelog/xlsx.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Tables can now also be exported as .xlsx diff --git a/test/MailSpec.hs b/test/MailSpec.hs index b82f4b60a..cab9e578e 100644 --- a/test/MailSpec.hs +++ b/test/MailSpec.hs @@ -2,7 +2,7 @@ module MailSpec where import TestImport import Utils.DateTimeSpec () -import Model.Types.LanguagesSpec () +import Model.TypesSpec () import Mail diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index f96a9bd00..95a9caa14 100644 --- a/test/Model/TypesSpec.hs +++ b/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 - <$> suchThat arbitrary validDelimiter - <*> arbitrary - <*> arbitrary - <*> elements ["UTF8", "CP1252"] + arbitrary = oneof + [ CsvFormatOptions + <$> suchThat arbitrary validDelimiter + <*> arbitrary + <*> 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