feat(csv): introduce csv export

messages/uniworx/de.msg

@@ -1171,3 +1171,10 @@ VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
 
 ExamUsersHeading: Klausurteilnehmer
+
+CsvFile: CSV-Datei
+CsvModifyExisting: Existierende Einträge angleichen
+CsvAddNew: Neue Einträge einfügen
+CsvDeleteMissing: Fehlende Einträge entfernen
+BtnCsvExport: CSV-Datei exportieren
+BtnCsvImport: CSV-Datei importieren

package.yaml

@@ -32,6 +32,7 @@ dependencies:
   - data-default
   - aeson >=0.6 && <1.3
   - conduit >=1.0 && <2.0
+  - conduit-combinators
   - monad-logger >=0.3 && <0.4
   - fast-logger >=2.2 && <2.5
   - wai-logger >=2.2 && <2.4
@@ -129,6 +130,9 @@ dependencies:
   - hourglass
   - unix
   - stm-delay
+  - cassava
+  - cassava-conduit
+  - constraints
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Handler/Admin.hs

@@ -388,6 +388,8 @@ postAdminFeaturesR = do
                               }
           psValidator   = def  -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
                         & defaultSorting [SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 
     mkStudytermsTable :: Set (Key StudyTerms) -> Set (Key StudyTerms) -> DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget)
@@ -421,6 +423,8 @@ postAdminFeaturesR = do
           psValidator   = def
                         -- & defaultSorting [SortAscBy "name", SortAscBy "short", SortAscBy "key"]
                         & defaultSorting [SortDescBy "isnew", SortDescBy "isbad", SortAscBy "key"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 
     mkCandidateTable =
@@ -454,5 +458,7 @@ postAdminFeaturesR = do
             ]
           dbtParams     = def
           psValidator   = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"]
+          dbtCsvEncode  = noCsvEncode
+          dbtCsvDecode  = Nothing
       in dbTable psValidator DBTable{..}
 

src/Handler/Corrections.hs

@@ -380,6 +380,8 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
     , dbtStyle     = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI }
     , dbtParams
     , dbtIdent     = "corrections" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
 data ActionCorrections = CorrDownload

src/Handler/Course.hs

@@ -205,6 +205,8 @@ makeCourseTable whereClause colChoices psValidator = do
     , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
     , dbtParams = def
     , dbtIdent = "courses" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
 getCourseListR :: Handler Html
@@ -402,6 +404,8 @@ getCShowR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "tutorials"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     tutorialDBTableValidator = def
       & defaultSorting [SortAscBy "type", SortAscBy "name"]
@@ -459,6 +463,8 @@ getCShowR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
@@ -1181,6 +1187,8 @@ makeCourseUserTable cid restrict colChoices psValidator = do
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
           }
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
     over _1 postprocess <$> dbTable psValidator DBTable{..}
   where
     postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)

src/Handler/Exam.hs

@@ -9,6 +9,7 @@ import Handler.Utils.Exam
 import Handler.Utils.Invitations
 import Handler.Utils.Table.Columns
 import Handler.Utils.Table.Cells
+import Handler.Utils.Csv
 import Jobs.Queue
 
 import Utils.Lens hiding (parts)
@@ -29,6 +30,10 @@ import qualified Data.CaseInsensitive as CI
 
 import qualified Control.Monad.State.Class as State
 
+import qualified Data.Csv as Csv
+
+import qualified Data.Conduit.List as C
+
 
 getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamListR tid ssh csh = do
@@ -74,6 +79,8 @@ getCExamListR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]
@@ -760,6 +767,9 @@ queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
 queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
 queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
 
+resultUser :: Lens' ExamUserTableData (Entity User)
+resultUser = _dbrOutput . _2
+
 resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
 resultStudyFeatures = _dbrOutput . _4 . _Just
 
@@ -769,6 +779,32 @@ resultStudyDegree = _dbrOutput . _5 . _Just
 resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
 resultStudyField = _dbrOutput . _6 . _Just
 
+resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
+resultExamOccurrence = _dbrOutput . _3 . _Just
+
+data ExamUserTableCsv = ExamUserTableCsv
+  { csvUserSurname :: Text
+  , csvUserName :: Text
+  , csvUserMatriculation :: Maybe Text
+  , csvUserField :: Maybe Text
+  , csvUserDegree :: Maybe Text
+  , csvUserSemester :: Maybe Int
+  , csvUserRoom :: Maybe Text
+  }
+  deriving (Generic)
+
+examUserTableCsvOptions :: Csv.Options
+examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToNamedRecord ExamUserTableCsv where
+  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+
+instance FromNamedRecord ExamUserTableCsv where
+  parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions
+
+instance DefaultOrdered ExamUserTableCsv where
+  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
+
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
@@ -825,6 +861,16 @@ postEUsersR tid ssh csh examn = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exam-users"
+        dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
+        dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
+          <$> view (resultUser . _entityVal . _userSurname)
+          <*> view (resultUser . _entityVal . _userDisplayName)
+          <*> view (resultUser . _entityVal . _userMatrikelnummer)
+          <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+          <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+          <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+          <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom)
+        dbtCsvDecode = Nothing
 
     examUsersDBTableValidator = def
   ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable

src/Handler/Home.hs

@@ -80,6 +80,8 @@ homeOpenCourses = do
     , dbtStyle     = def
     , dbtParams    = def
     , dbtIdent     = "open-courses" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   $(widgetFile "home/openCourses")
 
@@ -179,6 +181,8 @@ homeUpcomingSheets uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtParams    = def
     , dbtIdent     = "upcoming-sheets" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   $(widgetFile "home/upcomingSheets")
 
@@ -286,6 +290,8 @@ homeUpcomingExams uid = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     examDBTableValidator = def
       & defaultSorting [SortAscBy "time"]

src/Handler/Material.hs

@@ -149,6 +149,8 @@ getMaterialListR tid ssh csh = do
             ]
       , dbtFilter    = mempty
       , dbtFilterUI  = mempty
+      , dbtCsvEncode  = noCsvEncode
+      , dbtCsvDecode  = Nothing
       }
 
   let headingLong  = prependCourseTitle tid ssh csh MsgMaterialListHeading
@@ -219,6 +221,8 @@ getMShowR tid ssh csh mnm = do
             [ sortFilePath         $(sqlIJproj 2 2)
             , sortFileModification $(sqlIJproj 2 2)
             ]
+      , dbtCsvEncode  = noCsvEncode
+      , dbtCsvDecode  = Nothing
       }
     return (matEnt,fileTable')
 

src/Handler/Profile.hs

@@ -258,6 +258,8 @@ mkOwnedCoursesTable =
           ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
 
 
@@ -308,6 +310,8 @@ mkEnrolledCoursesTable =
       , dbtFilterUI  = mempty
       , dbtStyle     = def
       , dbtParams = def
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
 
 
@@ -387,6 +391,8 @@ mkSubmissionTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
                   dbtSorting  = dbtSorting'  uid
               in  dbTableWidget' validator DBTable{..}
@@ -459,6 +465,8 @@ mkSubmissionGroupTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 
@@ -535,6 +543,8 @@ mkCorrectionsTable =
         ]
       dbtFilterUI = mempty
       dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator DBTable{..}
 

src/Handler/Sheet.hs

@@ -310,6 +310,8 @@ getSheetListR tid ssh csh = do
       , dbtStyle     = def
       , dbtParams    = def
       , dbtIdent     = "sheets" :: Text
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
     -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
     --   -- Collect summary over all Sheets, not just the ones shown due to pagination:
@@ -404,6 +406,8 @@ getSShowR tid ssh csh shn = do
         )
       ]
     , dbtParams = def
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
   (hasHints, hasSolution) <- runDB $ do
     hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]

src/Handler/Submission.hs

@@ -520,6 +520,8 @@ submissionHelper tid ssh csh shn mcid = do
         , dbtFilter = mempty
         , dbtFilterUI = mempty
         , dbtParams = def
+        , dbtCsvEncode = noCsvEncode
+        , dbtCsvDecode = Nothing
         }
   mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 

src/Handler/SystemMessage.hs

@@ -224,6 +224,8 @@ postMessageListR = do
       , dbParamsFormIdent = def
       }
     , dbtIdent = "messages" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
     }
 
   let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)

src/Handler/Term.hs

