fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
59b945ce4c
fradrive/src/Handler/School/DayTasks.hs

660 lines
39 KiB
Haskell
Raw Blame History

-- 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 #-} -- TODO during development only
{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TODO during development only
module Handler.School.DayTasks
( getSchoolDayR, postSchoolDayR
) where
import Import
import Handler.Utils
import Handler.Utils.Company
import Handler.Utils.Occurrences
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 for memcaching occurrences
data OccurrenceCacheKey = OccurrenceCacheKeyTutorials SchoolId (Day,Day)
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Hashable, Binary)
getDayTutorials :: SchoolId -> (Day,Day) -> DB [TutorialId]
getDayTutorials ssh dlimit@(dstart, dend )
| dstart > dend = return mempty
| otherwise = memcachedByClass MemcachedKeyClassTutorialOccurrences (Just . Right $ 12 * diffDay) (OccurrenceCacheKeyTutorials 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) -- TODO reify seems problematic for now
-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
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 <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
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 Textarea)
suggsAttendanceNote sid cid tid = do
ol <- $(memcachedByHere) (Just . Right $ 12 * diffSecond) (sid,cid,tid) $ do -- memcached key good enough?
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 (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
-- E.orderBy [E.desc $ tut E.^. TutorialLastChanged, E.desc $ tpa E.^. TutorialParticipantDayDay, 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 (tut E.^. TutorialLastChanged, tpa E.^. TutorialParticipantDayNote)
-- E.orderBy [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
-- $logInfoS "NOTE-SUGGS *** A: " $ tshow suggs
pure $ mkOptionListCacheable $ fmap Textarea . mkOptionText <$> nubOrd suggs -- TODO: datalist does not work on textarea inputs!
-- $logInfoS "NOTE-SUGGS *** B: " $ tshow ol
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 . unTextarea)) . over _2 fvWidget <$>
mopt (textareaField & addDatalist (suggsAttendanceNote sid cid tid)) -- TODO: 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 :: 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 -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ (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 -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget)
mkDailyTable isAdmin ssh nd = getDayTutorials' ssh (nd,nd) >>= \case
tutLessons
| Map.null tutLessons -> return (FormMissing, [whamlet|No tutorials on this day|])
| 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 MsgFilterCourse) $ \(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-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid
, sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \row ->
let bookComp = row ^. resultParticipant . _entityVal . _tutorialParticipantCompany
primComp = row ^? resultCompanyId
bookLink = cellMaybe companyIdCell bookComp
result
| primComp /= bookComp
, Just (unCompanyKey -> csh) <- primComp
= bookLink
<> spacerCell
<> cell (iconTooltip [whamlet|_{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}|]
(Just IconCompanyWarning) True)
| otherwise = bookLink
in result
-- , sortable (Just "booking-company") (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 -- TODO: use iconCompanyWarning instead!
-- [whamlet|
-- <h2>
-- ^{userWidget row}
-- <p>
-- _{MsgAvsPrimaryCompany}: ^{companyWidget True (csh, csh, False)}
-- |]
-- ))
-- | otherwise = bookLink
-- in result
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
, colUserMatriclenr isAdmin
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
, colParticipantPermitField
, colParticipantEyeExamField
, colParticipantNoteField
, colAttendanceField dday
, colAttendanceNoteField dday
, colParkingField
-- 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-company", 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))
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, fltrUserMatriclenr queryUser
, ("course" , FilterColumn . E.mkContainsFilter $ queryCourse >>> (E.^. CourseName))
, ("tutorial" , FilterColumn . E.mkContainsFilter $ queryTutorial >>> (E.^. TutorialName))
, ("user-company" , FilterColumn . E.mkContainsFilter $ 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 "user-company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTablePrimeCompany)
, 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{..}
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
}
(fmap unFormResult -> tableRes,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
$logInfoS "****DailyTable****" $ tshow tableRes
formResult tableRes $ \resMap -> do
runDB $ do
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]
-- audit log? Currently decided against.
addMessageI Success $ MsgTutorialParticipantsDayEdits dday
redirect $ SchoolR ssh $ SchoolDayR nd
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
setTitleI (MsgMenuSchoolDay ssh dday)
[whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
^{tableDaily}
|]
Reference in New Issue View Git Blame Copy Permalink