From 95ceeddc83ff79dad6f2dc494015e85f2996c40d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Sep 2019 15:53:29 +0200 Subject: [PATCH] feat(csv): allow customisation of csv-export-options --- messages/uniworx/de.msg | 30 ++++++- models/users | 1 + routes | 1 + src/Foundation.hs | 3 + src/Handler/Profile.hs | 31 ++++++- src/Handler/Users/Add.hs | 1 + src/Handler/Utils/Csv.hs | 33 +++---- src/Handler/Utils/Form.hs | 88 +++++++++++++++++-- src/Handler/Utils/Table/Pagination.hs | 1 + src/Handler/Utils/Widgets.hs | 6 ++ src/Model/Types/Misc.hs | 80 +++++++++++++++++ src/Utils.hs | 3 +- src/Utils/Form.hs | 29 +++--- src/Yesod/Core/Types/Instances.hs | 9 +- .../table/csv-import-explanation/de.hamlet | 33 ++++--- templates/table/csv-transcode.hamlet | 2 + test/Database.hs | 6 ++ test/FoundationSpec.hs | 5 +- test/Model/MigrationSpec.hs | 12 +++ test/Model/TypesSpec.hs | 34 +++++++ test/ModelSpec.hs | 10 ++- test/TestImport.hs | 1 + 22 files changed, 367 insertions(+), 52 deletions(-) create mode 100644 test/Model/MigrationSpec.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f6bb5cfa4..02c290484 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1499,8 +1499,8 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen -CsvColumnsExplanationsLabel: Spalten -CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten +CsvColumnsExplanationsLabel: Spalten- & Zellenformat +CsvColumnsExplanationsTip: Bedeutung und Format der in der CSV-Datei enthaltenen Spalten CsvColumnExamUserSurname: Nachname(n) des Teilnehmers CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n)) @@ -1797,4 +1797,28 @@ AcceptApplicationsInvite: Einladungen verschicken AcceptApplicationsSecondary: Gleichstände auflösen AcceptApplicationsSecondaryTip: Wenn es im Laufe des Verfahrens mehrere Bewerber mit der selben Bewertung für den selben Platz gibt, wie soll der Gleichstand aufgelöst werden? AcceptApplicationsSecondaryRandom: Zufällig -AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung \ No newline at end of file +AcceptApplicationsSecondaryTime: Nach Zeitpunkt der Bewerbung + +CsvOptions: CSV-Optionen +CsvOptionsTip: Diese Einstellungen betreffen nur den CSV-Export; beim Import werden die verwendeten Einstellungen automatisch ermittelt. +CsvPresetRFC: Standard-Konform (RFC 4180) +CsvPresetExcel: Excel-Kompatibel +CsvCustom: Benutzerdefiniert +CsvDelimiter: Trennzeichen +CsvUseCrLf: Zeilenumbrüche +CsvQuoting: Quoting +CsvQuotingTip: Wann sollen Anführungszeichen (") um Felder platziert werden, um Interpretation von im Feld enthaltenen Zeichen als Trennzeichen zu verhindern? +CsvDelimiterNull: Null-Byte +CsvDelimiterTab: Tabulator +CsvDelimiterComma: Komma +CsvDelimiterColon: Doppelpunkt +CsvDelimiterBar: Senkrechter Strich +CsvDelimiterSpace: Leerzeichen +CsvDelimiterUnitSep: Teilgruppentrennzeichen +CsvCrLf: DOS (CRLF) +CsvLf: Unix (LF) +CsvQuoteNone: Nie +CsvQuoteMinimal: Nur wenn nötig +CsvQuoteAll: Immer +CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst +CsvChangeOptionsLabel: Export-Optionen \ No newline at end of file diff --git a/models/users b/models/users index 22c14f1dc..14c0ddc2e 100644 --- a/models/users +++ b/models/users @@ -30,6 +30,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos + csvOptions CsvOptions "default='{}'::jsonb" UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory diff --git a/routes b/routes index 79b77524e..f056b1f98 100644 --- a/routes +++ b/routes @@ -72,6 +72,7 @@ /user/profile ProfileDataR GET !free /user/authpreds AuthPredsR GET POST !free /user/set-display-email SetDisplayEmailR GET POST !free +/user/csv-options CsvOptionsR GET POST !free /exam-office ExamOfficeR !exam-office: / EOExamsR GET diff --git a/src/Foundation.hs b/src/Foundation.hs index ffe1d32b1..e3de692ef 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -315,6 +315,8 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''SchoolFunction id +embedRenderMessage ''UniWorX ''CsvPreset id +embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''AuthenticationMode id @@ -3287,6 +3289,7 @@ upsertCampusUser ldapData Creds{..} = do , userWarningDays = userDefaultWarningDays , userNotificationSettings = def , userMailLanguages = def + , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Just now diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 13a0e9c81..57a49c428 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,4 +1,11 @@ -module Handler.Profile where +module Handler.Profile + ( getProfileR, postProfileR + , getProfileDataR, makeProfileData + , getAuthPredsR, postAuthPredsR + , getUserNotificationR, postUserNotificationR + , getSetDisplayEmailR, postSetDisplayEmailR + , getCsvOptionsR, postCsvOptionsR + ) where import Import @@ -796,3 +803,25 @@ postSetDisplayEmailR = do siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do setTitleI MsgTitleChangeUserDisplayEmail $(i18nWidgetFile "set-display-email") + +getCsvOptionsR, postCsvOptionsR :: Handler Html +getCsvOptionsR = postCsvOptionsR +postCsvOptionsR = do + Entity uid User{userCsvOptions} <- requireAuth + + ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $ + csvOptionsForm (fslI MsgCsvOptions & setTooltip MsgCsvOptionsTip) (Just userCsvOptions) + + formResultModal optionsRes CsvOptionsR $ \opts -> do + lift . runDB $ update uid [ UserCsvOptions =. opts ] + tell . pure =<< messageI Success MsgCsvOptionsUpdated + + siteLayoutMsg MsgCsvOptions $ do + setTitleI MsgCsvOptions + + isModal <- hasCustomHeader HeaderIsModal + wrapForm optionsWgt' def + { formAction = Just $ SomeRoute CsvOptionsR + , formEncoding = optionsEnctype + , formAttrs = [ asyncSubmitAttr | isModal ] + } diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index b8e6efd35..897fbd1ca 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -73,6 +73,7 @@ postAdminUserAddR = do , userWarningDays = userDefaultWarningDays , userNotificationSettings = def , userMailLanguages = def + , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index ff84ddfb9..926879254 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -98,19 +98,23 @@ decodeCsv = transPipe throwExceptT $ do encodeCsv :: ( ToNamedRecord csv - , Monad m + , MonadHandler m + , HandlerSite m ~ UniWorX ) => Header -> ConduitT csv ByteString m () -- ^ Encode a stream of records -- -- Currently not streaming -encodeCsv hdr = fmap (encodeByName hdr) (C.foldMap pure) >>= C.sourceLazy +encodeCsv hdr = do + csvOpts <- fmap (maybe def (userCsvOptions . entityVal)) . lift $ liftHandler maybeAuth + fmap (encodeByNameWith (csvOpts ^. _CsvEncodeOptions) hdr) (C.foldMap pure) >>= C.sourceLazy encodeDefaultOrderedCsv :: forall csv m. ( ToNamedRecord csv , DefaultOrdered csv - , Monad m + , MonadHandler m + , HandlerSite m ~ UniWorX ) => ConduitT csv ByteString m () encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) @@ -118,33 +122,32 @@ encodeDefaultOrderedCsv = encodeCsv $ headerOrder (error "headerOrder" :: csv) respondCsv :: ToNamedRecord csv => Header - -> ConduitT () csv (HandlerFor site) () - -> HandlerFor site TypedContent + -> ConduitT () csv Handler () + -> Handler TypedContent respondCsv hdr src = respondSource typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk -respondDefaultOrderedCsv :: forall csv site. +respondDefaultOrderedCsv :: forall csv. ( ToNamedRecord csv , DefaultOrdered csv ) - => ConduitT () csv (HandlerFor site) () - -> HandlerFor site TypedContent + => ConduitT () csv Handler () + -> Handler TypedContent respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv) respondCsvDB :: ( ToNamedRecord csv - , YesodPersistRunner site + , YesodPersistRunner UniWorX ) => Header - -> ConduitT () csv (YesodDB site) () - -> HandlerFor site TypedContent + -> ConduitT () csv DB () + -> Handler TypedContent respondCsvDB hdr src = respondSourceDB typeCsv' $ src .| encodeCsv hdr .| awaitForever sendChunk -respondDefaultOrderedCsvDB :: forall csv site. +respondDefaultOrderedCsvDB :: forall csv. ( ToNamedRecord csv , DefaultOrdered csv - , YesodPersistRunner site ) - => ConduitT () csv (YesodDB site) () - -> HandlerFor site TypedContent + => ConduitT () csv DB () + -> Handler TypedContent respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv) fileSourceCsv :: ( FromNamedRecord csv diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2f8af499c..f0573a00f 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -12,6 +12,7 @@ import Handler.Utils.Form.Types import Handler.Utils.DateTime import Import +import Data.Char (chr, ord) import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -220,11 +221,7 @@ multiAction :: forall action a. -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction acts fs@FieldSettings{..} defAction csrf = do - mr <- getMessageRender - - let - options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) fs defAction + (actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts let actionResults = view _1 <$> results @@ -1199,3 +1196,84 @@ examPassedField :: forall m. ) => Field m ExamPassed examPassedField = hoistField liftHandler $ selectField optionsFinite + + +data CsvOptions' = CsvOptionsPreset' CsvPreset + | CsvOptionsCustom' + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveFinite ''CsvOptions' +instance PathPiece CsvOptions' where + toPathPiece = \case + CsvOptionsPreset' p -> toPathPiece p + CsvOptionsCustom' -> "custom" + fromPathPiece t = fromPathPiece t + <|> guardOn (t == "custom") CsvOptionsCustom' +instance RenderMessage UniWorX CsvOptions' where + renderMessage m ls = \case + CsvOptionsPreset' p -> mr p + CsvOptionsCustom' -> mr MsgCsvCustom + where + mr :: forall msg. RenderMessage UniWorX msg => msg -> Text + mr = renderMessage m ls + +csvOptionsForm :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => FieldSettings UniWorX + -> Maybe CsvOptions + -> AForm m CsvOptions +csvOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ classifyCsvOptions <$> mPrev + where + csvActs :: Map CsvOptions' (AForm Handler CsvOptions) + csvActs = mapF $ \case + CsvOptionsPreset' preset + -> pure $ csvPreset # preset + CsvOptionsCustom' + -> CsvOptions + <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev) + <*> areq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev) + <*> areq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev) + + delimiterOpts :: Handler (OptionList Char) + delimiterOpts = do + MsgRenderer mr <- getMsgRenderer + let + opts = + [ (MsgCsvDelimiterNull, '\0') + , (MsgCsvDelimiterTab, '\t') + , (MsgCsvDelimiterComma, ',') + , (MsgCsvDelimiterColon, chr 58) + , (MsgCsvDelimiterBar, '|') + , (MsgCsvDelimiterSpace, ' ') + , (MsgCsvDelimiterUnitSep, chr 31) + ] + olReadExternal t = do + i <- readMay t + guard $ i >= 0 && i <= 255 + let c = chr i + guard $ any ((== c) . view _2) opts + return c + olOptions = [ Option (mr msg) c (tshow $ ord c) + | (msg, c) <- opts + ] + return OptionList{..} + + lineEndOpts :: Handler (OptionList Bool) + lineEndOpts = optionsPathPiece + [ (MsgCsvCrLf, True ) + , (MsgCsvLf, False) + ] + + quoteOpts :: Handler (OptionList Quoting) + quoteOpts = optionsF + [ QuoteMinimal + , QuoteAll + ] + + classifyCsvOptions :: CsvOptions -> CsvOptions' + classifyCsvOptions opts + | Just preset <- opts ^? csvPreset + = CsvOptionsPreset' preset + | otherwise + = CsvOptionsCustom' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a17fe31d1..a268d550a 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -49,6 +49,7 @@ import Handler.Utils.Form import Handler.Utils.Csv import Handler.Utils.ContentDisposition import Handler.Utils.I18n +import Handler.Utils.Widgets import Utils import Utils.Lens diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 01a2c6f01..994fe893d 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -96,3 +96,9 @@ editedByW fmt tm usr = do heat :: Integral a => a -> a -> Double heat (toInteger -> full) (toInteger -> achieved) = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2) + +i18n :: forall m msg. + ( MonadWidget m + , RenderMessage (HandlerSite m) msg + ) => msg -> m () +i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m)) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index f21c55ecb..7d20c7bca 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + {-| Module: Model.Types.Misc Description: Additional uncategorized types @@ -5,6 +7,7 @@ Description: Additional uncategorized types module Model.Types.Misc ( module Model.Types.Misc + , Quoting(..) ) where import Import.NoModel @@ -14,6 +17,11 @@ import Data.Maybe (fromJust) import qualified Data.Text as Text import qualified Data.Text.Lens as Text +import Data.Csv (Quoting(..)) +import qualified Data.Csv as Csv + +import qualified Data.Aeson as JSON + data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) @@ -43,3 +51,75 @@ nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user 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 + { csvDelimiter :: Char + , csvUseCrLf :: Bool + , csvQuoting :: Csv.Quoting + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default CsvOptions 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' CsvOptions CsvPreset +csvPreset = prism' fromPreset toPreset + where + fromPreset :: CsvPreset -> CsvOptions + fromPreset CsvPresetRFC = CsvOptions { csvDelimiter = ',', csvUseCrLf = True, csvQuoting = QuoteMinimal } + fromPreset CsvPresetExcel = CsvOptions { csvDelimiter = ';', csvUseCrLf = True, csvQuoting = QuoteAll } + + toPreset :: CsvOptions -> Maybe CsvPreset + toPreset opts = case filter (\p -> fromPreset p == opts) universeF of + [p] -> Just p + _other -> Nothing + +_CsvEncodeOptions :: Iso' CsvOptions Csv.EncodeOptions +_CsvEncodeOptions = iso toEncode fromEncode + where + toEncode CsvOptions{..} = Csv.defaultEncodeOptions + { Csv.encDelimiter = fromIntegral $ fromEnum csvDelimiter + , Csv.encUseCrLf = csvUseCrLf + , Csv.encQuoting = csvQuoting + , Csv.encIncludeHeader = True + } + fromEncode encOpts = CsvOptions + { csvDelimiter = toEnum . fromIntegral $ Csv.encDelimiter encOpts + , csvUseCrLf = Csv.encUseCrLf encOpts + , csvQuoting = Csv.encQuoting encOpts + } + +instance ToJSON CsvOptions where + toJSON CsvOptions{..} = JSON.object + [ "delimiter" JSON..= fromEnum csvDelimiter + , "use-cr-lf" JSON..= csvUseCrLf + , "quoting" JSON..= csvQuoting + ] +instance FromJSON CsvOptions where + parseJSON = JSON.withObject "CsvOptions" $ \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 + return CsvOptions{..} +derivePersistFieldJSON ''CsvOptions + +nullaryPathPiece ''CsvPreset $ camelToPathPiece' 2 diff --git a/src/Utils.hs b/src/Utils.hs index 28c88912d..82c19d0b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -412,7 +412,8 @@ mapSymmDiff a b = Map.fromListWith Set.union . map (over _2 Set.singleton) . Set assocsSet :: Ord (k, v) => Map k v -> Set (k, v) assocsSet = setOf folded . imap (,) - +mapF :: (Ord k, Finite k) => (k -> v) -> Map k v +mapF = flip Map.fromSet $ Set.fromList universeF --------------- -- Functions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 31bc5ad08..80a4443db 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -491,6 +491,24 @@ reorderField optList = Field{..} withNum t n = tshow n <> "." <> t $(widgetFile "widgets/permutation/permutation") +optionsPathPiece :: ( MonadHandler m + , HandlerSite m ~ site + , MonoFoldable mono + , Element mono ~ (msg, val) + , RenderMessage site msg + , PathPiece val + ) + => mono -> m (OptionList val) +optionsPathPiece (otoList -> opts) = do + mr <- getMessageRender + let + mkOption (m, a) = Option + { optionDisplay = mr m + , optionInternalValue = a + , optionExternalValue = toPathPiece a + } + return . mkOptionList $ mkOption <$> opts + optionsF :: ( MonadHandler m , RenderMessage site (Element mono) , HandlerSite m ~ site @@ -498,16 +516,7 @@ optionsF :: ( MonadHandler m , MonoFoldable mono ) => mono -> m (OptionList (Element mono)) -optionsF (otoList -> opts) = do - mr <- getMessageRender - let - mkOption a = Option - { optionDisplay = mr a - , optionInternalValue = a - , optionExternalValue = toPathPiece a - } - return . mkOptionList $ mkOption <$> opts - +optionsF = optionsPathPiece . map (id &&& id) . otoList optionsFinite :: ( MonadHandler m , Finite a diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 8af451314..faac3b4a3 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -27,6 +27,7 @@ import Control.Monad.Base (MonadBase) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) import Control.Monad.Random.Class (MonadRandom) +import Control.Monad.Morph (MFunctor, MMonad) deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) @@ -52,6 +53,7 @@ newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT' :: ReaderT Loc m a } , MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO , MonadResource, MonadHandler, MonadWidget ) + deriving newtype ( MFunctor, MMonad, MonadTrans ) deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m) deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m) @@ -60,7 +62,8 @@ instance MonadReader r m => MonadReader r (CachedMemoT k v m) where reader = CachedMemoT . lift . reader local f (CachedMemoT act) = CachedMemoT $ mapReaderT (local f) act -deriving via (ReaderT Loc) instance MonadTrans (CachedMemoT k v) +instance MonadUnliftIO m => MonadUnliftIO (CachedMemoT k v m) where + askUnliftIO = (\UnliftIO{..} -> UnliftIO $ \(CachedMemoT f) -> unliftIO f) <$> CachedMemoT askUnliftIO -- | Uses `cachedBy` with a `Binary`-encoded @k@ @@ -73,3 +76,7 @@ runCachedMemoT :: Q Exp runCachedMemoT = do loc <- location [e| flip runReaderT loc . runCachedMemoT' |] + + +instance site ~ site' => ToWidget site (SomeMessage site') where + toWidget msg = toWidget =<< (getMessageRender <*> pure msg) diff --git a/templates/i18n/table/csv-import-explanation/de.hamlet b/templates/i18n/table/csv-import-explanation/de.hamlet index ba415fd30..33d4609ef 100644 --- a/templates/i18n/table/csv-import-explanation/de.hamlet +++ b/templates/i18n/table/csv-import-explanation/de.hamlet @@ -1,12 +1,23 @@ +$newline never

Hinweise zum Import von CSV-Dateien
+
Datenformat +
+ Beim Import wird, pro Spalte, das selbe Datenformat erwartet, wie es beim # + Export produziert wird (siehe Spalten- & Zellenformat # + unter CSV-Export).
+ Spalten können beliebig permutiert werden und dürfen auch fehlen (in # + diesem Fall wird die fehlende Spalte so behandelt als enthielte sie in # + jeder Zeile eine leere Zelle).
+ Spalten werden an ihrer Überschrift identifiziert. # + Die Überschrift darf daher nicht verändert oder entfernt werden.
Änderungen
- Einige Zellen können durch den Import verändert werden. + Einige Zellen können durch den Import verändert werden.
Nicht-änderbare Zellen werden ignoriert, falls diese verändert wurden.
Vorschau
- Es wird eine Vorschau angezeigt, bevor irgendetwas tatsächlich geändert wird. + Es wird eine Vorschau angezeigt, bevor irgendetwas tatsächlich geändert wird.
In der Vorschau können dann auch nur teilweise Änderungen ausgewählt werden.
Leere Zellen
@@ -16,22 +27,22 @@

Es werden nur konsistente Änderungen akzeptiert!

- Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen; - z.B. ändert man ein Studienfachzuordnung eines Teilnehmers ab, - dann müsste man auch Abschluss und Semesterzahl passend ändern. + Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen; # + ändert man z.B. die Studienfachzuordnung eines Teilnehmers ab, # + so müsste man auch Abschluss und Fachsemester passend ändern.
Da diese jedoch eindeutig sind, kann man diese Zellen einfach frei lassen.

Zeilen Identifikation
- Mehrere Spalten werden zur Identifikation der Zeile verwendet. - Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein, - so lange die Identifikation noch eindeutig ist. + Mehrere Spalten werden zur Identifikation der Zeile verwendet.
+ Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein, # + so lange die Identifikation noch eindeutig ist.
Sind mehrere Werte vorhanden, so müssen diese natürlich zueinander passen.
Zeilen hinzufügen
- Es können auch neue Zeilen hinzugefügt werden, so fern ausreichend - eindeutige Informationen vorhanden sind; + Es können auch neue Zeilen hinzugefügt werden, sofern ausreichend # + eindeutige Informationen vorhanden sind; # z.B. können so Prüfungsteilnehmer nachgemeldet werden.
Zeilen löschen
- Fehlende Zeilen werden in der Vorschau zur Löschung angeboten + Fehlende Zeilen werden in der Vorschau zur Löschung angeboten # und dann ggf. gelöscht. diff --git a/templates/table/csv-transcode.hamlet b/templates/table/csv-transcode.hamlet index 92e1ea95a..b2b7a2a7b 100644 --- a/templates/table/csv-transcode.hamlet +++ b/templates/table/csv-transcode.hamlet @@ -14,5 +14,7 @@ $if is _Just dbtCsvEncode

^{csvColExplanations'} +

+ ^{modal (i18n MsgCsvChangeOptionsLabel) (Left (SomeRoute CsvOptionsR))} ^{csvExportWdgt'} diff --git a/test/Database.hs b/test/Database.hs index 140f0e490..78416f2fe 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -111,6 +111,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = csvPreset # CsvPresetRFC } fhamann <- insert User { userIdent = "felix.hamann@campus.lmu.de" @@ -135,6 +136,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = csvPreset # CsvPresetExcel } jost <- insert User { userIdent = "jost@tcs.ifi.lmu.de" @@ -159,6 +161,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } maxMuster <- insert User { userIdent = "max@campus.lmu.de" @@ -183,6 +186,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } tinaTester <- insert $ User { userIdent = "tester@campus.lmu.de" @@ -207,6 +211,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } svaupel <- insert User { userIdent = "vaupel.sarah@campus.lmu.de" @@ -231,6 +236,7 @@ fillDb = do , userNotificationSettings = def , userCreated = now , userLastLdapSynchronisation = Nothing + , userCsvOptions = def } void . repsert (TermKey summer2017) $ Term { termName = summer2017 diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs index 2386c7ba6..953c65b17 100644 --- a/test/FoundationSpec.hs +++ b/test/FoundationSpec.hs @@ -18,10 +18,11 @@ instance Arbitrary (Route Auth) where instance Arbitrary (Route EmbeddedStatic) where arbitrary = do let printableText = pack . filter (/= '/') . getPrintableString <$> arbitrary + printableText' = printableText `suchThat` (not . null) pathLength <- getPositive <$> arbitrary - path <- replicateM pathLength printableText + path <- replicateM pathLength printableText' paramNum <- getNonNegative <$> arbitrary - params <- replicateM paramNum $ (,) <$> printableText <*> printableText + params <- replicateM paramNum $ (,) <$> printableText' <*> printableText return $ embeddedResourceR path params instance Arbitrary SchoolR where diff --git a/test/Model/MigrationSpec.hs b/test/Model/MigrationSpec.hs new file mode 100644 index 000000000..87d367d74 --- /dev/null +++ b/test/Model/MigrationSpec.hs @@ -0,0 +1,12 @@ +module Model.MigrationSpec where + +import TestImport + +import Model.Migration + + +spec :: Spec +spec = withApp $ -- `withApp` does migration, if needed + describe "Migration" $ + it "is idempotent" $ + (`shouldBe` False) <$> runDB requiresMigration -- Migration shouldn't be needed after `withApp` above diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index c27083034..2aac97b8d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -8,6 +8,7 @@ import Settings import Control.Lens (review, preview) import Data.Aeson (Value) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson import MailSpec () @@ -32,6 +33,8 @@ import Data.Scientific import Utils.Lens +import qualified Data.Char as Char + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -250,6 +253,28 @@ instance Arbitrary ExamPassed where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary Quoting where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary CsvOptions where + arbitrary = CsvOptions + <$> suchThat arbitrary validDelimiter + <*> arbitrary + <*> arbitrary + where + validDelimiter c = and + [ Char.isLatin1 c + , c /= '"' + , c /= '\r' + , c /= '\n' + ] + shrink = genericShrink + +instance Arbitrary CsvPreset where + arbitrary = genericArbitrary + shrink = genericShrink + spec :: Spec spec = do @@ -334,6 +359,12 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @ExamPassed) [ eqLaws, ordLaws, showReadLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws, csvFieldLaws ] + lawsCheckHspec (Proxy @Quoting) + [ eqLaws, ordLaws, jsonLaws, showReadLaws, finiteLaws, pathPieceLaws ] + lawsCheckHspec (Proxy @CsvOptions) + [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @CsvPreset) + [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ @@ -365,6 +396,9 @@ spec = do parse "1.8" `shouldSatisfy` is _Left parse "voided" `shouldBe` Right ExamVoided parse "no-show" `shouldBe` Right ExamNoShow + describe "CsvOptions" $ + it "json-decodes from empty object" . example $ + Aeson.parseMaybe Aeson.parseJSON (Aeson.object []) `shouldBe` Just (def :: CsvOptions) termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index a0139e9a8..a3d8de2c9 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -22,10 +22,13 @@ import Utils import System.FilePath import Data.Time +import Mail (MailLanguages(..)) + + instance Arbitrary EmailAddress where arbitrary = do - local <- suchThat arbitrary (\l -> isEmail l (CBS.pack "example.com")) - domain <- suchThat arbitrary (\d -> isEmail (CBS.pack "example") d) + local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com")) + domain <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\d -> isEmail (CBS.pack "example") d) let (Just result) = emailAddress (makeEmailLike local domain) pure result @@ -100,8 +103,9 @@ instance Arbitrary User where userDownloadFiles <- arbitrary userWarningDays <- arbitrary - userMailLanguages <- arbitrary + userMailLanguages <- fmap MailLanguages $ sublistOf =<< shuffle (toList appLanguages) userNotificationSettings <- arbitrary + userCsvOptions <- arbitrary userCreated <- arbitrary userLastLdapSynchronisation <- arbitrary diff --git a/test/TestImport.hs b/test/TestImport.hs index d14c8ae07..af8b15be8 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -140,6 +140,7 @@ createUser adjUser = do userNotificationSettings = def userCreated = now userLastLdapSynchronisation = Nothing + userCsvOptions = def runDB . insertEntity $ adjUser User{..} lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec