-- 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 #-} 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 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 -- Datatype to be used for memcaching occurrences data LessonCacheKey = LessonCacheKeyTutorials SchoolId (Day,Day) deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Hashable, Binary) -- | like getDayTutorials, but also returns the lessons occurring within the given time frame getDayTutorials' :: SchoolId -> (Day,Day) -> DB (Map TutorialId [LessonTime]) getDayTutorials' ssh dlimit@(dstart, dend ) | dstart > dend = return mempty | otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (LessonCacheKeyTutorials 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 [LessonTime] checkCandidate (Entity{entityVal=trm}, Entity{entityKey=tutId, entityVal=Tutorial{tutorialTime=JSONB occ}}) | let lessons = Set.filter lessonFltr $ occurringLessons trm occ , notNull lessons = Map.singleton tutId $ 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","width:60%")]) <$> 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","width:10%"), ("style","height:200px")]) <$> 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) $ 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 $ 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 IconCompany) 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 . dcr2widgetIcn Nothing , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn , colParticipantEyeExamField , colParticipantPermitField , 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. memcachedByInvalidate (CacheKeyTutorialCheckResults ssh nd) $ Proxy @DayCheckResults addMessageI Success $ MsgTutorialParticipantsDayEdits dday redirect $ SchoolR ssh $ SchoolDayR nd siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ 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 (Eq, Show, Generic, Binary) data DayCheckResults = DayCheckResults { dcrTimestamp :: UTCTime , dcrResults :: Map TutorialParticipantId DayCheckResult } deriving (Show, Generic, Binary) -- | True iff there is no problem at all dcrIsOk :: DayCheckResult -> Bool dcrIsOk (DayCheckResult (Just True) True True True) = True dcrIsOk _ = False -- | defines categories on DayCheckResult, implying an ordering, with most severe being least 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 instance Ord DayCheckResult where compare = compare `on` dcrSeverity type DayCheckGroups = ( Set TutorialParticipantId -- 1 severity , Set TutorialParticipantId -- 2 , Set TutorialParticipantId -- 3 , Set TutorialParticipantId -- 4 , Set TutorialParticipantId -- 5 ) dcrSeverityGroups :: Map TutorialParticipantId DayCheckResult -> DayCheckGroups dcrSeverityGroups = Map.foldMapWithKey groupBySeverity where groupBySeverity :: TutorialParticipantId -> DayCheckResult -> DayCheckGroups groupBySeverity tpid dcr = let sempty = mempty :: DayCheckGroups 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 -- | Show most important problem as text dcr2widgetTxt :: Maybe CompanyName -> DayCheckResult -> Widget dcr2widgetTxt _ DayCheckResult{dcAvsKnown=False} = i18n MsgAvsPersonSearchEmpty dcr2widgetTxt _ DayCheckResult{dcApronAccess=False} = i18n MsgAvsNoApronCard dcr2widgetTxt mcn DayCheckResult{dcBookingFirmOk=False} = i18n $ MsgAvsNoCompanyCard mcn dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Nothing} = i18n MsgCheckEyePermitMissing dcr2widgetTxt _ DayCheckResult{dcEyeFitsPermit=Just False}= i18n MsgCheckEyePermitIncompatible dcr2widgetTxt _ _ = i18n MsgNoProblem -- | Show all problems as icon with tooltip dcr2widgetIcn :: Maybe CompanyName -> DayCheckResult -> Widget dcr2widgetIcn mcn DayCheckResult{..} = mconcat [avsChk, apronChk, bookChk, permitChk] where mkTooltip ico msg = iconTooltip msg (Just ico) True avsChk = guardMonoid (not dcAvsKnown) $ mkTooltip IconUserUnknown (i18n MsgAvsPersonSearchEmpty) apronChk = guardMonoid (not dcApronAccess) $ mkTooltip IconUserBadge (i18n MsgAvsNoApronCard) bookChk = guardMonoid (not dcBookingFirmOk) $ mkTooltip IconCompanyWarning (i18n $ MsgAvsNoCompanyCard mcn) permitChk | isNothing dcEyeFitsPermit = mkTooltip IconFileMissing (i18n MsgCheckEyePermitMissing) | dcEyeFitsPermit == Just False = mkTooltip IconGlasses (i18n MsgCheckEyePermitIncompatible) | otherwise = mempty 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 -- | 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) -- UserDisplayName as Key ensures proper sort order badTutPartMap = foldl' sortBadParticipant mempty parts_avs mkBaddieWgt :: TutorialParticipantId -> ParticipantCheckData -> Widget mkBaddieWgt pid pcd = let name = nameWidget (pcd ^. _2) (pcd ^. _3) bookFirm = pcd ^. _5 problemText = maybe (text2widget "???") (dcr2widgetTxt bookFirm) (Map.lookup pid participantResults) problemIcons = maybe mempty (dcr2widgetIcn bookFirm) (Map.lookup pid participantResults) in [whamlet|^{name}: ^{problemIcons} ^{problemText}|] siteLayoutMsg MsgMenuSchoolDayCheck $ do setTitleI MsgMenuSchoolDayCheck [whamlet|

_{MsgMenuSchoolDay ssh dday}

$if Map.null badTutPartMap _{MsgNoProblem}. $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 (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))} |]