@@ -145,6 +145,8 @@ getTermShowR = do
         , dbtStyle = def
         , dbtParams = def
         , dbtIdent = "terms" :: Text
+        , dbtCsvEncode = noCsvEncode
+        , dbtCsvDecode = Nothing
         }
       defaultLayout $ do
         setTitleI MsgTermsHeading

src/Handler/Tutorial.hs

@@ -93,6 +93,8 @@ getCTutorialListR tid ssh csh = do
         dbtParams = def
         dbtIdent :: Text
         dbtIdent = "tutorials"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
 
     tutorialDBTableValidator = def
       & defaultSorting [SortAscBy "type", SortAscBy "name"]

src/Handler/Users.hs

@@ -140,6 +140,8 @@ getUsersR = do
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = def
       , dbtIdent     = "users" :: Text
+      , dbtCsvEncode = noCsvEncode
+      , dbtCsvDecode = Nothing
       }
 
   defaultLayout $ do

src/Handler/Utils.hs

@@ -31,6 +31,7 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 -- import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Mail       as Handler.Utils
+import Handler.Utils.ContentDisposition as Handler.Utils
 
 import System.Directory (listDirectory)
 import System.FilePath.Posix (takeBaseName, takeFileName)
@@ -41,21 +42,6 @@ import qualified Data.List.NonEmpty as NonEmpty
 import Control.Monad.Logger
 
 
--- | Check whether the user's preference for files is inline-viewing or downloading
-downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
-downloadFiles = do
-  mauth <- liftHandlerT maybeAuth
-  case mauth of
-    Just (Entity _ User{..}) -> return userDownloadFiles
-    Nothing -> do
-      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
-      return userDefaultDownloadFiles
-
-setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
-setContentDisposition' mFileName = do
-  wantsDownload <- downloadFiles
-  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
-
 -- | Simply send a `File`-Value
 sendThisFile :: File -> Handler TypedContent
 sendThisFile File{..}

src/Handler/Utils/ContentDisposition.hs

@@ -0,0 +1,24 @@
+module Handler.Utils.ContentDisposition
+  ( downloadFiles
+  , setContentDisposition'
+  ) where
+
+import Import
+
+import Utils.Lens
+
+-- | Check whether the user's preference for files is inline-viewing or downloading
+downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
+downloadFiles = do
+  mauth <- liftHandlerT maybeAuth
+  case mauth of
+    Just (Entity _ User{..}) -> return userDownloadFiles
+    Nothing -> do
+      UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+      return userDefaultDownloadFiles
+
+setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
+setContentDisposition' mFileName = do
+  wantsDownload <- downloadFiles
+  setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
+

src/Handler/Utils/Csv.hs

@@ -0,0 +1,71 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Utils.Csv
+  ( typeCsv, extensionCsv
+  , decodeCsv
+  , encodeCsv
+  , respondCsv, respondCsvDB
+  , fileSourceCsv
+  , CsvParseError(..)
+  , ToNamedRecord(..), FromNamedRecord(..)
+  , DefaultOrdered(..)
+  , ToField(..), FromField(..)
+  ) where
+
+import Import
+
+import Data.Csv
+import Data.Csv.Conduit
+
+import qualified Data.Conduit.List as C
+import qualified Data.Conduit.Combinators as C (sourceLazy)
+
+import qualified Data.Map as Map
+
+
+deriving instance Typeable CsvParseError
+instance Exception CsvParseError
+
+
+typeCsv :: ContentType
+typeCsv = "text/csv"
+
+extensionCsv :: Extension
+extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
+
+
+decodeCsv :: (MonadThrow m, FromNamedRecord csv) => Conduit ByteString m csv
+decodeCsv = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions
+
+encodeCsv :: ( ToNamedRecord csv
+             , DefaultOrdered csv
+             , Monad m
+             )
+          => Conduit csv m ByteString
+-- ^ Encode a stream of records
+--
+-- Currently not streaming
+encodeCsv = fmap encodeDefaultOrderedByName (C.foldMap pure) >>= C.sourceLazy
+
+  
+respondCsv :: ( ToNamedRecord csv
+              , DefaultOrdered csv
+              )
+           => Source (HandlerT site IO) csv
+           -> HandlerT site IO TypedContent
+respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+
+respondCsvDB :: ( ToNamedRecord csv
+                , DefaultOrdered csv
+                , YesodPersistRunner site
+                )
+             => Source (YesodDB site) csv
+             -> HandlerT site IO TypedContent
+respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+
+fileSourceCsv :: ( FromNamedRecord csv
+                 , MonadResource m
+                 )
+              => FileInfo
+              -> Source m csv
+fileSourceCsv = (.| decodeCsv) . fileSource

