From 2c0fc63be1de02e8acffbc6a9c5ee83b061c5825 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 21 Jan 2021 13:22:22 +0100 Subject: [PATCH] feat(dbtable): extra representations --- src/Handler/Admin/StudyFeatures.hs | 8 ++ src/Handler/Allocation/List.hs | 2 + src/Handler/Allocation/Users.hs | 1 + src/Handler/Course/Application/List.hs | 2 + src/Handler/Course/List.hs | 1 + src/Handler/Course/Show.hs | 1 + src/Handler/Course/User.hs | 2 + src/Handler/Course/Users.hs | 7 +- src/Handler/Exam/List.hs | 1 + src/Handler/Exam/Users.hs | 2 + src/Handler/ExamOffice/Exam.hs | 2 + src/Handler/ExamOffice/Exams.hs | 2 + src/Handler/ExternalExam/List.hs | 1 + src/Handler/Material.hs | 2 + src/Handler/News.hs | 2 + src/Handler/Profile.hs | 5 + src/Handler/School.hs | 2 + src/Handler/Sheet/List.hs | 1 + src/Handler/Sheet/Show.hs | 1 + src/Handler/Submission/Helper.hs | 1 + src/Handler/Submission/List.hs | 1 + src/Handler/SystemMessage.hs | 1 + src/Handler/Term.hs | 1 + src/Handler/Tutorial/List.hs | 1 + src/Handler/Users.hs | 1 + src/Handler/Utils/ExternalExam/Users.hs | 1 + src/Handler/Utils/Table/Pagination.hs | 51 +++++++- src/Handler/Utils/Workflow/Workflow.hs | 22 ++++ src/Handler/Workflow/Definition/List.hs | 1 + src/Handler/Workflow/Instance/List.hs | 1 + src/Handler/Workflow/Workflow/List.hs | 144 +++++++++++++++++++++- src/Handler/Workflow/Workflow/Workflow.hs | 60 +++------ src/Model/Types/Workflow.hs | 52 ++++++++ src/Utils.hs | 18 ++- src/Utils/Csv.hs | 14 ++- src/Utils/Parameters.hs | 1 + 36 files changed, 362 insertions(+), 54 deletions(-) diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index f4f40c7fb..9241198d7 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -346,6 +346,7 @@ postAdminFeaturesR = do & defaultSorting [SortAscBy "key"] dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in dbTable psValidator DBTable{..} mkStudytermsTable :: Set StudyTermsId -> Set StudyTermsId -> Set (Entity School) -> DB (FormResult (DBFormResult StudyTermsId (Maybe Text, Maybe Text, Set SchoolId, Set StudyTermsId, Maybe StudyDegreeId, Maybe StudyFieldType) (DBRow (Entity StudyTerms, Set (Entity StudyTerms), Set SchoolId))), Widget) @@ -401,6 +402,8 @@ postAdminFeaturesR = do & defaultSorting [SortAscBy "isnew", SortAscBy "isbad", SortAscBy "key"] dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + + dbtExtraReps = [] queryField = id _dbrKey' :: Getter (DBRow (Entity StudyTerms, _, _)) StudyTermsId @@ -438,6 +441,7 @@ postAdminFeaturesR = do psValidator = def & defaultSorting [SortAscBy "incidence", SortAscBy "key", SortAscBy "name"] dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in dbTable psValidator DBTable{..} mkParentCandidateTable = @@ -477,6 +481,8 @@ postAdminFeaturesR = do & defaultSorting [SortAscBy "child", SortAscBy "incidence", SortAscBy "parent"] dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + + dbtExtraReps = [] queryCandidate (c `E.LeftOuterJoin` _ `E.LeftOuterJoin` _) = c queryParent (_ `E.LeftOuterJoin` p `E.LeftOuterJoin` _) = p @@ -517,6 +523,8 @@ postAdminFeaturesR = do & defaultSorting [SortAscBy "key", SortAscBy "incidence"] dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + + dbtExtraReps = [] queryCandidate (c `E.LeftOuterJoin` _) = c queryTerm (_ `E.LeftOuterJoin` t) = t diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 0c2187e7a..d0e705419 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -128,6 +128,8 @@ getAllocationListR = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] + dbtIdent = allocationListIdent psValidator :: PSValidator _ _ diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 6921ec90b..b3db4fca5 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -317,6 +317,7 @@ postAUsersR tid ssh ash = do , dbtCsvExampleData = Nothing } dbtCsvDecode = Nothing + dbtExtraReps = [] allocationUsersDBTableValidator = def & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"] & defaultPagesize (PagesizeLimit 500) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 8e9f53d79..d942999e5 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -491,6 +491,8 @@ postCApplicationsR tid ssh csh = do where Entity _ User{..} = existing ^. singular (ix appId . resultUser) + dbtExtraReps = [] + dbtIdent = courseApplicationsIdent psValidator :: PSValidator _ _ diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 2ab517fce..92a96ffa5 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -197,6 +197,7 @@ makeCourseTable whereClause colChoices psValidator = do , dbtIdent = "courses" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } getCourseListR :: Handler Html diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 0e82bffba..1e1f08ea5 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -239,6 +239,7 @@ getCShowR tid ssh csh = do dbtIdent = "tutorials" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"] diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index c9a5e2217..482d1a53b 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -377,6 +377,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do dbtIdent = "course-user-exams" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] examDBTableValidator = def & defaultSorting [SortAscBy "registration-time"] postprocess :: FormResult (First ExamActionData, DBFormResult ExamId (Bool, _) _) -> FormResult (ExamActionData, Map ExamId _) postprocess inp = do @@ -499,6 +500,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do dbtIdent = "tutorials" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"] postprocess :: FormResult (First TutorialActionData, DBFormResult TutorialParticipantId (Bool, _) _) -> FormResult (TutorialActionData, Map TutorialParticipantId _) postprocess inp = do diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 64f156b7a..6431d3c7d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -167,10 +167,10 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns data UserTableCsv = UserTableCsv - { csvUserName :: Text + { csvUserName :: UserDisplayName , csvUserSex :: Maybe Sex - , csvUserMatriculation :: Maybe Text - , csvUserEmail :: CI Email + , csvUserMatriculation :: Maybe UserMatriculation + , csvUserEmail :: UserEmail , csvUserStudyFeatures :: UserTableStudyFeatures , csvUserSubmissionGroup :: Maybe SubmissionGroupName , csvUserRegistration :: UTCTime @@ -482,6 +482,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do CourseUserNote{..} <- lift . lift $ getJust noteId return courseUserNoteNote dbtCsvDecode = Nothing + dbtExtraReps = withCsvExtraRep (UserCsvExportData True) dbtCsvEncode [] 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/List.hs b/src/Handler/Exam/List.hs index e0c96add7..d05528227 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -71,6 +71,7 @@ mkExamTable (Entity cid Course{..}) = do dbtIdent = "exams" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] examDBTableValidator = def & defaultSorting [SortAscBy "time"] diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 9c45618f7..a870d9bbd 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -944,6 +944,8 @@ postEUsersR tid ssh csh examn = do [occId] -> return occId _other -> throwM ExamUserCsvExceptionNoMatchingOccurrence + dbtExtraReps = [] + examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"] & defaultPagesize PagesizeAll diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index c41684727..5e7a7cdc8 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -406,6 +406,8 @@ postEGradesR tid ssh csh examn = do } dbtCsvDecode = Nothing + dbtExtraReps = [] + examUsersDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "user-name"] & defaultPagesize PagesizeAll diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index e51a43fb1..f4f957c4c 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -249,6 +249,8 @@ getEOExamsR = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + + dbtExtraReps = [] examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"] diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index afcdf2e8f..738ef5fe1 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -70,6 +70,7 @@ getEExamListR = do dbtIdent = "external-exams" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] examDBTableValidator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "name"] & forceFilter "may-access" (Any True) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 245ebcdb4..46c313830 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -144,6 +144,7 @@ getMaterialListR tid ssh csh = do , dbtFilterUI = mempty , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } let headingLong = prependCourseTitle tid ssh csh MsgMaterialListHeading @@ -248,6 +249,7 @@ getMShowR tid ssh csh mnm = do ] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } return (matEnt,fileTable',zipLink) -- File table has no filtering by access, because we assume that diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 4595d1eb2..ab8c765b4 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -199,6 +199,7 @@ newsUpcomingSheets uid = do , dbtIdent = "upcoming-sheets" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } $(widgetFile "news/upcomingSheets") @@ -334,6 +335,7 @@ newsUpcomingExams uid = do dbtIdent = "exams" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] examDBTableValidator = def & defaultSorting [SortAscBy "time"] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 53382e491..e57de169b 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -533,6 +533,7 @@ mkOwnedCoursesTable = dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..} @@ -585,6 +586,7 @@ mkEnrolledCoursesTable = , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } @@ -665,6 +667,7 @@ mkSubmissionTable = dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid dbtSorting = dbtSorting' uid in dbTableWidget' validator DBTable{..} @@ -725,6 +728,7 @@ mkSubmissionGroupTable = dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} @@ -800,6 +804,7 @@ mkCorrectionsTable = dbtParams = def dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in dbTableWidget' validator DBTable{..} diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 184191c3f..7d590b6c4 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -43,6 +43,8 @@ getSchoolListR = do dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + + dbtExtraReps = [] dbtIdent :: Text dbtIdent = "schools" diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index c72fc8868..c46419064 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -174,6 +174,7 @@ getSheetListR tid ssh csh = do , dbtIdent = "sheets" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!! -- -- Collect summary over all Sheets, not just the ones shown due to pagination: diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index ccc39aa8d..462337399 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -97,6 +97,7 @@ getSShowR tid ssh csh shn = do , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } (hasHints, hasSolution) <- runDB $ do hasHints <- E.selectExists . E.from $ \sheet' -> diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index 4758b7b27..4067785d5 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -536,6 +536,7 @@ submissionHelper tid ssh csh shn mcid = do , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 648fb19d1..7e569f92a 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -409,6 +409,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams , dbtIdent = "corrections" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } data ActionCorrections = CorrDownload diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 83d6aa46b..f2e10f609 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -249,6 +249,7 @@ postMessageListR = do , dbtIdent = "messages" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False) diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index f44ce3030..18c5b1c47 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -154,6 +154,7 @@ getTermShowR = do dbtIdent = "terms" :: Text dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] termDBTableValidator = def & defaultSorting [SortDescBy "term-id"] in dbTableWidget' termDBTableValidator termDBTable defaultLayout $ do diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 348e86e16..5b2006ca6 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -91,6 +91,7 @@ getCTutorialListR tid ssh csh = do dbtIdent = "tutorials" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index b652b2cc4..97dc383ac 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -215,6 +215,7 @@ postUsersR = do , dbtIdent = "users" :: Text , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing + , dbtExtraReps = [] } formResult usersRes $ \case diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index f3d3aed0c..329ebf88e 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -529,6 +529,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do , GuessUserFirstName <$> csvEUserFirstName ] maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria (Just 1) -- we're only interested in at most one match + dbtExtraReps = [] externalExamUsersDBTableValidator = def & defaultSorting (bool id (SortAscBy "is-synced" :) (mode == EEUMGrades) [SortAscBy "user-name"]) & defaultPagesize PagesizeAll diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 836c8d913..11748f778 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -13,9 +13,10 @@ module Handler.Utils.Table.Pagination , module Handler.Utils.Table.Pagination.CsvColumnExplanations , DBCsvActionMode(..) , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew - , DBTCsvEncode(..), DBTCsvDecode(..) + , DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..) , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..) , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM + , withCsvExtraRep , singletonFilter , DBParams(..) , cellAttrs, cellContents @@ -120,6 +121,8 @@ import qualified Data.Csv as Csv import Jobs.Queue +import Data.Typeable (eqT) + #if MIN_VERSION_base(4,11,0) type Monoid' = Monoid @@ -585,11 +588,17 @@ data DBTCsvEncode r' k' csv = forall exportData. ) => DBTCsvEncode { dbtCsvExportForm :: AForm DB exportData , dbtCsvHeader :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data - , dbtCsvExampleData :: Maybe [csv] + , dbtCsvExampleData :: Maybe [csv] , dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv DB () , dbtCsvName :: FilePath , dbtCsvNoExportData :: Maybe (AnIso' exportData ()) } +data DBTExtraRep r' k' = forall rep. + ( HasContentType rep + , DBTableKey k' + ) => DBTExtraRep + { dbtERepDoEncode :: ConduitT (k', r') Void DB rep + } data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException. ( FromNamedRecord csv, ToNamedRecord csv , DBTableKey k' @@ -628,6 +637,7 @@ data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar). , dbtParams :: DBParams m x , dbtCsvEncode :: Maybe (DBTCsvEncode r' k' csv) , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv) + , dbtExtraReps :: [DBTExtraRep r' k'] , dbtIdent :: i } @@ -666,6 +676,19 @@ simpleCsvEncodeM fName f = Just DBTCsvEncode , dbtCsvExampleData = Nothing } +withCsvExtraRep :: forall exportData csv r' k'. + Typeable exportData + => exportData + -> Maybe (DBTCsvEncode r' k' csv) + -> [DBTExtraRep r' k'] -> [DBTExtraRep r' k'] +withCsvExtraRep exportData mEncode = maybe id (flip snoc) csvExtraRep + where csvExtraRep = do + DBTCsvEncode{ dbtCsvNoExportData = (_ :: Maybe (AnIso' exportData' ())), .. } <- mEncode + Refl <- eqT @exportData @exportData' + return DBTExtraRep + { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) + } + class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: Type -> Type) (x :: Type) where data DBParams m x :: Type @@ -1262,6 +1285,28 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db ] _other -> return () + let extraReps = maybe id (flip snoc) csvRep dbtExtraReps + where csvRep = do + DBTCsvEncode{..} <- dbtCsvEncode + noExportData' <- cloneIso <$> dbtCsvNoExportData + let exportData = noExportData' # () + return DBTExtraRep + { dbtERepDoEncode = toCsvRendered <$> lift (dbtCsvHeader $ Just exportData) <*> (dbtCsvDoEncode exportData .| C.foldMap (pure @[])) + } + extraReps' = (typeHtml, Nothing) : map ((,) <$> (\DBTExtraRep{..} -> getContentType dbtERepDoEncode) <*> Just) extraReps + doAltRep = maybe True (== dbtIdent) <$> lookupGlobalGetParam GetSelectTable + + maybeT (return ()) $ do + guardM doAltRep + + cts <- reqAccept <$> getRequest + + altRep <- hoistMaybe <=< asum $ do + mRep <- hoistMaybe . selectRep' extraReps' =<< cts + return . return $ mRep <&> \DBTExtraRep{..} -> fmap toTypedContent . runConduit $ C.sourceList (zip currentKeys rows) .| dbtERepDoEncode + + lift $ sendResponse =<< altRep + let rowCount | selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value @@ -1706,4 +1751,4 @@ cap' (view _Cornice -> cornice) = case cornice of | otherwise = (_Rowspan # (), "2") : filter (hasn't $ _1 . _Rowspan) attrs _Rowspan :: Prism' Text () -_Rowspan = prism' (\() -> "rowspan") $ flip guardOn () . ((==) `on` CI.mk) "rowspan" +_Rowspan = nearly <$> id <*> ((==) `on` CI.mk) $ "rowspan" diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 66bb85829..be615a834 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -2,6 +2,7 @@ module Handler.Utils.Workflow.Workflow ( ensureScope , followEdge , followAutomaticEdges, WorkflowAutomaticEdgeException(..) + , sourceWorkflowActionInfos , module Handler.Utils.Workflow.Restriction ) where @@ -14,6 +15,8 @@ import Handler.Utils.Workflow.Restriction import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Conduit.Combinators as C + ensureScope :: IdWorkflowScope -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId ensureScope wiScope cID = do @@ -75,3 +78,22 @@ followAutomaticEdges WorkflowGraph{..} = go [] return (edgeLbl, nodeLbl) filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history edgeDecisionInput = (cState, filledPayloads) + + +sourceWorkflowActionInfos + :: forall backend m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BackendCompatible SqlReadBackend backend + , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey + , MonadCatch m + ) + => WorkflowWorkflowId + -> WorkflowState FileReference UserId + -> ConduitT () (WorkflowActionInfo FileReference UserId) (ReaderT backend m) () +-- ^ Does `mayViewWorkflowAction` +sourceWorkflowActionInfos wwId wState = do + mAuthId <- maybeAuthId + let authCheck WorkflowActionInfo{..} + = mayViewWorkflowAction mAuthId wwId waiAction + yieldMany (workflowActionInfos wState) .| C.filterM authCheck + diff --git a/src/Handler/Workflow/Definition/List.hs b/src/Handler/Workflow/Definition/List.hs index 2944116d8..ecd19b12a 100644 --- a/src/Handler/Workflow/Definition/List.hs +++ b/src/Handler/Workflow/Definition/List.hs @@ -131,6 +131,7 @@ getAdminWorkflowDefinitionListR = do dbtIdent = "workflow-definitions" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] workflowDefinitionsDBTableValidator = def & defaultPagesize PagesizeAll & defaultSorting [SortAscBy "scope", SortAscBy "name"] diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index 2e9727649..0d4fc285d 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -118,6 +118,7 @@ getAdminWorkflowInstanceListR = do dbtIdent = "workflow-instances" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [] workflowInstancesDBTableValidator = def & defaultSorting [SortAscBy "scope", SortAscBy "name"] in dbTableDB' workflowInstancesDBTableValidator workflowInstancesDBTable diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 58039aca3..8b7670340 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -11,9 +11,10 @@ module Handler.Workflow.Workflow.List , getTopWorkflowWorkflowListR ) where -import Import +import Import hiding (Last(..), WriterT) import Utils.Workflow +import Handler.Utils.Workflow.Workflow import Handler.Utils.Workflow.CanonicalRoute import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor) @@ -28,6 +29,13 @@ import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Conduit.Combinators as C + +import Data.Semigroup (Last(..)) +import qualified Data.Monoid as Monoid (Last(..)) + +import Control.Monad.Trans.Writer.Strict (WriterT) + getGlobalWorkflowWorkflowListR :: Handler Html getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal @@ -115,14 +123,49 @@ type WorkflowWorkflowActionData = ( Maybe Text , Maybe Icon ) +data JsonWorkflowWorkflow = JsonWorkflowWorkflow + { jwwScope :: Maybe RouteWorkflowScope + , jwwInstance :: Maybe JsonWorkflowInstance + , jwwLastAction :: Maybe JsonWorkflowAction + , jwwPayload :: Map WorkflowPayloadLabel JsonWorkflowPayload + } deriving (Generic) + +data JsonWorkflowAction = JsonWorkflowAction + { jwaIx :: CryptoUUIDWorkflowStateIndex + , jwaTo :: Maybe WorkflowGraphNodeLabel + , jwaUser :: Maybe JsonWorkflowUser + , jwaTime :: UTCTime + } deriving (Generic) + +data JsonWorkflowInstance = JsonWorkflowInstance + { jwiScope :: RouteWorkflowScope + , jwiName :: WorkflowInstanceName + } deriving (Generic) + +data JsonWorkflowPayload = JsonWorkflowPayload + { jwpPayload :: [WorkflowFieldPayloadW Void JsonWorkflowUser] + , jwpHasFiles :: Bool + } deriving (Generic) + +data JsonWorkflowUser + = JsonWorkflowUserUser + { jwuDisplayName :: UserDisplayName + , jwuMatriculation :: Maybe UserMatriculation + , jwuDisplayEmail :: UserEmail + } + | JsonWorkflowUserAnonymous + | JsonWorkflowUserHidden + | JsonWorkflowUserGone + deriving (Generic) + resultWorkflowWorkflowId :: Lens' WorkflowWorkflowData CryptoFileNameWorkflowWorkflow resultWorkflowWorkflowId = _dbrOutput . _1 resultRouteScope :: Lens' WorkflowWorkflowData (Maybe RouteWorkflowScope) resultRouteScope = _dbrOutput . _2 -_resultWorkflowWorkflow :: Lens' WorkflowWorkflowData (Entity WorkflowWorkflow) -_resultWorkflowWorkflow = _dbrOutput . _3 +resultWorkflowWorkflow :: Lens' WorkflowWorkflowData (Entity WorkflowWorkflow) +resultWorkflowWorkflow = _dbrOutput . _3 resultWorkflowInstance :: Lens' WorkflowWorkflowData (Maybe (Entity WorkflowInstance)) resultWorkflowInstance = _dbrOutput . _4 @@ -288,7 +331,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) -> let criteria' = map CI.mk . unpack <$> Set.toList criteria in maybe False (\cSt -> any (`isInfixOf` cSt) criteria') $ x ^? resultLastAction . _Just . actionTo . _Just . to (map CI.mk . unpack) - , singletonMap "final" . FilterProjected $ \x (criterion :: Last Bool) -> case getLast criterion of + , singletonMap "final" . FilterProjected $ \x (criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of Nothing -> True Just needle -> let val = has (resultLastAction . _Just . actionTo . _Just) x && has (resultLastAction . _Just . actionFinal . _Just) x @@ -306,6 +349,78 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do dbtIdent = "workflow-workflows" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing + dbtExtraReps = [ DBTExtraRep $ toPrettyJSON <$> repWorkflowWorkflowJson, DBTExtraRep $ toYAML <$> repWorkflowWorkflowJson ] + + repWorkflowWorkflowJson :: ConduitT (E.Value WorkflowWorkflowId, WorkflowWorkflowData) Void DB (Map CryptoFileNameWorkflowWorkflow JsonWorkflowWorkflow) + repWorkflowWorkflowJson = C.foldMapM $ \(E.Value wwId, res) -> do + cID <- encrypt wwId + Map.singleton cID <$> do + let jwwScope = guardOnM wwListColumnScope $ res ^. resultRouteScope + jwwInstance <- fmap join . for (guardOnM wwListColumnInstance $ res ^. resultWorkflowInstance) $ \(Entity _ WorkflowInstance{..}) -> runMaybeT $ do + jwiScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope + let jwiName = workflowInstanceName + return JsonWorkflowInstance{..} + (fmap getLast -> wState) <- + let go :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => WorkflowActionInfo FileReference UserId + -> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) () + go WorkflowActionInfo{ waiIx = stIx, waiHistory = (workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..}} = maybeT (return ()) $ do + stCID <- encryptWorkflowStateIndex wwId stIx + + rScope <- hoistMaybe $ res ^. resultRouteScope + + let toJsonUser (Just (Entity _ User{..})) = JsonWorkflowUserUser + { jwuDisplayName = userDisplayName + , jwuMatriculation = userMatrikelnummer + , jwuDisplayEmail = userDisplayEmail + } + toJsonUser Nothing = JsonWorkflowUserGone + + mVia = Map.lookup wpVia . wgnEdges =<< Map.lookup wpTo wgNodes + hasWorkflowRole' role = $cachedHereBinary (rScope, wwId, role) . lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False + canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) + + aUser <- for wpUser $ \wpUser' -> lift . maybeT (return JsonWorkflowUserHidden) $ do + viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia + guardM $ anyM (otoList viewActors) hasWorkflowRole' + resUser <- lift . lift $ traverse getEntity wpUser' + return $ case resUser of + Just mEnt -> toJsonUser mEnt + Nothing -> JsonWorkflowUserAnonymous + + payload <- do + payload' <- fmap Map.fromList . forMaybeM (Map.toList currentPayload) $ \x@(payloadLbl, _) -> x <$ do + WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLbl $ Map.findWithDefault Map.empty wpTo (wgnPayloadView <$> wgNodes) + guardM . $cachedHereBinary payloadLbl . anyM (otoList wpvViewers) $ lift . hasWorkflowRole' + forM payload' $ \(otoList -> payloads) -> fmap (uncurry JsonWorkflowPayload . over _2 getAny) . execWriterT @_ @(_, Any) . forM_ payloads $ \case + WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t) + WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) + WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) + WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) + WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True) + WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) . toJsonUser =<< lift (lift . lift $ getEntity uid) + + nTo <- runMaybeT $ do + WGN{..} <- hoistMaybe $ Map.lookup wpTo wgNodes + WorkflowNodeView{..} <- hoistMaybe wgnViewers + guardM . lift $ anyM (otoList wnvViewers) hasWorkflowRole' + return wpTo + + tell . Just $ Last (stCID, nTo, aUser, wpTime, payload) + + Entity _ WorkflowWorkflow{..} = res ^. resultWorkflowWorkflow + wState = review _DBWorkflowState workflowWorkflowState + WorkflowGraph{..} = _DBWorkflowGraph # workflowWorkflowGraph + in runConduit $ sourceWorkflowActionInfos wwId wState .| execWriterC (C.mapM_ go) + + let jwwLastAction = wState <&> \(jwaIx, jwaTo, jwaUser, jwaTime, _) -> JsonWorkflowAction{..} + jwwPayload = wState ^. _Just . _5 + + return JsonWorkflowWorkflow{..} workflowWorkflowDBTableValidator = def & defaultSorting defSort & forceFilter "may-access" (Any True) @@ -317,3 +432,24 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do siteLayoutMsg heading $ do setTitleI title $(widgetFile "workflows/workflow-list") + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''JsonWorkflowWorkflow + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''JsonWorkflowAction + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''JsonWorkflowInstance + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''JsonWorkflowPayload + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + , fieldLabelModifier = camelToPathPiece' 1 + } ''JsonWorkflowUser diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 26a31b2e6..f63f95e43 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -22,7 +22,7 @@ import qualified Data.Set as Set import qualified Data.Sequence as Seq import qualified Control.Monad.State.Class as State -import Control.Monad.Trans.RWS.Strict (RWST, execRWST) +import Control.Monad.Trans.RWS.Strict (RWST) import qualified Crypto.Saltine.Class as Saltine import qualified Data.Binary as Binary @@ -36,7 +36,7 @@ import qualified Data.Scientific as Scientific import Text.Blaze (toMarkup) import Data.Void (absurd) -import Data.List (inits) +import qualified Data.Conduit.Combinators as C data WorkflowHistoryItemActor' user = WHIASelf | WHIAOther (Maybe user) | WHIAHidden | WHIAGone @@ -108,14 +108,10 @@ workflowR rScope cID = do , HandlerSite m ~ UniWorX , MonadCatch m ) - => WorkflowStateIndex - -> Maybe WorkflowGraphNodeLabel - -> [WorkflowAction FileReference UserId] - -> WorkflowAction FileReference UserId + => WorkflowActionInfo FileReference UserId -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) () - go stIx wpFrom history@(workflowStateCurrentPayloads -> currentPayload) act@WorkflowAction{..} = maybeT (return ()) $ do + go WorkflowActionInfo{ waiIx = stIx, waiFrom = wpFrom, waiHistory = history@(workflowStateCurrentPayloads -> currentPayload), waiAction = WorkflowAction{..} } = maybeT (return ()) $ do mAuthId <- maybeAuthId - guardM . lift . lift . hoist liftHandler $ mayViewWorkflowAction mAuthId wwId act stCID <- encryptWorkflowStateIndex wwId stIx let nodeView nodeLbl = do @@ -160,32 +156,18 @@ workflowR rScope cID = do payloadSort :: WorkflowFieldPayloadW Void (Maybe (Entity User)) -> WorkflowFieldPayloadW Void (Maybe (Entity User)) -> Ordering - payloadSort (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of - (WFPFile a', _ ) -> absurd a' - (_, WFPFile a' ) -> absurd a' - (WFPText a', WFPText b' ) -> compareUnicode a' b' - (WFPText{}, _ ) -> LT - (WFPNumber a', WFPNumber b') -> compare a' b' - (WFPNumber{}, WFPText{} ) -> GT - (WFPNumber{}, _ ) -> LT - (WFPBool a', WFPBool b' ) -> compare a' b' - (WFPBool{}, WFPText{} ) -> GT - (WFPBool{}, WFPNumber{} ) -> GT - (WFPBool{}, _ ) -> LT - (WFPDay a', WFPDay b' ) -> compare a' b' - (WFPDay{}, WFPText{} ) -> GT - (WFPDay{}, WFPNumber{} ) -> GT - (WFPDay{}, WFPBool{} ) -> GT - (WFPDay{}, _ ) -> LT - (WFPUser a', WFPUser b' ) -> case (a', b') of - (Nothing, _) -> GT - (_, Nothing) -> LT - (Just (Entity _ uA), Just (Entity _ uB)) - -> (compareUnicode `on` userSurname) uA uB - <> (compareUnicode `on` userDisplayName) uA uB - <> comparing userIdent uA uB - (WFPUser{}, _ ) -> GT - forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any). forM_ payloads $ \case + payloadSort = workflowPayloadSort ordFiles ordUsers + where + ordFiles = absurd + ordUsers a' b' = case (a', b') of + (Nothing, _) -> GT + (_, Nothing) -> LT + (Just (Entity _ uA), Just (Entity _ uB)) + -> (compareUnicode `on` userSurname) uA uB + <> (compareUnicode `on` userDisplayName) uA uB + <> comparing userIdent uA uB + + forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl . bool Nothing (Just fRoute) . getAny) <=< execWriterT @_ @(_, Any) . forM_ payloads $ \case WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t) WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) @@ -215,14 +197,8 @@ workflowR rScope cID = do , pure WorkflowHistoryItem{..} ) WorkflowGraph{..} = wGraph - wState = otoList $ review _DBWorkflowState workflowWorkflowState - in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . (\act -> execRWST act () Map.empty) $ sequence_ - [ go stIx fromSt payload act - | fromSt <- Nothing : map (Just . wpTo) wState - | act <- wState - | stIx <- [minBound..] - | payload <- tailEx $ inits wState - ] + wState = review _DBWorkflowState workflowWorkflowState + in fmap (over _2 (sortOn (Down . whiTime) . reverse) . view _2) . runConduit $ sourceWorkflowActionInfos wwId wState .| execRWSC () Map.empty (C.mapM_ go) return (mEdge, (workflowState, workflowHistory)) sequenceOf_ (_Just . _1 . _1 . _Just) mEdge diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index eb81283f3..ce27b4f1a 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -22,8 +22,10 @@ module Model.Types.Workflow , WorkflowPayloadLabel(..) , WorkflowStateIndex(..), workflowStateIndex, workflowStateSection , WorkflowState + , WorkflowActionInfo(..), workflowActionInfos , WorkflowAction(..), _wpTo, _wpVia, _wpPayload, _wpUser, _wpTime , WorkflowFieldPayloadW(..), _WorkflowFieldPayloadW, IsWorkflowFieldPayload', IsWorkflowFieldPayload + , workflowPayloadSort , WorkflowFieldPayload(..), _WorkflowFieldPayload , workflowStatePayload, workflowStateCurrentPayloads , WorkflowChildren @@ -59,6 +61,10 @@ import Unsafe.Coerce import Utils.Lens.TH +import Data.List (inits) + +import Data.RFC5051 (compareUnicode) + ----- WORKFLOW GRAPH ----- @@ -364,6 +370,23 @@ data WorkflowAction fileid userid = WorkflowAction } deriving (Eq, Ord, Show, Generic, Typeable) +data WorkflowActionInfo fileid userid = WorkflowActionInfo + { waiIx :: WorkflowStateIndex + , waiFrom :: Maybe WorkflowGraphNodeLabel + , waiHistory :: [WorkflowAction fileid userid] + , waiAction :: WorkflowAction fileid userid + } deriving (Eq, Ord, Show, Generic, Typeable) + +workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid] +workflowActionInfos wState + = [ WorkflowActionInfo{..} + | waiFrom <- Nothing : map (Just . wpTo) wState' + | waiAction <- wState' + | waiIx <- [minBound..] + | waiHistory <- tailEx $ inits wState' + ] + where wState' = otoList wState + data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) deriving (Typeable) @@ -395,6 +418,35 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work (WFPFile{}, _) -> LT (WFPUser{}, _) -> GT +workflowPayloadSort + :: forall fileid userid. + (fileid -> fileid -> Ordering) + -> (userid -> userid -> Ordering) + -> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering) +workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of + (WFPText a', WFPText b' ) -> compareUnicode a' b' + (WFPText{}, _ ) -> LT + (WFPNumber a', WFPNumber b') -> compare a' b' + (WFPNumber{}, WFPText{} ) -> GT + (WFPNumber{}, _ ) -> LT + (WFPBool a', WFPBool b' ) -> compare a' b' + (WFPBool{}, WFPText{} ) -> GT + (WFPBool{}, WFPNumber{} ) -> GT + (WFPBool{}, _ ) -> LT + (WFPDay a', WFPDay b' ) -> compare a' b' + (WFPDay{}, WFPText{} ) -> GT + (WFPDay{}, WFPNumber{} ) -> GT + (WFPDay{}, WFPBool{} ) -> GT + (WFPDay{}, _ ) -> LT + (WFPFile a', WFPFile b' ) -> ordFiles a' b' + (WFPFile{}, WFPText{} ) -> GT + (WFPFile{}, WFPNumber{} ) -> GT + (WFPFile{}, WFPBool{} ) -> GT + (WFPFile{}, WFPDay{} ) -> GT + (WFPFile{}, _ ) -> LT + (WFPUser a', WFPUser b' ) -> ordUsers a' b' + (WFPUser{}, _ ) -> GT + instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where show (WorkflowFieldPayloadW payload) = show payload diff --git a/src/Utils.hs b/src/Utils.hs index feeaa9adc..0302d34c9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -17,6 +17,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as CBS import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -222,7 +223,22 @@ delimitInternalState act = bracket createInternalState closeInternalState $ \new = HandlerData { handlerResource = newInternalState , .. } - + +selectRep' :: [(ContentType, a)] -> ContentType -> Maybe a +selectRep' cMap _ | null cMap = Nothing +selectRep' cMap' needle = asum + [ guardOnM (needleMain == "*" && needleSub == "*") $ preview (folded . _2) cMap' + , guardOnM (needleSub == "*") $ preview (folded . filtered (views _1 $ views _1 (== needleMain) . contentTypeTypes) . _2) cMap' + , Map.lookup needle cMap + , Map.lookup (noSpaces needle) cMap + , Map.lookup (simpleContentType needle) cMap + ] + where + cMap = Map.fromListWith const $ over _1 <$> [id, noSpaces, simpleContentType] <*> cMap' + + (needleMain, needleSub) = contentTypeTypes needle + + noSpaces = CBS.filter (/= ' ') --------------------- -- Text and String -- diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index c291ba7ee..c2fc930fa 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -14,11 +14,12 @@ import Settings.Mime import Data.Csv hiding (Name) import Data.Csv.Conduit (CsvParseError) +import qualified Data.Csv.Incremental as Incremental import Language.Haskell.TH (Name) import Language.Haskell.TH.Lib -import Yesod.Core.Content (ContentType, simpleContentType) +import Yesod.Core.Content import qualified Data.Map as Map @@ -54,6 +55,17 @@ data CsvRendered = CsvRendered , csvRenderedData :: [NamedRecord] } deriving (Eq, Read, Show, Generic, Typeable) +instance ToContent CsvRendered where + toContent CsvRendered{..} = toContent . Incremental.encodeByName csvRenderedHeader $ foldr ((<>) . Incremental.encodeNamedRecord) mempty csvRenderedData + +instance ToTypedContent CsvRendered where + toTypedContent = TypedContent + <$> getContentType . Identity + <*> toContent + +instance HasContentType CsvRendered where + getContentType _ = typeCsv' + toCsvRendered :: forall mono. ( ToNamedRecord (Element mono) , MonoFoldable mono diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index fd2e7abd3..5d8faa79f 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -31,6 +31,7 @@ data GlobalGetParam = GetLang | GetDryRun | GetDownload | GetError + | GetSelectTable deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite)