chore(daily): towards #2347 by caching and sorting results

src/Handler/School/DayTasks.hs

@@ -77,6 +77,7 @@ data DailyCacheKeys
   = CacheKeyTutorialOccurrences  SchoolId (Day,Day)
   | CacheKeySuggsParticipantNote SchoolId TutorialId
   | CacheKeySuggsAttendanceNote  SchoolId TutorialId
+  | CacheKeyTutorialCheckResults SchoolId Day
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Hashable, Binary, NFData)
 
@@ -355,7 +356,7 @@ suggsParticipantNote sid cid tid = do
 
 suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text)
 suggsAttendanceNote sid cid tid = do
-  ol <- memcachedBy (Just . Right $ 2* diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do
+  ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsAttendanceNote sid tid) $ do
     suggs <- runDB $ E.select $ do
       let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
       (tpn, prio) <- E.from $
@@ -666,10 +667,89 @@ postSchoolDayR ssh nd = do
     setTitleI (MsgMenuSchoolDay ssh dday)
     $(i18nWidgetFile "day-view")
 
+-- | A wrapper for several check results on tutorial participants
+data DayCheckResult = DayCheckResult
+      { dcEyeFitsPermit :: Maybe Bool
+      , dcAvsKnown      :: Bool
+      , dcApronAccess   :: Bool
+      , dcBookingFirmOk :: Bool
+      }
+  deriving (Show, Generic, Binary)
 
+dcIsOk :: DayCheckResult -> Bool
+dcIsOk (DayCheckResult (Just True) True True True) = True
+dcIsOk _ = False
+
+data DayCheckResults = DayCheckResults
+      { dcrTimestamp :: UTCTime
+      , dcrResults   :: Map TutorialParticipantId DayCheckResult
+      }
+  deriving (Show, Generic, Binary)
+
+type ParticipantCheckData = (Entity TutorialParticipant, (E.Value UserDisplayName, E.Value UserSurname), E.Value (Maybe AvsPersonId), E.Value (Maybe CompanyName))
+
+
+dayCheckParticipant :: Map AvsPersonId AvsDataPerson
+                    -> ParticipantCheckData
+                    -> DayCheckResult
+dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, (E.Value udn, E.Value usn), E.Value mapi, E.Value mcmp) =
+    let dcEyeFitsPermit = liftM2 eyeExamFitsDrivingPermit tutorialParticipantEyeExam tutorialParticipantDrivingPermit
+        (dcAvsKnown, (dcApronAccess, dcBookingFirmOk))
+          | 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
   -- isAdmin <- hasReadAccessTo AdminR
+  (tuts, parts_avs) <- runDB $ do
+    tuts <- Map.keys <$> getDayTutorials ssh (nd,nd)
+    -- participants <- selectList [TutorialParticipantTutorial <-. tuts] []
+    parts_avs :: [ParticipantCheckData]
+      <- 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] -- order no longer needed
+        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)
+  let getApi :: ParticipantCheckData -> 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)
+  -- gültigen Vorfeldausweis prüfen, buchende Firma mit Ausweisnummer aus AVS abgleichen
+  let toPartMap :: ParticipantCheckData -> Map TutorialParticipantId DayCheckResult
+      toPartMap pcd = Map.singleton (pcd ^. _1 . _entityKey) $ dayCheckParticipant avsStats pcd
+      particpantResults = foldMap toPartMap parts_avs
+  memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now particpantResults
+  -- the following is only for displaying results neatly
+  let sortBadParticipant acc pcd =
+        let tid = pcd ^. _1 . _entityVal . _tutorialParticipantTutorial
+            pid = pcd ^. _1 . _entityKey
+            udn = pcd ^. _2 . _1 . _unValue
+            ok  = maybe False dcIsOk $ Map.lookup pid particpantResults
+        in if ok then acc else Map.insertWith (<>) tid (Map.singleton (udn,pid) pcd) acc
+      badTutPartMap :: Map TutorialId (Map (UserDisplayName, TutorialParticipantId) ParticipantCheckData)
+      badTutPartMap = foldl' sortBadParticipant mempty parts_avs
+
   dday <- formatTime SelFormatDate nd
   siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
     setTitleI (MsgMenuSchoolDay ssh dday)