404 lines
23 KiB
Haskell
404 lines
23 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 #-} -- 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
|
|
|
|
|
|
|
|
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])
|
|
)
|
|
|
|
-- 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' Nothing optionsFinite
|
|
|
|
-- eyeExamField :: Field (HandlerFor UniWorX) UserEyeExam
|
|
-- eyeExamField = selectField optionsFinite
|
|
|
|
-- This does not type:
|
|
-- colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
-- colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ 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") $ Just x
|
|
-- ) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
-- colEyeExamField :: TODO
|
|
|
|
colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> 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 . _tutorialParticipantNote) -> note) mkUnique ->
|
|
over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
|
|
mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note)
|
|
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ 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
|
|
(\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
|
|
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
|
|
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> 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
|
|
(\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
|
|
over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
|
|
mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note)
|
|
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
|
|
colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ 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
|
|
(\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
|
|
over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
|
|
) -- Given the row data and a callback to make an input name suitably unique generate the MForm
|
|
|
|
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
|
|
mkDailyTable isAdmin ssh nd = do
|
|
tutLessons <- getDayTutorials' ssh (nd,nd)
|
|
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 = 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
|
|
, colUserNameModalHdr MsgCourseParticipant ForProfileDataR
|
|
, colUserMatriclenr isAdmin
|
|
, sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn
|
|
, 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
|
|
-- , colParkingField id
|
|
]
|
|
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 = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormNoSubmit
|
|
, dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
|
|
-- , dbParamsFormSubmit = FormSubmit
|
|
-- , dbParamsFormAdditional
|
|
-- = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
|
|
-- acts = mconcat
|
|
-- [ singletonMap MCActDummy $ pure MCActDummyData
|
|
-- ]
|
|
-- in renderAForm FormStandard
|
|
-- $ (, mempty) . First . Just
|
|
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId 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{..}
|
|
|
|
|
|
getSchoolDayR, postSchoolDayR :: SchoolId -> Day -> Handler Html
|
|
getSchoolDayR = postSchoolDayR
|
|
postSchoolDayR ssh nd = do
|
|
isAdmin <- hasReadAccessTo AdminR
|
|
dday <- formatTime SelFormatDate nd
|
|
(_,tableDaily) <- runDB $ mkDailyTable isAdmin ssh nd
|
|
siteLayoutMsg (MsgMenuSchoolDay ssh dday) $ do
|
|
setTitleI (MsgMenuSchoolDay ssh dday)
|
|
[whamlet|TODO Overview School #{ciOriginal (unSchoolKey ssh)}
|
|
^{tableDaily}
|
|
|]
|