314 lines
15 KiB
Haskell
314 lines
15 KiB
Haskell
{-# 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 Utils.DB
|
|
import Handler.Utils hiding (colSchoolShort)
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
type CourseTableData = DBRow
|
|
( Entity Course
|
|
, Bool -- isRegistered
|
|
, Entity School
|
|
, [Entity User]
|
|
, Maybe (Entity Allocation)
|
|
, 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
|
|
|
|
resultAllocation :: Traversal' CourseTableData (Entity Allocation)
|
|
resultAllocation = _dbrOutput . _5 . _Just
|
|
|
|
resultMayEditCourse :: Lens' CourseTableData Bool
|
|
resultMayEditCourse = _dbrOutput . _6
|
|
|
|
|
|
type CourseTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School))
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
|
|
|
queryCourse :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity Course))
|
|
queryCourse = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1)
|
|
|
|
querySchool :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Entity School))
|
|
querySchool = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1)
|
|
|
|
queryAllocation :: IndexPreservingGetter CourseTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
|
queryAllocation = to $(E.sqlLOJproj 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
|
|
allocation <- view queryAllocation
|
|
|
|
return $ mayViewCourse muid ata now course (allocation E.?. AllocationId)
|
|
|
|
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{..}) ->
|
|
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)
|
|
$ \(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 tickmarkCell
|
|
|
|
|
|
data AllocationSearch
|
|
= AllocationSearchNoAllocation
|
|
| AllocationSearchMatch TermId SchoolId AllocationShorthand
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance PathPiece AllocationSearch where
|
|
toPathPiece AllocationSearchNoAllocation = "no-allocation"
|
|
toPathPiece (AllocationSearchMatch tid ssh ash) = pathPieceJoined "-" # [toPathPiece tid, toPathPiece ssh, toPathPiece ash]
|
|
fromPathPiece t
|
|
| CI.mk (Text.strip t) == "no-allocation" = pure AllocationSearchNoAllocation
|
|
| Just [tid, ssh, ash] <- t ^? pathPieceJoined "-"
|
|
= AllocationSearchMatch <$> fromPathPiece tid <*> fromPathPiece ssh <*> fromPathPiece ash
|
|
| otherwise = mzero
|
|
|
|
|
|
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
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let allocSearchNoAllocOption = Option
|
|
{ optionDisplay = mr MsgFilterCourseAllocationNone
|
|
, optionInternalValue
|
|
, optionExternalValue = toPathPiece optionInternalValue
|
|
}
|
|
where optionInternalValue = AllocationSearchNoAllocation
|
|
allocationSearchOptions <- mkOptionList . (allocSearchNoAllocOption :) <$> do
|
|
allocs <- E.select . E.from $ \allocation -> do
|
|
E.orderBy [ E.desc $ allocation E.^. AllocationTerm
|
|
, E.asc $ allocation E.^. AllocationSchool
|
|
, E.asc $ allocation E.^. AllocationName
|
|
]
|
|
return ( allocation E.^. AllocationTerm, allocation E.^. AllocationSchool, allocation E.^. AllocationShorthand
|
|
, allocation E.^. AllocationName
|
|
)
|
|
return . flip map allocs $ \(E.Value tid, E.Value ssh, E.Value ash, E.Value aname)
|
|
-> let optionInternalValue = AllocationSearchMatch tid ssh ash
|
|
in Option
|
|
{ optionDisplay = mr $ MsgFilterCourseAllocationOption tid ssh aname
|
|
, optionInternalValue
|
|
, optionExternalValue = toPathPiece optionInternalValue
|
|
}
|
|
|
|
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
|
|
dbtSQLQuery = runReaderT $ do
|
|
course <- view queryCourse
|
|
school <- view querySchool
|
|
allocation <- view queryAllocation
|
|
|
|
lift . E.on . E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.&&. allocation E.?. AllocationId E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
|
|
lift . E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
|
|
registered <- view $ queryIsRegistered muid ata
|
|
isEditor <- view $ queryIsEditor muid ata
|
|
|
|
return (course, registered, school, allocation, 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, allocation, E.Value isEditor) -> do
|
|
lecturerList <- E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
|
|
return (course, registered, school, lecturerList, allocation, 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
|
|
allocation <- view queryAllocation
|
|
|
|
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
|
|
allocOpen = ( E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterFrom)
|
|
E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (E.joinV $ allocation E.?. AllocationRegisterTo)
|
|
)
|
|
E.||. ( courseOpen
|
|
E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (E.joinV $ allocation E.?. AllocationRegisterByCourse)
|
|
)
|
|
|
|
return $ ( courseOpen
|
|
E.&&. E.isNothing (allocation E.?. AllocationId)
|
|
)
|
|
E.||. ( allocOpen
|
|
E.&&. E.isJust (allocation E.?. AllocationId)
|
|
)
|
|
, 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 "allocation" . FilterColumn $ \row (criteria :: Set AllocationSearch) -> if
|
|
| Set.null criteria -> E.true
|
|
| otherwise -> flip E.any criteria $ \case
|
|
AllocationSearchNoAllocation -> E.isNothing $ view queryAllocation row E.?. AllocationId
|
|
AllocationSearchMatch tid ssh ash
|
|
-> view queryAllocation row E.?. AllocationTerm E.==. E.justVal tid
|
|
E.&&. view queryAllocation row E.?. AllocationSchool E.==. E.justVal ssh
|
|
E.&&. view queryAllocation row E.?. AllocationShorthand E.==. E.justVal ash
|
|
]
|
|
, 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 "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))
|
|
, pure $ prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return allocationSearchOptions) (fslI MsgFilterCourseAllocation)
|
|
]
|
|
, dbtStyle = def
|
|
{ dbsFilterLayout = defaultDBSFilterLayout
|
|
, dbsTemplate = DBSTCourse resultCourse resultLecturers resultIsRegistered resultSchool resultAllocation 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"]
|
|
coursesTable <- runDB $ makeCourseTable colonnade validator
|
|
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)])
|