Steffen Jost
92a43ac131
the function uses the memcachedByClass mechanism, which was slightly refined as well to include the class within the memcached keys for added correctness
875 lines
52 KiB
Haskell
875 lines
52 KiB
Haskell
|
|
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- 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) -- ^ Map TutorialId (TutorialName, [LessonTime])
|
|
| CacheKeyExamOccurrences SchoolId (Day,Day) -- ^ Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
|
|
| 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
|
|
|
|
-- | retrieve all exam occurrences for a school in a given time period; uses caching
|
|
getDayExamOccurrences :: SchoolId -> (Day,Day) -> DB (Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence))
|
|
getDayExamOccurrences ssh dlimit@(dstart, dend )
|
|
| dstart > dend = return mempty
|
|
| otherwise = memcachedByClass MemcachedKeyClassExamOccurrences (Just . Right $ 12 * diffDay) (CacheKeyExamOccurrences ssh dlimit) $ do
|
|
candidates <- E.select $ do
|
|
(trm :& crs :& exm :& occ) <- 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 @Exam `E.on` (\(_ :& crs :& exm) -> crs E.^. CourseId E.==. exm E.^. ExamCourse)
|
|
`E.innerJoin` E.table @ExamOccurrence `E.on` (\(_ :& _ :& exm :& occ) -> exm E.^. ExamId E.==. occ E.^. ExamOccurrenceExam)
|
|
E.where_ $ E.val ssh E.==. crs E.^. CourseSchool
|
|
E.&&. E.val dstart E.<=. trm E.^. TermEnd
|
|
E.&&. E.val dend E.>=. trm E.^. TermStart
|
|
E.&&. ( E.between (E.day $ occ E.^. ExamOccurrenceStart) (E.val dstart, E.val dend)
|
|
E.||. E.between (E.dayMaybe $ occ E.^. ExamOccurrenceEnd) (E.justVal dstart, E.justVal dend)
|
|
)
|
|
return (exm, occ)
|
|
return $ foldMap mkOccMap candidates
|
|
where
|
|
mkOccMap :: (Entity Exam, Entity ExamOccurrence) -> Map ExamOccurrenceId (CourseId, ExamName, ExamOccurrence)
|
|
mkOccMap (entityVal -> exm, Entity{..}) = Map.singleton entityKey (exm ^. _examCourse, exm ^. _examName, entityVal)
|
|
|
|
|
|
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 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|
|
|
-- <h2>
|
|
-- ^{userWidget row}
|
|
-- <p>
|
|
-- _{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
|
|
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 (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|
|
|
<h2>
|
|
_{MsgMenuSchoolDay ssh dday}
|
|
<p>
|
|
$if Map.null badTutPartMap
|
|
_{MsgNoProblem}.
|
|
$else
|
|
<dl .deflist.profile-dl>
|
|
$forall (tid,badis) <- Map.toList badTutPartMap
|
|
<dt .deflist__dt>
|
|
#{maybe "???" fst (Map.lookup tid tuts)}
|
|
<dd .deflist__dd>
|
|
<ul>
|
|
$forall ((_udn,pid),pcd) <- Map.toList badis
|
|
<li>
|
|
^{mkBaddieWgt pid pcd}
|
|
<p>
|
|
^{linkButton mempty (i18n MsgBtnCloseReload) [BCIsButton, BCPrimary] (SomeRoute (SchoolR ssh (SchoolDayR nd)))}
|
|
|] |