296 lines
16 KiB
Haskell
296 lines
16 KiB
Haskell
module Handler.Home where
|
||
|
||
import Import
|
||
|
||
import Utils.Lens
|
||
import Handler.Utils
|
||
import Handler.Utils.Table.Cells
|
||
|
||
|
||
import qualified Data.Map as Map
|
||
import Database.Esqueleto.Utils.TH
|
||
import qualified Database.Esqueleto as E
|
||
import qualified Database.Esqueleto.Utils as E
|
||
|
||
getHomeR :: Handler Html
|
||
getHomeR = do
|
||
muid <- maybeAuthId
|
||
upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams
|
||
defaultLayout $ do
|
||
setTitleI MsgHomeHeading
|
||
fromMaybe mempty upcomingExamsWidget
|
||
maybe mempty homeUpcomingSheets muid
|
||
homeOpenCourses
|
||
|
||
|
||
homeOpenCourses :: Widget
|
||
homeOpenCourses = do
|
||
cTime <- liftIO getCurrentTime
|
||
let tableData :: E.SqlExpr (Entity Course)
|
||
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
||
tableData course = do
|
||
E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
|
||
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
|
||
E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
|
||
E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
|
||
)
|
||
return course
|
||
|
||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
|
||
colonnade = mconcat
|
||
[ -- dbRow
|
||
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
||
msgCell $ courseTerm course
|
||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
||
msgCell $ courseSchool course
|
||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
|
||
let tid = courseTerm course
|
||
ssh = courseSchool course
|
||
csh = courseShorthand course
|
||
anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
|
||
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
||
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
|
||
]
|
||
courseTable <- liftHandlerT . runDB $ dbTableWidget' def DBTable
|
||
{ dbtSQLQuery = tableData
|
||
, dbtRowKey = (E.^. CourseId)
|
||
, dbtColonnade = colonnade
|
||
, dbtProj = return
|
||
, dbtSorting = Map.fromList
|
||
[ ( "term"
|
||
, SortColumn $ \course -> course E.^. CourseTerm
|
||
)
|
||
, ( "school"
|
||
, SortColumn $ \course -> course E.^. CourseSchool
|
||
)
|
||
, ( "course"
|
||
, SortColumn $ \course -> course E.^. CourseShorthand
|
||
)
|
||
, ( "deadline"
|
||
, SortColumn $ \course -> course E.^. CourseRegisterTo
|
||
)
|
||
]
|
||
, dbtFilter = mempty {- [ ( "term"
|
||
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
||
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||
)
|
||
] -}
|
||
, dbtFilterUI = mempty
|
||
, dbtStyle = def
|
||
, dbtParams = def
|
||
, dbtIdent = "open-courses" :: Text
|
||
}
|
||
$(widgetFile "home/openCourses")
|
||
|
||
homeUpcomingSheets :: UserId -> Widget
|
||
homeUpcomingSheets uid = do
|
||
cTime <- liftIO getCurrentTime
|
||
let tableData :: E.LeftOuterJoin
|
||
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
|
||
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
|
||
-> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
||
, E.SqlExpr (E.Value SchoolId)
|
||
, E.SqlExpr (E.Value CourseShorthand)
|
||
, E.SqlExpr (E.Value SheetName)
|
||
, E.SqlExpr (E.Value UTCTime)
|
||
, E.SqlExpr (E.Value (Maybe SubmissionId)))
|
||
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
|
||
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
|
||
E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser
|
||
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
|
||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||
E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
|
||
return
|
||
( course E.^. CourseTerm
|
||
, course E.^. CourseSchool
|
||
, course E.^. CourseShorthand
|
||
, sheet E.^. SheetName
|
||
, sheet E.^. SheetActiveTo
|
||
, submission E.?. SubmissionId
|
||
)
|
||
|
||
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
|
||
, E.Value SchoolId
|
||
, E.Value CourseShorthand
|
||
, E.Value SheetName
|
||
, E.Value UTCTime
|
||
, E.Value (Maybe SubmissionId)
|
||
))
|
||
(DBCell (HandlerT UniWorX IO) ())
|
||
colonnade = mconcat
|
||
[ -- dbRow
|
||
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
|
||
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
|
||
textCell $ toMessage tid
|
||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
|
||
textCell $ toMessage ssh
|
||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
|
||
anchorCell (CourseR tid ssh csh CShowR) (toWidget csh)
|
||
, sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
|
||
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn)
|
||
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
|
||
cell $ formatTime SelFormatDateTime deadline >>= toWidget
|
||
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
|
||
case mbsid of
|
||
Nothing -> cell $ do
|
||
let submitRoute = CSheetR tid ssh csh shn SubmissionNewR
|
||
whenM (hasWriteAccessTo submitRoute) $
|
||
modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
|
||
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
||
(toWidget $ hasTickmark True)
|
||
]
|
||
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
|
||
sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
|
||
{ dbtSQLQuery = tableData
|
||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||
, dbtColonnade = colonnade
|
||
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
||
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
||
, dbtSorting = Map.fromList
|
||
[ ( "term"
|
||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||
)
|
||
, ( "school"
|
||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
|
||
)
|
||
, ( "course"
|
||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
||
)
|
||
, ( "sheet"
|
||
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||
)
|
||
, ( "deadline"
|
||
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
||
)
|
||
, ( "done"
|
||
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
|
||
)
|
||
]
|
||
, dbtFilter = mempty {- [ ( "term"
|
||
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
||
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||
)
|
||
] -}
|
||
, dbtFilterUI = mempty
|
||
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
||
, dbtParams = def
|
||
, dbtIdent = "upcoming-sheets" :: Text
|
||
}
|
||
$(widgetFile "home/upcomingSheets")
|
||
|
||
|
||
|
||
homeUpcomingExams :: UserId -> DB Widget
|
||
homeUpcomingExams uid = do
|
||
now <- liftIO getCurrentTime
|
||
let fortnight = addWeeks 2 now
|
||
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
||
examDBTable = DBTable{..}
|
||
where
|
||
-- for ease of refactoring:
|
||
queryCourse = $(sqlIJproj 2 1)
|
||
queryExam = $(sqlIJproj 2 2)
|
||
lensCourse = _1
|
||
lensExam = _2
|
||
|
||
dbtSQLQuery (course `E.InnerJoin` exam) = do
|
||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||
E.where_ $ E.exists $ E.from $ \participant ->
|
||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||
E.where_ $ E.isJust (exam E.^. ExamRegisterFrom)
|
||
E.&&. exam E.^. ExamRegisterFrom E.<=. E.just (E.val fortnight)
|
||
E.where_ $ E.isJust (exam E.^. ExamEnd)
|
||
E.&&. exam E.^. ExamEnd E.>=. E.just (E.val now)
|
||
return (course, exam)
|
||
dbtRowKey = queryExam >>> (E.^. ExamId)
|
||
dbtProj r@DBRow{ dbrOutput } = do
|
||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||
Entity _ Course{..} = view lensCourse dbrOutput
|
||
guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
|
||
return r
|
||
dbtColonnade = dbColonnade $ mconcat
|
||
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||
msgCell courseTerm
|
||
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||
msgCell courseSchool
|
||
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
||
-- continue here
|
||
, sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do
|
||
let Entity _ Exam{..} = view lensExam dbrOutput
|
||
Entity _ Course{..} = view lensCourse dbrOutput
|
||
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName)
|
||
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> cell $ do
|
||
startT <- formatTime SelFormatDateTime examStart
|
||
endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd
|
||
[whamlet|
|
||
$newline never
|
||
#{startT}
|
||
$maybe endT' <- endT
|
||
\ – #{endT'}
|
||
|]
|
||
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
|
||
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
|
||
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||
let Entity eId Exam{..} = view lensExam dbrOutput
|
||
Entity _ Course{..} = view lensCourse dbrOutput
|
||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||
if
|
||
| mayRegister -> do
|
||
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||
return $ wrapForm examRegisterForm def
|
||
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
||
, formEncoding = examRegisterEnctype
|
||
, formSubmit = FormNoSubmit
|
||
}
|
||
| isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||
| otherwise -> return mempty
|
||
-}
|
||
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
||
let Entity eId Exam{..} = view lensExam dbrOutput
|
||
Entity _ Course{..} = view lensCourse dbrOutput
|
||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
||
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
||
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
||
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
||
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
||
| otherwise -> return [whamlet|_{label}|]
|
||
]
|
||
dbtSorting = Map.fromList
|
||
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
||
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
||
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
||
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
||
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
||
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
||
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
||
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
||
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
||
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
||
E.exists $ E.from $ \registration -> do
|
||
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
||
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||
))
|
||
]
|
||
dbtFilter = Map.empty
|
||
dbtFilterUI = const mempty
|
||
dbtStyle = def
|
||
dbtParams = def
|
||
dbtIdent :: Text
|
||
dbtIdent = "exams"
|
||
|
||
examDBTableValidator = def
|
||
& defaultSorting [SortAscBy "time"]
|
||
(Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable
|
||
return $(widgetFile "home/upcomingExams")
|
||
|
||
|