From 3646e42d3fa841629e7285ededca30dd4b213d37 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 16:38:55 +0200 Subject: [PATCH 001/132] chore(db-fill): student system-function --- test/Database/Fill.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c6c0d4ffb..5d8755b7b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -436,6 +436,8 @@ fillDb = do sdMst = StudyDegreeKey' 88 sdLAR = StudyDegreeKey' 33 sdLAG = StudyDegreeKey' 35 + for_ (maxMuster : tinaTester : manyUsers) $ \uid -> + void . insert' $ UserSystemFunction uid SystemStudent False False repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" ) repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" ) repsert sdLAR $ StudyDegree 33 (Just "LAR") Nothing -- intentionally left unknown From c7ce1679de799285ec7a9a0a62c0a202b9078eb3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 16:42:41 +0200 Subject: [PATCH 002/132] fix: typo course-assistant --- messages/uniworx/categories/courses/courses/de-de-formal.msg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index fb33d8c9f..eb106d048 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -242,9 +242,9 @@ CourseAllApplicationsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{ CourseLecInviteHeading courseName@Text: Einladung zum/zur Kursverwalter/Kursverwalterin für #{courseName} CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter:in für einen Kurs zu sein. CourseUserHasPersonalisedSheetFilesFilter: Teilnehmer:in hat personalisierte Übungsblatt-Dateien für -HeadingCourseMembers: Teilnehmer +HeadingCourseMembers: Teilnehmer:innen -CourseAssistant: Assitent +CourseAssistant: Assistent:in CourseParticipantStateIsInactive: Teilnehmer:in ist nicht aktiv CourseParticipantStateIsActive: Teilnehmer:in ist aktiv CourseUserSendMail: Nachricht an Teilnehmer:in senden From 90e4a620f0c1671ff332db1910c176e58ccbac06 Mon Sep 17 00:00:00 2001 From: ros Date: Mon, 31 May 2021 16:23:51 +0200 Subject: [PATCH 003/132] feat(course material): first two filters --- .../courses/material/de-de-formal.msg | 2 ++ .../categories/courses/material/en-eu.msg | 2 ++ src/Application.hs | 8 ++++++ src/Handler/Material.hs | 25 +++++++++++++------ test/Database/Fill.hs | 18 +++++++++++++ 5 files changed, 48 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/courses/material/de-de-formal.msg b/messages/uniworx/categories/courses/material/de-de-formal.msg index 63311eb1d..e8fe8430c 100644 --- a/messages/uniworx/categories/courses/material/de-de-formal.msg +++ b/messages/uniworx/categories/courses/material/de-de-formal.msg @@ -30,3 +30,5 @@ MaterialVideoDownload: Herunterladen MaterialFree: Kursmaterialien ohne Anmeldung zugänglich AccessibleSince: Verfügbar seit VisibleFrom: Veröffentlicht +FilterMaterialNameSearch !ident-ok: Name +FilterMaterialTypeAndDescriptionSearch: Art oder Beschreibung \ No newline at end of file diff --git a/messages/uniworx/categories/courses/material/en-eu.msg b/messages/uniworx/categories/courses/material/en-eu.msg index 8c2b0c202..4cc59f300 100644 --- a/messages/uniworx/categories/courses/material/en-eu.msg +++ b/messages/uniworx/categories/courses/material/en-eu.msg @@ -30,3 +30,5 @@ MaterialVideoDownload: Download MaterialFree: Course material is publicly available. AccessibleSince: Accessible since VisibleFrom: Published +FilterMaterialNameSearch !ident-ok: Name +FilterMaterialTypeAndDescriptionSearch: Type or description \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 0c0fcbbd5..9d5e8ebce 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -710,3 +710,11 @@ addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} + + + + + + + + diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 2e0e961b5..a09ea741a 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -102,17 +102,17 @@ getMaterialListR tid ssh csh = do & forceFilter "may-access" (Any True) dbTableWidget' psValidator DBTable { dbtIdent = "material-list" :: Text - , dbtStyle = def + , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = def - , dbtSQLQuery = \material -> do + , dbtSQLQuery = \material -> do E.where_ $ material E.^. MaterialCourse E.==. E.val cid let filesNum :: E.SqlExpr (E.Value Int64) filesNum = E.subSelectCount . E.from $ \materialFile -> E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId return (material, filesNum) , dbtRowKey = (E.^. MaterialId) - , dbtProj = dbtProjFilteredPostId - , dbtColonnade = widgetColonnade $ mconcat + , dbtProj = dbtProjFilteredPostId + , dbtColonnade = widgetColonnade $ mconcat [ -- dbRow, sortable (Just "type") (i18nCell MsgMaterialType) $ foldMap (textCell . CI.original) . materialType . row2material @@ -138,10 +138,21 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr - -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool + [ (singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr + -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool) + , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) + , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just needle -> (E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + --E.||. (E.castString (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + ) + ] - , dbtFilterUI = mempty + , dbtFilterUI = \mPrev -> mconcat $ catMaybes + [ Just $ prismAForm (singletonFilter "searchName") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) + , Just $ prismAForm (singletonFilter "searchTypeAndDescription") mPrev $ aopt textField (fslI MsgFilterMaterialTypeAndDescriptionSearch) ] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 5d8755b7b..b97ed31e3 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -730,6 +730,24 @@ fillDb = do } , examStaff = Just "Hofmann" } + _ <- insert' Material + { materialCourse = ffp + , materialName = "Material 1" + , materialType = Just "Typ 1" + , materialDescription = Just $ htmlToStoredMarkup [shamlet|Folien für die Zentralübung|] + , materialVisibleFrom = Just now + , materialLastEdit = now + } + + _ <- insert' Material + { materialCourse = ffp + , materialName = "Material 2" + , materialType = Just "Typ 2" + , materialDescription = Just $ htmlToStoredMarkup [shamlet|Videos für die Vorlesung|] + , materialVisibleFrom = Just now + , materialLastEdit = now + } + void . insertMany $ map (\u -> ExamRegistration examFFP u Nothing now) [ fhamann , maxMuster From 89e9887fe1112cbc21517e4b501ead33f5a969ba Mon Sep 17 00:00:00 2001 From: ros Date: Sun, 6 Jun 2021 11:22:13 +0200 Subject: [PATCH 004/132] feat(course material): materialDescription in progress --- src/Application.hs | 5 ----- src/Handler/Material.hs | 5 +---- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 9d5e8ebce..29eb69e05 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -713,8 +713,3 @@ addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do - - - - - diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index a09ea741a..226fbd28d 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -146,9 +146,7 @@ getMaterialListR tid ssh csh = do , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - --E.||. (E.castString (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - ) - + E.||. (E.castString (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "searchName") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) @@ -400,4 +398,3 @@ getMArchiveR tid ssh csh mnm = do let getMatQuery = materialArchiveSource tid ssh csh mnm serveSomeFiles archiveName getMatQuery - From 3a9622dfb8474d9f3764f5870197e317a96d9de3 Mon Sep 17 00:00:00 2001 From: ros Date: Fri, 11 Jun 2021 16:04:01 +0200 Subject: [PATCH 005/132] feat(course material): materialdescription search implemented --- src/Application.hs | 5 +---- src/Handler/Material.hs | 3 ++- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 29eb69e05..001d87096 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -709,7 +709,4 @@ addPWEntry :: User addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength - void $ insert User{..} - - - + void $ insert User{..} \ No newline at end of file diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 226fbd28d..147c79344 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -18,6 +18,7 @@ import qualified Data.CaseInsensitive as CI -- import qualified Data.Text.Encoding as Text import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E import Utils.Form import Handler.Utils @@ -146,7 +147,7 @@ getMaterialListR tid ssh csh = do , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - E.||. (E.castString (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) + E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "searchName") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) From decdda359d16cce429a7e7a07d4674840e5fe6af Mon Sep 17 00:00:00 2001 From: ros Date: Mon, 21 Jun 2021 15:18:45 +0200 Subject: [PATCH 006/132] =?UTF-8?q?feat(course=20material):=20auto=20vorsc?= =?UTF-8?q?hl=C3=A4ge=20f=C3=BCr=20materialtype?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Application.hs | 6 +++++- src/Handler/Material.hs | 14 ++++++++++++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 001d87096..d9a64a0f9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -709,4 +709,8 @@ addPWEntry :: User addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength - void $ insert User{..} \ No newline at end of file + void $ insert User{..} + + + + diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 147c79344..88e496565 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -81,6 +81,16 @@ fetchMaterial tid ssh csh mnm = getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let typeOptions :: HandlerFor UniWorX (OptionList Text) + typeOptions = do + previouslyUsed <- runDB $ + E.select $ E.from $ \material -> + E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) + return $ material E.^. MaterialType + return . mkOptionList $ map (\t -> Option t t t) (map CI.original (Set.toAscList (Set.fromList (mapMaybe E.unValue previouslyUsed)))) let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR @@ -97,7 +107,7 @@ getMaterialListR tid ssh csh = do seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility MsgRenderer mr <- getMsgRenderer table <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + --cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] & forceFilter "may-access" (Any True) @@ -151,7 +161,7 @@ getMaterialListR tid ssh csh = do ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "searchName") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) - , Just $ prismAForm (singletonFilter "searchTypeAndDescription") mPrev $ aopt textField (fslI MsgFilterMaterialTypeAndDescriptionSearch) ] + , Just $ prismAForm (singletonFilter "searchTypeAndDescription") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] From d8b1f9788c74ea5d7dc4f1f45432649d9601106a Mon Sep 17 00:00:00 2001 From: ros Date: Mon, 21 Jun 2021 16:00:55 +0200 Subject: [PATCH 007/132] feat(course material): small empty-bug fixed --- src/Application.hs | 1 + src/Handler/Material.hs | 3 +-- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index d9a64a0f9..d1d7195f2 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -714,3 +714,4 @@ addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do + diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 88e496565..ad378b383 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -107,7 +107,6 @@ getMaterialListR tid ssh csh = do seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility MsgRenderer mr <- getMsgRenderer table <- runDB $ do - --cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] & forceFilter "may-access" (Any True) @@ -156,7 +155,7 @@ getMaterialListR tid ssh csh = do Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> (E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes From 95d1b41c606a2abb4f09a9c7499119d9d108ba91 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Jun 2021 14:06:34 +0000 Subject: [PATCH 008/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index ad378b383..55c9ced2c 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -90,7 +90,7 @@ getMaterialListR tid ssh csh = do E.where_ $ material E.^. MaterialCourse E.==. E.val cid E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) return $ material E.^. MaterialType - return . mkOptionList $ map (\t -> Option t t t) (map CI.original (Set.toAscList (Set.fromList (mapMaybe E.unValue previouslyUsed)))) + return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR From a7b41e9cc89f794ecaadb0c4d52207c773467b78 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Jun 2021 14:07:01 +0000 Subject: [PATCH 009/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 55c9ced2c..a803b5f8d 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -148,8 +148,8 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ (singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr - -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool) + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr + -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) From 08ec676616814809d7b0a30933e6e73391ac3037 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 21 Jun 2021 14:07:28 +0000 Subject: [PATCH 010/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index a803b5f8d..81aa47187 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -150,7 +150,7 @@ getMaterialListR tid ssh csh = do , dbtFilter = mconcat [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool - , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + , (singletonMap "searchName" . FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of From c09acbbf8a7b95176b3d52449b3b9d26e315ccd6 Mon Sep 17 00:00:00 2001 From: ros Date: Mon, 21 Jun 2021 16:17:52 +0200 Subject: [PATCH 011/132] =?UTF-8?q?feat(course=20material):=20runDB=20f?= =?UTF-8?q?=C3=BCr=20cid=20nur=20einmal?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Application.hs | 7 +------ src/Handler/Material.hs | 26 +++++++++++++------------- 2 files changed, 14 insertions(+), 19 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index d1d7195f2..001d87096 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -709,9 +709,4 @@ addPWEntry :: User addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength - void $ insert User{..} - - - - - + void $ insert User{..} \ No newline at end of file diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 81aa47187..5f095626a 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -81,16 +81,6 @@ fetchMaterial tid ssh csh mnm = getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh - let typeOptions :: HandlerFor UniWorX (OptionList Text) - typeOptions = do - previouslyUsed <- runDB $ - E.select $ E.from $ \material -> - E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do - E.where_ $ material E.^. MaterialCourse E.==. E.val cid - E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) - return $ material E.^. MaterialType - return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR @@ -107,6 +97,16 @@ getMaterialListR tid ssh csh = do seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility MsgRenderer mr <- getMsgRenderer table <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + let typeOptions :: HandlerFor UniWorX (OptionList Text) + typeOptions = do + previouslyUsed <- runDB $ + E.select $ E.from $ \material -> + E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do + E.where_ $ material E.^. MaterialCourse E.==. E.val cid + E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) + return $ material E.^. MaterialType + return . mkOptionList $ map (\t -> Option t t t) (map CI.original (Set.toAscList (Set.fromList (mapMaybe E.unValue previouslyUsed)))) let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] & forceFilter "may-access" (Any True) @@ -148,9 +148,9 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr - -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool - , (singletonMap "searchName" . FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + [ (singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr + -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool) + , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of From bee8f84eb3528286349bef4b9ea23f1c6240e1d1 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 25 Jun 2021 12:22:22 +0000 Subject: [PATCH 012/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 5f095626a..84d3a142c 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -159,7 +159,7 @@ getMaterialListR tid ssh csh = do E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes - [ Just $ prismAForm (singletonFilter "searchName") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) + [ Just $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) , Just $ prismAForm (singletonFilter "searchTypeAndDescription") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing From 363762081ebd7e5f854ba7966c5d0398ffaf310b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 25 Jun 2021 12:22:29 +0000 Subject: [PATCH 013/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 84d3a142c..dfe10d2d9 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -160,7 +160,7 @@ getMaterialListR tid ssh csh = do ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) - , Just $ prismAForm (singletonFilter "searchTypeAndDescription") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)] + , Just $ prismAForm (singletonFilter "type-and-description") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)] , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing , dbtExtraReps = [] From bc09bedb84787a22feec2f310aa77e8d27bc4996 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 25 Jun 2021 12:23:09 +0000 Subject: [PATCH 014/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index dfe10d2d9..0b6fcc9cf 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -153,7 +153,7 @@ getMaterialListR tid ssh csh = do , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) - , (singletonMap "searchTypeAndDescription". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + , (singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) From 617eb7ff948b47b65c6e153c3e581926fd56880b Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Fri, 25 Jun 2021 12:23:16 +0000 Subject: [PATCH 015/132] Apply 1 suggestion(s) to 1 file(s) --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 0b6fcc9cf..0a8edb3a7 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -150,7 +150,7 @@ getMaterialListR tid ssh csh = do , dbtFilter = mconcat [ (singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool) - , (singletonMap "searchName". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + , (singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) , (singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of From d1cdb0d1da792ee593ad2167d319dd232e43bcc9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 25 Jun 2021 12:25:25 +0000 Subject: [PATCH 016/132] Apply 1 suggestion(s) to 1 file(s) --- messages/uniworx/categories/courses/material/de-de-formal.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/categories/courses/material/de-de-formal.msg b/messages/uniworx/categories/courses/material/de-de-formal.msg index e8fe8430c..7d3ab8df6 100644 --- a/messages/uniworx/categories/courses/material/de-de-formal.msg +++ b/messages/uniworx/categories/courses/material/de-de-formal.msg @@ -31,4 +31,4 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich AccessibleSince: Verfügbar seit VisibleFrom: Veröffentlicht FilterMaterialNameSearch !ident-ok: Name -FilterMaterialTypeAndDescriptionSearch: Art oder Beschreibung \ No newline at end of file +FilterMaterialTypeAndDescriptionSearch: Art und Beschreibung \ No newline at end of file From 86234e9624675a8a4a650f31a2316ee171853dd5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 25 Jun 2021 12:25:32 +0000 Subject: [PATCH 017/132] Apply 1 suggestion(s) to 1 file(s) --- messages/uniworx/categories/courses/material/en-eu.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/categories/courses/material/en-eu.msg b/messages/uniworx/categories/courses/material/en-eu.msg index 4cc59f300..55d202c82 100644 --- a/messages/uniworx/categories/courses/material/en-eu.msg +++ b/messages/uniworx/categories/courses/material/en-eu.msg @@ -31,4 +31,4 @@ MaterialFree: Course material is publicly available. AccessibleSince: Accessible since VisibleFrom: Published FilterMaterialNameSearch !ident-ok: Name -FilterMaterialTypeAndDescriptionSearch: Type or description \ No newline at end of file +FilterMaterialTypeAndDescriptionSearch: Type and description \ No newline at end of file From dc5fc3f710363f0644c43866505e32095b41ce92 Mon Sep 17 00:00:00 2001 From: ros Date: Fri, 25 Jun 2021 14:47:25 +0200 Subject: [PATCH 018/132] feat(course material): merge-request suggestions --- .../categories/courses/material/de-de-formal.msg | 2 +- .../uniworx/categories/courses/material/en-eu.msg | 2 +- src/Handler/Material.hs | 14 +++++++------- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/categories/courses/material/de-de-formal.msg b/messages/uniworx/categories/courses/material/de-de-formal.msg index 7d3ab8df6..6e244f71c 100644 --- a/messages/uniworx/categories/courses/material/de-de-formal.msg +++ b/messages/uniworx/categories/courses/material/de-de-formal.msg @@ -31,4 +31,4 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich AccessibleSince: Verfügbar seit VisibleFrom: Veröffentlicht FilterMaterialNameSearch !ident-ok: Name -FilterMaterialTypeAndDescriptionSearch: Art und Beschreibung \ No newline at end of file +FilterMaterialTypeAndDescriptionSearch: Art/Beschreibung \ No newline at end of file diff --git a/messages/uniworx/categories/courses/material/en-eu.msg b/messages/uniworx/categories/courses/material/en-eu.msg index 55d202c82..4fa16fd7e 100644 --- a/messages/uniworx/categories/courses/material/en-eu.msg +++ b/messages/uniworx/categories/courses/material/en-eu.msg @@ -31,4 +31,4 @@ MaterialFree: Course material is publicly available. AccessibleSince: Accessible since VisibleFrom: Published FilterMaterialNameSearch !ident-ok: Name -FilterMaterialTypeAndDescriptionSearch: Type and description \ No newline at end of file +FilterMaterialTypeAndDescriptionSearch: Type/description \ No newline at end of file diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 0a8edb3a7..31336fe1c 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -106,7 +106,7 @@ getMaterialListR tid ssh csh = do E.where_ $ material E.^. MaterialCourse E.==. E.val cid E.&&. E.not_ (E.isNothing $ material E.^. MaterialType) return $ material E.^. MaterialType - return . mkOptionList $ map (\t -> Option t t t) (map CI.original (Set.toAscList (Set.fromList (mapMaybe E.unValue previouslyUsed)))) + return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed let row2material = view $ _dbrOutput . _1 . _entityVal psValidator = def & defaultSorting [SortDescBy "last-edit"] & forceFilter "may-access" (Any True) @@ -148,15 +148,15 @@ getMaterialListR tid ssh csh = do , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) ) ] , dbtFilter = mconcat - [ (singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr - -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool) - , (singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + [ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr + -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool + , singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) - , (singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of + Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + , singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) - E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))) + E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch) From 5c5cbaddf8b33f455ff18789806a3e0f9ac447ed Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 17:56:07 +0200 Subject: [PATCH 019/132] fix(workflows): workflow-definition edit translations --- src/Handler/Utils/Form/MassInput.hs | 2 +- src/Handler/Workflow/Definition/Edit.hs | 32 ++++++++++++++----------- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 582e4193f..526ee5d9b 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -632,7 +632,7 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text) -> (Markup -> MForm handler (FormResult cellData, Widget)) - miCell _pos dat _mPrev nudge = miCell' nudge dat + miCell _pos dat mPrev' nudge = miCell' nudge $ fromMaybe dat mPrev' miDelete :: MassInputDelete ListLength miDelete = miDeleteList diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs index 1967fc958..b7865df88 100644 --- a/src/Handler/Workflow/Definition/Edit.hs +++ b/src/Handler/Workflow/Definition/Edit.hs @@ -54,22 +54,26 @@ postAWDEditR wds' wdn = do , workflowDefinitionInstanceCategory = wdfInstanceCategory } - when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do + when (is _Nothing insConflict) $ do deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId] - insert WorkflowDefinitionDescription - { workflowDefinitionDescriptionDefinition = wdId - , workflowDefinitionDescriptionLanguage = wddLang - , workflowDefinitionDescriptionTitle = wddTitle - , workflowDefinitionDescriptionDescription = wddDesc - } - when (is _Nothing insConflict) . iforM_ wdfInstanceDescriptions $ \wddLang (wddTitle, wddDesc) -> do + insertMany_ $ do + (wddLang, (wddTitle, wddDesc)) <- Map.toList wdfDescriptions + return WorkflowDefinitionDescription + { workflowDefinitionDescriptionDefinition = wdId + , workflowDefinitionDescriptionLanguage = wddLang + , workflowDefinitionDescriptionTitle = wddTitle + , workflowDefinitionDescriptionDescription = wddDesc + } + deleteWhere [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] - insert WorkflowDefinitionInstanceDescription - { workflowDefinitionInstanceDescriptionDefinition = wdId - , workflowDefinitionInstanceDescriptionLanguage = wddLang - , workflowDefinitionInstanceDescriptionTitle = wddTitle - , workflowDefinitionInstanceDescriptionDescription = wddDesc - } + insertMany_ $ do + (wddLang, (wddTitle, wddDesc)) <- Map.toList wdfInstanceDescriptions + return WorkflowDefinitionInstanceDescription + { workflowDefinitionInstanceDescriptionDefinition = wdId + , workflowDefinitionInstanceDescriptionLanguage = wddLang + , workflowDefinitionInstanceDescriptionTitle = wddTitle + , workflowDefinitionInstanceDescriptionDescription = wddDesc + } case insConflict of Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $ From f9391c32433be78eeed84b48a424a93141fa9092 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 17:56:45 +0200 Subject: [PATCH 020/132] chore: bump workflows --- testdata/workflows | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testdata/workflows b/testdata/workflows index cf7dcf58c..ea616bce8 160000 --- a/testdata/workflows +++ b/testdata/workflows @@ -1 +1 @@ -Subproject commit cf7dcf58c524176bbdd27ff279d68a5ab90cd06e +Subproject commit ea616bce889da4c923bd2aa35d176f70f3a7ca8f From 29de9106333cd222fc4f25a5016e6783111a19cd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 19:44:36 +0200 Subject: [PATCH 021/132] refactor: hlint --- src/Handler/Material.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 31336fe1c..021ab7865 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -152,7 +152,7 @@ getMaterialListR tid ssh csh = do -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool , singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) - Just needle -> (E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) + Just needle -> E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%) , singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) From 32efdae839b1a3e43ed4161d20e598964970f15e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 5 Jul 2021 22:13:00 +0200 Subject: [PATCH 022/132] feat(workflows): update instances from definitions --- frontend/src/app.sass | 7 +- .../categories/workflows/de-de-formal.msg | 9 +- .../uniworx/categories/workflows/en-eu.msg | 7 ++ .../navigation/breadcrumbs/de-de-formal.msg | 1 + .../utils/navigation/breadcrumbs/en-eu.msg | 1 + .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + routes | 2 + src/Foundation/Navigation.hs | 2 + src/Handler/Utils/Workflow/CanonicalRoute.hs | 6 +- src/Handler/Workflow/Instance.hs | 1 + src/Handler/Workflow/Instance/List.hs | 34 ++++- src/Handler/Workflow/Instance/Update.hs | 117 ++++++++++++++++++ templates/workflows/instances.hamlet | 4 +- 14 files changed, 182 insertions(+), 11 deletions(-) create mode 100644 src/Handler/Workflow/Instance/Update.hs diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 0b3dcfd32..017d9d98a 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -103,8 +103,8 @@ body .emph font-style: italic -a, -a:visited +a:not(.btn), +a:visited:not(.btn) text-decoration: none font-weight: 600 transition: color .2s ease, background-color .2s ease @@ -275,6 +275,9 @@ button:not(.btn-link), display: grid grid: min-content / auto-flow max-content + > form + margin: 0 !important + .buttongroup--inline display: inline-grid diff --git a/messages/uniworx/categories/workflows/de-de-formal.msg b/messages/uniworx/categories/workflows/de-de-formal.msg index 32456b267..b9beb0e01 100644 --- a/messages/uniworx/categories/workflows/de-de-formal.msg +++ b/messages/uniworx/categories/workflows/de-de-formal.msg @@ -146,4 +146,11 @@ YAMLFieldDecodeFailure yamlFailure@String: Konnte YAML nicht parsen: #{yamlFailu WGFTextInput: Textfeld WGFFileUpload: Dateifeld -WorkflowWorkflowListPersons: Beteiligte Benutzer \ No newline at end of file +WorkflowWorkflowListPersons: Beteiligte Benutzer + +BtnWorkflowInstanceUpdate !ident-ok: Update +WorkflowInstanceUpdateNoActions: Keine Updates verfügbar +WorkflowInstanceUpdateUpdatedGraph: Definitions-Update erfolgreich angewandt +WorkflowInstanceUpdateUpdatedCategory: Kategorie-Update erfolgreich angewandt +WorkflowInstanceUpdateDeletedDescriptionLanguage lang@Lang: Beschreibung/Titel in Sprache „#{lang}“ gelöscht +WorkflowInstanceUpdateUpdatedDescriptionLanguage lang@Lang: Beschreibung/Titel-Update für Sprache „#{lang}“ angewandt \ No newline at end of file diff --git a/messages/uniworx/categories/workflows/en-eu.msg b/messages/uniworx/categories/workflows/en-eu.msg index 41684ae60..1a1225136 100644 --- a/messages/uniworx/categories/workflows/en-eu.msg +++ b/messages/uniworx/categories/workflows/en-eu.msg @@ -147,3 +147,10 @@ YAMLFieldDecodeFailure yamlFailure: Could not parse YAML: #{yamlFailure} WGFTextInput: Text field WGFFileUpload: File field WorkflowWorkflowListPersons: Involved users + +BtnWorkflowInstanceUpdate: Update +WorkflowInstanceUpdateNoActions: No updates available +WorkflowInstanceUpdateUpdatedGraph: Successfully applied updated definition +WorkflowInstanceUpdateUpdatedCategory: Successfully applied updated category +WorkflowInstanceUpdateDeletedDescriptionLanguage lang: Successfully deleted description/title for language “#{lang}” +WorkflowInstanceUpdateUpdatedDescriptionLanguage lang: Successfully applied updated description/title for language “#{lang}” diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index a38672835..2c7b12fdd 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -96,6 +96,7 @@ BreadcrumbWorkflowInstanceWorkflowList: Laufende Workflows BreadcrumbWorkflowInstanceInitiate: Workflow starten BreadcrumbWorkflowInstanceList !ident-ok: Workflows BreadcrumbWorkflowInstanceNew: Neuer Workflow +BreadcrumbWorkflowInstanceUpdate !ident-ok: Update BreadcrumbWorkflowWorkflowList: Laufende Workflows BreadcrumbWorkflowWorkflow workflow@CryptoFileNameWorkflowWorkflow !ident-ok: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Dateien diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index f7fd04c97..d88d37830 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -96,6 +96,7 @@ BreadcrumbWorkflowInstanceWorkflowList: Running workflows BreadcrumbWorkflowInstanceInitiate: Start workflow BreadcrumbWorkflowInstanceList: Workflows BreadcrumbWorkflowInstanceNew: New workflow +BreadcrumbWorkflowInstanceUpdate !ident-ok: Update BreadcrumbWorkflowWorkflowList: Running workflows BreadcrumbWorkflowWorkflow workflow: #{toPathPiece workflow} BreadcrumbWorkflowWorkflowFiles: Files diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 383616869..69bc2b39d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -121,6 +121,7 @@ MenuAdminWorkflowDefinitionDelete: Löschen MenuAdminWorkflowInstanceList: Workflow-Instanzen MenuAdminWorkflowInstanceNew: Neue Workflow-Instanz MenuAdminWorkflowDefinitionInstantiate: Instanziieren +MenuWorkflowInstanceUpdate !ident-ok: Update MenuWorkflowInstanceDelete: Löschen MenuWorkflowInstanceWorkflows: Laufende Workflows MenuWorkflowInstanceInitiate: Workflow starten diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 7a02ce02a..3a4a45a16 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -122,6 +122,7 @@ MenuAdminWorkflowDefinitionDelete: Delete MenuAdminWorkflowInstanceList: Workflow instances MenuAdminWorkflowInstanceNew: New workflow instance MenuAdminWorkflowDefinitionInstantiate: Instantiate +MenuWorkflowInstanceUpdate !ident-ok: Update MenuWorkflowInstanceDelete: Delete MenuWorkflowInstanceWorkflows: Running workflows MenuWorkflowInstanceInitiate: Start workflow diff --git a/routes b/routes index c9b45f88c..85106d88f 100644 --- a/routes +++ b/routes @@ -80,6 +80,7 @@ /delete GWIDeleteR GET POST /workflows GWIWorkflowsR GET !¬empty /initiate GWIInitiateR GET POST !workflow + /update GWIUpdateR POST /global-workflows GlobalWorkflowWorkflowListR GET !free !/global-workflows/#CryptoFileNameWorkflowWorkflow GlobalWorkflowWorkflowR: / GWWWorkflowR GET POST !workflow @@ -146,6 +147,7 @@ /delete SWIDeleteR GET POST /workflows SWIWorkflowsR GET !¬empty /initiate SWIInitiateR GET POST !workflow + /update SWIUpdateR POST /workflows SchoolWorkflowWorkflowListR GET !free !/workflows/#CryptoFileNameWorkflowWorkflow SchoolWorkflowWorkflowR: / SWWWorkflowR GET POST !workflow diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5be9cbd42..05495331a 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -141,6 +141,7 @@ breadcrumb (SchoolR ssh sRoute) = case sRoute of i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just . SchoolR ssh $ if | mayEdit -> SchoolWorkflowInstanceR win SWIEditR | otherwise -> SchoolWorkflowInstanceListR + SWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just . SchoolR ssh $ SchoolWorkflowInstanceR win SWIEditR SchoolWorkflowWorkflowListR -> i18nCrumb MsgBreadcrumbWorkflowWorkflowList . Just $ SchoolR ssh SchoolWorkflowInstanceListR SchoolWorkflowWorkflowR cID sRoute' -> case sRoute' of SWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) . Just $ SchoolR ssh SchoolWorkflowWorkflowListR @@ -428,6 +429,7 @@ breadcrumb (GlobalWorkflowInstanceR win sRoute) = case sRoute of i18nCrumb MsgBreadcrumbWorkflowInstanceInitiate . Just $ if | mayEdit -> GlobalWorkflowInstanceR win GWIEditR | otherwise -> GlobalWorkflowInstanceListR + GWIUpdateR -> i18nCrumb MsgBreadcrumbWorkflowInstanceUpdate . Just $ GlobalWorkflowInstanceR win GWIEditR breadcrumb GlobalWorkflowWorkflowListR = i18nCrumb MsgBreadcrumbWorkflowWorkflowList $ Just GlobalWorkflowInstanceListR breadcrumb (GlobalWorkflowWorkflowR cID sRoute) = case sRoute of GWWWorkflowR -> i18nCrumb (MsgBreadcrumbWorkflowWorkflow cID) $ Just GlobalWorkflowWorkflowListR diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index cb3117475..507da9cee 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -16,7 +16,7 @@ data WorkflowScopeRoute deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowInstanceR - = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR + = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR | WIUpdateR deriving (Eq, Ord, Read, Show, Generic, Typeable) data WorkflowWorkflowR @@ -36,6 +36,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WIDeleteR -> GWIDeleteR WIWorkflowsR -> GWIWorkflowsR WIInitiateR -> GWIInitiateR + WIUpdateR -> GWIUpdateR WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> GWWWorkflowR @@ -50,6 +51,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute WIDeleteR -> SWIDeleteR WIWorkflowsR -> SWIWorkflowsR WIInitiateR -> SWIInitiateR + WIUpdateR -> SWIUpdateR WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of WWWorkflowR -> SWWWorkflowR @@ -65,6 +67,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute GWIDeleteR -> WIDeleteR GWIWorkflowsR -> WIWorkflowsR GWIInitiateR -> WIInitiateR + GWIUpdateR -> WIUpdateR GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR ) GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of GWWWorkflowR -> WWWorkflowR @@ -79,6 +82,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute SWIDeleteR -> WIDeleteR SWIWorkflowsR -> WIWorkflowsR SWIInitiateR -> WIInitiateR + SWIUpdateR -> WIUpdateR SchoolWorkflowWorkflowListR -> Just ( WSSchool ssh, WorkflowWorkflowListR ) SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of SWWWorkflowR -> WWWorkflowR diff --git a/src/Handler/Workflow/Instance.hs b/src/Handler/Workflow/Instance.hs index 836fa52be..4c9e1c883 100644 --- a/src/Handler/Workflow/Instance.hs +++ b/src/Handler/Workflow/Instance.hs @@ -7,3 +7,4 @@ import Handler.Workflow.Instance.New as Handler.Workflow.Instance import Handler.Workflow.Instance.Edit as Handler.Workflow.Instance import Handler.Workflow.Instance.Delete as Handler.Workflow.Instance import Handler.Workflow.Instance.Initiate as Handler.Workflow.Instance +import Handler.Workflow.Instance.Update as Handler.Workflow.Instance diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index 944109f1c..e2af7d31c 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -13,6 +13,7 @@ import Import import Handler.Utils import Utils.Workflow import Handler.Utils.Workflow.CanonicalRoute +import Handler.Workflow.Instance.Update import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E @@ -151,10 +152,12 @@ workflowInstanceListR rScope = do mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName - guard $ mayInitiate || mayEdit || mayList - return (wi, desc) + mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute workflowInstanceName + guard $ mayInitiate || mayEdit || mayList || mayUpdate + canUpdate <- lift $ workflowInstanceCanUpdate wiId + return (wi, desc, canUpdate) - return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc) + return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc, _) -> ( NTop workflowInstanceCategory , workflowInstanceDescriptionTitle <$> mDesc , workflowInstanceName @@ -168,11 +171,19 @@ workflowInstanceListR rScope = do siteLayoutMsg heading $ do setTitleI title let mPitch = Just $(i18nWidgetFile "workflow-instance-list-explanation") + updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do + (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate + lift $ wrapForm updateWdgt def + { formAction = Just . SomeRoute $ toUpdateRoute win + , formEncoding = updateEnctype + , formSubmit = FormNoSubmit + } $(widgetFile "workflows/instances") where toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR) toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + toUpdateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR) getTopWorkflowInstanceListR :: Handler Html getTopWorkflowInstanceListR = do @@ -192,10 +203,12 @@ getTopWorkflowInstanceListR = do mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName - guard $ mayInitiate || mayEdit || mayList - return (rScope, [(wi, desc)]) + mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute' rScope workflowInstanceName + guard $ mayInitiate || mayEdit || mayList || mayUpdate + canUpdate <- lift $ workflowInstanceCanUpdate wiId + return (rScope, [(wi, desc, canUpdate)]) - let iSortProj (Entity _ WorkflowInstance{..}, mDesc) + let iSortProj (Entity _ WorkflowInstance{..}, mDesc, _) = ( NTop workflowInstanceCategory , workflowInstanceDescriptionTitle <$> mDesc , workflowInstanceName @@ -209,8 +222,16 @@ getTopWorkflowInstanceListR = do toInitiateRoute = toInitiateRoute' rScope toEditRoute = toEditRoute' rScope toListRoute = toListRoute' rScope + toUpdateRoute = toUpdateRoute' rScope mPitch :: Maybe Widget mPitch = Nothing + updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do + (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate + lift $ wrapForm updateWdgt def + { formAction = Just . SomeRoute $ toUpdateRoute win + , formEncoding = updateEnctype + , formSubmit = FormNoSubmit + } showHeadings = Map.keys gInstances /= [WSGlobal] pitch = $(i18nWidgetFile "workflow-instance-list-explanation") @@ -220,3 +241,4 @@ getTopWorkflowInstanceListR = do toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR) toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR) toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR) + toUpdateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR) diff --git a/src/Handler/Workflow/Instance/Update.hs b/src/Handler/Workflow/Instance/Update.hs new file mode 100644 index 000000000..ebd018209 --- /dev/null +++ b/src/Handler/Workflow/Instance/Update.hs @@ -0,0 +1,117 @@ +module Handler.Workflow.Instance.Update + ( WorkflowInstanceUpdateButton(..) + , workflowInstanceCanUpdate + , postGWIUpdateR, postSWIUpdateR + ) where + +import Import +import Utils.Form +import Utils.Workflow + +import Handler.Utils.Workflow.CanonicalRoute + +import qualified Data.CaseInsensitive as CI + +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map + + +data WorkflowInstanceUpdateButton + = BtnWorkflowInstanceUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''WorkflowInstanceUpdateButton $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''WorkflowInstanceUpdateButton id + +instance Button UniWorX WorkflowInstanceUpdateButton where + btnClasses _ = [BCIsButton] + + +data WorkflowInstanceUpdateAction + = WIUpdateGraph SharedWorkflowGraphId + | WIUpdateCategory (Maybe WorkflowInstanceCategory) + | WIUpdateInstanceDescription Lang (Maybe (Text, Maybe StoredMarkup)) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +workflowInstanceUpdates :: WorkflowInstanceId + -> DB (Set WorkflowInstanceUpdateAction) +workflowInstanceUpdates wiId = execWriterT . maybeT_ $ do + WorkflowInstance{..} <- MaybeT . lift $ get wiId + wdId <- hoistMaybe workflowInstanceDefinition + WorkflowDefinition{..} <- MaybeT . lift $ get wdId + + when (workflowDefinitionGraph /= workflowInstanceGraph) $ + tellPoint $ WIUpdateGraph workflowDefinitionGraph + + when (workflowDefinitionInstanceCategory /= workflowInstanceCategory) $ + tellPoint $ WIUpdateCategory workflowDefinitionInstanceCategory + + iDescs <- lift . lift $ selectList [WorkflowInstanceDescriptionInstance ==. wiId] [] + dDescs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] [] + + let iDescs' = Map.fromList $ map (\(Entity _ WorkflowInstanceDescription{..}) -> (CI.mk workflowInstanceDescriptionLanguage, (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription))) iDescs + dDescs' = Map.fromList $ map (\(Entity _ WorkflowDefinitionInstanceDescription{..}) -> (CI.mk workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))) dDescs + + forM_ (Map.keysSet iDescs' `Set.union` Map.keysSet dDescs') $ \lang -> if + | Just iDesc <- Map.lookup lang iDescs' + , Just dDesc <- Map.lookup lang dDescs' + , iDesc /= dDesc + -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc + | Just dDesc <- Map.lookup lang dDescs' + , not $ Map.member lang iDescs' + -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc + | Map.member lang iDescs' + , not $ Map.member lang dDescs' + -> tellPoint $ WIUpdateInstanceDescription (CI.original lang) Nothing + | otherwise + -> return () + +workflowInstanceCanUpdate :: WorkflowInstanceId + -> DB Bool +workflowInstanceCanUpdate wiId = not . null <$> workflowInstanceUpdates wiId + + +postGWIUpdateR :: WorkflowInstanceName -> Handler Void +postGWIUpdateR = updateR WSGlobal + +postSWIUpdateR :: SchoolId -> WorkflowInstanceName -> Handler Void +postSWIUpdateR ssh = updateR $ WSSchool ssh + + +updateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler a +updateR rScope win = do + runDB $ do + scope <- maybeT notFound $ fromRouteWorkflowScope rScope + wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope + updates <- workflowInstanceUpdates wiId + + when (null updates) $ + addMessageI Warning MsgWorkflowInstanceUpdateNoActions + + forM_ updates $ \case + WIUpdateGraph graphId -> do + update wiId [ WorkflowInstanceGraph =. graphId ] + addMessageI Success MsgWorkflowInstanceUpdateUpdatedGraph + WIUpdateCategory iCat -> do + update wiId [ WorkflowInstanceCategory =. iCat ] + addMessageI Success MsgWorkflowInstanceUpdateUpdatedCategory + WIUpdateInstanceDescription lang Nothing -> do + deleteBy $ UniqueWorkflowInstanceDescription wiId lang + addMessageI Success $ MsgWorkflowInstanceUpdateDeletedDescriptionLanguage lang + WIUpdateInstanceDescription lang (Just (title, mDesc)) -> do + void $ upsertBy + (UniqueWorkflowInstanceDescription wiId lang) + WorkflowInstanceDescription + { workflowInstanceDescriptionInstance = wiId + , workflowInstanceDescriptionLanguage = lang + , workflowInstanceDescriptionTitle = title + , workflowInstanceDescriptionDescription = mDesc + } + [ WorkflowInstanceDescriptionTitle =. title + , WorkflowInstanceDescriptionDescription =. mDesc + ] + addMessageI Success $ MsgWorkflowInstanceUpdateUpdatedDescriptionLanguage lang + + redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR ) diff --git a/templates/workflows/instances.hamlet b/templates/workflows/instances.hamlet index 07895b7fc..7886eefcd 100644 --- a/templates/workflows/instances.hamlet +++ b/templates/workflows/instances.hamlet @@ -4,7 +4,7 @@ $maybe pitch <- mPitch ^{pitch}