chore(qualficiation): proof of concept qualification renewal code

messages/uniworx/categories/courses/tutorial/de-de-formal.msg

@@ -45,5 +45,7 @@ TutorialUsersDeregistered count@Int64: #{show count} #{pluralDE count "-Tutorium
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken
 TutorialUserGrantQualification: Qualifikation vergeben
+TutorialUserRenewQualification: Qualifikation regulär verlängern
+TutorialUserRenewedQualification n@Int: Qualifikation für #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} regulär verlängert
 TutorialUserGrantedQualification n@Int: Qualifikation erfolgreich an #{tshow n} Tutoriums-#{pluralDE n "Teilnehmer:in" "Teilnehmer:innen"} vergeben
 CommTutorial: Tutorium-Mitteilung

messages/uniworx/categories/courses/tutorial/en-eu.msg

@@ -46,5 +46,7 @@ TutorialUsersDeregistered count: Successfully deregistered #{show count} partici
 TutorialUserDeregister: Deregister from tutorial
 TutorialUserSendMail: Send mail
 TutorialUserGrantQualification: Grant Qualification
+TutorialUserRenewQualification: Renew Qualification
+TutorialUserRenewedQualification n@Int: Successfully renewed qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 TutorialUserGrantedQualification n: Successfully granted qualification #{tshow n} tutorial #{pluralEN n "user" "users"}
 CommTutorial: Tutorial message

src/Database/Esqueleto/Utils.hs

@@ -38,7 +38,7 @@ module Database.Esqueleto.Utils
   , unKey
   , selectCountRows, selectCountDistinct
   , selectMaybe
-  , day, diffDays, diffTimes
+  , day, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
   , module Database.Esqueleto.Utils.TH
@@ -65,6 +65,8 @@ import Crypto.Hash (Digest, SHA256)
 import Data.Coerce (Coercible)
 
 import Data.Time.Clock (NominalDiffTime)
+import Data.Time.Calendar (CalendarDiffDays)
+import Data.Time.Format.ISO8601 (iso8601Show)
 
 import qualified Data.Text.Lazy.Builder as Text.Builder
 
@@ -525,6 +527,14 @@ selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 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 . wrapSqlString . Text.Builder.fromString . iso8601Show
+  where 
+    singleQuote     = Text.Builder.singleton '\''
+    wrapSqlString b = singleQuote <> b <> singleQuote
+
+
 infixl 6 `diffDays`, `diffTimes`
 
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)

src/Handler/Tutorial/Users.hs

@@ -26,10 +26,11 @@ import Handler.Course.Users
 
 
 data TutorialUserAction
-   = TutorialUserGrantQualification
-   | TutorialUserSendMail
-   | TutorialUserDeregister
-   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+  = TutorialUserRenewQualification
+  | TutorialUserGrantQualification
+  | TutorialUserSendMail
+  | TutorialUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe TutorialUserAction
 instance Finite TutorialUserAction
@@ -37,13 +38,15 @@ nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''TutorialUserAction id
 
 data TutorialUserActionData
-   = TutorialUserGrantQualificationData
-     { tuQualification :: QualificationId
-     , tuValidUntil    :: Day
-     }
-   | TutorialUserSendMailData
-   | TutorialUserDeregisterData{}
-   deriving (Eq, Ord, Read, Show, Generic)
+  = TutorialUserRenewQualificationData
+    { tuQualification :: QualificationId }
+  | TutorialUserGrantQualificationData
+    { tuQualification :: QualificationId
+    , tuValidUntil    :: Day
+    }
+  | TutorialUserSendMailData
+  | TutorialUserDeregisterData{}
+  deriving (Eq, Ord, Read, Show, Generic)
 
 
 getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
@@ -85,7 +88,11 @@ postTUsersR tid ssh csh tutn = do
           }
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList
-        [ ( TutorialUserGrantQualification
+        [ ( TutorialUserRenewQualification
+          , TutorialUserRenewQualificationData
+            <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+          )
+        , ( TutorialUserGrantQualification
           , TutorialUserGrantQualificationData
             <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
             <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
@@ -103,6 +110,10 @@ postTUsersR tid ssh csh tutn = do
       runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
       addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
       redirect $ CTutorialR tid ssh csh tutn TUsersR
+    (TutorialUserRenewQualificationData{..}, selectedUsers) -> do
+      noks <- runDB $ renewQualificationUsers 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
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
         redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])

src/Handler/Utils/Qualification.hs

@@ -3,16 +3,18 @@
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 
-
-module Handler.Utils.Qualification 
+module Handler.Utils.Qualification
   ( module Handler.Utils.Qualification
-  ) where 
+  ) where
 
 import Import
 
+-- import Data.Time.Calendar (CalendarDiffDays(..))
+import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
+import qualified Database.Esqueleto.Utils as E
 
 upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do   
+upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
   Entity quid _ <- upsert
     QualificationUser
       { qualificationUserFirstHeld        = qualificationUserLastRefresh
@@ -20,18 +22,29 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
       , ..
       }
-    ( 
+    (
       [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
       , QualificationUserLastRefresh        =. qualificationUserLastRefresh
       , QualificationUserBlockedDue         =. Nothing
       ]
-    )    
+    )
   audit TransactionQualificationUserEdit
     { transactionQualificationUser        = quid
     , transactionQualification            = qualificationUserQualification
     , transactionUser                     = qualificationUserUser
     , transactionQualificationValidUntil  = qualificationUserValidUntil
     , transactionQualificationScheduleRenewal = mbScheduleRenewal
-    }
+    }
+
+renewQualificationUsers :: QualificationId -> [UserId] -> DB Int
+renewQualificationUsers qid uids = do
+  --TODO: user updateWhere Count instead
+  E.update $ \qu -> do
+    E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
+    E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
+        E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
+  -- TODO: AUDIT LOG!!!
+  -- forM_ uids $ \quid -> audit         
+  return (-1)