src/Handler/Utils/Table/Pagination.hs

@@ -6,7 +6,8 @@ module Handler.Utils.Table.Pagination
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
   , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
-  , DBTable(..), IsDBTable(..), DBCell(..)
+  , DBTCsvEncode, DBTCsvDecode
+  , DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
   , singletonFilter
   , DBParams(..)
   , cellAttrs, cellContents
@@ -34,6 +35,8 @@ module Handler.Utils.Table.Pagination
 
 import Handler.Utils.Table.Pagination.Types
 import Handler.Utils.Form
+import Handler.Utils.Csv
+import Handler.Utils.ContentDisposition
 import Utils
 import Utils.Lens.TH
 
@@ -67,7 +70,8 @@ import Text.Hamlet (hamletFile)
 
 import Data.Ratio ((%))
 
-import Control.Lens
+import Control.Lens hiding ((<.>))
+import Control.Lens.Extras (is)
 
 import Data.List (elemIndex)
 
@@ -89,6 +93,8 @@ import qualified Data.ByteString.Lazy as LBS
 
 import Data.Semigroup as Sem (Semigroup(..))
 
+import qualified Data.Conduit.List as C
+
 
 #if MIN_VERSION_base(4,11,0)
 type Monoid' = Monoid
@@ -154,12 +160,12 @@ instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
   filterColumn' fin _ _ = fin
 
 instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
-  filterColumn' cont is t = filterColumn' (cont t) is t
+  filterColumn' cont is' t = filterColumn' (cont t) is' t
 
 instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
-  filterColumn' cont is = filterColumn' (cont input) is'
+  filterColumn' cont is0 = filterColumn' (cont input) is'
     where
