From 605abda65a6fdf8dda3610452a9ef0c45bddfd90 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 4 May 2021 13:10:31 +0200 Subject: [PATCH 01/21] refactor: improve dbTable performance --- src/Data/CaseInsensitive/Instances.hs | 4 + src/Foundation/Authorization.hs | 12 +- src/Handler/Admin/StudyFeatures.hs | 12 +- src/Handler/Allocation/List.hs | 6 +- src/Handler/Allocation/Users.hs | 2 +- src/Handler/Course/Application/List.hs | 4 +- src/Handler/Course/List.hs | 4 +- src/Handler/Course/Show.hs | 2 +- src/Handler/Course/User.hs | 4 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/List.hs | 4 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/ExamOffice/Exam.hs | 4 +- src/Handler/ExamOffice/Exams.hs | 69 ++++++-- src/Handler/ExternalExam/List.hs | 4 +- src/Handler/Material.hs | 6 +- src/Handler/News.hs | 8 +- src/Handler/Profile.hs | 22 +-- src/Handler/School.hs | 3 +- src/Handler/Sheet/List.hs | 6 +- src/Handler/Sheet/Show.hs | 7 +- src/Handler/Submission/Helper.hs | 2 +- src/Handler/Submission/List.hs | 42 +++-- src/Handler/SystemMessage.hs | 8 +- src/Handler/Term.hs | 2 +- src/Handler/Tutorial/List.hs | 2 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/ExternalExam/Users.hs | 4 +- src/Handler/Utils/Table/Columns.hs | 32 ++-- src/Handler/Utils/Table/Pagination.hs | 166 ++++++++++++++----- src/Handler/Utils/Workflow/EdgeForm.hs | 3 +- src/Handler/Utils/Workflow/Workflow.hs | 1 - src/Handler/Workflow/Definition/List.hs | 6 +- src/Handler/Workflow/Instance/List.hs | 9 +- src/Handler/Workflow/Workflow/List.hs | 204 ++++++++++++++---------- src/Model/Types/Workflow.hs | 39 ++++- src/Utils.hs | 15 ++ src/Utils/Workflow.hs | 62 ++++++- test/Model/Types/WorkflowSpec.hs | 2 + 39 files changed, 541 insertions(+), 247 deletions(-) diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 00e9968fa..eadbd421b 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -88,6 +88,10 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where fromPathPiece = fmap CI.mk . fromPathPiece toPathPiece = toPathPiece . CI.original +instance PathPiece [CI Char] where + fromPathPiece = fmap (map CI.mk . (unpack :: Text -> [Char])) . fromPathPiece + toPathPiece = toPathPiece . (pack :: [Char] -> Text) . map CI.original + instance ToHttpApiData s => ToHttpApiData (CI s) where toUrlPiece = toUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index cd0c34b01..ff547456f 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1967,7 +1967,9 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro evalWorkflowRoleFor' :: forall m backend. ( HasCallStack + , MonadHandler m, HandlerSite m ~ UniWorX , MonadAP (ReaderT backend m), MonadIO m + , MonadThrow m , BackendCompatible SqlReadBackend backend ) => (forall m'. MonadAP m' => AuthTagsEval m') @@ -2006,7 +2008,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do uid <- maybeExceptT AuthenticationRequired $ return mAuthId wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId - WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId + Entity _ WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift $ getWorkflowWorkflowState wwId + -- WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState unless (uid `Set.member` uids) $ throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch @@ -2015,6 +2018,8 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do evalWorkflowRoleFor :: ( HasCallStack , MonadAP (ReaderT backend m), MonadIO m + , MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m , BackendCompatible SqlReadBackend backend ) => Maybe UserId @@ -2038,8 +2043,9 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do hasWorkflowRole :: ( HasCallStack , MonadAP (ReaderT backend m) - , BackendCompatible SqlReadBackend backend , MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + , BackendCompatible SqlReadBackend backend ) => Maybe WorkflowWorkflowId -> WorkflowRole UserId @@ -2065,7 +2071,7 @@ mayViewWorkflowAction' :: forall backend m fileid. -> WorkflowAction fileid UserId -> WriterT (Set AuthTag) (ReaderT backend m) Bool mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT $ projectBackend @SqlReadBackend) . maybeT (return False) $ do - WorkflowWorkflow{..} <- MaybeT . lift $ get wwId + Entity _ WorkflowWorkflow{..} <- MaybeT . lift $ getWorkflowWorkflowState wwId rScope <- hoist lift . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope cID <- catchMaybeT (Proxy @CryptoIDError) . lift . lift $ encrypt wwId WorkflowGraph{..} <- lift . lift $ getSharedIdWorkflowGraph workflowWorkflowGraph diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs index 9241198d7..f32357363 100644 --- a/src/Handler/Admin/StudyFeatures.hs +++ b/src/Handler/Admin/StudyFeatures.hs @@ -326,7 +326,7 @@ postAdminFeaturesR = do dbtSQLQuery :: E.SqlExpr (Entity StudyDegree) -> E.SqlQuery (E.SqlExpr (Entity StudyDegree)) dbtSQLQuery = return dbtRowKey = (E.^. StudyDegreeKey) - dbtProj = return + dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat [ sortable (Just "key") (i18nCell MsgGenericKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) , sortable (Just "name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName) (_dbrOutput . _entityKey)) @@ -356,7 +356,7 @@ postAdminFeaturesR = do dbtSQLQuery :: E.SqlExpr (Entity StudyTerms) -> E.SqlQuery (E.SqlExpr (Entity StudyTerms)) dbtSQLQuery = return dbtRowKey = (E.^. StudyTermsKey) - dbtProj field@(view _dbrOutput -> Entity fId _) = do + dbtProj = dbtProjSimple $ \field@(Entity fId _) -> do fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do E.where_ . E.exists . E.from $ \schoolTerms -> E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId @@ -368,7 +368,7 @@ postAdminFeaturesR = do E.where_ $ subTerms E.^. StudySubTermsChild E.==. E.val fId E.&&. subTerms E.^. StudySubTermsParent E.==. terms E.^. StudyTermsId return terms - return $ field & _dbrOutput %~ (, fieldParents, fieldSchools) + return (field, fieldParents, fieldSchools) dbtColonnade = formColonnade $ mconcat [ sortable (Just "key") (i18nCell MsgGenericKey) (maybe mempty numCell . preview (_dbrOutput . _1 . _entityVal . _studyTermsKey)) , sortable Nothing (i18nCell MsgStudySubTermsParentKey) (parentsCell _4 (_dbrOutput . _2 . to (Set.map entityKey)) _dbrKey') @@ -416,7 +416,7 @@ postAdminFeaturesR = do dbtSQLQuery :: E.SqlExpr (Entity StudyTermNameCandidate) -> E.SqlQuery ( E.SqlExpr (Entity StudyTermNameCandidate)) dbtSQLQuery = return dbtRowKey = (E.^. StudyTermNameCandidateId) - dbtProj = return + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateKey)) , sortable (Just "name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermNameCandidateName)) @@ -459,7 +459,7 @@ postAdminFeaturesR = do E.on $ parent E.?. StudyTermsKey E.==. E.just (candidate E.^. StudySubTermParentCandidateParent) return (candidate, parent, child) dbtRowKey = queryCandidate >>> (E.^. StudySubTermParentCandidateId) - dbtProj = return + dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "child") (i18nCell MsgStudySubTermsChildKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studySubTermParentCandidateKey)) , sortable (Just "child-name") (i18nCell MsgStudySubTermsChildName) (maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _studyTermsName . _Just)) @@ -502,7 +502,7 @@ postAdminFeaturesR = do E.on $ sterm E.?. StudyTermsKey E.==. E.just (candidate E.^. StudyTermStandaloneCandidateKey) return (candidate, sterm) dbtRowKey = queryCandidate >>> (E.^. StudyTermStandaloneCandidateId) - dbtProj = return + dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat [ sortable (Just "key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _1 . _entityVal . _studyTermStandaloneCandidateKey)) , sortable (Just "name") (i18nCell MsgStudyTermsName) (maybe mempty i18nCell . preview (_dbrOutput . _2 . _Just . _entityVal . _studyTermsName . _Just)) diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index d0e705419..1dcc6a715 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -77,8 +77,10 @@ getAllocationListR = do <*> view (queryAvailable muid ata now) <*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid) - dbtProj :: DBRow _ -> DB AllocationTableData - dbtProj = return . over (_dbrOutput . _2) (fromIntegral . E.unValue) . over (_dbrOutput . _3) (fromIntegral . E.unValue) + dbtProj :: _ AllocationTableData + dbtProj = dbtProjId + <&> _dbrOutput . _2 %~ fromIntegral . E.unValue + <&> _dbrOutput . _3 %~ fromIntegral . E.unValue dbtRowKey = view $ queryAllocation . to (E.^. AllocationId) diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs index 2b3acfc92..5316a3af8 100644 --- a/src/Handler/Allocation/Users.hs +++ b/src/Handler/Allocation/Users.hs @@ -187,7 +187,7 @@ postAUsersR tid ssh ash = do , assigned , vetoed) dbtRowKey = views queryAllocationUser (E.^. AllocationUserId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do + dbtProj = dbtProjSimple . runReaderT $ do feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey (,,,,,) <$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value) diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index 2007e8327..dcd1090fb 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -271,8 +271,8 @@ postCApplicationsR tid ssh csh = do , E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId ) - dbtProj :: DBRow _ -> DB CourseApplicationsTableData - dbtProj = traverse $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do + dbtProj :: _ CourseApplicationsTableData + dbtProj = dbtProjSimple $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey) return (application, user, hasFiles, allocation, isParticipant, feats) diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 92a96ffa5..a2f41be46 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -90,8 +90,8 @@ makeCourseTable whereClause colChoices psValidator = do return user isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course E.&&. E.just (user E.^. UserId) E.==. E.val muid - dbtProj :: DBRow _ -> DB CourseTableData - dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do + dbtProj :: _ CourseTableData + dbtProj = dbtProjSimple $ \(course, E.Value participants, E.Value registered, school) -> do lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course) >>= traverse (getJustEntity . allocationCourseAllocation . entityVal) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index abad8669c..f78f6e2ef 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -169,7 +169,7 @@ getCShowR tid ssh csh = do E.||. E.not_ (tutorial E.^. TutorialRoomHidden) return (tutorial, showRoom) dbtRowKey = (E.^. TutorialId) - dbtProj = traverse $ return . over _2 E.unValue + dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 14902c5e9..2171e7c03 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do ] return exam dbtRowKey = (E.^. ExamId) - dbtProj = traverse $ \exam@(Entity eId _) -> do + dbtProj = dbtProjSimple $ \exam@(Entity eId _) -> do registration <- getBy $ UniqueExamRegistration eId uid occurrence <- runMaybeT $ do Entity _ ExamRegistration{..} <- hoistMaybe registration @@ -444,7 +444,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid return (tutorial, tutorialParticipant) dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId - dbtProj = traverse $ \(tutorial, tutorialParticipant) -> do + dbtProj = dbtProjSimple $ \(tutorial, tutorialParticipant) -> do tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index cd3b6f2df..63f55577b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -375,7 +375,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q) dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do + dbtProj = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] [] exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] [] subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index d05528227..5c645afa6 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -29,7 +29,7 @@ mkExamTable (Entity cid Course{..}) = do E.where_ $ exam E.^. ExamCourse E.==. E.val cid return exam dbtRowKey = (E.^. ExamId) - dbtProj = return + dbtProj = dbtProjFilteredPostId dbtColonnade = dbColonnade . mconcat $ catMaybes [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom @@ -61,7 +61,7 @@ mkExamTable (Entity cid Course{..}) = do E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId ) ] - dbtFilter = singletonMap "may-read" . FilterProjected $ + dbtFilter = singletonMap "may-read" . mkFilterProjectedPost $ \(Any b) DBRow{ dbrOutput = Entity _ Exam{..} } -> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool dbtFilterUI = const mempty diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 1ae091831..573833353 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -454,7 +454,7 @@ postEUsersR tid ssh csh examn = do return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote) dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + dbtProj = dbtProjSimple . runReaderT $ (,,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> getExamParts diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 381e2def7..663763f9c 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -302,8 +302,8 @@ postEGradesR tid ssh csh examn = do return (examResult, user, occurrence, examRegistration, isSynced) dbtRowKey = views queryExamResult (E.^. ExamResultId) - dbtProj :: DBRow _ -> DB ExamUserTableData - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + dbtProj :: _ ExamUserTableData + dbtProj = dbtProjSimple . runReaderT $ (,,,,,,) <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value) <*> getSynchronised diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs index 7b98ed007..a272d3662 100644 --- a/src/Handler/ExamOffice/Exams.hs +++ b/src/Handler/ExamOffice/Exams.hs @@ -18,6 +18,22 @@ import qualified Colonnade import qualified Data.Conduit.Combinators as C +data ExamsTableFilterProj = ExamsTableFilterProj + { etProjFilterMayAccess :: Maybe Bool + , etProjFilterHasResults :: Maybe Bool + , etProjFilterIsSynced :: Maybe Bool + } + +instance Default ExamsTableFilterProj where + def = ExamsTableFilterProj + { etProjFilterMayAccess = Nothing + , etProjFilterHasResults = Nothing + , etProjFilterIsSynced = Nothing + } + +makeLenses_ ''ExamsTableFilterProj + + type ExamsTableExpr = ( E.SqlExpr (Maybe (Entity Exam)) `E.InnerJoin` E.SqlExpr (Maybe (Entity Course)) `E.InnerJoin` E.SqlExpr (Maybe (Entity School)) @@ -101,12 +117,33 @@ getEOExamsR = do return (exam, course, school, externalExam) dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId)) - dbtProj :: DBRow _ -> DB ExamsTableData - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do - exam <- view _1 - course <- view _2 - school <- view _3 - externalExam <- view _4 + -- [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if + -- | Just exam <- r ^? resultExam . _entityVal + -- , Just course <- r ^? resultCourse . _entityVal + -- -> hasReadAccessTo . urlRoute $ examLink course exam + -- | Just eexam <- r ^? resultExternalExam . _entityVal + -- -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool + -- | otherwise + -- -> return $ error "Got neither exam nor externalExam in result" + -- , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool) + -- , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool) + -- ] + + dbtProj :: _ ExamsTableData + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do -- dbtProjSimple . runReaderT $ do + exam <- view $ _dbtProjRow . _dbrOutput . _1 + course <- view $ _dbtProjRow . _dbrOutput . _2 + school <- view $ _dbtProjRow . _dbrOutput . _3 + externalExam <- view $ _dbtProjRow . _dbrOutput . _4 + + forMM_ (view $ _dbtProjFilter . _etProjFilterMayAccess) $ \b -> if + | Just (Entity _ exam') <- exam + , Just (Entity _ course') <- course + -> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ examLink course' exam' + | Just (Entity _ eexam) <- externalExam + -> guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ externalExamLink eexam + | otherwise + -> error "Got neither exam nor externalExam in result" let getExamResults = for_ exam $ \(Entity examId _) -> E.selectSource . E.from $ \examResult -> do @@ -119,7 +156,12 @@ getEOExamsR = do return $ ExternalExam.resultIsSynced (E.val uid) externalExamResult getResults = getExamResults >> getExternalExamResults foldResult (E.Value isSynced) = (Sum 1, guardMonoid isSynced $ Sum 1) - (Sum resultCount, Sum syncedCount) <- lift . runConduit $ getResults .| C.foldMap foldResult + (Sum resultCount, Sum syncedCount) <- lift . lift . runConduit $ getResults .| C.foldMap foldResult + + forMM_ (view $ _dbtProjFilter . _etProjFilterHasResults) $ \b -> + guard $ b == (resultCount > 0) + forMM_ (view $ _dbtProjFilter . _etProjFilterIsSynced) $ \b -> + guard $ b == (syncedCount >= resultCount) case (exam, course, school, externalExam) of (Just exam', Just course', Just school', Nothing) -> return @@ -189,16 +231,9 @@ getEOExamsR = do ] dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if - | Just exam <- r ^? resultExam . _entityVal - , Just course <- r ^? resultCourse . _entityVal - -> hasReadAccessTo . urlRoute $ examLink course exam - | Just eexam <- r ^? resultExternalExam . _entityVal - -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool - | otherwise - -> return $ error "Got neither exam nor externalExam in result" - , singletonMap "has-results" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultResults > 0) :: DB Bool) - , singletonMap "is-synced" . FilterProjected $ \(Any b) r -> (return $ b == (r ^. resultSynchronised >= r ^. resultResults) :: DB Bool) + [ singletonMap "may-access" . FilterProjected $ (_etProjFilterMayAccess ?~) . getAny + , singletonMap "has-results" . FilterProjected $ (_etProjFilterHasResults ?~) . getAny + , singletonMap "is-synced" . FilterProjected $ (_etProjFilterIsSynced ?~) . getAny ] dbtFilterUI = mconcat [ flip (prismAForm $ singletonFilter "is-synced" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamSynchronised) diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs index 738ef5fe1..aca05c75f 100644 --- a/src/Handler/ExternalExam/List.hs +++ b/src/Handler/ExternalExam/List.hs @@ -46,7 +46,7 @@ getEExamListR = do return (eexam, school) dbtRowKey = queryEExam >>> (E.^. ExternalExamId) - dbtProj = return + dbtProj = dbtProjFilteredPostId dbtColonnade = widgetColonnade $ mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm , sortable (Just "school") (i18nCell MsgSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName @@ -60,7 +60,7 @@ getEExamListR = do , ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName)) ] dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$> + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$> hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool ] dbtFilterUI = const mempty diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 65c853db4..caad3bddd 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -111,7 +111,7 @@ getMaterialListR tid ssh csh = do E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId return (material, filesNum) , dbtRowKey = (E.^. MaterialId) - , dbtProj = return + , dbtProj = dbtProjFilteredPostId , dbtColonnade = widgetColonnade $ mconcat [ -- dbRow, sortable (Just "type") (i18nCell MsgMaterialType) @@ -138,7 +138,7 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool ] , dbtFilterUI = mempty @@ -237,7 +237,7 @@ getMShowR tid ssh csh mnm = do in anchorCellM matLink wgt , materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified)) ] - , dbtProj = return + , dbtProj = dbtProjId , dbtStyle = def , dbtParams = def , dbtFilter = mempty diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 5124d597d..3047973b8 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -161,7 +161,7 @@ newsUpcomingSheets uid = do { dbtSQLQuery = tableData , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtColonnade = colonnade - , dbtProj = return + , dbtProj = dbtProjFilteredPostId , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm @@ -183,7 +183,7 @@ newsUpcomingSheets uid = do ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} -> + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term) , E.Value SchoolId , E.Value CourseShorthand @@ -252,7 +252,7 @@ newsUpcomingExams uid = do E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden) return (course, exam, register, occurrence, showRoom) dbtRowKey = queryExam >>> (E.^. ExamId) - dbtProj = return + dbtProj = dbtProjFilteredPostId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } -> msgCell courseTerm @@ -323,7 +323,7 @@ newsUpcomingExams uid = do )) ] dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} -> + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index cb7d70549..62d6f976b 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -504,7 +504,7 @@ mkOwnedCoursesTable = , course E.^. CourseShorthand ) dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId - dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))) + dbtProj = dbtProjId <&> _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do @@ -556,7 +556,7 @@ mkEnrolledCoursesTable = E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive return (course, participant E.^. CourseParticipantRegistration) , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId - , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue + , dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue , dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) @@ -620,10 +620,10 @@ mkSubmissionTable = E.&&. subEdit E.^. SubmissionEditUser E.==. E.val (Just uid) return . E.max_ $ subEdit E.^. SubmissionEditTime - dbtProj x = return $ x - & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) - & _dbrOutput . _2 %~ E.unValue - & _dbrOutput . _4 %~ E.unValue + dbtProj = dbtProjId + <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + <&> _dbrOutput . _2 %~ E.unValue + <&> _dbrOutput . _4 %~ E.unValue dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ @@ -697,8 +697,8 @@ mkSubmissionGroupTable = return (crse, sgroup) dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId - dbtProj x = return $ x - & _dbrOutput . _1 %~ $(E.unValueN 3) + dbtProj = dbtProjId + <&> _dbrOutput . _1 %~ $(E.unValueN 3) dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ @@ -764,9 +764,9 @@ mkCorrectionsTable = return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet)) dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId - dbtProj x = return $ x - & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) - & _dbrOutput . _2 %~ E.unValue + dbtProj = dbtProjId + <&> _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + <&> _dbrOutput . _2 %~ E.unValue dbtColonnade = mconcat [ sortable (Just "term") (i18nCell MsgTerm) $ diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 7d590b6c4..18fe80d86 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -19,8 +19,7 @@ getSchoolListR = do dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ dbtSQLQuery = return - dbtProj :: DBRow _ -> DB (DBRow (Entity School)) - dbtProj = return + dbtProj = dbtProjId dbtRowKey = (E.^. SchoolId) diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs index 86708390d..9b6f2289c 100644 --- a/src/Handler/Sheet/List.hs +++ b/src/Handler/Sheet/List.hs @@ -129,7 +129,7 @@ getSheetListR tid ssh csh = do ) return (sheet, lastSheetEdit sheet, submission, existFiles) , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId - , dbtProj = return + , dbtProj = dbtProjFilteredPostId , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName @@ -157,11 +157,11 @@ getSheetListR tid ssh csh = do -- ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} -> + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool)) in (== b) <$> sheetFilter sheetName :: DB Bool , singletonMap "rated" . FilterColumn $ \(Any b) -> (E.==. E.val b) . E.isJust . (E.?. SubmissionRatingTime) . querySubmission - , singletonMap "is-exam" . FilterProjected $ \(Any b) DBRow{..} -> + , singletonMap "is-exam" . mkFilterProjectedPost $ \(Any b) DBRow{..} -> let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool)) in return $ is _ExamPartPoints sheetType == b :: DB Bool ] diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 4603474f6..240b41d7e 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -71,12 +71,11 @@ getSShowR tid ssh csh shn = do { dbtSQLQuery = fileData , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId) , dbtColonnade = colonnadeFiles - , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference)) + , dbtProj = (dbrOutput :: _ -> (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))) <$> dbtProjFilteredPostId , dbtStyle = def , dbtFilter = mconcat - [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> - let (E.Value fName, _, E.Value fType, _) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference)) - in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{ dbrOutput = (E.Value fName, _ :: E.Value UTCTime, E.Value fType, _ :: E.Value (Maybe FileContentReference)) } -> + (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool ] , dbtFilterUI = mempty , dbtIdent = "files" :: Text diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index a148b289a..c7a947164 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -545,7 +545,7 @@ submissionHelper tid ssh csh shn mcid = do { dbtSQLQuery = submissionFiles smid , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId) , dbtColonnade = colonnadeFiles cid - , dbtProj = return . dbrOutput + , dbtProj = dbrOutput <$> dbtProjId , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = Map.fromList diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 7e569f92a..1370b6e63 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -37,6 +37,17 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +newtype CorrectionTableFilterProj = CorrectionTableFilterProj + { corrProjFilterSubmission :: Maybe (Set [CI Char]) + } + +instance Default CorrectionTableFilterProj where + def = CorrectionTableFilterProj + { corrProjFilterSubmission = Nothing + } + +makeLenses_ ''CorrectionTableFilterProj + type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool) type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -}) @@ -225,9 +236,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams ) in (submission, sheet, crse, corrector, lastEditQuery submission) ) - dbtProj :: DBRow _ -> DB CorrectionTableData - dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do - submittors <- E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput + cid <- encrypt sId + forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria -> + let haystack = map CI.mk . unpack $ toPathPiece cid + in guard $ any (`isInfixOf` haystack) criteria + + submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId) E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId @@ -238,13 +254,14 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId return . E.just $ submissionGroup E.^. SubmissionGroupName + return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') let submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors - nonAnonymousAccess <- or2M + nonAnonymousAccess <- lift . lift $ or2M (return $ not sheetAnonymousCorrection) (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR) - cid <- encrypt sId + return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess) dbTable psValidator DBTable { dbtSQLQuery @@ -397,10 +414,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment) ) , ( "submission" - , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) -> - let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7 - criteria' = map CI.mk . unpack <$> Set.toList criteria - in any (`isInfixOf` cid) criteria' + , FilterProjected (_corrProjFilterSubmission ?~) + -- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) -> + -- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7 + -- criteria' = map CI.mk . unpack <$> Set.toList criteria + -- in any (`isInfixOf` cid) criteria' ) ] , dbtFilterUI = fromMaybe mempty dbtFilterUI @@ -662,7 +680,7 @@ postCorrectionsR = do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses termOptions = runDB $ do - courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) + courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses schoolOptions = runDB $ do courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) @@ -671,8 +689,8 @@ postCorrectionsR = do psValidator = def & restrictCorrector & restrictAnonymous - & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] - -- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN + & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ] + & defaultFilter (singletonMap "israted" [toPathPiece False]) correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction ] diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index f2e10f609..87c19fd96 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -184,12 +184,8 @@ postMessageListR = do Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) in cell . toWidget $ fromMaybe content summary ] - dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do - smT <- (>>= view _2) <$> getSystemMessage smId - return DBRow - { dbrOutput = (smE, smT) - , .. - } + dbtProj = dbtProjSimple $ \smE@(Entity smId _) -> + (smE, ) . (>>= view _2) <$> getSystemMessage smId psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData)) (tableRes', tableView) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 18c5b1c47..d616420f3 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -76,7 +76,7 @@ getTermShowR = do E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm E.&&. mayViewCourse muid ata now course Nothing dbtRowKey = (E.^. TermId) - dbtProj = return . dbrOutput + dbtProj = dbrOutput <$> dbtProjId dbtColonnade = widgetColonnade $ mconcat [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _) -> cell $ do diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 5b2006ca6..e9026cc6b 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -38,7 +38,7 @@ getCTutorialListR tid ssh csh = do E.||. E.not_ (tutorial E.^. TutorialRoomHidden) return (tutorial, participants, showRoom) dbtRowKey = (E.^. TutorialId) - dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue + dbtProj = over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue <$> dbtProjId dbtColonnade = dbColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a2ba0c97d..8a0e541df 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -143,7 +143,7 @@ postUsersR = do { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtRowKey = (E.^. UserId) , dbtColonnade - , dbtProj = return + , dbtProj = dbtProjId , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \user -> user E.^. UserSurname diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs index 01969bb51..8605dabd7 100644 --- a/src/Handler/Utils/ExternalExam/Users.hs +++ b/src/Handler/Utils/ExternalExam/Users.hs @@ -215,8 +215,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do return (result, user, isSynced) dbtRowKey = views queryResult (E.^. ExternalExamResultId) - dbtProj :: DBRow _ -> DB ExternalExamUserTableData - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + dbtProj :: _ ExternalExamUserTableData + dbtProj = dbtProjSimple . runReaderT $ (,,,,) <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> getSynchronised diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index fdf602f60..898330a96 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -70,10 +70,10 @@ type OpticSortColumn' focus type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val)) type OpticFilterColumn' t inp focus - = forall r' filterMap. + = forall fs filterMap. ( IsMap filterMap , ContainerKey filterMap ~ FilterKey - , MapValue filterMap ~ FilterColumn t r' + , MapValue filterMap ~ FilterColumn t fs , IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool)) ) => (forall focus'. Getting focus' t focus) @@ -500,37 +500,37 @@ defaultSortingByName = defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter -- | Alias for sortUserName for consistency -fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t r') +fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t fs) fltrUserNameLink = fltrUserName fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname)) fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) -- | Search all names, i.e. DisplayName, Surname, EMail fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter [ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName) , mkContainsFilter $ queryUser >>> (E.^. UserSurname) @@ -579,7 +579,7 @@ fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bo , IsString d ) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -599,7 +599,7 @@ fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bo , IsString d ) => (a -> E.SqlExpr (Entity User)) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -724,7 +724,7 @@ fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value B , IsString d ) => (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) @@ -742,7 +742,7 @@ fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) , IsString d ) => (a -> E.SqlExpr (Maybe (Entity StudyTerms))) - -> (d, FilterColumn t r') + -> (d, FilterColumn t fs) fltrField queryFeatures = ( "terms" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) @@ -763,10 +763,10 @@ sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) - sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand)) fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)) - , IsString d - ) - => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) - -> (d, FilterColumn t r') + , IsString d + ) + => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) + -> (d, FilterColumn t fs) fltrDegree queryFeatures = ( "degree" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 27827d25b..0f4e34c96 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Utils.Table.Pagination ( module Handler.Utils.Table.Pagination.Types @@ -7,14 +8,19 @@ module Handler.Utils.Table.Pagination , SortColumn(..), SortDirection(..) , SortingSetting(..) , pattern SortAscBy, pattern SortDescBy - , FilterColumn(..), IsFilterColumn + , FilterColumn(..), IsFilterColumn, IsFilterProjected + , mkFilterProjectedPost + , DBTProjFilterPost(..) , DBRow(..), _dbrOutput, _dbrCount , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..) , module Handler.Utils.Table.Pagination.CsvColumnExplanations , DBCsvActionMode(..) , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew , DBTCsvEncode(..), DBTCsvDecode(..), DBTExtraRep(..) + , DBTProjCtx(..), _dbtProjFilter, _dbtProjRow, _dbtProjRow' , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..) + , dbtProjId, dbtProjSimple + , dbtProjFilteredPostId, dbtProjFilteredPostSimple , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , withCsvExtraRep , singletonFilter @@ -200,16 +206,50 @@ pattern SortDescBy :: SortingKey -> SortingSetting pattern SortDescBy key = SortingSetting key SortDesc -data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a - | forall a. IsFilterProjected r' a => FilterProjected a +type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k') +data DBRow r = forall k'. DBTableKey k' => DBRow + { dbrKey :: k' + , dbrOutput :: r + , dbrCount :: Int64 + } -filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) +makeLenses_ ''DBRow + +instance Functor DBRow where + fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } + +instance Foldable DBRow where + foldMap f DBRow{..} = f dbrOutput + +instance Traversable DBRow where + traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount + + +newtype DBTProjFilterPost r' = DBTProjFilterPost { unDBTProjFilterPost :: r' -> DB Bool } + +instance Default (DBTProjFilterPost r') where + def = mempty + +instance Semigroup (DBTProjFilterPost r') where + DBTProjFilterPost f <> DBTProjFilterPost g = DBTProjFilterPost $ \r' -> f r' `and2M` g r' + +instance Monoid (DBTProjFilterPost r') where + mempty = DBTProjFilterPost . const $ return True + + +data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a + | forall a. IsFilterProjected fs a => FilterProjected a + +filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool)) filterColumn (FilterColumn f) = Just $ filterColumn' f filterColumn _ = Nothing -filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool -filterProjected (FilterProjected f) = flip $ filterProjected' f -filterProjected _ = \_ _ -> return True +filterProjected :: FilterColumn t fs -> [Text] -> (fs -> fs) +filterProjected (FilterProjected f) = filterProjected' f +filterProjected _ = const id + +mkFilterProjectedPost :: forall r' a t. IsFilterProjectedPost r' a => a -> FilterColumn t (DBTProjFilterPost r') +mkFilterProjectedPost fin = FilterProjected $ \(ts :: [Text]) -> (<> filterProjectedPost' @r' fin ts) class IsFilterColumn t a where filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool) @@ -223,21 +263,33 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is' -class IsFilterProjected r' a where - filterProjected' :: a -> [Text] -> r' -> DB Bool +class IsFilterProjected fs a where + filterProjected' :: a -> [Text] -> (fs -> fs) -instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where - filterProjected' fin _ _ = fin +instance IsFilterProjected fs (fs -> fs) where + filterProjected' fin _ = fin -instance IsFilterProjected r' Bool where - filterProjected' fin _ _ = return fin - -instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where - filterProjected' cont is' r = filterProjected' (cont r) is' r - -instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where +instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected fs cont, MonoPointed l, Monoid l) => IsFilterProjected fs (l -> cont) where filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is' +class IsFilterProjectedPost r' a where + filterProjectedPost' :: a -> [Text] -> DBTProjFilterPost r' + +instance IsFilterProjectedPost r' Bool where + filterProjectedPost' fin _ = DBTProjFilterPost . const $ return fin + +instance IsFilterProjectedPost r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where + filterProjectedPost' fin _ = DBTProjFilterPost $ const fin + +instance IsFilterProjectedPost r' (DBTProjFilterPost r') where + filterProjectedPost' fin _ = fin + +instance IsFilterProjectedPost r' cont => IsFilterProjectedPost r' (r' -> cont) where + filterProjectedPost' cont is' = DBTProjFilterPost $ \r' -> let DBTProjFilterPost cont' = filterProjectedPost' (cont r') is' in cont' r' + +instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjectedPost r' cont, MonoPointed l, Monoid l) => IsFilterProjectedPost r' (l -> cont) where + filterProjectedPost' cont is' = filterProjectedPost' (cont $ is' ^. mono' _PathPiece) is' + data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll deriving (Eq, Ord, Read, Show, Generic) @@ -431,24 +483,17 @@ makeLenses_ ''DBCsvException instance (Typeable k', Show k') => Exception (DBCsvException k') - -type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k') -data DBRow r = forall k'. DBTableKey k' => DBRow - { dbrKey :: k' - , dbrOutput :: r - , dbrCount :: Int64 + +data DBTProjCtx fs r = DBTProjCtx + { dbtProjFilter :: fs + , dbtProjRow :: DBRow r } -makeLenses_ ''DBRow +makeLenses_ ''DBTProjCtx -instance Functor DBRow where - fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } +_dbtProjRow' :: Lens' (DBTProjCtx () r) (DBRow r) +_dbtProjRow' = _dbtProjRow -instance Foldable DBRow where - foldMap f DBRow{..} = f dbrOutput - -instance Traversable DBRow where - traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } @@ -579,7 +624,7 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromInner = maybe Map.empty $ Map.singleton key . pure fromOuter = Map.lookup key >=> listToMaybe - + data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv , DBTableKey k' @@ -628,19 +673,20 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException , dbtCsvRenderException :: csvException -> DB Text } -data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar). +data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar) fs. ( ToSortable h, Functor h , E.SqlSelect a r, E.SqlIn k k', DBTableKey k' , PathPiece i, Eq i , E.From t , AsCornice h p r' (DBCell m x) colonnade + , Default fs ) => 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 -> DB r' + , dbtProj :: ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' , dbtColonnade :: colonnade , dbtSorting :: Map SortingKey (SortColumn t r') - , dbtFilter :: Map FilterKey (FilterColumn t r') + , dbtFilter :: Map FilterKey (FilterColumn t fs) , dbtFilterUI :: DBFilterUI , dbtStyle :: DBStyle r' , dbtParams :: DBParams m x @@ -652,6 +698,50 @@ data DBTable m x = forall a r r' h i t k k' csv colonnade (p :: Pillar). type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text]) +dbtProjId' :: forall fs r r'. + DBRow r ~ r' + => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjId' = view _dbtProjRow + +dbtProjId :: forall fs r r'. + ( fs ~ (), DBRow r ~ r' ) + => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjId = dbtProjId' + +dbtProjSimple' :: forall fs r r' r''. + DBRow r'' ~ r' + => (r -> DB r'') + -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjSimple' cont = (views _dbtProjRow . set _dbrOutput) <=< (hoist lift . magnify (_dbtProjRow . _dbrOutput)) $ lift . cont =<< ask + +dbtProjSimple :: forall fs r r' r''. + ( fs ~ (), DBRow r'' ~ r' ) + => (r -> DB r'') + -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjSimple = dbtProjSimple' + +withFilteredPost :: forall fs r r'. + fs ~ DBTProjFilterPost r' + => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' + -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +withFilteredPost proj = do + r' <- proj + p <- views _dbtProjFilter unDBTProjFilterPost + guardM . lift . lift $ p r' + return r' + +dbtProjFilteredPostId :: forall fs r r'. + ( fs ~ DBTProjFilterPost r', DBRow r ~ r' ) + => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjFilteredPostId = withFilteredPost dbtProjId' + +dbtProjFilteredPostSimple :: forall fs r r' r''. + ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' ) + => (r -> DB r'') + -> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r' +dbtProjFilteredPostSimple = withFilteredPost . dbtProjSimple' + + noCsvEncode :: Maybe (DBTCsvEncode r' k' Void) noCsvEncode = Nothing @@ -1115,7 +1205,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = id - allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter' + dbtProjFilter = ala Endo foldMap (psFilter' <&> \(f, args) -> filterProjected f args) def sortProjected | is _Just previousKeys @@ -1130,7 +1220,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db adjustOrder SortDesc EQ = EQ adjustOrder SortDesc GT = LT - (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows' + (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (\dbtProjRow -> runReaderT dbtProj DBTProjCtx{..}) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows' csvExample <- runMaybeT $ do DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs index b5ac09b55..020c1d7fd 100644 --- a/src/Handler/Utils/Workflow/EdgeForm.hs +++ b/src/Handler/Utils/Workflow/EdgeForm.hs @@ -73,6 +73,7 @@ workflowEdgeForm :: ( MonadHandler m , MonadHandler m' , HandlerSite m' ~ UniWorX , MonadUnliftIO m' + , MonadThrow m' ) => Either WorkflowInstanceId WorkflowWorkflowId -> Maybe WorkflowEdgeForm @@ -80,7 +81,7 @@ workflowEdgeForm :: ( MonadHandler m workflowEdgeForm mwwId mPrev = runMaybeT $ do MsgRenderer mr <- getMsgRenderer - ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId + ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getWorkflowWorkflowState) mwwId let (scope, sharedGraphId) = case ctx' of Left (Entity _ WorkflowInstance{..}) -> ( _DBWorkflowScope # workflowInstanceScope , workflowInstanceGraph diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 3ab5595b8..7294810db 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -97,4 +97,3 @@ sourceWorkflowActionInfos wwId wState = do 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 ecd19b12a..b74fc4632 100644 --- a/src/Handler/Workflow/Definition/List.hs +++ b/src/Handler/Workflow/Definition/List.hs @@ -66,7 +66,7 @@ getAdminWorkflowDefinitionListR = do return (workflowDefinition, workflowInstanceCount, workflowCount) dbtRowKey = (E.^. WorkflowDefinitionId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do + dbtProj = dbtProjFilteredPostSimple . runReaderT $ do wd@(Entity wdId _) <- view _1 descLangs <- lift . E.select . E.from $ \workflowDefinitionDescription -> do E.where_ $ workflowDefinitionDescription E.^. WorkflowDefinitionDescriptionDefinition E.==. E.val wdId @@ -116,8 +116,8 @@ getAdminWorkflowDefinitionListR = do dbtFilter = mconcat [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowDefinitionName) , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowDefinitionScope) - , singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts - , singletonMap "instance-title" . FilterProjected $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts + , singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowDefinitionDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts + , singletonMap "instance-title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultInstanceDescription . _entityVal . _workflowDefinitionInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowDefinitionName) diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index 8038ed7a4..7da5bb38b 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -75,11 +75,8 @@ getAdminWorkflowInstanceListR = do return (workflowInstance, workflowCount) dbtRowKey = (E.^. WorkflowInstanceId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do - wi@(Entity wiId _) <- view _1 - desc <- lift $ selectWorkflowInstanceDescription wiId - (wi, desc,) - <$> view (_2 . _Value) + dbtProj = dbtProjFilteredPostSimple $ \(wi@(Entity wiId _), E.Value iCount) -> + (wi, , iCount) <$> selectWorkflowInstanceDescription wiId dbtColonnade :: Colonnade Sortable WorkflowInstanceData _ dbtColonnade = mconcat [ sortable (Just "name") (i18nCell MsgWorkflowInstanceName) . anchorEdit $ views (resultWorkflowInstance . _entityVal . _workflowInstanceName) i18n @@ -105,7 +102,7 @@ getAdminWorkflowInstanceListR = do dbtFilter = mconcat [ singletonMap "name" . FilterColumn $ E.mkContainsFilter (E.^. WorkflowInstanceName) , singletonMap "scope" . FilterColumn $ E.mkExactFilter (E.^. WorkflowInstanceScope) - , singletonMap "title" . FilterProjected $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts + , singletonMap "title" . mkFilterProjectedPost $ \(ts :: Set Text) (view $ resultDescription . _entityVal . _workflowInstanceDescriptionTitle -> t) -> oany ((flip isInfixOf `on` CI.foldCase) t) ts ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgWorkflowInstanceName) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index c537e72fc..8d96b8a3f 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -35,10 +35,28 @@ import Data.Semigroup (Last(..)) import qualified Data.Monoid as Monoid (Last(..)) import Control.Monad.Trans.Writer.Strict (WriterT) -import Control.Monad.Trans.State.Strict (execStateT) -import qualified Control.Monad.State.Class as State +-- import Control.Monad.Trans.State.Strict (execStateT) +-- import qualified Control.Monad.State.Class as State -import qualified Data.RFC5051 as RFC5051 +-- import qualified Data.RFC5051 as RFC5051 + + +data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj + { wwProjFilterMayAccess :: Maybe Bool + , wwProjFilterWorkflowWorkflow :: Maybe [[CI Char]] + , wwProjFilterCurrentState :: Maybe [[CI Char]] + , wwProjFilterFinal :: Maybe Bool + } + +instance Default WorkflowWorkflowListFilterProj where + def = WorkflowWorkflowListFilterProj + { wwProjFilterMayAccess = Nothing + , wwProjFilterWorkflowWorkflow = Nothing + , wwProjFilterCurrentState = Nothing + , wwProjFilterFinal = Nothing + } + +makeLenses_ ''WorkflowWorkflowListFilterProj getGlobalWorkflowWorkflowListR :: Handler Html @@ -186,8 +204,8 @@ resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescrip resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData) resultLastAction = _dbrOutput . _6 -resultPersons :: Traversal' WorkflowWorkflowData (Entity User) -resultPersons = _dbrOutput . _7 . traverse +-- resultPersons :: Traversal' WorkflowWorkflowData (Entity User) +-- resultPersons = _dbrOutput . _7 . traverse actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text) actionTo = _1 @@ -231,15 +249,24 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do lift <=< asks $ E.where_ . sqlPred return (workflowWorkflow, workflowInstance) dbtRowKey = views queryWorkflowWorkflow (E.^. WorkflowWorkflowId) - dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do - ww@(Entity wwId WorkflowWorkflow{..}) <- view _1 - mwi <- view _2 - wiDesc <- lift . runMaybeT $ do + dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do + ww@(Entity wwId WorkflowWorkflow{..}) <- view $ _dbtProjRow . _dbrOutput . _1 + mwi <- view $ _dbtProjRow . _dbrOutput . _2 + + cID <- encrypt wwId + forMM_ (view $ _dbtProjFilter . _wwProjFilterWorkflowWorkflow) $ \criteria -> + let haystack = map CI.mk . unpack $ toPathPiece cID + in guard $ any (`isInfixOf` haystack) criteria + + rScope <- lift . lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope + forMM_ (view $ _dbtProjFilter . _wwProjFilterMayAccess) $ \needle -> do + rScope' <- hoistMaybe rScope + guardM . lift . lift $ (== needle) . is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)) False + + wiDesc <- lift . lift . $cachedHereBinary (entityKey <$> mwi) . runMaybeT $ do Entity wiId _ <- hoistMaybe mwi MaybeT $ selectWorkflowInstanceDescription wiId - cID <- encrypt wwId - rScope <- lift . runMaybeT . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope - WorkflowGraph{..} <- lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph + WorkflowGraph{..} <- lift . lift . getSharedIdWorkflowGraph $ ww ^. _entityVal . _workflowWorkflowGraph let hasWorkflowRole' :: WorkflowRole UserId -> DB Bool hasWorkflowRole' role = maybeT (return False) $ do rScope' <- hoistMaybe rScope @@ -247,7 +274,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do lift . $cachedHereBinary (wwId, role) $ is _Authorized <$> hasWorkflowRole (Just wwId) role canonRoute False let - goAction p w = lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p + goAction p w = lift . lift . go $ ww ^? _entityVal . _workflowWorkflowState . from _DBWorkflowState . p where go Nothing = return Nothing go (Just (act, newSt)) = maybeT (go $ newSt ^? _nullable . p) $ do @@ -264,7 +291,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do | otherwise -> maybeT (return WHIAHidden) $ do viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia guardM . lift $ anyM (otoList viewActors) hasWorkflowRole' - resUser <- lift $ traverse getEntity wpUser' + resUser <- lift . for wpUser' $ \uid -> $cachedHereBinary uid $ getEntity uid return $ case resUser of Nothing -> WHIAOther Nothing Just Nothing -> WHIAGone @@ -280,52 +307,53 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do <*> pure actFinal lastAct <- descAction $ re _nullable . _Snoc . swapped - persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do - let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes - guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act - lift . maybeT_ . hoist (zoom _1) $ do - viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia - guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole' - State.modify' $ Set.insert wpUser' - iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do - let users = setOf (typesCustom @WorkflowChildren) ps - guard . not $ null users - WorkflowPayloadView{..} <- hoistMaybe $ do - WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes - Map.lookup pLbl wgnPayloadView - guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole' - at pLbl ?= users + -- persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do + -- let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes + -- guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act + -- lift . maybeT_ . hoist (zoom _1) $ do + -- viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia + -- guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole' + -- State.modify' $ Set.insert wpUser' + -- iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do + -- let users = setOf (typesCustom @WorkflowChildren) ps + -- guard . not $ null users + -- WorkflowPayloadView{..} <- hoistMaybe $ do + -- WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes + -- Map.lookup pLbl wgnPayloadView + -- guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole' + -- at pLbl ?= users - persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' + -- persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' - return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) + -- return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) + return (cID, rScope, ww, mwi, wiDesc, lastAct, error "persons") dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat -- TODO: columns - [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . toPathPiece - , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x - , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x - , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x -> - let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname) - in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell - , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell - , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell + [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . (toPathPiece :: CryptoFileNameWorkflowWorkflow -> Text) + -- , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x + -- , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x + -- , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x -> + -- let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname) + -- in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + -- , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell + -- , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell + -- , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell ] where - personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded))) - <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded))) + -- personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded))) + -- <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded))) - stateCell = \case - (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) - (Just n, Nothing) -> textCell n - (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] - actorCell = \case - Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) - Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) - Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) - Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) - Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) - Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname + -- stateCell = \case + -- (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) + -- (Just n, Nothing) -> textCell n + -- (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] + -- actorCell = \case + -- Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) + -- Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) + -- Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) + -- Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) + -- Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) + -- Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _ anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f @@ -333,15 +361,15 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do cID <- view resultWorkflowWorkflowId rScope <- hoistMaybe =<< view resultRouteScope return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) - anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f - where mkLink = runReaderT $ do - rScope <- hoistMaybe =<< view resultRouteScope - return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f - where mkLink = runReaderT $ do - rScope <- hoistMaybe =<< view resultRouteScope - win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) - return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + -- anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f + -- where mkLink = runReaderT $ do + -- rScope <- hoistMaybe =<< view resultRouteScope + -- return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) + -- anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f + -- where mkLink = runReaderT $ do + -- rScope <- hoistMaybe =<< view resultRouteScope + -- win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) + -- return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) dbtSorting = mconcat [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope @@ -352,23 +380,37 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do , singletonMap "final" . SortProjected . comparing $ \x -> guardOnM (has (resultLastAction . _Just . actionTo . _Just) x) (x ^? resultLastAction . _Just . actionFinal . _Just) ] dbtFilter = mconcat - [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) -> - let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId - criteria' = map CI.mk . unpack <$> Set.toList criteria - in any (`isInfixOf` cid) criteria' - , singletonMap "may-access" . FilterProjected $ \x (Any b) -> fmap (== b) . maybeT (return False) $ do - let cID = x ^. resultWorkflowWorkflowId - rScope <- hoistMaybe $ x ^. resultRouteScope - lift . lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool - , singletonMap "current-state" . FilterProjected $ \x (criteria :: Set Text) -> + [ singletonMap "workflow-workflow" . FilterProjected $ \(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 :: 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 - in needle == val + in _wwProjFilterWorkflowWorkflow ?~ criteria' + , singletonMap "current-state" . FilterProjected $ \(criteria :: Set Text) -> -- TODO + let criteria' = map CI.mk . unpack <$> Set.toList criteria + in _wwProjFilterCurrentState ?~ criteria' + , singletonMap "final" . FilterProjected $ \(criterion :: Monoid.Last Bool) -> case Monoid.getLast criterion of -- TODO + Nothing -> id + Just needle -> _wwProjFilterFinal ?~ needle + , singletonMap "may-access" . FilterProjected $ \(Any criterion) -> _wwProjFilterMayAccess ?~ criterion ] + -- [ singletonMap "workflow-workflow" . FilterProjected $ \x (criteria :: Set Text) -> + -- let cid = map CI.mk . unpack . toPathPiece $ x ^. resultWorkflowWorkflowId + -- criteria' = map CI.mk . unpack <$> Set.toList criteria + -- in any (`isInfixOf` cid) criteria' + -- , + + -- , singletonMap "may-access" . FilterPreProjected $ \(x :: DBRow (Entity WorkflowWorkflow, Maybe (Entity WorkflowInstance))) (Any b) -> fmap (== b) . maybeT (return False) $ do + -- let Entity wwId WorkflowWorkflow{..} = x ^. _dbrOutput . _1 + -- cID <- encrypt wwId + -- rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope + -- lift $ is _Authorized <$> evalAccess (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) False :: MaybeT (YesodDB UniWorX) Bool + -- , 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 :: 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 + -- in needle == val + -- ] dbtFilterUI = mconcat [ flip (prismAForm $ singletonFilter "workflow-workflow") $ aopt textField (fslI MsgWorkflowWorkflowListNumber) , flip (prismAForm $ singletonFilter "current-state") $ aopt textField (fslI MsgWorkflowWorkflowListCurrentState) @@ -453,11 +495,11 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do return JsonWorkflowWorkflow{..} workflowWorkflowDBTableValidator = def - & defaultSorting defSort + -- & defaultSorting defSort & forceFilter "may-access" (Any True) - defSort | wwListColumnInstance = SortAscBy "instance" : defSort' - | otherwise = defSort' - where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"] + -- defSort | wwListColumnInstance = SortAscBy "instance" : defSort' + -- | otherwise = defSort' + -- where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"] in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable siteLayoutMsg heading $ do diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 69751dfa7..b9c0a0f73 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -67,6 +67,8 @@ import Data.List (inits) import Data.RFC5051 (compareUnicode) +import qualified Data.Binary as Binary + ----- WORKFLOW GRAPH ----- @@ -474,7 +476,7 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid) => Ord (Work (WFPBool{}, _) -> LT (WFPDay{}, WFPText{}) -> GT (WFPDay{}, WFPNumber{}) -> GT - (WFPDay{}, WFPDay{}) -> GT + (WFPDay{}, WFPBool{}) -> GT (WFPDay{}, _) -> LT (WFPFile{}, WFPText{}) -> GT (WFPFile{}, WFPNumber{}) -> GT @@ -488,6 +490,7 @@ workflowPayloadSort (fileid -> fileid -> Ordering) -> (userid -> userid -> Ordering) -> (WorkflowFieldPayloadW fileid userid -> WorkflowFieldPayloadW fileid userid -> Ordering) +-- ^ @workflowPayloadSort compare compare /= compare@ workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of (WFPText a', WFPText b' ) -> compareUnicode a' b' (WFPText{}, _ ) -> LT @@ -545,7 +548,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) - deriving anyclass (Universe, Finite, NFData) + deriving anyclass (Universe, Finite, NFData, Binary) type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload @@ -1127,6 +1130,38 @@ instance (Binary termid, Binary schoolid, Binary courseid) => Binary (WorkflowSc instance Binary userid => Binary (WorkflowRole userid) +instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowAction fileid userid) +instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowFieldPayloadW fileid userid) where + get = do + tag <- Binary.get + case tag of + WFPText' -> do + t <- Binary.get + return $ WorkflowFieldPayloadW $ WFPText t + WFPNumber' -> do + n <- Binary.get + return $ WorkflowFieldPayloadW $ WFPNumber n + WFPBool' -> do + b <- Binary.get + return $ WorkflowFieldPayloadW $ WFPBool b + WFPDay' -> do + d <- Binary.get + return $ WorkflowFieldPayloadW $ WFPDay d + WFPFile' -> do + fid <- Binary.get + return $ WorkflowFieldPayloadW $ WFPFile fid + WFPUser' -> do + uid <- Binary.get + return $ WorkflowFieldPayloadW $ WFPUser uid + put = \case + WorkflowFieldPayloadW (WFPText t ) -> Binary.put WFPText' >> Binary.put t + WorkflowFieldPayloadW (WFPNumber n ) -> Binary.put WFPNumber' >> Binary.put n + WorkflowFieldPayloadW (WFPBool b ) -> Binary.put WFPBool' >> Binary.put b + WorkflowFieldPayloadW (WFPDay d ) -> Binary.put WFPDay' >> Binary.put d + WorkflowFieldPayloadW (WFPFile fid) -> Binary.put WFPFile' >> Binary.put fid + WorkflowFieldPayloadW (WFPUser uid) -> Binary.put WFPUser' >> Binary.put uid + + ----- TH Jail ----- makeWrapped ''WorkflowGraphReference diff --git a/src/Utils.hs b/src/Utils.hs index ed364adc1..60fc69175 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -7,6 +7,7 @@ import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold +import qualified Data.Traversable as Trav import Data.Foldable as Utils (foldlM, foldrM) import Data.Monoid (First, Sum(..), Endo) import Data.Proxy @@ -975,6 +976,20 @@ sortOnM :: (Ord b, Monad m) -> m [a] sortOnM f = fmap (map snd . sortBy (comparing fst)) . mapM (\x -> (\y -> y `seq` (y, x)) <$> f x) +-- Stolen from Agda... + +mapMM :: (Traversable t, Monad m) => (a -> m b) -> m (t a) -> m (t b) +mapMM f mxs = Trav.mapM f =<< mxs + +forMM :: (Traversable t, Monad m) => m (t a) -> (a -> m b) -> m (t b) +forMM = flip mapMM + +mapMM_ :: (Foldable t, Monad m) => (a -> m ()) -> m (t a) -> m () +mapMM_ f mxs = Fold.mapM_ f =<< mxs + +forMM_ :: (Foldable t, Monad m) => m (t a) -> (a -> m ()) -> m () +forMM_ = flip mapMM_ + -------------- -- Foldable -- -------------- diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs index 5454c150a..d1ece08b7 100644 --- a/src/Utils/Workflow.hs +++ b/src/Utils/Workflow.hs @@ -12,9 +12,12 @@ module Utils.Workflow , selectWorkflowInstanceDescription , SharedWorkflowGraphException(..), getSharedDBWorkflowGraph, getSharedIdWorkflowGraph , insertSharedWorkflowGraph + , getWorkflowWorkflowState', getWorkflowWorkflowState + , WorkflowWorkflowStateParseException(..) ) where import Import.NoFoundation +import Foundation.Type import qualified Data.CryptoID.Class.ImplicitNamespace as I import qualified Crypto.MAC.KMAC as Crypto @@ -25,8 +28,11 @@ import qualified Crypto.Hash as Crypto import Language.Haskell.TH (nameBase) import qualified Data.Aeson as Aeson +import Handler.Utils.Memcached + import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Internal.Internal as E {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -49,19 +55,19 @@ _DBWorkflowScope = iso toScope' toScope & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolShorthand SqlBackendKey) @(WorkflowScope TermId SchoolId SqlBackendKey)) SchoolKey & over (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId SqlBackendKey) @(WorkflowScope TermId SchoolId CourseId) @SqlBackendKey @CourseId) (review _SqlKey) -fromRouteWorkflowScope :: ( MonadIO m +fromRouteWorkflowScope :: ( MonadHandler m , BackendCompatible SqlReadBackend backend ) => RouteWorkflowScope -> MaybeT (ReaderT backend m) IdWorkflowScope -fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh +fromRouteWorkflowScope rScope = $cachedHereBinary rScope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh -toRouteWorkflowScope :: ( MonadIO m +toRouteWorkflowScope :: ( MonadHandler m , BackendCompatible SqlReadBackend backend ) => IdWorkflowScope -> MaybeT (ReaderT backend m) RouteWorkflowScope -toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand) +toRouteWorkflowScope scope = $cachedHereBinary scope . hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand) type IdWorkflowGraph = WorkflowGraph FileReference UserId @@ -168,3 +174,51 @@ insertSharedWorkflowGraph graph = withReaderT (projectBackend @SqlBackend) $ where swgId = WorkflowGraphReference . Crypto.hashlazy $ Aeson.encode graph swgId' = SharedWorkflowGraphKey swgId + + +newtype WorkflowWorkflowStateParse = WorkflowWorkflowStateParse PersistValue + deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Binary) + +newtype WorkflowWorkflowStateParseException = WorkflowWorkflowStateParseException Text + deriving stock (Show, Generic, Typeable) + deriving anyclass (Exception) + +getWorkflowWorkflowState' :: forall backend m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BackendCompatible SqlReadBackend backend + , MonadThrow m + ) + => WorkflowWorkflowId + -> Maybe WorkflowWorkflow + -> ReaderT backend m (Maybe (Entity WorkflowWorkflow)) +getWorkflowWorkflowState' wwId Nothing = withReaderT (projectBackend @SqlBackend . projectBackend @SqlReadBackend) . runMaybeT $ do + res <- MaybeT . E.selectMaybe . E.from $ \workflowWorkflow -> do + E.where_ $ workflowWorkflow E.^. WorkflowWorkflowId E.==. E.val wwId + return + ( workflowWorkflow E.^. WorkflowWorkflowInstance + , workflowWorkflow E.^. WorkflowWorkflowScope + , workflowWorkflow E.^. WorkflowWorkflowGraph + , E.veryUnsafeCoerceSqlExprValue $ workflowWorkflow E.^. WorkflowWorkflowState + ) + let + ( E.Value workflowWorkflowInstance + , E.Value workflowWorkflowScope + , E.Value workflowWorkflowGraph + , E.Value (wwState :: PersistValue) -- Don't parse + ) = res + wwState' <- memcachedBy Nothing (WorkflowWorkflowStateParse wwState) . return $ fromPersistValue wwState + case wwState' of + Left err -> lift . throwM $ WorkflowWorkflowStateParseException err + Right workflowWorkflowState -> return $ Entity wwId WorkflowWorkflow{..} +getWorkflowWorkflowState' wwId (Just ww@WorkflowWorkflow{..}) = Just (Entity wwId ww) <$ do + memcachedBySet Nothing (WorkflowWorkflowStateParse $ toPersistValue workflowWorkflowState) workflowWorkflowState + +getWorkflowWorkflowState :: forall backend m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BackendCompatible SqlReadBackend backend + , MonadThrow m + ) + => WorkflowWorkflowId + -> ReaderT backend m (Maybe (Entity WorkflowWorkflow)) +getWorkflowWorkflowState = flip getWorkflowWorkflowState' Nothing diff --git a/test/Model/Types/WorkflowSpec.hs b/test/Model/Types/WorkflowSpec.hs index 542690a20..263e66610 100644 --- a/test/Model/Types/WorkflowSpec.hs +++ b/test/Model/Types/WorkflowSpec.hs @@ -160,3 +160,5 @@ spec = do [ eqLaws, ordLaws, jsonLaws ] lawsCheckHspec (Proxy @WorkflowScope') [ eqLaws, ordLaws, boundedEnumLaws, showLaws, showReadLaws, universeLaws, finiteLaws, pathPieceLaws, jsonLaws, persistFieldLaws, binaryLaws ] + lawsCheckHspec (Proxy @(WorkflowFieldPayloadW FileReference SqlBackendKey)) + [ eqLaws, ordLaws, showLaws, jsonLaws, binaryLaws ] From 3c7434479feccf558cd4195afd55af962a3e290b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 4 May 2021 15:06:32 +0200 Subject: [PATCH 02/21] chore(release): 25.10.1 --- CHANGELOG.md | 2 ++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8a82ef56c..ffe6c1d13 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.10.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.0...v25.10.1) (2021-05-04) + ## [25.10.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.3...v25.10.0) (2021-04-15) diff --git a/package-lock.json b/package-lock.json index 400589d5f..09fb829e3 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.0", + "version": "25.10.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2f8013dd7..26570819e 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.0", + "version": "25.10.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f6de3f536..fc0ed05a5 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.10.0 +version: 25.10.1 dependencies: - base - yesod From c2212a86e6170ab392029f91eee1ea277f530530 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 4 May 2021 19:40:50 +0200 Subject: [PATCH 03/21] refactor: hlint --- .gitlab-ci.yml | 6 ++---- src/Model/Types/Workflow.hs | 28 +++++++--------------------- 2 files changed, 9 insertions(+), 25 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 514846b63..b2c28a2b8 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -271,8 +271,7 @@ yesod:test:hlint: before_script: *haskell script: - stack install hlint - - stack exec -- hlint --cc src > gl-code-quality-report.json - - jq . gl-code-quality-report.json + - stack exec -- hlint --cc src > gl-code-quality-report.json || jq . gl-code-quality-report.json artifacts: paths: @@ -307,8 +306,7 @@ yesod:test:hlint:dev: before_script: *haskell script: - stack install hlint - - stack exec -- hlint --cc src > gl-code-quality-report.json - - jq . gl-code-quality-report.json + - stack exec -- hlint --cc src > gl-code-quality-report.json || jq . gl-code-quality-report.json artifacts: paths: diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index b9c0a0f73..ada4ef374 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -1132,27 +1132,13 @@ instance Binary userid => Binary (WorkflowRole userid) instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowAction fileid userid) instance (Binary fileid, Binary userid, Typeable fileid, Typeable userid) => Binary (WorkflowFieldPayloadW fileid userid) where - get = do - tag <- Binary.get - case tag of - WFPText' -> do - t <- Binary.get - return $ WorkflowFieldPayloadW $ WFPText t - WFPNumber' -> do - n <- Binary.get - return $ WorkflowFieldPayloadW $ WFPNumber n - WFPBool' -> do - b <- Binary.get - return $ WorkflowFieldPayloadW $ WFPBool b - WFPDay' -> do - d <- Binary.get - return $ WorkflowFieldPayloadW $ WFPDay d - WFPFile' -> do - fid <- Binary.get - return $ WorkflowFieldPayloadW $ WFPFile fid - WFPUser' -> do - uid <- Binary.get - return $ WorkflowFieldPayloadW $ WFPUser uid + get = Binary.get >>= \case + WFPText' -> WorkflowFieldPayloadW . WFPText <$> Binary.get + WFPNumber' -> WorkflowFieldPayloadW . WFPNumber <$> Binary.get + WFPBool' -> WorkflowFieldPayloadW . WFPBool <$> Binary.get + WFPDay' -> WorkflowFieldPayloadW . WFPDay <$> Binary.get + WFPFile' -> WorkflowFieldPayloadW . WFPFile <$> Binary.get + WFPUser' -> WorkflowFieldPayloadW . WFPUser <$> Binary.get put = \case WorkflowFieldPayloadW (WFPText t ) -> Binary.put WFPText' >> Binary.put t WorkflowFieldPayloadW (WFPNumber n ) -> Binary.put WFPNumber' >> Binary.put n From 6fb46c6e2b843b75a311af09812de705dffe927d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 4 May 2021 19:41:09 +0200 Subject: [PATCH 04/21] chore(release): 25.10.2 --- CHANGELOG.md | 2 ++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ffe6c1d13..86ce3ac55 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.10.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.1...v25.10.2) (2021-05-04) + ## [25.10.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.0...v25.10.1) (2021-05-04) ## [25.10.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.9.3...v25.10.0) (2021-04-15) diff --git a/package-lock.json b/package-lock.json index 09fb829e3..2cc54cc33 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.1", + "version": "25.10.2", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 26570819e..0e757f657 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.1", + "version": "25.10.2", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index fc0ed05a5..f24c8df0c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.10.1 +version: 25.10.2 dependencies: - base - yesod From e55c6d795fd724bdb732e22d13c96d6b67ea7da1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 May 2021 11:59:59 +0200 Subject: [PATCH 05/21] fix: restore workflowWorkflowList columns --- src/Handler/Workflow/Workflow/List.hs | 105 +++++++++++++------------- 1 file changed, 52 insertions(+), 53 deletions(-) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 8d96b8a3f..5164e67fc 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -35,10 +35,10 @@ import Data.Semigroup (Last(..)) import qualified Data.Monoid as Monoid (Last(..)) import Control.Monad.Trans.Writer.Strict (WriterT) --- import Control.Monad.Trans.State.Strict (execStateT) --- import qualified Control.Monad.State.Class as State +import Control.Monad.Trans.State.Strict (execStateT) +import qualified Control.Monad.State.Class as State --- import qualified Data.RFC5051 as RFC5051 +import qualified Data.RFC5051 as RFC5051 data WorkflowWorkflowListFilterProj = WorkflowWorkflowListFilterProj @@ -204,8 +204,8 @@ resultWorkflowInstanceTitle = to $ \x -> case x ^? resultWorkflowInstanceDescrip resultLastAction :: Lens' WorkflowWorkflowData (Maybe WorkflowWorkflowActionData) resultLastAction = _dbrOutput . _6 --- resultPersons :: Traversal' WorkflowWorkflowData (Entity User) --- resultPersons = _dbrOutput . _7 . traverse +resultPersons :: Traversal' WorkflowWorkflowData (Entity User) +resultPersons = _dbrOutput . _7 . traverse actionTo :: Lens' WorkflowWorkflowActionData (Maybe Text) actionTo = _1 @@ -307,53 +307,52 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do <*> pure actFinal lastAct <- descAction $ re _nullable . _Snoc . swapped - -- persons' <- lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do - -- let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes - -- guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act - -- lift . maybeT_ . hoist (zoom _1) $ do - -- viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia - -- guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole' - -- State.modify' $ Set.insert wpUser' - -- iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do - -- let users = setOf (typesCustom @WorkflowChildren) ps - -- guard . not $ null users - -- WorkflowPayloadView{..} <- hoistMaybe $ do - -- WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes - -- Map.lookup pLbl wgnPayloadView - -- guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole' - -- at pLbl ?= users + persons' <- lift . lift . flip (execStateT @_ @(Set UserId, Map WorkflowPayloadLabel (Set UserId))) mempty . forM_ (ww ^.. _entityVal . _workflowWorkflowState . from _DBWorkflowState . re _nullable . folded) $ \act -> maybeT_ . forM_ (join $ wpUser act) $ \wpUser' -> do + let mVia = Map.lookup (wpVia act) . wgnEdges =<< Map.lookup (wpTo act) wgNodes + guardM . lift . lift $ mayViewWorkflowAction mAuthId wwId act + lift . maybeT_ . hoist (zoom _1) $ do + viewActors <- hoistMaybe $ preview _wgeViewActor =<< mVia + guardM . lift . lift $ anyM (otoList viewActors) hasWorkflowRole' + State.modify' $ Set.insert wpUser' + iforM_ (wpPayload act) $ \pLbl ps -> lift . maybeT_ . hoist (zoom _2) $ do + let users = setOf (typesCustom @WorkflowChildren) ps + guard . not $ null users + WorkflowPayloadView{..} <- hoistMaybe $ do + WGN{wgnPayloadView} <- Map.lookup (wpTo act) wgNodes + Map.lookup pLbl wgnPayloadView + guardM . lift . lift $ anyM (otoList wpvViewers) hasWorkflowRole' + at pLbl ?= users - -- persons <- lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' + persons <- lift . lift . mapMaybeM (MaybeT . getEntity) . toList $ view _1 persons' <> view (_2 . folded) persons' - -- return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) - return (cID, rScope, ww, mwi, wiDesc, lastAct, error "persons") + return (cID, rScope, ww, mwi, wiDesc, lastAct, persons) dbtColonnade :: Colonnade Sortable _ _ dbtColonnade = mconcat -- TODO: columns [ sortable (Just "workflow-workflow") (i18nCell MsgWorkflowWorkflowListNumber) . (addCellClass ("cryptoid" :: Text) .) . anchorWorkflowWorkflow . views resultWorkflowWorkflowId $ toWidget . (toPathPiece :: CryptoFileNameWorkflowWorkflow -> Text) - -- , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x - -- , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x - -- , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x -> - -- let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname) - -- in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] - -- , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell - -- , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell - -- , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell + , guardMonoid wwListColumnScope . sortable (Just "scope") (i18nCell MsgWorkflowWorkflowListScope) $ \x -> foldMap (\t -> anchorWorkflowScope (const $ i18n t :: _ -> Widget) x) $ view resultRouteScope x + , guardMonoid wwListColumnInstance . sortable (Just "instance") (i18nCell MsgWorkflowWorkflowListInstance) $ \x -> foldMap (\t -> anchorWorkflowInstance (const t) x) $ preview resultWorkflowInstanceTitle x + , sortable Nothing (i18nCell MsgWorkflowWorkflowListPersons) $ \x -> + let lCell = flip listCell (uncurry userCell) . sortBy personCmp $ x ^.. resultPersons . _entityVal . to ((,) <$> userDisplayName <*> userSurname) + in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + , sortable (Just "current-state") (i18nCell MsgWorkflowWorkflowListCurrentState) $ fromMaybe mempty . previews (resultLastAction . _Just . $(multifocusL 2) actionTo actionFinal) stateCell + , sortable (Just "last-action-time") (i18nCell MsgWorkflowWorkflowListLastActionTime) $ fromMaybe mempty . previews (resultLastAction . _Just . actionTime) dateTimeCell + , sortable (Just "last-action-user") (i18nCell MsgWorkflowWorkflowListLastActionUser) $ fromMaybe mempty . previews (resultLastAction . _Just . actionActor) actorCell ] where - -- personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded))) - -- <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded))) + personCmp = (RFC5051.compareUnicode `on` (pack . toListOf (_2 . to (unpack . CI.foldCase) . folded))) + <> (RFC5051.compareUnicode `on` (pack . toListOf (_1 . to (unpack . CI.foldCase) . folded))) - -- stateCell = \case - -- (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) - -- (Just n, Nothing) -> textCell n - -- (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] - -- actorCell = \case - -- Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) - -- Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) - -- Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) - -- Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) - -- Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) - -- Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname + stateCell = \case + (Nothing, _) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryStateHidden & addCellClass ("explanation" :: Text) + (Just n, Nothing) -> textCell n + (Just n, Just fin) -> cell [whamlet|#{icon fin} #{n}|] + actorCell = \case + Nothing -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserAutomatic & addCellClass ("explanation" :: Text) + Just WHIASelf -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserSelf & addCellClass ("explanation" :: Text) + Just WHIAGone -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserGone & addCellClass ("explanation" :: Text) + Just WHIAHidden -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserHidden & addCellClass ("explanation" :: Text) + Just (WHIAOther Nothing) -> i18nCell MsgWorkflowWorkflowWorkflowHistoryUserNotLoggedIn & addCellClass ("explanation" :: Text) + Just (WHIAOther (Just (Entity _ User{..}))) -> userCell userDisplayName userSurname anchorWorkflowWorkflow :: (WorkflowWorkflowData -> Widget) -> _ anchorWorkflowWorkflow f = maybeAnchorCellM <$> mkLink <*> f @@ -361,15 +360,15 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do cID <- view resultWorkflowWorkflowId rScope <- hoistMaybe =<< view resultRouteScope return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) - -- anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f - -- where mkLink = runReaderT $ do - -- rScope <- hoistMaybe =<< view resultRouteScope - -- return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) - -- anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f - -- where mkLink = runReaderT $ do - -- rScope <- hoistMaybe =<< view resultRouteScope - -- win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) - -- return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + anchorWorkflowScope f = maybeAnchorCellM <$> mkLink <*> f + where mkLink = runReaderT $ do + rScope <- hoistMaybe =<< view resultRouteScope + return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowListR) + anchorWorkflowInstance f = maybeAnchorCellM <$> mkLink <*> f + where mkLink = runReaderT $ do + rScope <- hoistMaybe =<< view resultRouteScope + win <- hoistMaybe =<< preview (resultWorkflowInstance . _Just . _entityVal . _workflowInstanceName) + return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) dbtSorting = mconcat [ singletonMap "workflow-workflow" . SortProjected . comparing $ view resultWorkflowWorkflowId , singletonMap "scope" . SortProjected . comparing $ view resultRouteScope From e73f09bbb0e5e42a8d3c569a60c612391be2d9b7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 May 2021 12:00:29 +0200 Subject: [PATCH 06/21] chore(release): 25.10.3 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 86ce3ac55..9f176e9c8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.10.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.2...v25.10.3) (2021-05-05) + + +### Bug Fixes + +* restore workflowWorkflowList columns ([e55c6d7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e55c6d795fd724bdb732e22d13c96d6b67ea7da1)) + ## [25.10.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.1...v25.10.2) (2021-05-04) ## [25.10.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.0...v25.10.1) (2021-05-04) diff --git a/package-lock.json b/package-lock.json index 2cc54cc33..d30644a0e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.2", + "version": "25.10.3", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 0e757f657..ad7ca5720 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.2", + "version": "25.10.3", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f24c8df0c..5502c2ef0 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.10.2 +version: 25.10.3 dependencies: - base - yesod From e95abc97ee9efc90c570cd191b534248cb394fe3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 May 2021 13:08:12 +0200 Subject: [PATCH 07/21] refactor: stabilize showCompactCorrectorLoad --- src/Model/Types/Sheet.hs | 10 +++++----- test/Model/TypesSpec.hs | 10 ++++++++++ 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 23b1a7f80..3a6e015f9 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -363,15 +363,15 @@ derivePersistField "CorrectorState" showCompactCorrectorLoad :: Load -> CorrectorState -> Text showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]" showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}" -showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = tutorialText - | otherwise = proportionText <> " + " <> tutorialText +showCompactCorrectorLoad Load{..} CorrectorNormal | byProportion == 0 = fromMaybe mempty tutorialText + | otherwise = maybe id (\tt pt -> pt <> " + " <> tt) tutorialText proportionText where proportionText = let propDbl :: Double propDbl = fromRational byProportion in tshow $ roundToDigits 2 propDbl - tutorialText = case byTutorial of Nothing -> mempty - Just True -> "(T)" - Just False -> "T" + tutorialText = byTutorial <&> \case + True -> "(T)" + False -> "T" instance Csv.ToField (SheetType epid, Maybe Points) where toField (_, Nothing) = mempty diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 95a9caa14..a5c011ea5 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -523,6 +523,16 @@ spec = do toPathPiece ExamCloseSeparate `shouldBe` "separate" toPathPiece (ExamCloseOnFinished False) `shouldBe` "on-finished" toPathPiece (ExamCloseOnFinished True) `shouldBe` "on-finished-hidden" + describe "CompactCorrectorLoad" $ do + it "matches expectations" . example $ do + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 0 } CorrectorNormal `shouldBe` "T" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 0 } CorrectorNormal `shouldBe` "(T)" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorNormal `shouldBe` "1.0" + showCompactCorrectorLoad Load{ byTutorial = Just False, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + T" + showCompactCorrectorLoad Load{ byTutorial = Just True, byProportion = 1 } CorrectorNormal `shouldBe` "1.0 + (T)" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 0 } CorrectorNormal `shouldBe` "" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorMissing `shouldBe` "[1.0]" + showCompactCorrectorLoad Load{ byTutorial = Nothing, byProportion = 1 } CorrectorExcused `shouldBe` "{1.0}" termExample :: (TermIdentifier, Text) -> Expectation termExample (term, encoded) = example $ do From 15cab05ec0ab61b5ca795b4f9a09cf1c56682ac9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 5 May 2021 18:19:04 +0200 Subject: [PATCH 08/21] chore: don't use git:// --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index d76cd4465..f75ba5f9a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,7 +24,7 @@ extra-deps: commit: b7071df50bad3a251a544b984e4bf98fa09b8fae - git: git@gitlab2.rz.ifi.lmu.de:uni2work/conduit-resumablesink.git commit: cbea6159c2975d42f948525e03e12fc390da53c5 - - git: git://github.com/jtdaugherty/HaskellNet.git + - git: https://github.com/jtdaugherty/HaskellNet.git commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/HaskellNet-SSL.git commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 From c7782d01947cb66b3834212f2e7993ffd65540d4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 May 2021 12:33:26 +0200 Subject: [PATCH 09/21] chore: offset ports used in nix-shell --- shell.nix | 18 +++++++++--------- start.sh | 4 ++-- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/shell.nix b/shell.nix index a6096242b..de09bff73 100644 --- a/shell.nix +++ b/shell.nix @@ -24,7 +24,7 @@ let shellHook = '' export PROMPT_INFO="${oldAttrs.name}" - export EDITOR=emacsclient + export PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000)) cleanup() { set +e -x @@ -63,14 +63,14 @@ let if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then set -xe - memcached -l localhost -p 11211 &>/dev/null & + memcached -l localhost -p $(($PORT_OFFSET + 11211)) &>/dev/null & widget_memcached_pid=$? cleanup_widget_memcached() { [[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid } - export WIDGET_MEMCACHED_HOST=localhost WIDGET_MEMCACHED_PORT=11211 + export WIDGET_MEMCACHED_HOST=localhost WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211)) set +xe fi @@ -78,14 +78,14 @@ let if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then set -xe - memcached -l localhost -p 11212 &>/dev/null & + memcached -l localhost -p $(($PORT_OFFSET + 11212)) &>/dev/null & session_memcached_pid=$? cleanup_session_memcached() { [[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid } - export SESSION_MEMCACHED_HOST=localhost SESSION_MEMCACHED_PORT=11212 + export SESSION_MEMCACHED_HOST=localhost SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) set +xe fi @@ -93,14 +93,14 @@ let if [[ -z "$MEMCACHED_HOST" ]]; then set -xe - memcached -l localhost -p 11213 &>/dev/null & + memcached -l localhost -p $(($PORT_OFFSET + 11213)) &>/dev/null & memcached_pid=$? cleanup_session_memcached() { [[ -n "$memcached_pid" ]] && kill $memcached_pid } - export MEMCACHED_HOST=localhost MEMCACHED_PORT=11212 + export MEMCACHED_HOST=localhost MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) set +xe fi @@ -119,12 +119,12 @@ let export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1) - minio server --address localhost:9000 ''${MINIO_DIR} &>''${MINIO_LOGFILE} & + minio server --address localhost:$(($PORT_OFFSET + 9000)) ''${MINIO_DIR} &>''${MINIO_LOGFILE} & minio_pid=$? sleep 1 - export UPLOAD_S3_HOST=localhost UPLOAD_S3_PORT=9000 UPLOAD_S3_SSL=false UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY} UPLOAD_S3_KEY=''${MINIO_SECRET_KEY} + export UPLOAD_S3_HOST=localhost UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000)) UPLOAD_S3_SSL=false UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY} UPLOAD_S3_KEY=''${MINIO_SECRET_KEY} set +xe fi diff --git a/start.sh b/start.sh index 329fdad02..e69f11277 100755 --- a/start.sh +++ b/start.sh @@ -31,10 +31,10 @@ fi if ! [ -z "$(which yesod)" ] then - yesod devel $@ + yesod devel -p $((${PORT_OFFSET:-0} + 3000)) -q $((${PORT_OFFSET:-0} + 3443)) $@ elif ! [ -z "$(which stack)" ] then - stack exec -- yesod devel $@ + stack exec -- yesod devel -p $((${PORT_OFFSET:-0} + 3000)) -q $((${PORT_OFFSET:-0} + 3443)) $@ else exit 1 fi From 90599ae7fde54ecaa950a3ad60ce676e4a5cdcaf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 May 2021 12:57:40 +0200 Subject: [PATCH 10/21] chore: tweak approot for port offset --- stack.yaml.lock | 4 ++-- start.sh | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 742fb3c1e..c5af573fd 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -40,13 +40,13 @@ packages: - completed: name: HaskellNet version: 0.5.1 - git: git://github.com/jtdaugherty/HaskellNet.git + git: https://github.com/jtdaugherty/HaskellNet.git pantry-tree: size: 4011 sha256: 921b437ef18ccb04f889301c407263d6b5b72c5864803a000b1e61328988ce70 commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 original: - git: git://github.com/jtdaugherty/HaskellNet.git + git: https://github.com/jtdaugherty/HaskellNet.git commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 - completed: name: HaskellNet-SSL diff --git a/start.sh b/start.sh index e69f11277..7f9765589 100755 --- a/start.sh +++ b/start.sh @@ -16,6 +16,7 @@ export COOKIES_SECURE=${COOKIES_SECURE:-false} export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true} export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false} export RIBBON=${RIBBON:-${__HOST:-localhost}} +export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} unset HOST move-back() { From 454a91702bdbbed7e473ef94a603bcea2e716406 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 May 2021 14:22:22 +0200 Subject: [PATCH 11/21] fix(workflow-workflow-list): restore default sorting --- src/Handler/Workflow/Workflow/List.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 5164e67fc..b29e0ff44 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -494,11 +494,11 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do return JsonWorkflowWorkflow{..} workflowWorkflowDBTableValidator = def - -- & defaultSorting defSort + & defaultSorting defSort & forceFilter "may-access" (Any True) - -- defSort | wwListColumnInstance = SortAscBy "instance" : defSort' - -- | otherwise = defSort' - -- where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"] + defSort | wwListColumnInstance = SortAscBy "instance" : defSort' + | otherwise = defSort' + where defSort' = [SortAscBy "final", SortAscBy "current-state", SortDescBy "last-action-time"] in dbTableDB' workflowWorkflowDBTableValidator workflowWorkflowDBTable siteLayoutMsg heading $ do From dbec1e213a19ec726b928e5de3e6e25d866f4136 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 6 May 2021 14:49:37 +0200 Subject: [PATCH 12/21] chore(release): 25.10.4 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9f176e9c8..02ffca3de 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.10.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.3...v25.10.4) (2021-05-06) + + +### Bug Fixes + +* **workflow-workflow-list:** restore default sorting ([454a917](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/454a91702bdbbed7e473ef94a603bcea2e716406)) + ## [25.10.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.2...v25.10.3) (2021-05-05) diff --git a/package-lock.json b/package-lock.json index d30644a0e..692e4ad4f 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.3", + "version": "25.10.4", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index ad7ca5720..f1044c73f 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.3", + "version": "25.10.4", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5502c2ef0..843902b79 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.10.3 +version: 25.10.4 dependencies: - base - yesod From add7672c9b2b0eccf403b7111a2bf1664b48ab08 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 11:25:15 +0200 Subject: [PATCH 13/21] chore: switch to direnv-based dev-shell --- .envrc | 2 + .gitignore | 4 +- flake.lock | 44 +++++++++++ flake.nix | 27 +++++++ shell.nix | 213 ++++++++++++++++++++++++++++------------------------- 5 files changed, 188 insertions(+), 102 deletions(-) create mode 100644 .envrc create mode 100644 flake.lock create mode 100644 flake.nix diff --git a/.envrc b/.envrc new file mode 100644 index 000000000..a5d14d340 --- /dev/null +++ b/.envrc @@ -0,0 +1,2 @@ +use flake +dotenv_if_exists .develop.env diff --git a/.gitignore b/.gitignore index cb73be599..225eeb4dc 100644 --- a/.gitignore +++ b/.gitignore @@ -44,4 +44,6 @@ tunnel.log /sessions /changelog.json /.current-version -/.current-changelog.md \ No newline at end of file +/.current-changelog.md +**/.direnv +.develop.env \ No newline at end of file diff --git a/flake.lock b/flake.lock new file mode 100644 index 000000000..b486ac53f --- /dev/null +++ b/flake.lock @@ -0,0 +1,44 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1619345332, + "narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28", + "type": "github" + }, + "original": { + "owner": "numtide", + "ref": "master", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1620323686, + "narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "dfacb8329b2236688b9a1e705116203a213b283a", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "master", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 000000000..b19677831 --- /dev/null +++ b/flake.nix @@ -0,0 +1,27 @@ +{ + inputs = { + nixpkgs = { + type = "github"; + owner = "NixOS"; + repo = "nixpkgs"; + ref = "master"; + }; + flake-utils = { + type = "github"; + owner = "numtide"; + repo = "flake-utils"; + ref = "master"; + }; + }; + + outputs = { nixpkgs, flake-utils, ... }: flake-utils.lib.eachDefaultSystem + (system: + let pkgs = import nixpkgs { + inherit system; + config.allowUnfree = true; + }; + in { + devShell = import ./shell.nix { inherit pkgs; }; + } + ); +} diff --git a/shell.nix b/shell.nix index de09bff73..8ff87a860 100644 --- a/shell.nix +++ b/shell.nix @@ -1,12 +1,8 @@ -{ nixpkgs ? import ./nixpkgs.nix {} }: +{ pkgs ? (import ./nixpkgs.nix {}).pkgs }: let - inherit (nixpkgs {}) pkgs; - # haskellPackages = import ./stackage.nix { inherit nixpkgs; }; haskellPackages = pkgs.haskellPackages; - drv = haskellPackages.callPackage ./uniworx.nix {}; - postgresSchema = pkgs.writeText "schema.sql" '' CREATE USER uniworx WITH SUPERUSER; CREATE DATABASE uniworx_test; @@ -19,129 +15,144 @@ let local all all trust ''; - override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]); - shellHook = '' - export PROMPT_INFO="${oldAttrs.name}" + develop = pkgs.writeScriptBin "develop" '' + #!${pkgs.zsh}/bin/zsh - export PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000)) + cleanup() { + set +e -x + type cleanup_postgres &>/dev/null && cleanup_postgres + type cleanup_widget_memcached &>/dev/null && cleanup_widget_memcached + type cleanup_session_memcached &>/dev/null && cleanup_session_memcached + type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached + type cleanup_minio &>/dev/null && cleanup_minio - cleanup() { - set +e -x - type cleanup_postgres &>/dev/null && cleanup_postgres - type cleanup_widget_memcached &>/dev/null && cleanup_widget_memcached - type cleanup_session_memcached &>/dev/null && cleanup_session_memcached - type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached - type cleanup_minio &>/dev/null && cleanup_minio - set +x + [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env" + set +x + } + + trap cleanup EXIT + + basePath=$(pwd) + + echo "" > ''${basePath}/.develop.env + + PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000)) + echo "PORT_OFFSET=''${PORT_OFFSET}" >> ''${basePath}/.develop.env + + if [[ -z "$PGHOST" ]]; then + set -xe + + pgDir=$(mktemp -d) + pgSockDir=$(mktemp -d) + pgLogFile=$(mktemp) + initdb --no-locale -D ''${pgDir} + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms" + psql -h ''${pgSockDir} -f ${postgresSchema} postgres + printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} + + cleanup_postgres() { + set +e -x + pg_ctl stop -D ''${pgDir} + rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} + set +x } - trap cleanup EXIT + set +xe + fi - if [[ -z "$PGHOST" ]]; then - set -xe + echo "PGHOST=''${pgSockDir}" >> ''${basePath}/.develop.env + echo "PGLOG=''${pgLogFile}" >> ''${basePath}/.develop.env - pgDir=$(mktemp -d) - pgSockDir=$(mktemp -d) - pgLogFile=$(mktemp) - initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms" - export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} - psql -f ${postgresSchema} postgres - printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} + if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then + set -xe - cleanup_postgres() { - set +e -x - pg_ctl stop -D ''${pgDir} - rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile} - set +x - } + memcached -l localhost -p $(($PORT_OFFSET + 11211)) &>/dev/null & + widget_memcached_pid=$! - set +xe - fi + cleanup_widget_memcached() { + [[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid + } - if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then - set -xe + set +xe + fi - memcached -l localhost -p $(($PORT_OFFSET + 11211)) &>/dev/null & - widget_memcached_pid=$? + echo "WIDGET_MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env + echo "WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211))" >> ''${basePath}/.develop.env - cleanup_widget_memcached() { - [[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid - } + echo "PGLOG=''${PGLOG}" >> ''${basePath}/.develop.env - export WIDGET_MEMCACHED_HOST=localhost WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211)) + if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then + set -xe - set +xe - fi + memcached -l localhost -p $(($PORT_OFFSET + 11212)) &>/dev/null & + session_memcached_pid=$! - if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then - set -xe + cleanup_session_memcached() { + [[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid + } - memcached -l localhost -p $(($PORT_OFFSET + 11212)) &>/dev/null & - session_memcached_pid=$? + set +xe + fi - cleanup_session_memcached() { - [[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid - } + echo "SESSION_MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env + echo "SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212))" >> ''${basePath}/.develop.env - export SESSION_MEMCACHED_HOST=localhost SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) + if [[ -z "$MEMCACHED_HOST" ]]; then + set -xe - set +xe - fi + memcached -l localhost -p $(($PORT_OFFSET + 11213)) &>/dev/null & + memcached_pid=$! - if [[ -z "$MEMCACHED_HOST" ]]; then - set -xe + cleanup_session_memcached() { + [[ -n "$memcached_pid" ]] && kill $memcached_pid + } - memcached -l localhost -p $(($PORT_OFFSET + 11213)) &>/dev/null & - memcached_pid=$? + set +xe + fi - cleanup_session_memcached() { - [[ -n "$memcached_pid" ]] && kill $memcached_pid - } + echo "MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env + echo "MEMCACHED_PORT=$(($PORT_OFFSET + 11212))" >> ''${basePath}/.develop.env - export MEMCACHED_HOST=localhost MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) + if [[ -z "$UPLOAD_S3_HOST" ]]; then + set -xe - set +xe - fi + cleanup_minio() { + [[ -n "$minio_pid" ]] && kill $minio_pid + [[ -n "$minio_dir" ]] && rm -rvf ''${minio_dir} + [[ -n "MINIO_LOGFILE" ]] && rm -rvf ''${MINIO_LOGFILE} + } - if [[ -z "$UPLOAD_S3_HOST" ]]; then - set -xe + MINIO_DIR=$(mktemp -d) + MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log) + MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) + MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1) - cleanup_minio() { - [[ -n "$minio_pid" ]] && kill $minio_pid - [[ -n "$minio_dir" ]] && rm -rvf ''${minio_dir} - [[ -n "MINIO_LOGFILE" ]] && rm -rvf ''${MINIO_LOGFILE} - } + minio server --address localhost:$(($PORT_OFFSET + 9000)) ''${MINIO_DIR} &>''${MINIO_LOGFILE} & + minio_pid=$! - export MINIO_DIR=$(mktemp -d) - export MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log) - export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) - export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1) + sleep 1 - minio server --address localhost:$(($PORT_OFFSET + 9000)) ''${MINIO_DIR} &>''${MINIO_LOGFILE} & - minio_pid=$? + set +xe + fi - sleep 1 + echo "MINIO_DIR=''${MINIO_DIR}" >> ''${basePath}/.develop.env + echo "MINIO_LOGFILE=''${MINIO_LOGFILE}" >> ''${basePath}/.develop.env + echo "UPLOAD_S3_HOST=localhost" >> ''${basePath}/.develop.env + echo "UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000))" >> ''${basePath}/.develop.env + echo "UPLOAD_S3_SSL=false" >> ''${basePath}/.develop.env + echo "UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}" >> ''${basePath}/.develop.env + echo "UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}" >> ''${basePath}/.develop.env - export UPLOAD_S3_HOST=localhost UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000)) UPLOAD_S3_SSL=false UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY} UPLOAD_S3_KEY=''${MINIO_SECRET_KEY} + if [ -n "$ZSH_VERSION" ]; then + autoload -U +X compinit && compinit + autoload -U +X bashcompinit && bashcompinit + fi + eval "$(stack --bash-completion-script stack)" - set +xe - fi - - if [ -n "$ZSH_VERSION" ]; then - autoload -U +X compinit && compinit - autoload -U +X bashcompinit && bashcompinit - fi - eval "$(stack --bash-completion-script stack)" - - ${oldAttrs.shellHook} - ''; - }; - - dummy = pkgs.stdenv.mkDerivation { - name = "interactive-uniworx-environment"; - shellHook = ""; - }; -in pkgs.stdenv.lib.overrideDerivation dummy override - #pkgs.stdenv.lib.overrideDerivation drv.env override + $(getent passwd $USER | cut -d: -f 7) + ''; +in pkgs.mkShell { + name = "uni2work"; + + nativeBuildInputs = [develop] ++ (with pkgs; [ nodejs-14_x postgresql_12 openldap google-chrome exiftool memcached minio minio-client ]) ++ (with pkgs.haskellPackages; [ stack yesod-bin hlint cabal-install weeder profiteur ]); +} From f0074c8ac8238f053e74e155c65816b79117348c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 12:08:14 +0200 Subject: [PATCH 14/21] chore(gitlab-ci): reduce artifact expiry times --- .gitlab-ci.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index b2c28a2b8..defefbd35 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -124,7 +124,7 @@ yesod:build:dev: paths: - bin/ name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" - expire_in: "1 week" + expire_in: "1 day" rules: - if: $CI_COMMIT_REF_NAME =~ /(^v[0-9].*)|((^|\/)profile($|\/))/ @@ -151,7 +151,7 @@ yesod:build: paths: - bin/ name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" - expire_in: "1 week" + expire_in: "1 day" rules: - if: $CI_COMMIT_REF_NAME =~ /^v[0-9].*/ @@ -181,7 +181,7 @@ yesod:build:profile: paths: - bin/ name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" - expire_in: "1 week" + expire_in: "1 day" rules: - if: $CI_COMMIT_REF_NAME =~ /(^|\/)profile($|\/)/ @@ -277,7 +277,7 @@ yesod:test:hlint: paths: - gl-code-quality-report.json name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" - expire_in: "1 week" + expire_in: "1 day" reports: codequality: gl-code-quality-report.json @@ -312,7 +312,7 @@ yesod:test:hlint:dev: paths: - gl-code-quality-report.json name: "${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA}" - expire_in: "1 week" + expire_in: "1 day" reports: codequality: gl-code-quality-report.json From d71aa7d2de9d2a46447d6e9a3e664afb0f1e2394 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 12:22:04 +0200 Subject: [PATCH 15/21] chore(gitlab-ci): more precise caching --- .gitlab-ci.yml | 50 ++++++++++++++++++++++++++++++++------------------ 1 file changed, 32 insertions(+), 18 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index defefbd35..f138a2a4e 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -7,14 +7,6 @@ workflow: default: image: name: fpco/stack-build:lts-16.31 - cache: &global_cache - key: default - paths: - - .npm - - node_modules - - .stack - - .stack-work - - .well-known-cache variables: STACK_ROOT: "${CI_PROJECT_DIR}/.stack" @@ -43,6 +35,13 @@ stages: # - deploy npm install: + cache: + - &npm-cache + key: default-npm + paths: + - .npm + - node_modules + stage: setup script: - ./.npmrc.gup @@ -69,6 +68,12 @@ npm install: interruptible: true frontend:build: + cache: + - &frontend-cache + key: default-frontend + paths: + - .well-known-cache + stage: frontend:build script: - npm run frontend:build @@ -98,6 +103,13 @@ frontend:lint: interruptible: true yesod:build:dev: + cache: + - &stack-dev-cache + key: default-stack-dev + paths: + - .stack + - .stack-work + stage: yesod:build script: - stack build --test --copy-bins --local-bin-path $(pwd)/bin --fast --flag uniworx:-library-only --flag uniworx:dev --flag uniworx:pedantic --no-strip --no-run-tests @@ -136,6 +148,13 @@ yesod:build:dev: interruptible: true yesod:build: + cache: + - &stack-cache + key: default-stack + paths: + - .stack + - .stack-work + stage: yesod:build script: - stack build --test --copy-bins --local-bin-path $(pwd)/bin --flag uniworx:-library-only --flag uniworx:-dev --flag uniworx:pedantic --no-strip --no-run-tests @@ -165,8 +184,11 @@ yesod:build: yesod:build:profile: cache: - <<: *global_cache - policy: pull + - &stack-profile-cache + key: default-stack-profile + paths: + - .stack + - .stack-work stage: yesod:build script: @@ -195,7 +217,6 @@ yesod:build:profile: yesod:test:yesod: stage: test - cache: {} services: &test-services - name: postgres:10.10 @@ -224,7 +245,6 @@ yesod:test:yesod: yesod:test:yesod:dev: stage: test - cache: {} services: *test-services @@ -321,9 +341,6 @@ yesod:test:hlint:dev: interruptible: true frontend:test: - cache: - <<: *global_cache - policy: pull stage: test script: - npm run frontend:test @@ -344,7 +361,6 @@ frontend:test: interruptible: true parse-changelog: - cache: {} stage: prepare release needs: - job: npm install @@ -373,7 +389,6 @@ parse-changelog: interruptible: true upload: - cache: {} variables: GIT_STRATEGY: none stage: upload packages @@ -411,7 +426,6 @@ upload: curl --header "JOB-TOKEN: ${CI_JOB_TOKEN}" --upload-file bin/uniworx-wflint ${PACKAGE_REGISTRY_URL}/${VERSION}/uniworx-wflint release: - cache: {} variables: GIT_STRATEGY: none stage: release From 4ff3e6cee5397fec331f159b85977fe2b008b342 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 12:40:12 +0200 Subject: [PATCH 16/21] chore(develop): fix minio cleanup --- shell.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/shell.nix b/shell.nix index 8ff87a860..d6bc7b130 100644 --- a/shell.nix +++ b/shell.nix @@ -118,8 +118,8 @@ let cleanup_minio() { [[ -n "$minio_pid" ]] && kill $minio_pid - [[ -n "$minio_dir" ]] && rm -rvf ''${minio_dir} - [[ -n "MINIO_LOGFILE" ]] && rm -rvf ''${MINIO_LOGFILE} + [[ -n "''${MINIO_DIR}" ]] && rm -rvf ''${MINIO_DIR} + [[ -n "''${MINIO_LOGFILE}" ]] && rm -rvf ''${MINIO_LOGFILE} } MINIO_DIR=$(mktemp -d) From dc24d9aa576a5c30a5e2232b81d0f79856279629 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 20:38:52 +0200 Subject: [PATCH 17/21] chore(develop): fix env export --- shell.nix | 77 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 50 insertions(+), 27 deletions(-) diff --git a/shell.nix b/shell.nix index d6bc7b130..701304db9 100644 --- a/shell.nix +++ b/shell.nix @@ -36,8 +36,7 @@ let echo "" > ''${basePath}/.develop.env - PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000)) - echo "PORT_OFFSET=''${PORT_OFFSET}" >> ''${basePath}/.develop.env + export PORT_OFFSET=$(((16#$(whoami | sha256sum | head -c 16)) % 1000)) if [[ -z "$PGHOST" ]]; then set -xe @@ -50,6 +49,9 @@ let psql -h ''${pgSockDir} -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} + export PGHOST=''${pgSockDir} + export PGLOG=''${pgLogFile} + cleanup_postgres() { set +e -x pg_ctl stop -D ''${pgDir} @@ -60,15 +62,15 @@ let set +xe fi - echo "PGHOST=''${pgSockDir}" >> ''${basePath}/.develop.env - echo "PGLOG=''${pgLogFile}" >> ''${basePath}/.develop.env - if [[ -z "$WIDGET_MEMCACHED_HOST" ]]; then set -xe memcached -l localhost -p $(($PORT_OFFSET + 11211)) &>/dev/null & widget_memcached_pid=$! + export WIDGET_MEMCACHED_HOST=localhost + export WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211)) + cleanup_widget_memcached() { [[ -n "$widget_memcached_pid" ]] && kill $widget_memcached_pid } @@ -76,17 +78,15 @@ let set +xe fi - echo "WIDGET_MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env - echo "WIDGET_MEMCACHED_PORT=$(($PORT_OFFSET + 11211))" >> ''${basePath}/.develop.env - - echo "PGLOG=''${PGLOG}" >> ''${basePath}/.develop.env - if [[ -z "$SESSION_MEMCACHED_HOST" ]]; then set -xe memcached -l localhost -p $(($PORT_OFFSET + 11212)) &>/dev/null & session_memcached_pid=$! + export SESSION_MEMCACHED_HOST=localhost + export SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) + cleanup_session_memcached() { [[ -n "$session_memcached_pid" ]] && kill $session_memcached_pid } @@ -94,15 +94,15 @@ let set +xe fi - echo "SESSION_MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env - echo "SESSION_MEMCACHED_PORT=$(($PORT_OFFSET + 11212))" >> ''${basePath}/.develop.env - if [[ -z "$MEMCACHED_HOST" ]]; then set -xe memcached -l localhost -p $(($PORT_OFFSET + 11213)) &>/dev/null & memcached_pid=$! + export MEMCACHED_HOST=localhost + export MEMCACHED_PORT=$(($PORT_OFFSET + 11212)) + cleanup_session_memcached() { [[ -n "$memcached_pid" ]] && kill $memcached_pid } @@ -110,9 +110,6 @@ let set +xe fi - echo "MEMCACHED_HOST=localhost" >> ''${basePath}/.develop.env - echo "MEMCACHED_PORT=$(($PORT_OFFSET + 11212))" >> ''${basePath}/.develop.env - if [[ -z "$UPLOAD_S3_HOST" ]]; then set -xe @@ -122,26 +119,52 @@ let [[ -n "''${MINIO_LOGFILE}" ]] && rm -rvf ''${MINIO_LOGFILE} } - MINIO_DIR=$(mktemp -d) - MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log) - MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) - MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1) + export MINIO_DIR=$(mktemp -d) + export MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log) + export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) + export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1) minio server --address localhost:$(($PORT_OFFSET + 9000)) ''${MINIO_DIR} &>''${MINIO_LOGFILE} & minio_pid=$! + export UPLOAD_S3_HOST=localhost + export UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000)) + export UPLOAD_S3_SSL=false + export UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY} + export UPLOAD_S3_KEY=''${MINIO_SECRET_KEY} + sleep 1 set +xe fi - echo "MINIO_DIR=''${MINIO_DIR}" >> ''${basePath}/.develop.env - echo "MINIO_LOGFILE=''${MINIO_LOGFILE}" >> ''${basePath}/.develop.env - echo "UPLOAD_S3_HOST=localhost" >> ''${basePath}/.develop.env - echo "UPLOAD_S3_PORT=$(($PORT_OFFSET + 9000))" >> ''${basePath}/.develop.env - echo "UPLOAD_S3_SSL=false" >> ''${basePath}/.develop.env - echo "UPLOAD_S3_KEY_ID=''${MINIO_ACCESS_KEY}" >> ''${basePath}/.develop.env - echo "UPLOAD_S3_KEY=''${MINIO_SECRET_KEY}" >> ''${basePath}/.develop.env + set -xe + + cat >> ''${basePath}/.develop.env < Date: Fri, 7 May 2021 20:41:32 +0200 Subject: [PATCH 18/21] fix: update imprint & add instructions for help --- src/Handler/Help.hs | 1 + .../i18n/help-instructions/de-de-formal.hamlet | 15 +++++++++++++++ templates/i18n/help-instructions/en-eu.hamlet | 15 +++++++++++++++ templates/i18n/imprint/de-de-formal.hamlet | 7 ++++--- templates/i18n/imprint/en.hamlet | 7 ++++--- 5 files changed, 39 insertions(+), 6 deletions(-) create mode 100644 templates/i18n/help-instructions/de-de-formal.hamlet create mode 100644 templates/i18n/help-instructions/en-eu.hamlet diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index f6070369e..b3ff768c9 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -51,6 +51,7 @@ helpForm mReferer mUid = renderWForm FormStandard $ do hfReferer' <- wopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) hfUserId' <- multiActionW identActions (fslI MsgHelpAnswer) (HIUser <$ mUid) hfSubject' <- wopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing + wformMessage =<< messageWidget Info $(i18nWidgetFile "help-instructions") hfRequest' <- case sessErr of Nothing -> fmap Just <$> wreq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing Just _ -> wopt htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing diff --git a/templates/i18n/help-instructions/de-de-formal.hamlet b/templates/i18n/help-instructions/de-de-formal.hamlet new file mode 100644 index 000000000..99370c184 --- /dev/null +++ b/templates/i18n/help-instructions/de-de-formal.hamlet @@ -0,0 +1,15 @@ +$newline never + +

