46 lines
2.3 KiB
Haskell
46 lines
2.3 KiB
Haskell
module Handler.Utils.Tutorial
|
|
( fetchTutorialAux
|
|
, fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql 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
|