From 9d4dde069cb2282f0099d810ab4e9015e7efdf14 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 29 Nov 2024 13:32:04 +0100 Subject: [PATCH] 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 | 2 +- src/Handler/School/DayTasks.hs | 68 +++++++++++++++++++++++++++++----- src/Model/Types/User.hs | 9 ++++- src/Utils.hs | 4 +- 4 files changed, 70 insertions(+), 13 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 57bc37d1a..b8bd82a87 100644 --- a/src/Handler/Admin/Avs.hs +++ b/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 diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index be7efc3bb..f600edc27 100644 --- a/src/Handler/School/DayTasks.hs +++ b/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 diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 0abcd42af..4c106917c 100644 --- a/src/Model/Types/User.hs +++ b/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 \ No newline at end of file diff --git a/src/Utils.hs b/src/Utils.hs index 4f20248d3..0ae1fed18 100644 --- a/src/Utils.hs +++ b/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]