feat(csv): allow customisation of csv-export-options

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
+CsvColumnsExplanationsLabel: Spalten- & Zellenformat
-CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten
+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
+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

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

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

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

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 ]
+      }

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

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) ()
+           -> ConduitT () csv Handler ()
-           -> HandlerFor site TypedContent
+           -> 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) ()
+                         => ConduitT () csv Handler ()
-                         -> HandlerFor site TypedContent
+                         -> Handler TypedContent
 respondDefaultOrderedCsv = respondCsv $ headerOrder (error "headerOrder" :: csv)
 
 respondCsvDB :: ( ToNamedRecord csv
-                , YesodPersistRunner site
+                , YesodPersistRunner UniWorX
                 )
              => Header
-             -> ConduitT () csv (YesodDB site) ()
+             -> ConduitT () csv DB ()
-             -> HandlerFor site TypedContent
+             -> 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) ()
+                           => ConduitT () csv DB ()
-                           -> HandlerFor site TypedContent
+                           -> Handler TypedContent
 respondDefaultOrderedCsvDB = respondCsvDB $ headerOrder (error "headerOrder" :: csv)
 
 fileSourceCsv :: ( FromNamedRecord csv

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
+  (actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction
-
-  let
-    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) 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'

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
 

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))

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

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 --

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
+optionsF = optionsPathPiece . map (id &&& id) . otoList
-  mr <- getMessageRender
-  let
-    mkOption a = Option
-      { optionDisplay       = mr a
-      , optionInternalValue = a
-      , optionExternalValue = toPathPiece a
-      }
-  return . mkOptionList $ mkOption <$> opts
-
 
 optionsFinite :: ( MonadHandler m
                  , Finite a

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)

templates/i18n/table/csv-import-explanation/de.hamlet

@@ -1,12 +1,23 @@
+$newline never
 <h3>Hinweise zum Import von CSV-Dateien
 <dl .deflist>
+    <dt .deflist__dt>Datenformat
+    <dd .deflist__dd>
+      Beim Import wird, pro Spalte, das selbe Datenformat erwartet, wie es beim #
+      Export produziert wird (siehe <i>Spalten- & Zellenformat</i> #
+      unter <i>CSV-Export</i>).<br />
+      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).<br />
+      Spalten werden an ihrer Überschrift identifiziert. #
+      Die Überschrift darf daher nicht verändert oder entfernt werden.
     <dt .deflist__dt>Änderungen
     <dd .deflist__dd>
-      Einige Zellen können durch den Import verändert werden.
+      Einige Zellen können durch den Import verändert werden.<br />
       Nicht-änderbare Zellen werden ignoriert, falls diese verändert wurden.
     <dt .deflist__dt>Vorschau
     <dd .deflist__dd>
-      Es wird eine Vorschau angezeigt, bevor irgendetwas tatsächlich geändert wird.
+      Es wird eine Vorschau angezeigt, bevor irgendetwas tatsächlich geändert wird.<br />
       In der Vorschau können dann auch nur teilweise Änderungen ausgewählt werden.
     <dt .deflist__dt>Leere Zellen
     <dd .deflist__dd>
@@ -16,22 +27,22 @@
       <p>
         Es werden nur konsistente Änderungen akzeptiert!
       <p>
-        Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen;
+        Daraus folgt, dass es sinnvoll sein kann, gewisse Zellen frei zu lassen; #
-        z.B. ändert man ein Studienfachzuordnung eines Teilnehmers ab,
+        ändert man z.B. die Studienfachzuordnung eines Teilnehmers ab, #
-        dann müsste man auch Abschluss und Semesterzahl passend ändern.
+        so müsste man auch Abschluss und Fachsemester passend ändern.<br />
         Da diese jedoch eindeutig sind, kann man diese Zellen einfach frei lassen.
     <dt .deflist__dt>Zeilen Identifikation
     <dd .deflist__dd>
-        Mehrere Spalten werden zur Identifikation der Zeile verwendet.
+        Mehrere Spalten werden zur Identifikation der Zeile verwendet.<br />
-        Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein,
+        Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein, #
-        so lange die Identifikation noch eindeutig ist.
+        so lange die Identifikation noch eindeutig ist.<br />
         Sind mehrere Werte vorhanden, so müssen diese natürlich zueinander passen.
     <dt .deflist__dt>Zeilen hinzufügen
     <dd .deflist__dd>
-        Es können auch neue Zeilen hinzugefügt werden, so fern ausreichend
+        Es können auch neue Zeilen hinzugefügt werden, sofern ausreichend #
-        eindeutige Informationen vorhanden sind;
+        eindeutige Informationen vorhanden sind; #
         z.B. können so Prüfungsteilnehmer nachgemeldet werden.
     <dt .deflist__dt>Zeilen löschen
     <dd .deflist__dd>
-        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.

templates/table/csv-transcode.hamlet

@@ -14,5 +14,7 @@ $if is _Just dbtCsvEncode
     <div .csv-export__content>
       <p>
         ^{csvColExplanations'}
+      <p>
+        ^{modal (i18n MsgCsvChangeOptionsLabel) (Left (SomeRoute CsvOptionsR))}
       ^{csvExportWdgt'}
 

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

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

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

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

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"))
+      local <- suchThat (CBS.pack . getPrintableString <$> arbitrary) (\l -> isEmail l (CBS.pack "example.com"))
-      domain <- suchThat arbitrary (\d -> isEmail (CBS.pack "example") d)
+      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

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