chore(qualifications): renew regularly implemented

models/lms.model

@@ -57,7 +57,7 @@ QualificationEdit
 QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  validUntil        Day
+  validUntil        Day                           -- addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
   lastRefresh       Day                           -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
   firstHeld         Day                           -- first time the qualification was earned, should never change
   blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked

src/Audit/Types.hs

@@ -201,7 +201,7 @@ data Transaction
   | TransactionQualificationUserEdit
     { transactionQualificationUser            :: QualificationUserId
     , transactionQualification                :: QualificationId
-    , transactionUser                         :: UserId
+    , transactionUser                         :: UserId                 -- qualification holder that is updated
     , transactionQualificationValidUntil      :: Day
     , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
     }

src/Database/Esqueleto/Utils.hs

@@ -528,7 +528,7 @@ day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
 day = E.unsafeSqlCastAs "date"
 
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
--- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working   example 
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
   where 
     singleQuote     = Text.Builder.singleton '\''

src/Handler/Admin/Avs.hs

@@ -23,6 +23,7 @@ import qualified Data.Map as Map
 
 import Handler.Utils
 import Handler.Utils.Avs
+-- import Handler.Utils.Qualification
 
 import Utils.Avs
 

src/Handler/LMS.hs

@@ -46,7 +46,7 @@ import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a

src/Handler/Qualification.hs

@@ -35,7 +35,7 @@ import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
 
-import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+-- import Handler.Utils.Qualification (validQualification)
 
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a

src/Handler/Tutorial/Users.hs

@@ -111,7 +111,7 @@ postTUsersR tid ssh csh tutn = do
       addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers) -> do
-      noks <- runDB $ renewQualificationUsers tuQualification $ Set.toList selectedUsers      
+      noks <- runDB $ renewValidQualificationUsers tuQualification $ Set.toList selectedUsers      
       addMessageI (if noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
       redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do

src/Handler/Utils/Avs.hs

@@ -5,9 +5,11 @@
 {-# LANGUAGE TypeApplications #-}
 
 
+-- Module for functions directly related to the AVS interface,
+-- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
+
 module Handler.Utils.Avs
-  ( validQualification, validQualification'
+  ( guessAvsUser
-  , guessAvsUser
   , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
@@ -35,6 +37,7 @@ import qualified Data.CaseInsensitive as CI
 import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
 
 import Handler.Utils.Company
+import Handler.Utils.Qualification
 
 import           Database.Esqueleto.Experimental ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
@@ -63,21 +66,7 @@ instance Exception AvsException
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
 -}
 
-------------------
--- SQL Snippets --
-------------------
 
-validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
-validQualification nowaday = \qualUser ->
-  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
-                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
-           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
-
-validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
-validQualification' nowaday qualUser =
-  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
-                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
-     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
 
 
 ------------------

src/Handler/Utils/Qualification.hs

@@ -13,6 +13,42 @@ import Import
 import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
 import qualified Database.Esqueleto.Utils as E
 
+
+
+------------------
+-- SQL Snippets --
+------------------
+
+-- TODO: consider replacing `nowaday` by `Database.Esqueleto.PostgreSQL.now_` or better `day(now_)` cast as date
+validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
+validQualification nowaday = \qualUser ->
+  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
+
+validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
+validQualification' nowaday qualUser =
+  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
+                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
+     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
+
+
+selectValidQualifications :: QualificationId -> Maybe [UserId] -> Day -> DB [Entity QualificationUser]
+selectValidQualifications qid mbUids nowaday = 
+  -- nowaday <- utctDay <$> liftIO getCurrentTime
+  E.select $ do 
+    qUser <- E.from $ E.table @QualificationUser
+    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
+          E.&&. validQualification nowaday qUser
+          E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
+    pure qUser
+
+
+------------------------
+-- Complete Functions --
+------------------------
+
+
 upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
 upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
   Entity quid _ <- upsert
@@ -31,20 +67,37 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       ]
     )
   audit TransactionQualificationUserEdit
-    { transactionQualificationUser        = quid
+    { transactionQualificationUser            = quid
-    , transactionQualification            = qualificationUserQualification
+    , transactionQualification                = qualificationUserQualification
-    , transactionUser                     = qualificationUserUser
+    , transactionUser                         = qualificationUserUser
-    , transactionQualificationValidUntil  = qualificationUserValidUntil
+    , transactionQualificationValidUntil      = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
     }
 
-renewQualificationUsers :: QualificationId -> [UserId] -> DB Int
+renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
-renewQualificationUsers qid uids = do
+renewValidQualificationUsers qid uids =
-  --TODO: user updateWhere Count instead
+  -- This code works in principle, but it does not allow audit log entries.
-  E.update $ \qu -> do
+  -- E.update $ \qu -> do
-    E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
+  --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
-    E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
+  --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
-        E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
+  --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
-  -- TODO: AUDIT LOG!!!
+  get qid >>= \case     
-  -- forM_ uids $ \quid -> audit         
+    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
-  return (-1)
+      nowaday <- utctDay <$> liftIO getCurrentTime
+      quEntsAll <- selectValidQualifications qid (Just uids) nowaday     
+      let maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
+          quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
+      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
+        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
+        update quId [ QualificationUserValidUntil   =. newValidTo
+                    , QualificationUserLastRefresh  =. nowaday
+                    ]
+        audit TransactionQualificationUserEdit
+          { transactionQualificationUser            = quId
+          , transactionQualification                = qualificationUserQualification
+          , transactionUser                         = qualificationUserUser
+          , transactionQualificationValidUntil      = newValidTo
+          , transactionQualificationScheduleRenewal = Nothing
+          }
+      return $ length quEnts
+    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

src/Jobs/Handler/LMS.hs

@@ -70,6 +70,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                   E.&&. quser E.^. QualificationUserScheduleRenewal
                   E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day
                   E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
+                  E.&&. E.isNothing (quser E.^. QualificationUserBlockedDue)
                   E.&&. E.notExists (do
                           luser <- E.from $ E.table @LmsUser
                           E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
@@ -208,12 +209,20 @@ dispatchJobLmsResults qid = JobHandlerAtomic act
               newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
           note <- if saneDate && isLmsSuccess newStatus
             then do
+              -- TODO: refactor using functions from Handler.Utils.Qualification to ensure nothing is forgotten!
               update quid [ QualificationUserValidUntil  =. newValidTo
                           , QualificationUserLastRefresh =. lmsResultSuccess
-                          ]
+                          ]                    
               update luid [ LmsUserStatus   =. Just newStatus
                           , LmsUserReceived =. Just lmsResultTimestamp
                           ]
+              audit TransactionQualificationUserEdit
+                { transactionQualificationUser            = quid
+                , transactionQualification                = qualificationUserQualification
+                , transactionUser                         = qualificationUserUser
+                , transactionQualificationValidUntil      = newValidTo
+                , transactionQualificationScheduleRenewal = Nothing
+                }
               return Nothing
             else do
               let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]

src/Utils/Form.hs

@@ -848,12 +848,26 @@ cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s)
 cfCI = convertField CI.mk CI.original
 
 cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList)
+cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split (==',')) (T.intercalate ", " . Set.toList)
+
+-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
+-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
+--   where anySeparator :: Char -> Bool
+--         anySeparator c = C.isSeparator c || c == ',' || c == ';'
 
 cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
+cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
-  where anySeparator :: Char -> Bool
+  where splitConditionally :: Text -> [Text]
-        anySeparator c = C.isSeparator c || c == ',' || c == ';'
+        splitConditionally t 
+          | ';' `telem` t = T.split (==';') t
+          | ',' `telem` t = T.split (==',') t
+          | otherwise  = T.split C.isSeparator t 
+        -- Our version of Data.Text does not yet support T.elem
+        telem :: Char -> Text -> Bool
+        telem c = T.any (==c)
+
+
+
 
 -- -- TODO: consider using package ordered-containers?
 -- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text]