chore(admin): show active card colors on problem resolution page

messages/uniworx/categories/avs/de-de-formal.msg

@@ -29,4 +29,9 @@ RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer
 AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
 LicenceTableChangeAvs: Im AVS ändern
 LicenceTableGrantFDrive: In FRADrive erteilen
-LicenceTableRevokeFDrive: In FRADrive entziehen
+LicenceTableRevokeFDrive: In FRADrive entziehen
+TableAvsActiveCards: Gültige Ausweise
+AvsCardColorGreen: Grün
+AvsCardColorBlue: Blau
+AvsCardColorRed: Rot
+AvsCardColorYellow: Gelb

messages/uniworx/categories/avs/en-eu.msg

@@ -30,3 +30,8 @@ AvsCommunicationError: AVS interface returned an unexpected error.
 LicenceTableChangeAvs: Change in AVS
 LicenceTableGrantFDrive: Grant in FRADrive
 LicenceTableRevokeFDrive: Revoke in FRADrive
+TableAvsActiveCards: Valid Cards
+AvsCardColorGreen: Green
+AvsCardColorBlue: Blue
+AvsCardColorRed: Red
+AvsCardColorYellow: Yellow

src/Foundation/I18n.hs

@@ -251,6 +251,13 @@ embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages
 mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
 mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
 
+instance RenderMessage UniWorX AvsDataCardColor where
+  renderMessage _foundation _ls (AvsCardColorMisc t) = Text.cons '*' t
+  renderMessage f ls AvsCardColorGrün = renderMessage f ls MsgAvsCardColorGreen
+  renderMessage f ls AvsCardColorBlau = renderMessage f ls MsgAvsCardColorBlue
+  renderMessage f ls AvsCardColorRot  = renderMessage f ls MsgAvsCardColorRed
+  renderMessage f ls AvsCardColorGelb = renderMessage f ls MsgAvsCardColorYellow
+
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
 

src/Handler/Admin.hs

@@ -51,11 +51,12 @@ getAdminProblemsR = do
   diffLics <- try retrieveDifferingLicences <&> \case
     -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
     (Left e) -> Left $ text2widget $ tshow (e :: SomeException)
