fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): add suspension to qualifications

Browse Source
This commit is contained in:
Steffen Jost 2022-09-16 11:22:52 +02:00
parent bd539358bd
commit 4dc828f9a2
8 changed files with 36 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -12,6 +12,7 @@ TableQualificationCountTotal: Gesamt
LmsQualificationValidUntil: Gültig bis
TableQualificationLastRefresh: Zuletzt erneuert
TableQualificationFirstHeld: Erstmalig
TableQualificationBlockedDue: Suspendiert
LmsUser: Inhaber
TableLmsEmail: E-Mail
TableLmsIdent: Identifikation

1
messages/uniworx/categories/qualification/en-eu.msg
View File

@ -12,6 +12,7 @@ TableQualificationCountTotal: Total
LmsQualificationValidUntil: Valid until
TableQualificationLastRefresh: Last renewed
TableQualificationFirstHeld: First held
TableQualificationBlockedDue: Suspended
LmsUser: Licensee
TableLmsEmail: Email
TableLmsIdent: Identifier

1
models/lms.model
View File

@ -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

24
src/Handler/LMS.hs
View File

@ -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

1
src/Handler/LMS/Fake.hs
View File

@ -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

2
src/Jobs/Handler/LMS.hs
View File

@ -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

6
src/Model/Migration/Definitions.hs
View File

@ -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"|]

22
test/Database/Fill.hs
View File

@ -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