diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 3dced793a..f8b57cfcb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -337,7 +337,11 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls) qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a qualificationBlockedCell Nothing = mempty -qualificationBlockedCell (Just qb) = msgCell qb <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell (qualificationBlockedDay qb) +qualificationBlockedCell (Just QualificationBlocked{..}) + | 12 >= length qualificationBlockedReason = mkCellWith textCell + | otherwise = mkCellWith modalCell + where + mkCellWith c = c qualificationBlockedReason <> spacerCell <> iconCell IconBlocked <> spacerCell <> dayCell qualificationBlockedDay avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoCell = numCell . view _userAvsNoPerson diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 68dd375f8..7d6593d6f 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -278,7 +278,9 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act , transactionReceived = lReceived } update luid [LmsUserStatus =. (oldStatus <> Just newStatus)] - updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms blockedDay)] + updateBy (UniqueQualificationUser qid (lmsUserUser luser)) + [QualificationUserBlockedDue =. Just (QualificationBlocked { qualificationBlockedDay = blockedDay + , qualificationBlockedReason = "LMS" } )] queueDBJob JobSendNotification { jRecipient = lmsUserUser luser , jNotification = NotificationQualificationExpired { nQualification = qid, nExpiry = blockedDay } diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index 36370ba72..59c1a6547 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -65,27 +65,24 @@ instance Csv.ToField LmsStatus where toField (LmsSuccess d) = "Success: " <> Csv.toField d -data QualificationBlocked - = QualificationBlockedLms { qualificationBlockedDay :: Day } - | QualificationBlockedAvs { qualificationBlockedDay :: Day } -- not yet used +data QualificationBlocked = QualificationBlocked { qualificationBlockedDay :: Day + , qualificationBlockedReason :: Text + } deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData) deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 -- remove lms from constructor, since the object is tagged with lms already - , fieldLabelModifier = camelToPathPiece' 2 -- just day suffices for the day field - , omitNothingFields = True - , sumEncoding = TaggedObject "lms-status" "lms-result" + { tagSingleConstructors = False + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True } ''QualificationBlocked derivePersistFieldJSON ''QualificationBlocked instance Csv.ToField QualificationBlocked where - toField (QualificationBlockedLms d) = "Blocked by LMS: " <> Csv.toField d - toField (QualificationBlockedAvs d) = "Blocked by AVS: " <> Csv.toField d + toField QualificationBlocked{..} = "Blocked " <> Csv.toField qualificationBlockedDay <> " due to " <> Csv.toField qualificationBlockedReason --- | ToMessage instance ignores contained timestamp -instance ToMessage QualificationBlocked where - toMessage (QualificationBlockedLms _) = "LMS" - toMessage (QualificationBlockedAvs _) = "AVS" +-- | ToMessage instance ignores contained timestamp by design +-- instance ToMessage QualificationBlocked where -- no longer used +-- toMessage QualificationBlocked{..} = qualificationBlockedReason -- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index b773e6a2a..01acaf593 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -519,7 +519,7 @@ fillDb = do 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 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) True -- TODO: better dates! + void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True -- TODO: better dates! void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True -- TODO: better dates! void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True -- TODO: better dates! void . insert' $ QualificationUser gkleen qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing True