fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
28837c41ab
fradrive/src/Handler/Course/List.hs

253 lines
12 KiB
Haskell
Raw Blame History

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Handler.Course.List
( makeCourseTable
, getCourseListR
, getTermCurrentR
, getTermSchoolCourseListR
, getTermCourseListR
) where
import Import
import Data.Maybe (fromJust)
import Utils.Course
import Utils.Form
import Handler.Utils hiding (colSchoolShort)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
type CourseTableData = DBRow
( Entity Course
, Bool -- isRegistered
, Entity School
, [Entity User]
, Bool -- mayEditCourse
)
resultCourse :: Lens' CourseTableData (Entity Course)
resultCourse = _dbrOutput . _1
resultSchool :: Lens' CourseTableData (Entity School)
resultSchool = _dbrOutput . _3
resultIsRegistered :: Lens' CourseTableData Bool
resultIsRegistered = _dbrOutput . _2
resultLecturers :: Traversal' CourseTableData (Entity User)
resultLecturers = _dbrOutput . _4 . traverse
resultMayEditCourse :: Lens' CourseTableData Bool
resultMayEditCourse = _dbrOutput . _5
type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School))
queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course))
queryCourse = to $(E.sqlIJproj 2 1)
querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School))
querySchool = to $(E.sqlIJproj 2 2)
queryParticipants :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Int))
queryParticipants = queryCourse . to (E.^. CourseId) . to numCourseParticipants
queryIsRegistered :: Maybe UserId
-> AuthTagActive
-> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsRegistered muid ata = queryCourse . to (E.^. CourseId) . to (isCourseParticipant muid ata)
queryMayViewCourse :: Maybe UserId
-> AuthTagActive
-> UTCTime -- ^ @now@
-> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryMayViewCourse muid ata now = to . runReader $ do
course <- view queryCourse
return $ mayViewCourse muid ata now course
queryIsEditor :: Maybe UserId
-> AuthTagActive
-> IndexPreservingGetter CourseTableExpr (E.SqlExpr (E.Value Bool))
queryIsEditor muid ata = queryCourse . to (mayEditCourse muid ata)
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgFilterCourse)
$ \(view resultCourse -> Entity _ Course{..}) ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|_{courseName}|]
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
$ \(view resultCourse -> Entity _ Course{..}) -> maybeCell courseDescription modalCell
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort)
$ \(view resultCourse -> Entity _ Course{..}) ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgFilterTerm)
$ \(view resultCourse -> Entity _ Course{..}) ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort) $ \res
-> let Entity _ Course{..} = res ^. resultCourse
Entity _ School{..} = res ^. resultSchool
in anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered) $ views resultIsRegistered ((spacerCell <>) . tickmarkCell)
makeCourseTable :: (ToSortable h, Functor h)
=> Colonnade h CourseTableData (DBCell Handler ()) -> PSValidator Handler () -> DB Widget
makeCourseTable colChoices psValidator' = do
let psValidator = psValidator'
& forceFilter "may-read" (Any True)
muid <- lift maybeAuthId
now <- liftIO getCurrentTime
ata <- getSessionActiveAuthTags
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
dbtSQLQuery = runReaderT $ do
course <- view queryCourse
school <- view querySchool
lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
registered <- view $ queryIsRegistered muid ata
isEditor <- view $ queryIsEditor muid ata
return (course, registered, school, isEditor)
lecturerQuery cid (user `E.InnerJoin` lecturer) = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse
E.&&. lecturer E.^. LecturerType E.==. E.val CourseLecturer
return user
isCourseAdminQuery cid (user `E.InnerJoin` lecturer) = do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ cid E.==. lecturer E.^. LecturerCourse
return user
dbtProj :: _ CourseTableData
dbtProj = dbtProjSimple $ \(course, E.Value registered, school, E.Value isEditor) -> do
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
return (course, registered, school, lecturerList, isEditor)
dbTableWidget' psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = views queryCourse (E.^. CourseId)
, dbtColonnade = colChoices
, dbtProj
, dbtSorting = mconcat
[ singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseName)
, singletonMap "cshort" . SortColumn $ views queryCourse (E.^. CourseShorthand)
, singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
, singletonMap "school" . SortColumn $ views querySchool (E.^. SchoolName)
, singletonMap "schoolshort" . SortColumn $ views querySchool (E.^. SchoolShorthand)
, singletonMap "register-from" . SortColumn $ views queryCourse (E.^. CourseRegisterFrom)
, singletonMap "register-to" . SortColumn $ views queryCourse (E.^. CourseRegisterTo)
, singletonMap "members" . SortColumn $ view queryParticipants
, singletonMap "registered" . SortColumn . view $ queryIsRegistered muid ata
]
, dbtFilter = mconcat
[ singletonMap "may-read" . FilterColumn $ \t (Any b) -> views (queryMayViewCourse muid ata now) (E.==. E.val b) t
, singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseName)
, singletonMap "cshort" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
, singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
, singletonMap "school" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolName)
, singletonMap "schoolshort" . FilterColumn . E.mkExactFilter $ views querySchool (E.^. SchoolShorthand)
, singletonMap "lecturer" . FilterColumn . E.mkExistsFilter $ \t (c :: Text) -> E.from $ \t' -> do
user <- isCourseAdminQuery (view queryCourse t E.^. CourseId) t'
E.where_ $ user E.^. UserDisplayName `E.hasInfix` E.val c
, singletonMap "openregistration" . FilterColumn . E.mkExactFilterLast . runReader $ do
course <- view queryCourse
let regTo = course E.^. CourseRegisterTo
regFrom = course E.^. CourseRegisterFrom
courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) regTo
return courseOpen
, singletonMap "registered" . FilterColumn . E.mkExactFilterLast . view $ queryIsRegistered muid ata
, singletonMap "search" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.maybe (E.val mempty) (E.castString . esqueletoMarkupOutput) (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
, singletonMap "search-shorthand" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
, singletonMap "search-title" . FilterColumn $ \(view queryCourse -> course) criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
]
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
[ pure $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
, pure $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
, pure $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
, pure $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
, pure $ prismAForm (singletonFilter "search-shorthand") mPrev $ aopt textField (fslI MsgFilterCourseSearchShorthand)
, pure $ prismAForm (singletonFilter "search-title") mPrev $ aopt textField (fslI MsgFilterCourseSearchTitle)
, pure $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen)
, guardOn (is _Just muid)
$ prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered))
]
, dbtStyle = def
{ dbsFilterLayout = defaultDBSFilterLayout
, dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultMayEditCourse
}
, dbtParams = def
, dbtIdent = "courses" :: Text
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
, dbtExtraReps = []
}
getCourseListR :: Handler Html
getCourseListR = do
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourse -- colCourseDescr
, colDescription
, colSchoolShort
, colTerm
, colCShort
, maybe mempty (const colRegistered) muid
]
validator = def
& defaultSorting [SortDescBy "term",SortAscBy "course"]
now <- liftIO getCurrentTime
coursesTable <- runDB $ do
activeTs <- selectList [TermActiveFrom <=. now
, FilterOr [TermActiveTo >. Just now, TermActiveTo ==. Nothing]
, FilterOr [TermActiveFor ==. muid, TermActiveFor ==. Nothing] -- TermActiveFor <-. [Nothing, muid] did not work as intended
] [Desc TermActiveTerm]
let addTermFilter = if null activeTs
then id
else defaultFilter $ singletonMap "term" [toPathPiece termActiveTerm | Entity _ TermActive{termActiveTerm} <- activeTs]
makeCourseTable colonnade (validator & addTermFilter)
defaultLayout $ do
setTitleI MsgCourseListTitle
$(widgetFile "courses")
getTermCurrentR :: Handler Html
getTermCurrentR = maybeT notFound $ do
currentTerm <- MaybeT $ runDB getCurrentTerm
redirect (CourseListR, [("courses-term", toPathPiece currentTerm)])
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = redirect (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])
getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = redirect (CourseListR, [("courses-term", toPathPiece tid)])
Reference in New Issue View Git Blame Copy Permalink