+ + Bitte bedenken Sie beim Stellen Ihrer Anfrage, dass das # + Uni2work-Kernteam aktuell aus Sarah Vaupel und Gregor Kleen besteht # + und zwei Personen nicht hinreichend sind um in allen Fällen eine # + zeitnahe Bearbeitung Ihres Anliegens zu garantieren. + +

+ + Falls sich Ihr Anliegen auf eine konkrete Veranstaltung bezieht, # + ziehen Sie bitte auch in Betracht (insbesondere bei zeitkritischen # + Anliegen wie z.B. Abgaben) sich direkt an die Kursverwalter zu # + wenden. diff --git a/templates/i18n/help-instructions/en-eu.hamlet b/templates/i18n/help-instructions/en-eu.hamlet new file mode 100644 index 000000000..65e205bae --- /dev/null +++ b/templates/i18n/help-instructions/en-eu.hamlet @@ -0,0 +1,15 @@ +$newline never + +

+ + When formulating your request please consider that the Uni2work core # + team currently consists of Sarah Vaupel and Gregor Kleen and that # + two people are not enough to guarantee a timely answer in all cases. + +

+ + If your request is related to a specific course, please also # + consider contacting the relevant course administrators as well. # + + Especially if your request is time sensitive (e.g. submitting for an # + exercise sheet). diff --git a/templates/i18n/imprint/de-de-formal.hamlet b/templates/i18n/imprint/de-de-formal.hamlet index fbcb8a89b..bd923593d 100644 --- a/templates/i18n/imprint/de-de-formal.hamlet +++ b/templates/i18n/imprint/de-de-formal.hamlet @@ -3,11 +3,12 @@ $newline never

