From 4dc828f9a21ba87adff92df6cfbd7648303d69d6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 16 Sep 2022 11:22:52 +0200 Subject: [PATCH] chore(lms): add suspension to qualifications --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 1 + src/Handler/LMS.hs | 24 +++++++++++++------ src/Handler/LMS/Fake.hs | 1 + src/Jobs/Handler/LMS.hs | 2 +- src/Model/Migration/Definitions.hs | 6 ++--- test/Database/Fill.hs | 22 ++++++++--------- 8 files changed, 36 insertions(+), 22 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1706eeef9..d8ba68545 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -12,6 +12,7 @@ TableQualificationCountTotal: Gesamt LmsQualificationValidUntil: Gültig bis TableQualificationLastRefresh: Zuletzt erneuert TableQualificationFirstHeld: Erstmalig +TableQualificationBlockedDue: Suspendiert LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: Identifikation diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6d89b424b..aba17c5d5 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -12,6 +12,7 @@ TableQualificationCountTotal: Total LmsQualificationValidUntil: Valid until TableQualificationLastRefresh: Last renewed TableQualificationFirstHeld: First held +TableQualificationBlockedDue: Suspended LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: Identifier diff --git a/models/lms.model b/models/lms.model index 18466434b..b3165578e 100644 --- a/models/lms.model +++ b/models/lms.model @@ -51,6 +51,7 @@ QualificationUser validUntil Day lastRefresh Day -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False firstHeld Day -- first time the qualification was earned, should never change + blockedDue Text Maybe -- isJust means that the qualification is currently revoked -- temporärer Entzug vorsehen -- Begründungsfeld vorsehen UniqueQualificationUser qualification user diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 75284be67..5574b9418 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -178,11 +178,13 @@ data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. , ltcValidUntil :: Day , ltcLastRefresh :: Day , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe Text , ltcLmsIdent :: Maybe LmsIdent , ltcLmsStatus :: Maybe LmsStatus , ltcLmsStarted :: Maybe UTCTime , ltcLmsDatePin :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime , ltcLmsEnded :: Maybe UTCTime } deriving Generic @@ -192,19 +194,23 @@ ltcExample :: LmsTableCsv ltcExample = LmsTableCsv { ltcDisplayName = "Max Mustermann" , ltcEmail = "m.mustermann@does.not.exist" - , ltcValidUntil = compday - , ltcLastRefresh = compday - , ltcFirstHeld = compday + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing , ltcLmsIdent = Nothing , ltcLmsStatus = Nothing - , ltcLmsStarted = Nothing + , ltcLmsStarted = Just compTime , ltcLmsDatePin = Nothing , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing , ltcLmsEnded = Nothing } where - compday :: Day - compday = utctDay $compileTime + compTime :: UTCTime + compTime = $compileTime + compDay :: Day + compDay = utctDay compTime ltcOptions :: Csv.Options ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } @@ -338,6 +344,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) @@ -391,11 +398,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) + <*> view (resultQualUser . _entityVal . _qualificationUserBlockedDue) <*> preview (resultLmsUser . _entityVal . _lmsUserIdent) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) <*> preview (resultLmsUser . _entityVal . _lmsUserStarted) <*> preview (resultLmsUser . _entityVal . _lmsUserDatePin) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) + <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) dbtCsvDecode = Nothing dbtExtraReps = [] @@ -446,9 +455,10 @@ postLmsR sid qsh = do [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d + , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d + , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> t) -> foldMap textCell t , sortable (Just "lms-ident") (i18nLms MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid , sortable (Just "lms-status") (i18nLms MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index eabd8a656..11f66a0aa 100644 --- a/src/Handler/LMS/Fake.hs +++ b/src/Handler/LMS/Fake.hs @@ -113,6 +113,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u qualificationUserValidUntil = addDays expOffset expiryNotifyDay qualificationUserFirstHeld = addGregorianMonthsClip (-24) qualificationUserValidUntil qualificationUserLastRefresh = qualificationUserFirstHeld + qualificationUserBlockedDue = Nothing _ <- upsert QualificationUser{..} [ QualificationUserValidUntil =. qualificationUserValidUntil , QualificationUserLastRefresh =. qualificationUserLastRefresh diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 37eae1275..01b46cd90 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -108,7 +108,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act (Just _) -> return () -- lmsUser started, but not yet notified --- process all received input and renew qualifications +-- process all received input and renew or block qualifications dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX dispatchJobLmsDequeue qid = JobHandlerAtomic act -- wenn bestanden: qualification verlängern diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 7b1526437..ead829102 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -432,7 +432,7 @@ customMigrations = mapF $ \case whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do [executeQQ| - CREATe TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL); + CREATE TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file"); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id"); ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id"); @@ -463,7 +463,7 @@ customMigrations = mapF $ \case Migration20190828UserFunction -> do [executeQQ| - CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text ); + CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text ); |] whenM (tableExists "user_admin") $ do @@ -1002,7 +1002,7 @@ customMigrations = mapF $ \case whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do [executeQQ| - CREATe TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL) + CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL) |] let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|] diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index bc556fb46..b08851225 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -505,17 +505,17 @@ fillDb = do qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3) False qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True - void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) -- TODO: better dates! - void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) - void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) - void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) - void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) - void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) - void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) - void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) + void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates! + void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing + void . insert' $ QualificationUser maxMuster qid_f (n_day 0) (n_day $ -2) (n_day $ -8) Nothing + void . insert' $ QualificationUser svaupel qid_f (n_day 1) (n_day $ -1) (n_day $ -2) Nothing + void . insert' $ QualificationUser sbarth qid_f (n_day 400) (n_day $ -40) (n_day $ -1200) Nothing + void . insert' $ QualificationUser tinaTester qid_f (n_day 3) (n_day $ -60) (n_day $ -250) Nothing + void . insert' $ QualificationUser gkleen qid_r (n_day $ -7) (n_day $ -2) (n_day $ -9) Nothing + void . insert' $ QualificationUser maxMuster qid_r (n_day 1) (n_day $ -1) (n_day $ -2) Nothing + void . insert' $ QualificationUser fhamann qid_r (n_day $ -3) (n_day $ -1) (n_day $ -2) Nothing + void . insert' $ QualificationUser svaupel qid_l (n_day 1) (n_day $ -1) (n_day $ -2) Nothing + void . insert' $ QualificationUser gkleen qid_l (n_day 9) (n_day $ -1) (n_day $ -7) Nothing void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now