chore(avs): add min valid duration end date in add tutorial participant

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 )

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

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

test/Database/Fill.hs

@@ -510,7 +510,7 @@ fillDb = do
   let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
   let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>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!