-    (Right AvsLicenceDifferences{..}) -> Right  ( Set.size avsLicenceDiffRevokeAll
+    (Right AvsLicenceDifferences{..}) -> Right
-                                                , Set.size avsLicenceDiffGrantVorfeld
+      ( Set.size avsLicenceDiffRevokeAll
-                                                , Set.size avsLicenceDiffRevokeRollfeld
+      , Set.size avsLicenceDiffGrantVorfeld
-                                                , Set.size avsLicenceDiffGrantRollfeld
+      , Set.size avsLicenceDiffRevokeRollfeld
-                                                )
+      , Set.size avsLicenceDiffGrantRollfeld
+      )
   -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
   -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
   -- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`

src/Handler/Admin/Avs.hs

@@ -365,7 +365,8 @@ postProblemAvsSynchR = getProblemAvsSynchR
 getProblemAvsSynchR = do    
   let catchAllAvs' r = flip catch (\err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) >> redirect r)
       catchAllAvs    = catchAllAvs' ProblemAvsSynchR -- == current route; use only in conditions that are not repeated upon reload; do not call redirect within catchAllAvs actions!
-  AvsLicenceDifferences{..} <- catchAllAvs' AdminR retrieveDifferingLicences
+  (AvsLicenceDifferences{..}, apidStatus) <- catchAllAvs' AdminR retrieveDifferingLicencesStatus
+  -- TODO: for all ids, uery PersonStatus and create a Map from AvsId to a List of all valid Cards
 
   --  
   unknownLicenceOwners' <- whenNonEmpty avsLicenceDiffRevokeAll $ \neZeros ->
@@ -421,10 +422,10 @@ getProblemAvsSynchR = do
 
   -- licence differences
   ((tres0,tb0),(tres1up,tb1up),(tres1down,tb1down),(tres2,tb2)) <- runDB $ (,,,) 
-          <$> mkLicenceTable "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll      
+          <$> mkLicenceTable apidStatus "avsLicDiffRevokeVorfeld"  AvsLicenceVorfeld   avsLicenceDiffRevokeAll      
-          <*> mkLicenceTable "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
+          <*> mkLicenceTable apidStatus "avsLicDiffGrantVorfeld"   AvsNoLicence        avsLicenceDiffGrantVorfeld   
-          <*> mkLicenceTable "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
+          <*> mkLicenceTable apidStatus "avsLicDiffRevokeRollfeld" AvsLicenceRollfeld  avsLicenceDiffRevokeRollfeld 
-          <*> mkLicenceTable "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld  
+          <*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld"  AvsNoLicence        avsLicenceDiffGrantRollfeld  
   
   now <- liftIO getCurrentTime
   let nowaday = utctDay now      
@@ -510,8 +511,8 @@ instance HasUser LicenceTableData where
   hasUser   = resultUser . _entityVal
 
 
-mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
+mkLicenceTable :: AvsPersonIdMapPersonCard -> Text -> AvsLicence -> Set AvsPersonId -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
-mkLicenceTable dbtIdent aLic apids = do 
+mkLicenceTable apidStatus dbtIdent aLic apids = do 
   currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
   avsQualifications <- selectList [QualificationAvsLicence !=. Nothing] []
   now <- liftIO getCurrentTime
@@ -553,6 +554,7 @@ mkLicenceTable dbtIdent aLic apids = do
         , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
         , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
                                                                                    ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> cellMaybe qualificationBlockedCell b
+        , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
         ]
       dbtSorting = mconcat
         [ single $ sortUserNameLink queryUser         

src/Handler/Utils/Avs.hs

@@ -14,11 +14,13 @@ module Handler.Utils.Avs
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , AvsLicenceDifferences(..)
   , setLicence, setLicenceAvs, setLicencesAvs
-  , retrieveDifferingLicences, computeDifferingLicences
+  , retrieveDifferingLicences, retrieveDifferingLicencesStatus
+  , computeDifferingLicences
   , synchAvsLicences
   , lookupAvsUser, lookupAvsUsers
   , AvsException(..)
   , updateReceivers
+  , AvsPersonIdMapPersonCard
   ) where
 
 import Import
@@ -178,6 +180,18 @@ data AvsLicenceDifferences = AvsLicenceDifferences
     }
   deriving (Show)
 
+#ifdef DEVELOPMENT
+-- avsLicenceDifferences2LicenceIds is not used in DEVELOPMENT build
+#else
+avsLicenceDifferences2LicenceIds :: AvsLicenceDifferences -> Set AvsPersonId
+avsLicenceDifferences2LicenceIds AvsLicenceDifferences{..} = Set.unions 
+  [ avsLicenceDiffRevokeAll     
+  , avsLicenceDiffGrantVorfeld  
+  , avsLicenceDiffRevokeRollfeld
+  , avsLicenceDiffGrantRollfeld 
+  ]
+#endif 
+
 avsLicenceDifferences2personLicences :: AvsLicenceDifferences -> Set AvsPersonLicence
 avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
      Set.map (AvsPersonLicence AvsNoLicence)       avsLicenceDiffRevokeAll
@@ -188,24 +202,50 @@ avsLicenceDifferences2personLicences AvsLicenceDifferences{..} =
 computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
 computeDifferingLicences = fmap avsLicenceDifferences2personLicences . getDifferingLicences
 
-retrieveDifferingLicences :: Handler AvsLicenceDifferences
+type AvsPersonIdMapPersonCard = Map AvsPersonId (Set AvsDataPersonCard)
-retrieveDifferingLicences = do
-#ifdef DEVELOPMENT  
-  avsUsrs <- runDB $ selectList [] [LimitTo 444]
-  getDifferingLicences $ AvsResponseGetLicences $ Set.fromList $
-    [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
-    , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
-    , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
-    , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
-    -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
-    ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
-#else
-  AvsQuery{..}  <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-  allLicences   <- throwLeftM avsQueryGetAllLicences
-  getDifferingLicences allLicences
-#endif
-  
 
+avsResponseStatusMap :: AvsResponseStatus -> AvsPersonIdMapPersonCard
+avsResponseStatusMap (AvsResponseStatus status) = Map.fromDistinctAscList [(avsStatusPersonID,avsStatusPersonCardStatus) | AvsStatusPerson{..}<- Set.toAscList status]
+
+retrieveDifferingLicences :: Handler AvsLicenceDifferences
+retrieveDifferingLicences = fst <$> retrieveDifferingLicences' False
+
+retrieveDifferingLicencesStatus :: Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
+retrieveDifferingLicencesStatus = retrieveDifferingLicences' True
+
+retrieveDifferingLicences' :: Bool -> Handler (AvsLicenceDifferences, AvsPersonIdMapPersonCard)
+retrieveDifferingLicences' getStatus = do  
+#ifdef DEVELOPMENT
+  avsUsrs <- runDB $ selectList [] [LimitTo 444]
+  let allLicences = AvsResponseGetLicences $ Set.fromList $
+        [ AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 77         -- AVS:1 FD:2
+        , AvsPersonLicence AvsLicenceRollfeld $ AvsPersonId 12345678   -- AVS:2 FD:1
+        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 5          -- AVS:1 FD:0 (nichts)
+        , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 2          -- AVS:1 FD:0 (ungültig)
+        -- , AvsPersonLicence AvsLicenceVorfeld  $ AvsPersonId 4          -- AVS:1 FD:1
+        ] ++ [AvsPersonLicence AvsLicenceVorfeld avsid | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs]
+#else
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  allLicences  <- throwLeftM avsQueryGetAllLicences
+#endif
+  lDiff <- getDifferingLicences allLicences  
+#ifdef DEVELOPMENT
+  let mkAdpc valid color = AvsDataPersonCard valid Nothing Nothing color (Set.singleton 'F') Nothing Nothing Nothing Nothing (AvsCardNo "1234") "5"
+      lStat = AvsResponseStatus $ bool mempty fakes getStatus -- not really needed, but avoids unused variable error
+      fakes = Set.fromList $ 
+              [ AvsStatusPerson (AvsPersonId 77      ) $ Set.singleton $ mkAdpc True AvsCardColorGelb
+              , AvsStatusPerson (AvsPersonId 12345678) $ Set.fromList [mkAdpc False AvsCardColorGrün, mkAdpc True  AvsCardColorGelb, mkAdpc False AvsCardColorBlau, mkAdpc True  AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Violett"]
+              , AvsStatusPerson (AvsPersonId 5       ) $ Set.fromList [mkAdpc True  AvsCardColorGrün, mkAdpc False AvsCardColorGelb, mkAdpc True  AvsCardColorBlau, mkAdpc False AvsCardColorRot, mkAdpc True $ AvsCardColorMisc "Pink"]
+              , AvsStatusPerson (AvsPersonId 2       ) $ Set.singleton $ mkAdpc True AvsCardColorGrün
+              ] <> 
+              [ AvsStatusPerson  avsid $ Set.singleton $ mkAdpc (even $ avsPersonId avsid) AvsCardColorGelb | Entity _ UserAvs{userAvsPersonId = avsid} <- avsUsrs ]
+#else
+  let statQry = AvsQueryStatus $ avsLicenceDifferences2LicenceIds lDiff
+  lStat <- if getStatus then throwLeftM $ avsQueryStatus statQry else return $ AvsResponseStatus mempty -- avoid unnecessary avs calls
+#endif
+  return (lDiff, avsResponseStatusMap lStat)
+
+  
 getDifferingLicences :: AvsResponseGetLicences -> Handler AvsLicenceDifferences
 getDifferingLicences (AvsResponseGetLicences licences) = do
   now <- liftIO getCurrentTime

src/Handler/Utils/Table/Cells.hs

@@ -7,6 +7,7 @@ module Handler.Utils.Table.Cells where
 import Import hiding (link)
 
 import Text.Blaze (ToMarkup(..))
+import qualified Data.Set as Set
 
 import Handler.Utils.Table.Pagination
 import Handler.Utils.DateTime
@@ -381,3 +382,16 @@ qualificationBlockedCell (Just QualificationBlocked{..})
 
 avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c 
 avsPersonNoCell = numCell . view _userAvsNoPerson
+
+avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
+avsPersonCardCell cards = wgtCell 
+    [whamlet|
+      $newline never
+      <ul .list--iconless .list--inline .list--comma-separated>
+        $forall c <- validColors
+          <li>
+            _{c}
+    |]
+  where 
+    validCards  = Set.filter avsDataValid cards
+    validColors = Set.toDescList $ Set.map avsDataCardColor validCards

src/Model/Types/Avs.hs

@@ -281,12 +281,13 @@ licence2char AvsLicenceRollfeld = 'R'
 data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (NFData)
+  -- instance RenderMessage declared in Foundation.I18n
 
 instance ToJSON AvsDataCardColor where
-  toJSON AvsCardColorGrün = "Grün"
+  toJSON  AvsCardColorGrün    = "Grün"
-  toJSON AvsCardColorBlau = "Blau"
+  toJSON  AvsCardColorBlau    = "Blau"
-  toJSON AvsCardColorRot  = "Rot"
+  toJSON  AvsCardColorRot     = "Rot"
-  toJSON AvsCardColorGelb = "Gelb"
+  toJSON  AvsCardColorGelb    = "Gelb"
   toJSON (AvsCardColorMisc t) = String t
 
 instance FromJSON AvsDataCardColor where