From 92ff99a36ef941d2ff888d7e3a5381e1d8a11f46 Mon Sep 17 00:00:00 2001 From: "Jost, Steffen" Date: Wed, 26 Mar 2025 16:58:07 +0100 Subject: [PATCH 1/9] chore(tutorial): granting qualification automatically picks better expiry date Previously, the form for granting tutorial users a qualification suggested the minimum of all expiry dates, if there where several course qualficiations. This lead to some users being granted driving licences being valid for only one month. The expiry date can now be left blank, using the validDuration of the selected qualification instead. The default is blank, if there are more than one course qualification having disagreeing qualification dates. --- .../courses/tutorial/de-de-formal.msg | 6 ++- .../categories/courses/tutorial/en-eu.msg | 7 +-- src/Handler/Qualification.hs | 11 +++-- src/Handler/Tutorial/Users.hs | 46 +++++++++++-------- src/Utils.hs | 3 ++ 5 files changed, 43 insertions(+), 30 deletions(-) diff --git a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 21d9960f2..875139f6c 100644 --- a/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/messages/uniworx/categories/courses/tutorial/de-de-formal.msg @@ -47,9 +47,11 @@ TutorialUserDeregister: Vom Kurs abmelden TutorialUserSendMail: Mitteilung verschicken TutorialUserPrintQualification: Zertifikat drucken TutorialUserGrantQualification: Qualifikation vergeben +TutorialUserGrantQualificationDateTooltip: Leer lassen, um das Ablaufdatum auf das heutige Datum plus Standardgültigkeitsdauer zu setzen. +TutorialUserGrantQualificationDateError qsh@QualificationShorthand: Qualifikation #{qsh} hat keine Standardgültigkeitsdauer, daher ist ein explizites Ablaufdatum erforderlich! TutorialUserRenewQualification: Qualifikation regulär verlängern -TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert -TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben +TutorialUserRenewedQualification qsh@QualificationShorthand n@Int: Qualifikation #{qsh} für #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert. +TutorialUserGrantedQualification qsh@QualificationShorthand day@Text n@Int: Qualifikation #{qsh} bis #{day} erfolgreich an #{tshow n} Kurs-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben. TutorialUserAssignExam: Zur Prüfung einteilen TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} zur Prüfung #{p} eingeteilt CommTutorial: Kursmitteilung diff --git a/messages/uniworx/categories/courses/tutorial/en-eu.msg b/messages/uniworx/categories/courses/tutorial/en-eu.msg index 7d3a8468d..4315f700b 100644 --- a/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/messages/uniworx/categories/courses/tutorial/en-eu.msg @@ -43,14 +43,15 @@ TutorInviteHeading tutn: Invitation to be instructor for #{tutn} TutorInviteExplanation: You were invited to be a instructor. TutorCorrectorInvitationAccepted shn: You are now a corrector for #{shn} TutorialUsersDeregistered count: Successfully deregistered #{show count} participants from course - TutorialUserDeregister: Deregister from course TutorialUserSendMail: Send mail TutorialUserPrintQualification: Print certificate TutorialUserGrantQualification: Grant qualification +TutorialUserGrantQualificationDateTooltip: Leave blank for expiry on today's date plus standard qualification valid duration. +TutorialUserGrantQualificationDateError qsh@QualificationShorthand: Qualification #{qsh} has no standard valid duration. Please provide an explicit expiry date! TutorialUserRenewQualification: Renew qualification -TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} course #{pluralEN n "user" "users"} -TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} course #{pluralEN n "user" "users"} +TutorialUserRenewedQualification qsh n: Successfully renewed #{qsh} qualification for #{pluralENsN n "course participant"} +TutorialUserGrantedQualification qsh day n: Successfully granted #{qsh} qualification until #{day} to #{pluralENsN n "course participant"} TutorialUserAssignExam: Register for examination TutorialUserExamAssignedFor n@Int m@Int p@Text: #{n}/#{m} enrolled for exam #{p} CommTutorial: Course message diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 0c0970a26..d65491264 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -614,14 +614,15 @@ postQualificationR sid qsh = do (noks,nterm) <- runDB $ (,) <$> renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing selUsrs <*> terminateLms (LmsOrphanReasonManualRenewal renewReason) qid selUsrs - addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks when (nterm >0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams $ QualificationR sid qsh - (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do + (QualificationActGrantData grantValidDay, selectedUsers) | isAdmin -> do + grantValidDayText <- formatTime SelFormatDate grantValidDay nterm <- runDB $ do - forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin" - terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidday) qid $ Set.toList selectedUsers - addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers + forM_ selectedUsers $ upsertQualificationUser qid now grantValidDay Nothing "Admin" + terminateLms (LmsOrphanReasonManualGrant $ "bis " <> tshow grantValidDay) qid $ Set.toList selectedUsers + addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh grantValidDayText $ Set.size selectedUsers when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams $ QualificationR sid qsh (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e1489e808..fc2715e72 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -57,7 +57,7 @@ data TutorialUserActionData { tuQualification :: QualificationId } | TutorialUserGrantQualificationData { tuQualification :: QualificationId - , tuValidUntil :: Day + , tuValidUntil :: Maybe Day } | TutorialUserSendMailData | TutorialUserDeregisterData @@ -116,6 +116,7 @@ postTUsersR tid ssh csh tutn = do let heading = prependCourseTitle tid ssh csh $ CI.original tutn croute = CTutorialR tid ssh csh tutn TUsersR now <- liftIO getCurrentTime + let nowaday = utctDay now isAdmin <- hasReadAccessTo AdminR (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications, dbegin, hasExams, exmFltr, exOccs) <- runDB do trm <- get404 tid @@ -123,9 +124,9 @@ postTUsersR tid ssh csh tutn = do -- tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn (cid, tutEnt@(Entity tutid _)) <- fetchCourseIdTutorial tid ssh csh tutn qualifications <- getCourseQualifications cid - let nowaday = utctDay now - minDur :: Maybe Int = minimumMaybe $ mapMaybe (view _qualificationValidDuration) qualifications -- no instance Ord CalendarDiffDays - dayExpiry = flip computeNewValidDate nowaday <$> minDur + let dayExpiry = case nubOrd (mapMaybe qualificationValidDuration qualifications) of + [oneDuration] -> Just $ Just $ computeNewValidDate qvd nowaday -- suggest end day only if it is unique for all course qualifications + _ -> Nothing -- using the minimum here causes confusion, better leave blank! colChoices = mconcat $ [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgTableCourseMembers ForProfileDataR @@ -173,7 +174,7 @@ postTUsersR tid ssh csh tutn = do , ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry + <*> aopt dayField (fslI MsgLmsQualificationValidUntil & setTooltip MsgTutorialUserGrantQualificationDateTooltip) dayExpiry ) ] ) ++ @@ -184,7 +185,7 @@ postTUsersR tid ssh csh tutn = do table <- makeCourseUserTable cid acts isInTut colChoices psValidator (Just csvColChoices) return (tutEnt, table, qualifications, dbegin, hasExams, exmFltr, exOccs) - let courseQids = Set.fromList (entityKey <$> qualifications) + let courseQids = entities2map qualifications tcontent <- formResultMaybe participantRes $ \case (TutorialUserPrintQualificationData, selectedUsers) -> do rcvr <- requireAuth @@ -204,25 +205,30 @@ postTUsersR tid ssh csh tutn = do -- typePDF = "application/pdf" -- sendResponse (typePDF, toContent pdf) (TutorialUserGrantQualificationData{..}, selectedUsers) - | tuQualification `Set.member` courseQids -> do - -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - today <- liftIO getCurrentTime - let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn - selUsrs = Set.toList selectedUsers - nterm <- runDB $ do - forM_ selUsrs $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason - terminateLms (LmsOrphanReasonManualGrant [st|bis #{tshow tuValidUntil}, #{reason}|]) tuQualification selUsrs - addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers - when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm - reloadKeepGetParams croute + | Just grantQual <- Map.lookup tuQualification courseQids -> + case tuValidUntil <|> (flip computeNewValidDate nowaday <$> qualificationValidDuration grantQual) of + Nothing -> do -- TODO: change QualificationUser to have an optionnal validUntil for idefinitely valid qualifications + addMessageI Error $ MsgTutorialUserGrantQualificationDateError $ qualificationShorthand grantQual + (Just expiryDay) -> do + let qsh = qualificationShorthand grantQual + reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn + selUsrs = Set.toList selectedUsers + expiryDayText <- formatTime SelFormatDate expiryDay + nterm <- runDB $ do + forM_ selUsrs $ upsertQualificationUser tuQualification now expiryDay Nothing reason + terminateLms (LmsOrphanReasonManualGrant [st|bis #{expiryDayText}, #{reason}|]) tuQualification selUsrs + addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification qsh expiryDayText $ Set.size selectedUsers + when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm + reloadKeepGetParams croute (TutorialUserRenewQualificationData{..}, selectedUsers) - | tuQualification `Set.member` courseQids -> do - let selUsrs = Set.toList selectedUsers + | Just grantQual <- Map.lookup tuQualification courseQids -> do + let qsh = qualificationShorthand grantQual + selUsrs = Set.toList selectedUsers mr <- getMessageRender (noks,nterm) <- runDB $ (,) <$> renewValidQualificationUsers tuQualification Nothing Nothing selUsrs <*> terminateLms (LmsOrphanReasonManualGrant $ mr heading) tuQualification selUsrs - addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks + addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification qsh noks when (nterm > 0) $ addMessageI Warning $ MsgLmsActTerminated nterm reloadKeepGetParams croute (TutorialUserSendMailData, selectedUsers) -> do diff --git a/src/Utils.hs b/src/Utils.hs index 285740f6a..508d40e4a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -927,6 +927,9 @@ mapFromSetM = (sequenceA .) . Map.fromSet setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList +mapFromFoldable :: (Ord k, Foldable t) => (v -> k) -> t v -> Map k v +mapFromFoldable getKey = foldMap (Map.singleton =<< getKey) + mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) mapFM = sequenceA . mapF From f784f645a61d3ca9f75f50619c2eef5a873cc892 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 11:06:15 +0100 Subject: [PATCH 2/9] docs(Makefile): add missing help entries for shell and ghci --- Makefile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Makefile b/Makefile index fbc403b6b..e29a25460 100644 --- a/Makefile +++ b/Makefile @@ -77,9 +77,11 @@ start-%: docker compose up -d --build $* .PHONY: shell-% +# HELP(shell-$SERVICE): launch a (bash) shell inside a given service shell-%: docker compose run --build --no-deps $* bash .PHONY: ghci +# HELP: launch ghci ghci: docker compose run --build --no-deps backend stack ghci $(SRC) From fd6ba5b0c58bf684c1e3e5ff12c6c618ddd778ab Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 11:07:14 +0100 Subject: [PATCH 3/9] build(backend/Dockerfile): add ENTRYPOINT to support launching ghci with given SRC, etc. --- backend/Dockerfile | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/backend/Dockerfile b/backend/Dockerfile index d6ccf8b2d..b654aa309 100644 --- a/backend/Dockerfile +++ b/backend/Dockerfile @@ -33,4 +33,8 @@ ENV PROJECT_DIR=${PROJECT_DIR} # RUN mkdir -p "${PROJECT_DIR}"; chmod -R 777 "${PROJECT_DIR}" WORKDIR ${PROJECT_DIR} ENV HOME=${PROJECT_DIR} -ENV STACK_ROOT="${PROJECT_DIR}/.stack" \ No newline at end of file +ENV STACK_ROOT="${PROJECT_DIR}/.stack" + +ENV STACK_SRC="" +ENV STACK_ENTRY="ghci ${STACK_SRC}" +ENTRYPOINT stack ${STACK_ENTRY} \ No newline at end of file From 5ab47c6c4fbb10c09dea51d5e87d68dacd3b1c91 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 11:30:05 +0100 Subject: [PATCH 4/9] chore: update gitignore [skip ci] --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 9c207a919..133c5eb8e 100644 --- a/.gitignore +++ b/.gitignore @@ -41,6 +41,7 @@ src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig /instance +backend/instance .stack-work-* .stack-work.lock .directory From 123e9eb05789033866cb34d5788060fe01017dcc Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 11:30:54 +0100 Subject: [PATCH 5/9] build(Makefile): fix shell and ghci targets for entrypoint --- Makefile | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index e29a25460..456f8b7be 100644 --- a/Makefile +++ b/Makefile @@ -3,6 +3,9 @@ export SHELL=bash export CLEAN_DEPENDENCIES ?= false export CLEAN_IMAGES ?= false +export ENTRYPOINT ?= bash +export SRC + .PHONY: help # HELP: print out this help message help: @@ -79,11 +82,11 @@ start-%: .PHONY: shell-% # HELP(shell-$SERVICE): launch a (bash) shell inside a given service shell-%: - docker compose run --build --no-deps $* bash + docker compose run --build --no-deps --entrypoint="$(ENTRYPOINT)" $* .PHONY: ghci -# HELP: launch ghci -ghci: - docker compose run --build --no-deps backend stack ghci $(SRC) +# HELP: launch ghci instance. Use in combination with SRC to specify the modules to be loaded by ghci: make ghci SRC=src/SomeModule.hs +ghci: ENTRYPOINT=stack ghci $(SRC) +ghci: shell-backend ; .PHONY: stop # HELP: stop all services From 5fd52768bcc3eb045c6f88b19cd73084a7c1705e Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 11:35:01 +0100 Subject: [PATCH 6/9] build(Makefile): add list-projects target --- Makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/Makefile b/Makefile index 456f8b7be..db8df3c86 100644 --- a/Makefile +++ b/Makefile @@ -109,6 +109,10 @@ status: # HELP: print an overview of the ressource usage of the currently running services top: docker compose stats +.PHONY: list-projects +# HELP: list all currently running projects on this machine +list-projects: + docker compose ls .PHONY: log-% # HELP(log-$SERVICE): follow the output of a given service. Service must be running. From 7b486702f450edf038e4a76cbb5b275f45edc13b Mon Sep 17 00:00:00 2001 From: "Jost, Steffen" Date: Thu, 27 Mar 2025 11:33:06 +0000 Subject: [PATCH 7/9] Add map creating utility after merge confligt --- backend/src/Utils.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/backend/src/Utils.hs b/backend/src/Utils.hs index d89688145..5bc514f51 100644 --- a/backend/src/Utils.hs +++ b/backend/src/Utils.hs @@ -932,6 +932,11 @@ mapFromSetM = (sequenceA .) . Map.fromSet setToMap :: (Ord k) => (v -> k) -> Set v -> Map k v setToMap mkKey = Map.fromList . fmap (\x -> (mkKey x, x)) . Set.toList +-- Create a Map given a key-computation +-- For Entity, use Utils.DB.entities2map instead +mapFromFoldable :: (Ord k, Foldable t) => (v -> k) -> t v -> Map k v +mapFromFoldable getKey = foldMap (Map.singleton =<< getKey) + mapFM :: (Applicative m, Ord k, Finite k) => (k -> m v) -> m (Map k v) mapFM = sequenceA . mapF From d2105c8894fa08b2d869cf16b8f318ab99c648bb Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 12:52:07 +0100 Subject: [PATCH 8/9] build(backend/Dockerfile): prevent chown of backend files by allow-different-user in stack config --- backend/Makefile | 1 - backend/stack.yaml | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/Makefile b/backend/Makefile index 5915ecea4..b294f317f 100644 --- a/backend/Makefile +++ b/backend/Makefile @@ -9,7 +9,6 @@ endif .PHONY: dependencies dependencies: - chown -R `id -un`:`id -gn` "$(PROJECT_DIR)"; \ stack install hpack; stack install yesod-bin; \ stack build -j2 --only-dependencies diff --git a/backend/stack.yaml b/backend/stack.yaml index aaba0bfd0..1813ffb76 100644 --- a/backend/stack.yaml +++ b/backend/stack.yaml @@ -9,6 +9,7 @@ flags: rebuild-ghc-options: true #ghc-options: # "$everything": -fno-prof-auto +allow-different-user: true local-bin-path: ./bin From 599d2c1c7a867f3f5301e39755313c98050cde11 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 27 Mar 2025 12:52:49 +0100 Subject: [PATCH 9/9] build(backend/Dockerfile): switch to custom-built haskell/stack Dockerfile to supply missing LLVM --- backend/Dockerfile | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/backend/Dockerfile b/backend/Dockerfile index b654aa309..7b8069f2f 100644 --- a/backend/Dockerfile +++ b/backend/Dockerfile @@ -1,20 +1,20 @@ -ARG FROM_IMG=docker.io/library/haskell -ARG FROM_TAG=8.10.4 +ARG FROM_IMG=docker.io/library/debian +ARG FROM_TAG=12.5 FROM ${FROM_IMG}:${FROM_TAG} ENV LANG=de_DE.UTF-8 +# basic dependencies +RUN apt-get -y update && apt-get -y install git +RUN apt-get -y update && apt-get -y install haskell-stack +RUN apt-get -y update && apt-get -y install llvm +RUN apt-get -y update && apt-get install -y --no-install-recommends locales locales-all + # compile-time dependencies -RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \ ---mount=type=cache,target=/var/lib/apt,sharing=locked \ -apt-get -y update && apt-get install -y libpq-dev libsodium-dev -# RUN apt-get -y update && apt-get -y install llvm -# RUN apt-get -y update && apt-get -y install g++ libghc-zlib-dev libpq-dev libsodium-dev pkg-config -# RUN apt-get -y update && DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends tzdata -RUN --mount=type=cache,target=/var/cache/apt,sharing=locked \ ---mount=type=cache,target=/var/lib/apt,sharing=locked \ -apt-get -y update && apt-get install -y --no-install-recommends locales locales-all +RUN apt-get -y update && apt-get install -y libpq-dev libsodium-dev +RUN apt-get -y update && apt-get -y install g++ libghc-zlib-dev libpq-dev libsodium-dev pkg-config +RUN apt-get -y update && DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends tzdata # run-time dependencies for uniworx binary RUN apt-get -y update && apt-get -y install fonts-roboto