fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(daily): fix #2349 completing daily sanity check

Browse Source
This commit is contained in:
Steffen Jost 2024-12-02 13:28:33 +01:00
parent e051557d3e
commit 44a60bcef6
1 changed files with 43 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
src/Handler/School/DayTasks.hs
View File

@ -446,8 +446,8 @@ colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserPark
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
)
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget)
mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case
mkDailyTable :: Bool -> SchoolId -> Day -> Maybe DayCheckResults -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Maybe Widget)
mkDailyTable isAdmin ssh nd dcrs = getDayTutorials ssh (nd,nd) >>= \case
tutLessons
| Map.null tutLessons -> return (FormMissing, Nothing)
| otherwise -> do
@ -497,10 +497,10 @@ mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case
result
| primComp /= bookComp
, Just (unCompanyKey -> csh) <- primComp
= bookLink
= cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
(Just IconCompanyWarning) True)
<> spacerCell
<> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
(Just IconCompanyWarning) True)
<> bookLink
| otherwise = bookLink
in result
-- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row ->
@ -523,6 +523,9 @@ mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case
-- ))
-- | otherwise = bookLink
-- in result
, maybeEmpty dcrs $ \DayCheckResults{..} ->
sortable (Just "check-fail") (timeCell dcrTimestamp) $ \(view $ resultParticipant . _entityKey -> tpid) ->
maybeCell (Map.lookup tpid dcrResults) $ wgtCell . dcr2widget' Nothing
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
, colUserMatriclenr isAdmin
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
@ -554,6 +557,16 @@ mkDailyTable isAdmin ssh nd = getDayTutorials ssh (nd,nd) >>= \case
, ("attendance" , SortColumnNullsInv $ queryParticipantDay >>> (E.?. TutorialParticipantDayAttendance))
, ("note-attend" , SortColumn $ queryParticipantDay >>> (E.?. TutorialParticipantDayNote))
, ("parking" , SortColumnNullsInv $ queryUserDay >>> (E.?. UserDayParkingToken))
-- , ("check-fail" , SortColumn $ queryParticipant >>> (\pid -> pid E.^. TutorialParticipantId `E.in_` E.vals (maybeEmpty dcrs $ dcrResults >>> Map.keys)))
, let dcrsLevels = maybeEmpty dcrs $ dcrSeverityGroups . dcrResults in
("check-fail" , SortColumn $ queryParticipant >>> (\((E.^. TutorialParticipantId) -> pid) -> E.case_
[ E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _1)) E.then_ (E.val 1)
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _2)) E.then_ (E.val 2)
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _3)) E.then_ (E.val 3)
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _4)) E.then_ (E.val 4)
, E.when_ (pid `E.in_` E.vals (dcrsLevels ^. _5)) E.then_ (E.val 5)
](E.else_ E.val (99 :: Int64))
))
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
@ -627,7 +640,8 @@ postSchoolDayR ssh nd = do
, dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just
, dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False
}
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
dcrs <- memcachedByGet (CacheKeyTutorialCheckResults ssh nd)
(fmap unFormResult -> tableRes, tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd dcrs
-- logInfoS "****DailyTable****" $ tshow tableRes
formResult tableRes $ \resMap -> do
tuts <- runDB $ forM (Map.toList resMap) $ \(tpid, DailyFormData{..}) -> do
@ -718,6 +732,29 @@ dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest
dcr2widget _ DayCheckResult{dcEyeFitsPermit=Just False}= text2widget "Sehtest und Führerschein passen nicht zusammen"
dcr2widget _ _ = text2widget "Kein Problem vorhanden"
dcrSeverity :: DayCheckResult -> Int
dcrSeverity DayCheckResult{dcAvsKnown=False} = 1
dcrSeverity DayCheckResult{dcApronAccess=False} = 2
dcrSeverity DayCheckResult{dcBookingFirmOk=False} = 3
dcrSeverity DayCheckResult{dcEyeFitsPermit=Nothing} = 4
dcrSeverity DayCheckResult{dcEyeFitsPermit=Just False} = 5
dcrSeverity _ = 99
dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
dcrSeverityGroups dcrs = Map.foldMapWithKey groupBySeverity mempty
where
groupBySeverity :: TutorialParticipantId -> DayCheckResult -> (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
groupBySeverity tpid dcr =
let sempty = mempty :: (Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId,Set TutorialParticipantId)
in case dcrSeverity dcr of
1 -> set _1 (Set.singleton tpid) sempty
2 -> set _2 (Set.singleton tpid) sempty
3 -> set _3 (Set.singleton tpid) sempty
4 -> set _4 (Set.singleton tpid) sempty
5 -> set _5 (Set.singleton tpid) sempty
_ -> sempty
-- Alternative version using icons to display everything at once
dcr2widget' :: Maybe CompanyName -> DayCheckResult -> Widget
dcr2widget' mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk]