70 lines
3.7 KiB
Haskell
70 lines
3.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Tutorial
|
|
( fetchTutorialAux
|
|
, fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
|
|
, showTutorialRoom
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
fetchTutorialAux :: ( SqlBackendCanRead backend
|
|
, E.SqlSelect b a
|
|
, MonadHandler m
|
|
, Typeable a
|
|
)
|
|
=> (E.SqlExpr (Entity Tutorial) -> E.SqlExpr (Entity Course) -> b)
|
|
-> TermId -> SchoolId -> CourseShorthand -> TutorialName -> ReaderT backend m a
|
|
fetchTutorialAux prj tid ssh csh tutn =
|
|
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, tutn)
|
|
in cachedBy cachId $ do
|
|
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
|
|
E.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. tut E.^. TutorialName E.==. E.val tutn
|
|
return $ prj tut course
|
|
case tutList of
|
|
[tut] -> return tut
|
|
_other -> notFound
|
|
|
|
fetchTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> DB (Entity Tutorial)
|
|
fetchTutorial = fetchTutorialAux const
|
|
|
|
fetchTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Tutorial)
|
|
fetchTutorialId tid ssh cid tutn = E.unValue <$> fetchTutorialAux (\tutorial _ -> tutorial E.^. TutorialId) tid ssh cid tutn
|
|
|
|
fetchCourseIdTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Key Tutorial)
|
|
fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. TutorialId)) tid ssh cid tutn
|
|
|
|
fetchCourseIdTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Entity Tutorial)
|
|
fetchCourseIdTutorial tid ssh cid tutn = over _1 E.unValue <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid tutn
|
|
|
|
showTutorialRoom :: forall tutorial tutorialId courseId.
|
|
( E.SqlProject Tutorial TutorialId tutorial tutorialId
|
|
, E.SqlProject Tutorial CourseId tutorial courseId
|
|
)
|
|
=> E.SqlExpr (E.Value UserId) -> E.SqlExpr tutorial -> E.SqlExpr (E.Value Bool)
|
|
showTutorialRoom uid tutorial = E.or
|
|
[ E.exists . E.from $ \tutor ->
|
|
E.where_ $ tutor E.^. TutorUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutor E.^. TutorTutorial) E.==. tutorial `E.sqlProject` TutorialId
|
|
, E.exists . E.from $ \(lecturer `E.InnerJoin` course) -> do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (course E.^. CourseId) E.==. tutorial `E.sqlProject` TutorialCourse
|
|
, E.exists . E.from $ \tutorialParticipant ->
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutorialParticipant E.^. TutorialParticipantTutorial) E.==. tutorial `E.sqlProject` TutorialId
|
|
]
|