Merge branch 'master' of https://dev.azure.com/fraport/Fahrerausbildung/_git/FRADrive

.gitignore

@@ -42,6 +42,7 @@ src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
 /instance
+backend/instance
 .stack-work-*
 .stack-work.lock
 .directory

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.

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"
+ENV STACK_ROOT="${PROJECT_DIR}/.stack"
+
+ENV STACK_SRC=""
+ENV STACK_ENTRY="ghci ${STACK_SRC}"
+ENTRYPOINT stack ${STACK_ENTRY}

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
 

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

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

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

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

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
 

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