Inhalt
    -
  • Gregor Kleen +
  • Gregor Kleen & Sarah Vaupel
  • Oettingenstraße 67
  • D-80538 München -
  • E-Mail: ^{mailtoHtml "gregor.kleen@tcs.ifi.lmu.de"} -
  • Telefon: +49 (0) 89 / 2180 - 9139 +
  • E-Mail: ^{mailtoHtml "uni2work@ifi.lmu.de"} +
  • Telefon (Gregor Kleen): +49 (0) 89 / 2180 - 9139 +
  • Telefon (Sarah Vaupel): —

    Jugendschutz
      diff --git a/templates/i18n/imprint/en.hamlet b/templates/i18n/imprint/en.hamlet index 0d6e61564..c2506db40 100644 --- a/templates/i18n/imprint/en.hamlet +++ b/templates/i18n/imprint/en.hamlet @@ -3,11 +3,12 @@ $newline never

      Contents
        -
      • Gregor Kleen +
      • Gregor Kleen & Sarah Vaupel
      • Oettingenstraße 67
      • D-80538 München (Germany) -
      • E-Mail: ^{mailtoHtml "gregor.kleen@tcs.ifi.lmu.de"} -
      • Telefon: +49 (0) 89 / 2180 - 9139 +
      • E-Mail: ^{mailtoHtml "uni2work@ifi.lmu.de"} +
      • Telefon (Gregor Kleen): +49 (0) 89 / 2180 - 9139 +
      • Telefon (Sarah Vaupel): —

        Youth Protection
          From 9597b911ce2afcc5c22543cb02eb9abef45f608d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 May 2021 20:56:06 +0200 Subject: [PATCH 19/21] chore(release): 25.10.5 --- CHANGELOG.md | 7 +++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 10 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 02ffca3de..3dddabc22 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [25.10.5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.4...v25.10.5) (2021-05-07) + + +### Bug Fixes + +* update imprint & add instructions for help ([eec9a39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/eec9a3974fc4cde5cc70ab650d018667ce044a92)) + ## [25.10.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.10.3...v25.10.4) (2021-05-06) diff --git a/package-lock.json b/package-lock.json index 692e4ad4f..4465644e7 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.4", + "version": "25.10.5", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index f1044c73f..95f3b47fa 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "25.10.4", + "version": "25.10.5", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 843902b79..b2385aee6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 25.10.4 +version: 25.10.5 dependencies: - base - yesod From a6627a5e760a8280279e939950f081b53f68e187 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 8 May 2021 13:17:53 +0200 Subject: [PATCH 20/21] chore(nix): always use nixpkgs from flake input --- nixpkgs.nix | 18 ++++++++---------- shell.nix | 2 +- stack.nix | 2 +- stackage.nix | 2 +- 4 files changed, 11 insertions(+), 13 deletions(-) diff --git a/nixpkgs.nix b/nixpkgs.nix index 6a21dfbda..4492a1c3a 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -1,10 +1,8 @@ -{ nixpkgs ? import -}: - -import ((nixpkgs {}).fetchFromGitHub { - owner = "NixOS"; - repo = "nixpkgs"; - rev = "a7a1447e5d40a9ad90983d33e151f5474eddeed9"; - sha256 = "1zb8wgsq9grrsdcz81y08h45rj8i5r8ckjhg2cv1cqmam4dczcrf"; - fetchSubmodules = true; -}) +import ( + let + lock = builtins.fromJSON (builtins.readFile ./flake.lock); + in fetchTarball { + url = "https://api.github.com/repos/NixOS/nixpkgs/tarball/${lock.nodes.nixpkgs.locked.rev}"; + sha256 = lock.nodes.nixpkgs.locked.narHash; + } +) diff --git a/shell.nix b/shell.nix index 701304db9..73dd7f849 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ pkgs ? (import ./nixpkgs.nix {}).pkgs }: +{ pkgs ? (import ./nixpkgs.nix).pkgs }: let haskellPackages = pkgs.haskellPackages; diff --git a/stack.nix b/stack.nix index 53fb60f6b..762fd7481 100644 --- a/stack.nix +++ b/stack.nix @@ -1,4 +1,4 @@ -{ ghc, nixpkgs ? import ./nixpkgs.nix {} }: +{ ghc, nixpkgs ? import ./nixpkgs.nix }: let # haskellPackages = import ./stackage.nix { inherit nixpkgs; }; diff --git a/stackage.nix b/stackage.nix index 0dfcdcae4..58a86fc86 100644 --- a/stackage.nix +++ b/stackage.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import ./nixpkgs.nix {} +{ nixpkgs ? import ./nixpkgs.nix , snapshot ? "lts-13.21" }: From d33c03431ad97619fc95c67d1913fea3b588d591 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 8 May 2021 13:25:43 +0200 Subject: [PATCH 21/21] chore(develop): better name temporary directories --- shell.nix | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/shell.nix b/shell.nix index 73dd7f849..08a048fb6 100644 --- a/shell.nix +++ b/shell.nix @@ -41,9 +41,9 @@ let if [[ -z "$PGHOST" ]]; then set -xe - pgDir=$(mktemp -d) - pgSockDir=$(mktemp -d) - pgLogFile=$(mktemp) + pgDir=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} postgresql.XXXXXX) + pgSockDir=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} postgresql.sock.XXXXXX) + pgLogFile=$(mktemp --tmpdir=''${XDG_RUNTIME_DIR} postgresql.XXXXXX.log) initdb --no-locale -D ''${pgDir} pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms" psql -h ''${pgSockDir} -f ${postgresSchema} postgres @@ -119,8 +119,8 @@ let [[ -n "''${MINIO_LOGFILE}" ]] && rm -rvf ''${MINIO_LOGFILE} } - export MINIO_DIR=$(mktemp -d) - export MINIO_LOGFILE=$(mktemp --tmpdir minio.XXXXXX.log) + export MINIO_DIR=$(mktemp -d --tmpdir=''${XDG_RUNTIME_DIR} minio.XXXXXX) + export MINIO_LOGFILE=$(mktemp --tmpdir=''${XDG_RUNTIME_DIR} minio.XXXXXX.log) export MINIO_ACCESS_KEY=$(${pkgs.pwgen}/bin/pwgen -s 16 1) export MINIO_SECRET_KEY=$(${pkgs.pwgen}/bin/pwgen -s 32 1)