-- SPDX-FileCopyrightText: 2024 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- TODO during development only {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only {-# OPTIONS_GHC -fno-warn-unused-matches #-} -- TODO during development only module Handler.School.DayTasks ( getSchoolDayR, postSchoolDayR , getSchoolDayCheckR ) where import Import import Handler.Utils import Handler.Utils.Company import Handler.Utils.Occurrences import Handler.Utils.Avs import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Aeson as Aeson import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.PostgreSQL.JSON ((@>.)) import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH -- | Maximal number of suggestions for note fields in Day Task view maxSuggestions :: Int64 maxSuggestions = 7 -- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing -- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -- instance Universe DailyTableAction -- instance Finite DailyTableAction -- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2 -- embedRenderMessage ''UniWorX ''DailyTableAction id -- data DailyTableActionData = DailyActDummyData -- deriving (Eq, Ord, Read, Show, Generic) -- | partial JSON object to be used for filtering with "@>" -- ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions occurrenceDayValue :: Day -> Value occurrenceDayValue d = Aeson.object [ "exceptions" Aeson..= [ Aeson.object [ "exception" Aeson..= ("occur"::Text) , "day" Aeson..= d ] ] ] {- More efficient DB-only version, but ignores regular schedules getDayTutorials :: SchoolId -> Day -> DB [TutorialId] getDayTutorials ssh d = E.unValue <<$>> E.select (do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ E.between (E.val d) (trm E.^. TermStart, trm E.^. TermEnd) E.&&. crs E.^. CourseSchool E.==. E.val ssh E.&&. (E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue d)) return $ tut E.^. TutorialId ) -} -- | Datatype to be used as key for memcaching DayTask related stuff; note that newtype-CacheKeys are optimized away, so multiple constructors are advisable 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) -- getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId] -- getDayTutorials ssh dlimit@(dstart, dend ) -- | dstart > dend = return mempty -- | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do -- same key is ok, distinguished by return type -- candidates <- E.select $ do -- (trm :& crs :& tut) <- E.from $ E.table @Term -- `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) -- `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) -- E.where_ $ crs E.^. CourseSchool E.==. E.val ssh -- E.&&. trm E.^. TermStart E.<=. E.val dend -- E.&&. trm E.^. TermEnd E.>=. E.val dstart -- return (trm, tut, E.just (tut E.^. TutorialTime) @>. E.jsonbVal (occurrenceDayValue dstart)) -- -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates -- return $ mapMaybe checkCandidate candidates -- where -- period = Set.fromAscList [dstart..dend] -- checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- most common case -- checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}, _) -- | not $ Set.null $ Set.intersection period $ occurrencesCompute' trm occ -- = Just tutId -- | otherwise -- = Nothing -- | like the previous version above, but also returns the lessons occurring within the given time frame -- Due to caching, we only use the more informative version, unless experiments with the full DB show otherwise getDayTutorials :: SchoolId -> (Day,Day) -> DB (Map TutorialId (TutorialName, [LessonTime])) getDayTutorials ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (CacheKeyTutorialOccurrences ssh dlimit) $ do candidates <- E.select $ do (trm :& crs :& tut) <- E.from $ E.table @Term `E.innerJoin` E.table @Course `E.on` (\(trm :& crs) -> crs E.^. CourseTerm E.==. trm E.^. TermId) `E.innerJoin` E.table @Tutorial `E.on` (\(_ :& crs :& tut) -> crs E.^. CourseId E.==. tut E.^. TutorialCourse) E.where_ $ crs E.^. CourseSchool E.==. E.val ssh E.&&. trm E.^. TermStart E.<=. E.val dend E.&&. trm E.^. TermEnd E.>=. E.val dstart return (trm, tut) -- logErrorS "DAILY" $ foldMap (\(Entity{entityVal=someTerm},Entity{entityVal=Tutorial{..}},_) -> tshow someTerm <> " *** " <> ciOriginal tutorialName <> ": " <> tshow (unJSONB tutorialTime)) candidates return $ foldMap checkCandidate candidates where checkCandidate :: (Entity Term, Entity Tutorial) -> Map TutorialId (TutorialName, [LessonTime]) checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ, tutorialName=tName}}) | let lessons = Set.filter lessonFltr $ occurringLessons trm occ , notNull lessons = Map.singleton tutId (tName , Set.toAscList lessons) -- due to Set not having a Functor instance, we need mostly need lists anyway | otherwise = mempty lessonFltr :: LessonTime -> Bool lessonFltr LessonTime{..} = dstart <= localDay lessonStart && dend >= localDay lessonEnd type DailyTableExpr = ( E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Tutorial) `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) `E.InnerJoin` E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserAvs)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserDay)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity TutorialParticipantDay)) ) type DailyTableOutput = E.SqlQuery ( E.SqlExpr (Entity Course) , E.SqlExpr (Entity Tutorial) , E.SqlExpr (Entity TutorialParticipant) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity UserAvs)) , E.SqlExpr (Maybe (Entity UserDay)) , E.SqlExpr (Maybe (Entity TutorialParticipantDay)) , E.SqlExpr (E.Value (Maybe CompanyId)) , E.SqlExpr (E.Value (Maybe [QualificationId])) ) type DailyTableData = DBRow ( Entity Course , Entity Tutorial , Entity TutorialParticipant , Entity User , Maybe (Entity UserAvs) , Maybe (Entity UserDay) , Maybe (Entity TutorialParticipantDay) , E.Value (Maybe CompanyId) , E.Value (Maybe [QualificationId]) ) data DailyFormData = DailyFormData { dailyFormDrivingPermit :: Maybe UserDrivingPermit , dailyFormEyeExam :: Maybe UserEyeExam , dailyFormParticipantNote :: Maybe Text , dailyFormAttendance :: Bool , dailyFormAttendanceNote :: Maybe Text , dailyFormParkingToken :: Bool } deriving (Eq, Show) makeLenses_ ''DailyFormData -- force declarations before this point to avoid staging restrictions $(return []) queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) queryCourse = $(sqlMIXproj' ''DailyTableExpr 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) -- reify seems problematic for now queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlMIXproj' ''DailyTableExpr 4) queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5) queryUserDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserDay)) queryUserDay = $(sqlMIXproj' ''DailyTableExpr 6) queryParticipantDay :: DailyTableExpr -> E.SqlExpr (Maybe (Entity TutorialParticipantDay)) queryParticipantDay = $(sqlMIXproj' ''DailyTableExpr 7) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 resultTutorial :: Lens' DailyTableData (Entity Tutorial) resultTutorial = _dbrOutput . _2 resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) resultParticipant = _dbrOutput . _3 resultUser :: Lens' DailyTableData (Entity User) resultUser = _dbrOutput . _4 resultUserAvs :: Traversal' DailyTableData UserAvs resultUserAvs = _dbrOutput . _5 . _Just . _entityVal resultUserDay :: Traversal' DailyTableData UserDay resultUserDay = _dbrOutput . _6 . _Just . _entityVal resultParticipantDay :: Traversal' DailyTableData TutorialParticipantDay resultParticipantDay = _dbrOutput . _7 . _Just . _entityVal resultCompanyId :: Traversal' DailyTableData CompanyId resultCompanyId = _dbrOutput . _8 . _unValue . _Just resultCourseQualis :: Traversal' DailyTableData [QualificationId] resultCourseQualis = _dbrOutput . _9 . _unValue . _Just instance HasEntity DailyTableData User where hasEntity = resultUser instance HasUser DailyTableData where hasUser = resultUser . _entityVal -- see colRatedField' for an example of formCell usage drivingPermitField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserDrivingPermit drivingPermitField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam eyeExamField = selectField' (Just $ SomeMessage MsgBoolIrrelevant) optionsFinite mkDailyFormColumn :: (RenderMessage UniWorX msg) => Text -> msg -> Lens' DailyTableData a -> ASetter' DailyFormData a -> Field _ a -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) mkDailyFormColumn k msg lg ls f = sortable (Just $ SortingKey $ stripCI k) (i18nCell msg) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view lg -> x) mkUnique -> over (_1.mapped) (ls .~) . over _2 fvWidget <$> mreq f (fsUniq mkUnique k) (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit" & addClass' "uwx-narrow") (Just x) ) -- Given the row data and a callback to make an input name suitably unique generate the MForm colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParticipantEyeExamField' l = sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ (cellAttrs <>~ [("style","width:1%")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam" & addClass' "uwx-narrow") (Just x) ) -- colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) -- colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- (views (resultParticipant . _entityKey) return) -- (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique -> -- over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> -- mopt textareaField (fsUniq mkUnique "note-tutorial") (Just $ Textarea <$> note) -- ) colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParticipantNoteField = sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","min-width:12em")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^. resultParticipant . _entityVal . _tutorialParticipantNote sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey in over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> mopt (textField & cfStrip & addDatalist (suggsParticipantNote sid cid tid)) (fsUniq mkUnique "note-tutorial") (Just note) ) suggsParticipantNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsParticipantNote sid cid tid = do ol <- memcachedBy (Just . Right $ 2 * diffHour) (CacheKeySuggsParticipantNote sid tid) $ do suggs <- runDB $ E.select $ do let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows (tpn, prio) <- E.from $ ( do tpa <- E.from $ E.table @TutorialParticipant E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.==. E.val tid E.groupBy $ tpa E.^. TutorialParticipantNote E.orderBy [E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val (1 :: Int64)) ) `E.unionAll_` ( do (tpa :& tut) <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.==. E.val cid E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val 2) ) `E.unionAll_` ( do tpa :& tut :& crs <- E.from $ E.table @TutorialParticipant `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantTutorial) `E.innerJoin` E.table @Course `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) E.where_ $ E.isJust (tpa E.^. TutorialParticipantNote) E.&&. tpa E.^. TutorialParticipantTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.!=. E.val cid E.&&. crs E.^. CourseSchool E.==. E.val sid E.groupBy (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantNote) E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantNote, E.val 3) ) E.groupBy (tpn, prio) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type -- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol pure $ mkOptionListFromCacheable ol suggsAttendanceNote :: SchoolId -> CourseId -> TutorialId -> Handler (OptionList Text) suggsAttendanceNote sid cid 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 $ ( do tpa <- E.from $ E.table @TutorialParticipantDay E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) E.&&. tpa E.^. TutorialParticipantDayTutorial E.==. E.val tid E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay) E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantDayNote, E.val (1 :: Int64)) ) `E.unionAll_` ( do (tpa :& tut) <- E.from $ E.table @TutorialParticipantDay `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.==. E.val cid E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged) E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantDayNote, E.val 2) ) `E.unionAll_` ( do tpa :& tut :& crs <- E.from $ E.table @TutorialParticipantDay `E.innerJoin` E.table @Tutorial `E.on` (\(tpa :& tut) -> tut E.^. TutorialId E.==. tpa E.^. TutorialParticipantDayTutorial) `E.innerJoin` E.table @Course `E.on` (\(_ :& tut :& crs) -> tut E.^. TutorialCourse E.==. crs E.^. CourseId) E.where_ $ E.isJust (tpa E.^. TutorialParticipantDayNote) E.&&. tpa E.^. TutorialParticipantDayTutorial E.!=. E.val tid E.&&. tut E.^. TutorialCourse E.!=. E.val cid E.&&. crs E.^. CourseSchool E.==. E.val sid E.groupBy (tpa E.^. TutorialParticipantDayNote, tpa E.^. TutorialParticipantDayDay, tut E.^. TutorialLastChanged) E.orderBy [E.desc $ tpa E.^. TutorialParticipantDayDay, E.desc $ tut E.^. TutorialLastChanged, E.desc countRows'] E.limit maxSuggestions pure (tpa E.^. TutorialParticipantDayNote, E.val 3) ) E.groupBy (tpn, prio) E.orderBy [E.asc prio, E.asc tpn] E.limit maxSuggestions pure $ E.coalesceDefault [tpn] $ E.val "" -- default never used due to where_ condtions, but conveniently changes type pure $ mkOptionListCacheable $ mkOptionText <$> nubOrd suggs -- NOTE: datalist does not work on textarea inputs pure $ mkOptionListFromCacheable ol colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id (views (resultParticipant . _entityKey) return) (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique -> over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance ) colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colAttendanceNoteField dday = sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","min-width:12em")]) <$> formCell id (views (resultParticipant . _entityKey) return) (\row mkUnique -> let note = row ^? resultParticipantDay . _tutorialParticipantDayNote sid = row ^. resultCourse . _entityVal . _courseSchool cid = row ^. resultCourse . _entityKey tid = row ^. resultTutorial . _entityKey in over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap Text.strip) . over _2 fvWidget <$> -- For Textarea use: fmap (Text.strip . unTextarea) mopt (textField & cfStrip & addDatalist (suggsAttendanceNote sid cid tid)) (fsUniq mkUnique "note-attendance") note ---- Version für Textare -- mopt (textareaField) -- & addDatalist (suggsAttendanceNote sid cid tid)) -- NOTE: datalist does not work on textarea inputs -- (fsUniq mkUnique "note-attendance" & addClass' "uwx-short" -- -- & addAttr "rows" "2" -- does not work without class uwx-short -- -- & addAttr "cols" "12" -- let it stretch -- -- & addAutosubmit -- submits while typing -- ) (Textarea <<$>> note) ) colParkingField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData))) colParkingField = colParkingField' _dailyFormParkingToken -- colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) -- colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- (views (resultParticipant . _entityKey) return) -- (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> -- over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking -- ) colParkingField' :: ASetter' a Bool -> Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData))) colParkingField' l dday = sortable (Just "parking") (i18nCell $ MsgTableUserParkingToken dday) $ (cellAttrs %~ addAttrsClass "text--center") <$> formCell id -- TODO: this should not be id! Refactor to simplify the thrid argument below (views (resultParticipant . _entityKey) return) (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking ) 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 dday <- formatTime SelFormatDate nd let tutIds = Map.keys tutLessons dbtSQLQuery :: DailyTableExpr -> DailyTableOutput dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs `E.LeftOuterJoin` udy `E.LeftOuterJoin` tdy) = do EL.on $ tut E.^. TutorialId E.=?. tdy E.?. TutorialParticipantDayTutorial E.&&. usr E.^. UserId E.=?. tdy E.?. TutorialParticipantDayUser E.&&. E.val nd E.=?. tdy E.?. TutorialParticipantDayDay EL.on $ usr E.^. UserId E.=?. udy E.?. UserDayUser E.&&. E.val nd E.=?. udy E.?. UserDayDay EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId E.where_ $ tut E.^. TutorialId `E.in_` E.valList tutIds let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey)) sortable (Just "course") (i18nCell MsgTableCourse) $ \(view $ resultCourse . _entityVal -> c) -> courseCell c , sortable (Just "tutorial") (i18nCell MsgCourseTutorial) $ \row -> let Course{courseTerm=tid, courseSchool=cssh, courseShorthand=csh} = row ^. resultCourse . _entityVal tutName = row ^. resultTutorial . _entityVal . _tutorialName in anchorCell (CTutorialR tid cssh csh tutName TUsersR) $ citext2widget tutName , sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ \(view $ resultTutorial . _entityKey -> tutId) -> cellMaybe (lessonTimesCell False . snd) $ Map.lookup tutId tutLessons , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> tutId) -> -- listInlineCell (nubOrd . concat $ mapMM lessonRoom $ Map.lookup tutId tutLessons) roomReferenceCell cellMaybe ((`listInlineCell` roomReferenceCell) . nubOrd) $ mapMM lessonRoom $ snd <$> Map.lookup tutId tutLessons -- , sortable Nothing (i18nCell MsgTableTutorialRoom) $ \(view $ resultTutorial . _entityKey -> _) -> listCell ["A","D","C","B"] textCell -- DEMO: listCell reverses the order, for list-types! listInlineCell is fixed now , sortable Nothing (i18nCell $ MsgCourseQualifications 3) $ \(preview resultCourseQualis -> cqs) -> maybeCell cqs $ flip listInlineCell qualificationIdShortCell -- , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> cellMaybe companyIdCell mcid -- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row -> let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany primComp = row ^? resultCompanyId bookLink = cellMaybe companyIdCell bookComp result | primComp /= bookComp , Just (unCompanyKey -> csh) <- primComp = cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True) <> spacerCell <> bookLink | otherwise = bookLink in result -- , sortable (Just "booking-firm") (i18nCell MsgTableBookingCompany) $ \row -> -- let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany -- primComp = row ^? resultCompanyId -- bookLink = cellMaybe companyIdCell bookComp -- warnIcon = \csh -> iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|] (Just IconCompanyWarning) True -- result -- | primComp /= bookComp -- , Just (unCompanyKey -> csh) <- primComp -- = bookLink -- <> spacerCell -- <> cell (modal (warnIcon csh) (Right -- maybe just use iconCompanyWarning instead of modal? -- [whamlet| --

-- ^{userWidget row} --

-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)} -- |] -- )) -- | 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 , colParticipantPermitField , colParticipantEyeExamField , colParticipantNoteField , colAttendanceField dday , colAttendanceNoteField dday , colParkingField dday -- FOR DEBUGGING ONLY: -- , sortable (Just "permit") (i18nCell MsgTutorialDrivingPermit) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantDrivingPermit -> x) -> x & cellMaybe i18nCell -- , sortable (Just "eye-exam") (i18nCell MsgTutorialEyeExam) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantEyeExam -> x) -> x & cellMaybe i18nCell -- , sortable (Just "note-tutorial") (i18nCell MsgTutorialNote) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantNote -> x) -> x & cellMaybe textCell -- , sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance -> x) -> x & cellMaybe tickmarkCell -- , sortable (Just "note-attend") (i18nCell $ MsgTutorialDayNote dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just -> x) -> x & cellMaybe textCell -- , sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell ] dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserMatriclenr queryUser , ("course" , SortColumn $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) , ("booking-firm" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) , ("permit" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantDrivingPermit)) , ("eye-exam" , SortColumnNullsInv $ queryParticipant >>> (E.^. TutorialParticipantEyeExam)) , ("note-tutorial" , SortColumn $ queryParticipant >>> (E.^. TutorialParticipantNote)) , ("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 , fltrUserMatriclenr queryUser , ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName)) , ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName)) , ("booking-firm" , FilterColumn . E.mkContainsFilterWith Just $ queryParticipant >>> (E.^. TutorialParticipantCompany)) , ("user-company" , FilterColumn . E.mkContainsFilterWith Just $ queryUser >>> selectCompanyUserPrime) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgFilterCourse) , prismAForm (singletonFilter "tutorial" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCourseTutorial) , prismAForm (singletonFilter "booking-firm" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableBookingCompanyShort) , prismAForm (singletonFilter "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompanyShort) , fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text dbtIdent = "daily" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd } -- dbtParams = DBParamsForm -- { dbParamsFormMethod = POST -- , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute -- , dbParamsFormAttrs = [] -- , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = \frag -> do -- let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) -- acts = mconcat -- [ singletonMap DailyActDummy $ pure DailyActDummyData -- ] -- (actionRes, action) <- multiActionM acts "" Nothing mempty -- return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) -- -- , dbParamsFormAdditional -- -- = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData) -- -- acts = mconcat -- -- [ singletonMap DailyActDummy $ pure DailyActDummyData -- -- ] -- -- in renderAForm FormStandard -- -- $ (, mempty) . First . Just -- -- <$> multiActionA acts (fslI MsgTableAction) Nothing -- , dbParamsFormEvaluate = liftHandler . runFormPost -- , dbParamsFormResult = _1 -- , dbParamsFormIdent = def -- } -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData) -- -> FormResult ( DailyTableActionData, Set TutorialId) -- postprocess inp = do -- (First (Just act), jobMap) <- inp -- let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap -- return (act, jobSet) psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"] -- over _1 postprocess <$> dbTable psValidator DBTable{..} over _2 Just <$> dbTable psValidator DBTable{..} getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html getSchoolDayR = postSchoolDayR postSchoolDayR ssh nd = do isAdmin <- hasReadAccessTo AdminR dday <- formatTime SelFormatDate nd let unFormResult = getDBFormResult $ \row -> let tpt = row ^. resultParticipant . _entityVal in DailyFormData { dailyFormDrivingPermit = tpt ^. _tutorialParticipantDrivingPermit , dailyFormEyeExam = tpt ^. _tutorialParticipantEyeExam , dailyFormParticipantNote = tpt ^. _tutorialParticipantNote , dailyFormAttendance = row ^? resultParticipantDay ._tutorialParticipantDayAttendance & fromMaybe False , dailyFormAttendanceNote = row ^? resultParticipantDay ._tutorialParticipantDayNote . _Just , dailyFormParkingToken = row ^? resultUserDay . _userDayParkingToken & fromMaybe False } 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 -- logDebugS "TableForm" (tshow dfd) TutorialParticipant{..} <- get404 tpid -- needed anyway to find the ParticipantDay/UserDay updated when ( tutorialParticipantDrivingPermit /= dailyFormDrivingPermit || tutorialParticipantEyeExam /= dailyFormEyeExam || tutorialParticipantNote /= dailyFormParticipantNote) $ update tpid [ TutorialParticipantDrivingPermit =. dailyFormDrivingPermit , TutorialParticipantEyeExam =. dailyFormEyeExam , TutorialParticipantNote =. dailyFormParticipantNote ] let tpdUq = UniqueTutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd if not dailyFormAttendance && isNothing (canonical dailyFormAttendanceNote) then deleteBy tpdUq else upsertBy_ tpdUq (TutorialParticipantDay tutorialParticipantTutorial tutorialParticipantUser nd dailyFormAttendance dailyFormAttendanceNote) [ TutorialParticipantDayAttendance =. dailyFormAttendance , TutorialParticipantDayNote =. dailyFormAttendanceNote ] let udUq = UniqueUserDay tutorialParticipantUser nd updateUserDay = if dailyFormParkingToken then flip upsertBy_ (UserDay tutorialParticipantUser nd dailyFormParkingToken) -- upsert if a permit was issued else updateBy -- only update to no permit, if the record exists, but do not create a fresh record with parkingToken==False updateUserDay udUq [ UserDayParkingToken =. dailyFormParkingToken] return tutorialParticipantTutorial forM_ tuts $ \tid -> do memcachedByInvalidate (CacheKeySuggsParticipantNote ssh tid) $ Proxy @(OptionListCacheable Text) memcachedByInvalidate (CacheKeySuggsAttendanceNote ssh tid) $ Proxy @(OptionListCacheable Text) -- audit log? Currently decided against. addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do let consistencyBtn = btnModal MsgMenuSchoolDayCheck [BCIsButton, BCDefault] (Left $ SomeRoute $ SchoolR ssh $ SchoolDayCheckR nd) 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) data DayCheckResults = DayCheckResults { dcrTimestamp :: UTCTime , dcrResults :: Map TutorialParticipantId DayCheckResult } deriving (Show, Generic, Binary) type ParticipantCheckData = (Entity TutorialParticipant, UserDisplayName, UserSurname, Maybe AvsPersonId, Maybe CompanyName) dayCheckParticipant :: Map AvsPersonId AvsDataPerson -> ParticipantCheckData -> DayCheckResult dayCheckParticipant avsStats (Entity {entityVal=TutorialParticipant{..}}, udn, usn, mapi, 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 dcrIsOk :: DayCheckResult -> Bool dcrIsOk (DayCheckResult (Just True) True True True) = True dcrIsOk _ = False -- TODO: i18n and use icons to show all results at once -- TODO: using memcache, display icons in column in daily view, if cache is filled dcr2widget :: Maybe CompanyName -> DayCheckResult -> Widget dcr2widget _ DayCheckResult{dcAvsKnown=False} = text2widget "AVS Abfrage fehlgeschlagen" dcr2widget _ DayCheckResult{dcApronAccess=False} = text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden" dcr2widget mcn DayCheckResult{dcBookingFirmOk=False} = [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] dcr2widget _ DayCheckResult{dcEyeFitsPermit=Nothing} = text2widget "Sehtest oder Führerschein fehlen noch" 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] where mkTooltip ico msg = iconTooltip msg (Just ico) True avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (text2widget "AVS Abfrage fehlgeschlagen") apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (text2widget "Kein gültiger Ausweis mit Vorfeld-Zugang gefunden") bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning [whamlet|Für buchende Firma #{maybeMonoid mcn} liegt kein gültiger Ausweis vor|] permitChk | isNothing dcEyeFitsPermit = mkTooltip IconGlasses (text2widget "Sehtest oder Führerschein fehlen noch") | dcEyeFitsPermit == Just False = mkTooltip IconFileMissing (text2widget "Sehtest und Führerschein passen nicht zusammen") | otherwise = mempty -- | 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 now <- liftIO getCurrentTime let nowaday = utctDay now dday <- formatTime SelFormatDate nd (tuts, parts_avs) <- runDB $ do tuts <- getDayTutorials ssh (nd,nd) parts_avs :: [ParticipantCheckData] <- $(unValueNIs 5 [2..5]) <<$>> 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 (Map.keys 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 . view _4 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 participantResults = foldMap toPartMap parts_avs memcachedBySet (Just . Right $ 2 * diffHour) (CacheKeyTutorialCheckResults ssh nd) $ DayCheckResults now participantResults -- 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 ok = maybe False dcrIsOk $ Map.lookup pid participantResults 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 mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget mkBaddieWgt pid pcd = let name = nameWidget (pcd ^. _2) (pcd ^. _3) bookFirm = pcd ^. _5 problems = maybe (text2widget "???") (dcr2widget bookFirm) (Map.lookup pid participantResults) problems' = maybe mempty (dcr2widget' bookFirm) (Map.lookup pid participantResults) -- TODO: decide which version to use in [whamlet|^{name}: ^{problems'} ^{problems}|] siteLayoutMsg MsgMenuSchoolDayCheck $ do setTitleI MsgMenuSchoolDayCheck -- TODO: i18n [whamlet|

_{MsgMenuSchoolDay ssh dday}

$if Map.null badTutPartMap Es wurden keine Probleme gefunden. $else

$forall (tid,badis) <- Map.toList badTutPartMap
#{maybe "???" fst (Map.lookup tid tuts)}
    $forall ((udn,pid),pcd) <- Map.toList badis
  • ^{mkBaddieWgt pid pcd}

    ^{linkButton mempty (text2widget "Schliessen") [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} |]