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

2019-09-30 15:53:29 +02:00 · 2019-09-30 15:53:29 +02:00 · 95ceeddc83
commit 95ceeddc83
parent 64f771518e
22 changed files with 367 additions and 52 deletions
--- 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
+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
--- 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
--- a/1
+++ b/1
@ -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
--- 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
--- 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 ]
+      }
--- 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
--- 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
--- 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'
--- 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

--- 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))
--- 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
--- 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 --
--- 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
--- 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)
--- a/templates/i18n/table/csv-import-explanation/de.hamlet
+++ b/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;
-        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.<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.
-        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.<br />
+        Es muss nicht in jeder Spalte der Zeile ein Wert vorhanden sein, #
+        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
-        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.
    <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.
--- a/templates/table/csv-transcode.hamlet
+++ b/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'}

--- 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
--- 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
--- a/test/Model/MigrationSpec.hs
+++ 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
--- 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
--- 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
--- 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