chore(lms): add arbritrary text to qualificationBlocked

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

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 }

src/Model/Types/Lms.hs

@@ -65,27 +65,24 @@ instance Csv.ToField LmsStatus where
   toField (LmsSuccess d) = "Success: " <> Csv.toField d
 
 
-data QualificationBlocked 
+data QualificationBlocked = QualificationBlocked { qualificationBlockedDay    :: Day
-      = QualificationBlockedLms { qualificationBlockedDay :: Day } 
+                                                 , qualificationBlockedReason :: Text 
-      | QualificationBlockedAvs { qualificationBlockedDay :: Day } -- not yet used
+                                                 } 
   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
+  { tagSingleConstructors = False
-  , fieldLabelModifier     = camelToPathPiece' 2      -- just day suffices for the day field
+  , fieldLabelModifier     = camelToPathPiece' 2
-  , omitNothingFields = True
+  , omitNothingFields = True  
-  , sumEncoding = TaggedObject "lms-status" "lms-result"
   } ''QualificationBlocked 
 derivePersistFieldJSON ''QualificationBlocked 
 
 instance Csv.ToField QualificationBlocked  where
-  toField (QualificationBlockedLms d) = "Blocked by LMS: " <> Csv.toField d
+  toField QualificationBlocked{..} = "Blocked " <> Csv.toField qualificationBlockedDay <> " due to " <> Csv.toField qualificationBlockedReason
-  toField (QualificationBlockedAvs d) = "Blocked by AVS: " <> Csv.toField d
 
--- | ToMessage instance ignores contained timestamp
+-- | ToMessage instance ignores contained timestamp by design
-instance ToMessage QualificationBlocked where 
+-- instance ToMessage QualificationBlocked where -- no longer used
-  toMessage (QualificationBlockedLms _) = "LMS"
+--   toMessage QualificationBlocked{..} = qualificationBlockedReason
-  toMessage (QualificationBlockedAvs _) = "AVS"
 
 -- | LMS interface requires Bool to be encoded by 0 or 1 only
 newtype LmsBool = LmsBool { lms2bool :: Bool }

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