feat(csv-export): .xlsx
This commit is contained in:
Gregor Kleen
parent
78c54959b6
commit
5c513946c1
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -163,6 +163,7 @@ dependencies:
|
||||
- IntervalMap
|
||||
- haskell-src-meta
|
||||
- either
|
||||
- xlsx
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
- IncoherentInstances
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 _))
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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(..))
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
191
src/Model/Types/Csv.hs
Normal file
191
src/Model/Types/Csv.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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)
|
||||
|
||||
69
src/Utils/Csv/Mail.hs
Normal file
69
src/Utils/Csv/Mail.hs
Normal file
@ -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)
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
2
templates/i18n/changelog/xlsx.de-de-formal.hamlet
Normal file
2
templates/i18n/changelog/xlsx.de-de-formal.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Tabellen können nun auch als .xlsx exportiert werden
|
||||
2
templates/i18n/changelog/xlsx.en-eu.hamlet
Normal file
2
templates/i18n/changelog/xlsx.en-eu.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Tables can now also be exported as .xlsx
|
||||
@ -2,7 +2,7 @@ module MailSpec where
|
||||
|
||||
import TestImport
|
||||
import Utils.DateTimeSpec ()
|
||||
import Model.Types.LanguagesSpec ()
|
||||
import Model.TypesSpec ()
|
||||
|
||||
import Mail
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user