-      (input, ($ []) -> is') = go (mempty, id) is
+      (input, ($ []) -> is') = go (mempty, id) is0
       go acc [] = acc
       go (acc, is3) (i:is2)
         | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
@@ -263,6 +269,37 @@ piIsUnset PaginationInput{..} = and
   , isNothing piPage
   ]
 
+
+data ButtonCsvMode = BtnCsvExport | BtnCsvImport
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCsvMode
+instance Finite ButtonCsvMode
+
+embedRenderMessage ''UniWorX ''ButtonCsvMode id
+
+nullaryPathPiece ''ButtonCsvMode $ camelToPathPiece' 1
+
+instance Button UniWorX ButtonCsvMode where
+  btnLabel BtnCsvExport
+    = [whamlet|
+        $newline never
+        #{fontAwesomeIcon "file-csv"}
+        \ _{BtnCsvExport}
+      |]
+  btnLabel BtnCsvImport
+    = [whamlet|
+        $newline never
+        _{BtnCsvImport}
+      |]
+
+data DBCsvMode = DBCsvNormal
+               | DBCsvExport
+               | DBCsvImport
+                 { _dbCsvFiles :: [FileInfo]
+                 , _dbCsvModifyExisting, _dbCsvAddNew, _dbCsvDeleteMissing :: Bool
+                 }
+
+
 type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k')
 data DBRow r = forall k'. DBTableKey k' => DBRow
   { dbrKey :: k'
@@ -402,7 +439,10 @@ instance PathPiece x => PathPiece (WithIdent x) where
     WithIdent <$> pure ident <*> fromPathPiece rest
 
 
-data DBTable m x = forall a r r' h i t k k'.
+type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv) (Conduit r' (YesodDB UniWorX) csv)
+type DBTCsvDecode csv = DictMaybe (FromNamedRecord csv) (Sink csv (YesodDB UniWorX) ())
+
+data DBTable m x = forall a r r' h i t k k' csv.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, E.SqlIn k k', DBTableKey k'
   , PathPiece i, Eq i
@@ -410,16 +450,21 @@ data DBTable m x = forall a r r' h i t k k'.
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
   , dbtRowKey :: t -> k                 -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
-  , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
+  , dbtProj :: DBRow r -> MaybeT (YesodDB UniWorX) r'
   , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map SortingKey (SortColumn t)
   , dbtFilter :: Map FilterKey (FilterColumn t)
-  , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
+  , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
   , dbtStyle :: DBStyle
   , dbtParams :: DBParams m x
+  , dbtCsvEncode :: DBTCsvEncode r' csv
+  , dbtCsvDecode :: DBTCsvDecode csv
   , dbtIdent :: i
   }
 
+noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void) (Conduit r' (YesodDB UniWorX) Void)
+noCsvEncode = Nothing
+
 class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
   data DBParams m x :: *
   type DBResult m x :: *
@@ -691,18 +736,68 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   mapM_ (addMessageI Warning) errs
 
+  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
+  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  let
+    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
+    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
+    substPi = foldr (.) id
+      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
+      , foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
+      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
+      , setParam (wIdent "page") $ fmap toPathPiece piPage
+      , setParam (wIdent "pagination") Nothing
+      ]
+    tblLink' :: (QueryText -> QueryText) -> Widget
+    tblLink' = toWidget <=< toTextUrl . tblLink
+
+  ((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport]
+  ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport
+    <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
+    <*> apopt checkBoxField (fslI MsgCsvModifyExisting) (Just True)
+    <*> apopt checkBoxField (fslI MsgCsvAddNew) (Just True)
+    <*> apopt checkBoxField (fslI MsgCsvDeleteMissing) (Just False)
+
+  let
+    csvMode = asum
+      [ csvExportRes <* guard (is _Just dbtCsvEncode)
+      , csvImportRes <* guard (is _Just dbtCsvDecode)
+      , FormSuccess DBCsvNormal
+      ]
+    csvExportWdgt' = wrapForm csvExportWdgt FormSettings
+      { formMethod = GET
+      , formAction = Just $ tblLink id
+      , formEncoding = csvExportEnctype
+      , formAttrs = [("target", "_blank")]
+      , formSubmit = FormNoSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+    csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings
+      { formMethod = POST
+      , formAction = Just $ tblLink id
+      , formEncoding = csvImportEnctype
+      , formAttrs = []
+      , formSubmit = FormSubmit
+      , formAnchor = Nothing :: Maybe Text
+      }
+
+  
   rows' <- E.select . E.from $ \t -> do
     res <- dbtSQLQuery t
     E.orderBy (map (sqlSortDirection t) psSorting')
-    case previousKeys of
+    case csvMode of
-      Nothing
+      FormSuccess DBCsvExport -> return ()
-        | PagesizeLimit l <- psLimit
+      FormSuccess DBCsvImport{} -> return ()
-          -> do
+      _other -> do
-            E.limit l
+        case previousKeys of
-            E.offset (psPage * l)
+          Nothing
-      Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
+            | PagesizeLimit l <- psLimit
-      _other  -> return ()
+              -> do
-    Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
+                E.limit l
+                E.offset (psPage * l)
+          Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
+          _other  -> return ()
+        Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
     return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
 
   let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
@@ -720,20 +815,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
 
   (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
 
-  Just currentRoute <- getCurrentRoute -- `dbTable` should never be called from a 404-handler
+
-  getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+  formResult csvMode $ \case
-  let
+    DBCsvExport
-    tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
+      | Just (Dict, dbtCsvEncode') <- dbtCsvEncode
-    tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
+        -> do
-    substPi = foldr (.) id
+          setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv
-      [ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
+          sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode'
-      , foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
+    DBCsvImport{}
-      , setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
+      | Just (Dict, _dbtCsvDecode) <- dbtCsvDecode
-      , setParam (wIdent "page") $ fmap toPathPiece piPage
+        -> error "dbCsvImport"
-      , setParam (wIdent "pagination") Nothing
+    _other      -> return ()
-      ]
-    tblLink' :: (QueryText -> QueryText) -> Widget
-    tblLink' = toWidget <=< toTextUrl . tblLink
 
   let
     rowCount
@@ -786,6 +878,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , formSubmit = FormAutoSubmit
       , formAnchor = Just $ wIdent "pagesize-form"
       }
+
+    csvWdgt = $(widgetFile "table/csv-transcode")
+   
     uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
 
     dbInvalidateResult' = foldr (<=<) return . catMaybes $

src/Import/NoModel.hs

@@ -74,6 +74,9 @@ import Network.Mime as Import
 import Data.Aeson.TH as Import
 import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
 
+import Data.Constraint as Import (Dict(..))
+import Data.Void as Import (Void)
+
 import Language.Haskell.TH.Instances as Import ()
 import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()

src/Utils.hs

@@ -77,6 +77,8 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty)
 
 import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
 
+import Data.Constraint (Dict(..))
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -978,3 +980,12 @@ foldJoin = foldr (\/) bottom
 
 foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
 foldMeet = foldr (/\) top
+
+-----------------
+-- Constraints --
+-----------------
+
+type DictMaybe constr a = Maybe (Dict constr, a)
+
+pattern DictJust :: constr => a -> DictMaybe constr a
+pattern DictJust a = Just (Dict, a)

src/Utils/Form.hs

@@ -8,6 +8,7 @@ import Yesod.Core.Instances ()
 import Settings
 
 import Utils.Parameters
+import Utils.Lens
 
 import Text.Blaze (Markup)
 import qualified Text.Blaze.Internal as Blaze (null)
@@ -32,8 +33,6 @@ import Control.Monad.Morph (MFunctor(..))
 
 import Data.List ((!!))
 
-import Control.Lens
-
 import Web.PathPieces
 
 import Data.UUID
@@ -197,6 +196,8 @@ data FormIdentifier
   | FIDDBTableFilter
   | FIDDBTablePagesize
   | FIDDBTable
+  | FIDDBTableCsvExport
+  | FIDDBTableCsvImport
   | FIDDelete
   | FIDCourseRegister
   | FIDuserRights
@@ -591,6 +592,19 @@ htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
     sanitize :: Text -> m (Either FormMessage Html)
     sanitize = return . Right . preEscapedText . sanitizeBalance
 
+fileFieldMultiple :: Monad m => Field m [FileInfo]
+fileFieldMultiple = Field
+  { fieldParse = \_ files -> return $ case files of
+      [] -> Right Nothing
+      fs -> Right $ Just fs
+  , fieldView = \id' name attrs _ isReq ->
+      [whamlet|
+        $newline never
+        <input type="file" uw-file-input id=#{id'} name=#{name} *{attrs} multiple :isReq:required="required">
+      |]                                  
+  , fieldEnctype = Multipart
+  }
+
 -----------
 -- Forms --
 -----------
@@ -635,7 +649,7 @@ wrapForm' btn formWidget FormSettings{..} = do
 -------------------
 
 -- | Use this type to pass information to the form template
-data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
+data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport
 
 renderAForm :: Monad m => FormLayout -> FormRender m a
 renderAForm formLayout aform fragment = do
@@ -932,3 +946,20 @@ apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx
 wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
 wpreq f fs mx = mFormToWForm $ mpreq f fs mx
+
+
+mpopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
+-- ^ Pseudo optional
+--
+-- `FieldView` has `fvRequired` set to `False`
+-- Otherwise acts exactly like `mreq`.
+mpopt f fs mx = set (_2 . _fvRequired) False <$> mreq f fs mx
+
+apopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+apopt f fs mx = formToAForm $ over _2 pure <$> mpopt f fs mx
+
+wpopt :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpopt f fs mx = mFormToWForm $ mpopt f fs mx

src/Utils/Lens.hs

@@ -143,6 +143,8 @@ makeLenses_ ''ExamGradingRule
 
 makeLenses_ ''UTCTime
 
+makeLenses_ ''ExamOccurrence
+
 
 -- makeClassy_ ''Load
 

templates/table/csv-transcode.hamlet

@@ -0,0 +1,7 @@
+$newline never
+$if is _Just dbtCsvDecode
+  <div .csv-import>
+    ^{csvImportWdgt'}
+$if is _Just dbtCsvEncode
+  <div .csv-export>
+    ^{csvExportWdgt'}

templates/table/layout.hamlet

@@ -5,6 +5,7 @@ $else
   <div .table-header>
     <div .table__row-count>
       _{MsgRowCount rowCount}
+    ^{csvWdgt}
 
   ^{table}