From 631bbef0b8d202e3127de602ad1b5f30b896cd0a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 19:24:10 +0200 Subject: [PATCH] feat(csv): introduce csv export --- messages/uniworx/de.msg | 7 ++ package.yaml | 4 + src/Handler/Admin.hs | 6 + src/Handler/Corrections.hs | 2 + src/Handler/Course.hs | 8 ++ src/Handler/Exam.hs | 46 +++++++ src/Handler/Home.hs | 6 + src/Handler/Material.hs | 4 + src/Handler/Profile.hs | 10 ++ src/Handler/Sheet.hs | 4 + src/Handler/Submission.hs | 2 + src/Handler/SystemMessage.hs | 2 + src/Handler/Term.hs | 2 + src/Handler/Tutorial.hs | 2 + src/Handler/Users.hs | 2 + src/Handler/Utils.hs | 16 +-- src/Handler/Utils/ContentDisposition.hs | 24 ++++ src/Handler/Utils/Csv.hs | 71 +++++++++++ src/Handler/Utils/Table/Pagination.hs | 157 +++++++++++++++++++----- src/Import/NoModel.hs | 3 + src/Utils.hs | 11 ++ src/Utils/Form.hs | 37 +++++- src/Utils/Lens.hs | 2 + templates/table/csv-transcode.hamlet | 7 ++ templates/table/layout.hamlet | 1 + 25 files changed, 387 insertions(+), 49 deletions(-) create mode 100644 src/Handler/Utils/ContentDisposition.hs create mode 100644 src/Handler/Utils/Csv.hs create mode 100644 templates/table/csv-transcode.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ab4cb18fc..9eddec075 100644 --- a/messages/uniworx/de.msg +++ b/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 \ No newline at end of file diff --git a/package.yaml b/package.yaml index 455e60729..36d15b9cc 100644 --- a/package.yaml +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1b6242611..a2f4eafa3 100644 --- a/src/Handler/Admin.hs +++ b/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{..} diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d6ca66636..7ee549d03 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 156fc77ae..404338e73 100644 --- a/src/Handler/Course.hs +++ b/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) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index b3f15b334..1758e3ffa 100644 --- a/src/Handler/Exam.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 53cde3d91..7103afe14 100644 --- a/src/Handler/Home.hs +++ b/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"] diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index dbf6c8bad..3ff0c1349 100644 --- a/src/Handler/Material.hs +++ b/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') diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 783752808..8afac65ce 100644 --- a/src/Handler/Profile.hs +++ b/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{..} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 946e0395f..740be11cc 100644 --- a/src/Handler/Sheet.hs +++ b/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 ] diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 0fe085dc1..6dd006d40 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 48a0a9337..273e33d6d 100644 --- a/src/Handler/SystemMessage.hs +++ b/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) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f2e27c298..64a85bfef 100644 --- a/src/Handler/Term.hs +++ b/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 diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 07c6bd181..1f56bcc8d 100644 --- a/src/Handler/Tutorial.hs +++ b/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"] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index cf089cb58..30470cf3a 100644 --- a/src/Handler/Users.hs +++ b/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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index ed7682772..155774b6f 100644 --- a/src/Handler/Utils.hs +++ b/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{..} diff --git a/src/Handler/Utils/ContentDisposition.hs b/src/Handler/Utils/ContentDisposition.hs new file mode 100644 index 000000000..7be2bd81b --- /dev/null +++ b/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 + diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs new file mode 100644 index 000000000..27299f655 --- /dev/null +++ b/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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index e87d4a405..ced5cf30e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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 - Nothing - | PagesizeLimit l <- psLimit - -> do - 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 + case csvMode of + FormSuccess DBCsvExport -> return () + FormSuccess DBCsvImport{} -> return () + _other -> do + case previousKeys of + Nothing + | PagesizeLimit l <- psLimit + -> do + 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 - 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 + + formResult csvMode $ \case + DBCsvExport + | Just (Dict, dbtCsvEncode') <- dbtCsvEncode + -> do + setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv + sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode' + DBCsvImport{} + | Just (Dict, _dbtCsvDecode) <- dbtCsvDecode + -> error "dbCsvImport" + _other -> return () 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 $ diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 744c848b6..bb7c5dd78 100644 --- a/src/Import/NoModel.hs +++ b/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 () diff --git a/src/Utils.hs b/src/Utils.hs index 6096851e2..759064296 100644 --- a/src/Utils.hs +++ b/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) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0129b8750..1749dd51a 100644 --- a/src/Utils/Form.hs +++ b/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 + + |] + , 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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 8fdd73d46..9388bea0b 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -143,6 +143,8 @@ makeLenses_ ''ExamGradingRule makeLenses_ ''UTCTime +makeLenses_ ''ExamOccurrence + -- makeClassy_ ''Load diff --git a/templates/table/csv-transcode.hamlet b/templates/table/csv-transcode.hamlet new file mode 100644 index 000000000..dd4576e25 --- /dev/null +++ b/templates/table/csv-transcode.hamlet @@ -0,0 +1,7 @@ +$newline never +$if is _Just dbtCsvDecode +
+ ^{csvImportWdgt'} +$if is _Just dbtCsvEncode +
+ ^{csvExportWdgt'} diff --git a/templates/table/layout.hamlet b/templates/table/layout.hamlet index eb8baadcb..836f5810c 100644 --- a/templates/table/layout.hamlet +++ b/templates/table/layout.hamlet @@ -5,6 +5,7 @@ $else
_{MsgRowCount rowCount} + ^{csvWdgt} ^{table}