From b83fbc114aafeebcb724ca64784289002cb864ea Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 16 Dec 2022 18:44:01 +0100 Subject: [PATCH] chore(avs): add min valid duration end date in add tutorial participant --- src/Handler/Tutorial/Users.hs | 10 ++++++---- src/Utils.hs | 2 ++ src/Utils/Lens.hs | 3 +++ test/Database/Fill.hs | 2 +- 4 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index e92a9822c..bb476a868 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -53,8 +53,10 @@ postTUsersR tid ssh csh tutn = do (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn qualifications <- selectList [QualificationSchool ==. ssh] [] - - let colChoices = mconcat $ catMaybes + now <- liftIO getCurrentTime + let minDur :: Maybe Int = minimumMaybe $ catMaybes (view _qualificationValidDuration <$> qualifications) -- no instance Ord CalendarDiffDays + dayExpiry = flip addGregorianDurationClip (utctDay now) . fromMonths <$> minDur + colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure colUserName , guardOn showSex colUserSex' @@ -72,7 +74,7 @@ postTUsersR tid ssh csh tutn = do csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"] cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - let + let qualOpt :: Entity Qualification -> Handler (Option QualificationId) qualOpt (Entity qualId qual) = do cQualId :: CryptoUUIDQualification <- encrypt qualId @@ -86,7 +88,7 @@ postTUsersR tid ssh csh tutn = do [ ( TutorialUserGrantQualification , TutorialUserGrantQualificationData <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing -- does this suffice? Set to QualificationValidDuration + now + <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry ) , ( TutorialUserSendMail, pure TutorialUserSendMailData ) , ( TutorialUserDeregister, pure TutorialUserDeregisterData ) diff --git a/src/Utils.hs b/src/Utils.hs index fc4f9b211..eb7f68f46 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -646,6 +646,8 @@ lastMaybe (_:t) = lastMaybe t lastMaybe' :: [a] -> Maybe a lastMaybe' l = fmap snd $ l ^? _Snoc +minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono) +minimumMaybe = fmap minimum . fromNullable -- | Merge/Add any attribute-value pair to an existing list of such pairs. -- If the attribute exists, the new valu will be prepended, separated by a single empty space diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 3c0255370..dba76b879 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -148,6 +148,9 @@ instance HasStudyTerms a => HasStudyTerms (Entity a) where instance HasStudyDegree a => HasStudyDegree (Entity a) where hasStudyDegree = _entityVal . hasStudyDegree +instance HasQualification a => HasQualification (Entity a) where + hasQualification = _entityVal . hasQualification + -- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: -- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index aec546945..ee05ac755 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -510,7 +510,7 @@ fillDb = do let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" - qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" + qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlockedLms $ n_day $ -5) -- TODO: better dates! void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing -- TODO: better dates!