236 lines
11 KiB
Haskell
236 lines
11 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.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
import Database.Esqueleto.PostgreSQL.JSON as E
|
|
|
|
|
|
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 "@>"
|
|
occurrenceDayValue :: Day -> Value
|
|
occurrenceDayValue d = Aeson.object
|
|
[ "exceptions" Aeson..=
|
|
[ Aeson.object
|
|
[ "exception" Aeson..= ("occur"::Text)
|
|
, "day" Aeson..= d
|
|
] ] ]
|
|
-- TODO: ensure that an appropriate GIN index for the jsonb column is set
|
|
|
|
{- 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 $ 9 * diffDay) (OccurrenceCacheKeyTutorials ssh dlimit) $
|
|
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]
|
|
|
|
-- TODO: checkCandidate (_, Entity{entityKey=tutId}, E.unValue -> True) = Just tutId -- 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
|
|
|
|
type DailyTableExpr =
|
|
( E.SqlExpr (Entity Course)
|
|
`E.InnerJoin` E.SqlExpr (Entity Tutorial)
|
|
`E.InnerJoin` E.SqlExpr (Entity TutorialParticipant)
|
|
`E.InnerJoin` E.SqlExpr (Entity User)
|
|
)
|
|
type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)))
|
|
type DailyTableData = DBRow (Entity Course, Entity Tutorial, Entity TutorialParticipant, Entity User, E.Value (Maybe CompanyId))
|
|
|
|
queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
|
|
queryCourse = $(sqlIJproj 4 1)
|
|
|
|
queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
|
|
queryTutorial = $(sqlIJproj 4 2)
|
|
|
|
queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
|
|
queryParticipant = $(sqlIJproj 4 3)
|
|
|
|
queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 4 4)
|
|
|
|
resultCourse :: Lens' DailyTableData (Entity Course)
|
|
resultCourse = _dbrOutput . _1
|
|
|
|
resultTutorial :: Lens' DailyTableData (Entity Tutorial)
|
|
resultTutorial = _dbrOutput . _2
|
|
|
|
resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant)
|
|
resultParticipant = _dbrOutput . _3
|
|
|
|
-- resultCompanyId :: Traversal' DailyTableData CompanyId
|
|
-- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just
|
|
|
|
resultUser :: Lens' DailyTableData (Entity User)
|
|
resultUser = _dbrOutput . _4
|
|
|
|
resultCompanyId :: Traversal' DailyTableData CompanyId
|
|
resultCompanyId = _dbrOutput . _5 . _unValue . _Just
|
|
|
|
instance HasEntity DailyTableData User where
|
|
hasEntity = resultUser
|
|
|
|
instance HasUser DailyTableData where
|
|
hasUser = resultUser . _entityVal
|
|
|
|
mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
|
|
mkDailyTable isAdmin ssh nd = do
|
|
tuts <- getDayTutorials ssh (nd,nd)
|
|
let
|
|
dbtSQLQuery :: DailyTableExpr -> DailyTableOutput
|
|
dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do
|
|
EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId
|
|
EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial
|
|
EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser
|
|
E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts
|
|
return (crs, tut, tpu, usr, selectCompanyUserPrime usr)
|
|
dbtRowKey = queryTutorial >>> (E.^. TutorialId)
|
|
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 (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
|
|
]
|
|
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))
|
|
]
|
|
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}
|
|
|]
|