diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index 05e471b74..dc8244a8d 100644 --- a/src/Handler/School/DayTasks.hs +++ b/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)