236 lines
14 KiB
Haskell
236 lines
14 KiB
Haskell
module Handler.Course.List
|
|
( makeCourseTable
|
|
, getCourseListR
|
|
, getTermCurrentR
|
|
, getTermSchoolCourseListR
|
|
, getTermCourseListR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import Utils.Course
|
|
import Utils.Form
|
|
-- import Utils.DB
|
|
import Handler.Utils hiding (colSchoolShort)
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
|
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User], Maybe (Entity Allocation), Bool)
|
|
|
|
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colCourse = sortable (Just "course") (i18nCell MsgFilterCourse)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } ->
|
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
|
[whamlet|_{courseName}|]
|
|
|
|
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colDescription = sortable Nothing mempty
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } ->
|
|
case courseDescription of
|
|
Nothing -> mempty
|
|
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
|
|
|
|
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colCShort = sortable (Just "cshort") (i18nCell MsgFilterCourseShort)
|
|
$ \DBRow{ dbrOutput=(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)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _, _, _) } ->
|
|
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
|
|
|
|
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgFilterCourseSchoolShort)
|
|
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _, _, _) } ->
|
|
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
|
|
|
|
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
|
colRegistered = sortable (Just "registered") (i18nCell MsgFilterRegistered)
|
|
$ \DBRow{ dbrOutput=(_, _, registered, _, _, _, _) } -> tickmarkCell registered
|
|
|
|
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
|
|
|
|
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
|
|
course2Participants (course `E.InnerJoin` _school) = numCourseParticipants $ course E.^. CourseId
|
|
|
|
course2Registered :: Maybe UserId -> AuthTagActive -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
|
|
course2Registered muid ata (course `E.InnerJoin` _school) = isCourseParticipant muid ata $ course E.^. CourseId
|
|
|
|
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
|
|
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
|
|
makeCourseTable whereClause colChoices psValidator = do
|
|
muid <- lift maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
ata <- getSessionActiveAuthTags
|
|
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery qin@(course `E.InnerJoin` school) = do
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
let participants = course2Participants qin
|
|
let registered = course2Registered muid ata qin
|
|
let mayView = mayViewCourse muid ata now course Nothing
|
|
E.where_ $ whereClause (course, participants, registered, mayView)
|
|
return (course, participants, registered, school)
|
|
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
|
|
isEditorQuery course user = E.where_ $ mayEditCourse' muid ata course
|
|
E.&&. E.just (user E.^. UserId) E.==. E.val muid
|
|
dbtProj :: DBRow _ -> DB CourseTableData
|
|
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
|
|
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
|
courseAlloc <- getBy (UniqueAllocationCourse $ entityKey course)
|
|
>>= traverse (getJustEntity . allocationCourseAllocation . entityVal)
|
|
isEditorList <- E.select $ E.from $ isEditorQuery course
|
|
return (course, participants, registered, school, lecturerList, courseAlloc, not $ null isEditorList)
|
|
snd <$> dbTable psValidator DBTable
|
|
{ dbtSQLQuery
|
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
|
, dbtColonnade = colChoices
|
|
, dbtProj
|
|
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
|
|
[ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
|
|
, ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
|
|
, ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
|
|
, ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
|
|
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
|
|
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
|
|
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
|
|
, ( "members", SortColumn course2Participants )
|
|
, ( "registered", SortColumn $ course2Registered muid ata)
|
|
]
|
|
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
|
|
[ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
, ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
, ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
|
|
-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
|
|
-- )
|
|
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
|
|
emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
|
|
)
|
|
, ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
|
|
)
|
|
, ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
|
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> E.exists $ E.from $ \t -> do
|
|
user <- isCourseAdminQuery (course E.^. CourseId) t
|
|
E.where_ $ E.any (E.hasInfix (user E.^. UserDisplayName) . E.val) (criterias :: Set.Set Text)
|
|
)
|
|
, ( "openregistration", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Bool) of
|
|
Nothing -> E.val True
|
|
Just b -> 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
|
|
alloc allocation = do
|
|
E.where_ . E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
return allocation
|
|
allocOpen allocation = ( E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom)
|
|
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo)
|
|
)
|
|
E.||. ( courseOpen
|
|
E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse)
|
|
)
|
|
in (E.==. E.val b) $ ( courseOpen
|
|
E.&&. E.not_ (E.exists . void $ E.from alloc)
|
|
)
|
|
E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc)
|
|
)
|
|
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
|
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
Just needle -> course2Registered muid ata tExpr E.==. E.val needle
|
|
)
|
|
, ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) 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.%))
|
|
)
|
|
]
|
|
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
|
|
[ Just $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
|
|
, Just $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableCourseSchool)
|
|
, Just $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
|
|
, Just $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgFilterCourseSearch)
|
|
, Just $ prismAForm (singletonFilter "openregistration" . maybePrism _PathPiece) mPrev $ fmap (\x -> if isJust x && not (fromJust x) then Nothing else x) . aopt checkBoxField (fslI MsgFilterCourseRegisterOpen)
|
|
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterCourseRegistered))
|
|
]
|
|
, dbtStyle = def
|
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
|
, dbsTemplate = DBSTCourse
|
|
(_dbrOutput . _1) -- course
|
|
(_dbrOutput . _5) -- lecturer list
|
|
(_dbrOutput . _3) -- isRegistered
|
|
(_dbrOutput . _4) -- school
|
|
(_dbrOutput . _6 . _Just) -- allocation
|
|
(_dbrOutput . _7) -- mayEditCourse
|
|
}
|
|
, 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
|
|
]
|
|
whereClause (_, _, _, mayView) = mayView
|
|
validator = def
|
|
& defaultSorting [SortDescBy "term",SortAscBy "course"]
|
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
|
defaultLayout $ do
|
|
setTitleI MsgCourseListTitle
|
|
$(widgetFile "courses")
|
|
|
|
getTermCurrentR :: Handler Html
|
|
getTermCurrentR = do
|
|
termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
|
|
case fromNullable termIds of
|
|
Nothing
|
|
-> notFound
|
|
Just (maximum -> tid)
|
|
-> redirect (CourseListR, [("courses-term", toPathPiece tid)]) -- redirect avoids problematic breadcrumbs, headings, etc.
|
|
|
|
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)])
|