chore(daily): towards #2347 by implementing basic check for one user

also prepare for caching results and show on daily page, if existing

src/Handler/Admin/Avs.hs

@@ -805,7 +805,7 @@ postAdminAvsUserR uuid = do
     mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
     -- mbStatus  <- try $ fmap fltrIdStatus  $ avsQuery $ AvsQueryStatus  $ Set.singleton                  userAvsPersonId
     mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
-    let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
+    let compsUsed :: [CompanyName] = mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just . to stripCI
     compDict <- if 1 >= length compsUsed
       then return mempty -- switch company only sensible if there is more than one company to choose
       else do

src/Handler/School/DayTasks.hs

@@ -664,6 +664,42 @@ postSchoolDayR ssh nd = do
     setTitleI (MsgMenuSchoolDay ssh dday)
     $(i18nWidgetFile "day-view")
 
+-- | A wrapper for several check results on tutorial participants
+data DayCheckResult = DayCheckResult
+      { dcrEyeFitsPermit :: Maybe Bool
+      , dcrAvsKnown      :: Bool
+      , dcrApronAccess   :: Bool
+      , dcrBookingFirmOk :: Bool
+      }
+  deriving (Show, Generic, Binary)
+
+data DayCheckResults = DayCheckResults
+      { dcrResults   :: Map TutorialParticipantId DayCheckResult
+      , dcrTimestamp :: UTCTime
+      }
+  deriving (Show, Generic, Binary)
+
+dayCheckParticipant :: Map AvsPersonId AvsDataPerson
+                    -> (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName))
+                    -> DayCheckResult
+dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value mcmp) =
+    let dcrEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit
+        (dcrAvsKnown, (dcrApronAccess, dcrBookingFirmOk))
+          | Just AvsDataPerson{avsPersonPersonCards = apcs} <- lookupMaybe avsStats mapi
+            = (True , mapBoth getAny $ foldMap (hasApronAccess &&& fitsBooking mcmp) apcs)
+          | otherwise
+            = (False, (False, False))
+    in DayCheckResult{..}
+  where
+    hasApronAccess :: AvsDataPersonCard -> Any
+    hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorGelb} = Any True
+    hasApronAccess AvsDataPersonCard{avsDataValid=True, avsDataCardColor=AvsCardColorRot}  = Any True
+    hasApronAccess _ = Any False
+
+    fitsBooking :: Maybe CompanyName -> AvsDataPersonCard -> Any
+    fitsBooking (Just cn) AvsDataPersonCard{avsDataValid=True,avsDataFirm=Just df}  = Any $ cn == stripCI df
+    fitsBooking _ _ = Any False
+
 -- | Prüft die Teilnehmer der Tagesansicht: AVS online aktualisieren, gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
 getSchoolDayCheckR :: SchoolId -> Day -> Handler Html
 getSchoolDayCheckR ssh nd = do
@@ -673,21 +709,35 @@ getSchoolDayCheckR ssh nd = do
   (tuts, parts_avs) <- runDB $ do
     tuts <- Map.keys <$> getDayTutorials ssh (nd,nd)
     -- participants <- selectList [TutorialParticipantTutorial <-. tuts] []
-    parts_avs <- E.select $ do
-      (tpa :& avs) <- E.from $  E.table @TutorialParticipant
-          `E.leftJoin` E.table @UserAvs
-          `E.on` (\(tpa :& avs) -> tpa E.^. TutorialParticipantUser E.=?. avs E.?. UserAvsUser)
-      E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts
-      E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial]
-      return (tpa, avs E.?. UserAvsPersonId) -- , avs E.?. UserAvsNoPerson)
+    parts_avs :: [(Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName))]
+      <- E.select $ do
+        (tpa :& usr :& avs :& cmp) <- E.from $  E.table @TutorialParticipant
+            `E.innerJoin` E.table @User
+            `E.on` (\(tpa :& usr)           -> tpa E.^. TutorialParticipantUser    E.==. usr E.^. UserId)
+            `E.leftJoin`  E.table @UserAvs
+            `E.on` (\(tpa :& _ :& avs)      -> tpa E.^. TutorialParticipantUser    E.=?. avs E.?. UserAvsUser)
+            `E.leftJoin`  E.table @Company
+            `E.on` (\(tpa :& _ :& _ :& cmp) -> tpa E.^. TutorialParticipantCompany E.==. cmp E.?. CompanyId)
+        E.where_ $ tpa E.^. TutorialParticipantTutorial `E.in_` E.vals tuts
+        E.orderBy [E.asc $ tpa E.^. TutorialParticipantTutorial, E.asc $ usr E.^. UserDisplayName]
+        return (tpa, (usr E.^. UserDisplayName, usr E.^. UserSurname), avs E.?. UserAvsPersonId, cmp E.?. CompanyName)
     -- additionally queue proper AVS synchs for all users, unless there were already done today
     void $ queueAvsUpdateByUID (foldMap (^. _1 . _entityVal . _tutorialParticipantUser . to Set.singleton) parts_avs) (Just nowaday)
     return (tuts, parts_avs)
