diff --git a/.gitignore b/.gitignore index 98a2b7de2..30756b640 100644 --- a/.gitignore +++ b/.gitignore @@ -42,6 +42,7 @@ src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig /instance +backend/instance .stack-work-* .stack-work.lock .directory diff --git a/Makefile b/Makefile index fbc403b6b..db8df3c86 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: @@ -77,11 +80,13 @@ 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 + docker compose run --build --no-deps --entrypoint="$(ENTRYPOINT)" $* .PHONY: 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 @@ -104,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. diff --git a/backend/Dockerfile b/backend/Dockerfile index d6ccf8b2d..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 @@ -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 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/messages/uniworx/categories/courses/tutorial/de-de-formal.msg b/backend/messages/uniworx/categories/courses/tutorial/de-de-formal.msg index 21d9960f2..875139f6c 100644 --- a/backend/messages/uniworx/categories/courses/tutorial/de-de-formal.msg +++ b/backend/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/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg b/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg index 7d3a8468d..4315f700b 100644 --- a/backend/messages/uniworx/categories/courses/tutorial/en-eu.msg +++ b/backend/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/backend/src/Handler/Qualification.hs b/backend/src/Handler/Qualification.hs index 0c0970a26..d65491264 100644 --- a/backend/src/Handler/Qualification.hs +++ b/backend/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/backend/src/Handler/Tutorial/Users.hs b/backend/src/Handler/Tutorial/Users.hs index e1489e808..fc2715e72 100644 --- a/backend/src/Handler/Tutorial/Users.hs +++ b/backend/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/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 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