-  -- avsStats :: Map AvsPersonId AvsDataPerson
-  avsStats <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap (foldMap Set.singleton . E.unValue . snd) parts_avs -- query AVS, but does not affect DB (no update)
+  let getApi :: (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName)) -> Set AvsPersonId
+      getApi = foldMap Set.singleton . E.unValue . view _3
+  avsStats :: Map AvsPersonId AvsDataPerson
+    <- catchAVShandler False False True mempty $ lookupAvsUsers $ foldMap getApi parts_avs -- query AVS, but does not affect DB (no update)
+  -- let compsUsed :: Set CompanyName = Set.fromList $ foldMap (^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just . to stripCI) avsStats
+  -- compDict :: Map CompanyName CompanyId <- fmap (Map.fromAscList . fmap $(unValueN 2)) $ runDBRead $ E.select $ do
+  --   cmp <- E.from $ E.table @Company
+  --   E.where_ $ cmp E.^. CompanyName `E.in_` E.vals compsUsed
+  --   E.orderBy [E.asc $ cmp E.^. CompanyName, E.asc $ cmp E.^. CompanyAvsId]
+  --   return (cmp E.^. CompanyName, cmp E.^. CompanyId)
 
   -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
   -- traverse part_avs sorted by tuts, lookup name and check each person
+  -- dayCheckParticipant parts_avs
 
   dday <- formatTime SelFormatDate nd
   siteLayoutMsg MsgMenuSchoolDayCheck $ do

src/Model/Types/User.hs

@@ -36,7 +36,7 @@ data UserDrivingPermit = UserDrivingPermitB
 
 instance Show UserDrivingPermit where
   show UserDrivingPermitB   = "B"
-  show UserDrivingPermitB01 = "B01"
+  show UserDrivingPermitB01 = "B01" -- Brille notwendig
 
 instance RenderMessage a UserDrivingPermit where
   renderMessage _foundation _languages = tshow
@@ -53,7 +53,7 @@ data UserEyeExam = UserEyeExamSX
 
 instance Show UserEyeExam where
   show UserEyeExamSX  = "SX"
-  show UserEyeExamS01 = "S01"
+  show UserEyeExamS01 = "S01" -- Brille notwendig
 
 instance RenderMessage a UserEyeExam where
   renderMessage _foundation _languages = tshow
@@ -63,3 +63,8 @@ deriveJSON defaultOptions
   } ''UserEyeExam
 derivePersistFieldJSON ''UserEyeExam
 nullaryPathPiece ''UserEyeExam $ camelToPathPiece' 3
+
+eyeExamFitsDrivingPermit :: UserEyeExam -> UserDrivingPermit -> Bool
+eyeExamFitsDrivingPermit UserEyeExamSX  _                    = True
+eyeExamFitsDrivingPermit UserEyeExamS01 UserDrivingPermitB01 = True
+eyeExamFitsDrivingPermit _              _                    = False

src/Utils.hs

@@ -835,7 +835,6 @@ listBracket b@(s,e) (h:t)
 
 infixl 5 !!!
 
-
 (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
 (!!!) m k = fromMaybe mempty $ Map.lookup k m
 
@@ -844,6 +843,9 @@ lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
 -- lookupSome m ks = ks >>= (m !!!)
 lookupSome = (=<<) . (!!!)
 
+lookupMaybe :: Ord k => Map k a -> Maybe k -> Maybe a
+lookupMaybe = (=<<) . flip Map.lookup
+
 groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
 groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]