79d4ae20ee
Support course applications BREAKING CHANGE: auditing for course registrations and deregistrations, more tightly couple exam results, exam registration, and course registration (delete them together now)
251 lines
15 KiB
Haskell
251 lines
15 KiB
Haskell
module Handler.Course.Show
|
|
( getCShowR
|
|
, getCRegisterTemplateR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Utils.Lens
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Handler.Course.Register
|
|
|
|
import System.FilePath (addExtension)
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
|
|
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCShowR tid ssh csh = do
|
|
mbAid <- maybeAuthId
|
|
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do
|
|
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
|
|
<- lift . E.select . E.from $
|
|
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
|
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
|
|
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
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.limit 1 -- we know that there is at most one match, but we tell the DB this info too
|
|
let numParticipants = E.sub_select . E.from $ \part -> do
|
|
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
return ( E.countRows :: E.SqlExpr (E.Value Int))
|
|
return (course,school E.^. SchoolName, numParticipants, participant)
|
|
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
|
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
|
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return ( lecturer E.^. LecturerType
|
|
, user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
|
let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
|
|
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
|
|
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
|
|
(assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff
|
|
correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
|
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
|
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
|
mAllocation <- fmap (fmap entityVal . listToMaybe) . lift . E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
|
|
E.limit 1
|
|
return allocation
|
|
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
|
|
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
|
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
|
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication)
|
|
|
|
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
|
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
|
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
|
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
|
regForm <- if
|
|
| is _Just mbAid -> do
|
|
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
|
(regWidget, regEnctype) <- generateFormPost $ renderAForm FormStandard courseRegisterForm'
|
|
return $ wrapForm' regButton regWidget def
|
|
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
|
|
, formEncoding = regEnctype
|
|
, formSubmit = FormSubmit
|
|
}
|
|
| otherwise
|
|
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
|
|
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
|
|
|
|
let
|
|
tutorialDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery tutorial = do
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
return tutorial
|
|
dbtRowKey = (E.^. TutorialId)
|
|
dbtProj = return
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
|
|
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
|
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
|
|
tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
|
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
|
return [whamlet|
|
|
$newline never
|
|
<ul .list--iconless .list--inline .list--comma-separated>
|
|
$forall tutor <- tutTutors
|
|
<li>
|
|
^{nameEmailWidget' tutor}
|
|
|]
|
|
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
|
|
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime
|
|
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
|
|
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
|
|
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
|
|
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
|
|
Nothing -> mempty
|
|
Just tutorialCapacity' -> sqlCell $ do
|
|
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
|
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
|
in return $ E.val tutorialCapacity' E.-. numParticipants
|
|
return . toWidget . tshow $ max 0 freeCapacity
|
|
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
|
isRegistered <- case mbAid of
|
|
Nothing -> return False
|
|
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
|
|
if
|
|
| mayRegister -> do
|
|
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
|
return $ wrapForm tutRegisterForm def
|
|
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
|
|
, formEncoding = tutRegisterEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
| isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
|
|
| otherwise -> return mempty
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
|
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
|
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
|
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
|
|
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
|
|
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
|
|
]
|
|
dbtFilter = Map.empty
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "tutorials"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
tutorialDBTableValidator = def
|
|
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
|
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
|
|
|
let
|
|
examDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery exam = do
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
return exam
|
|
dbtRowKey = (E.^. ExamId)
|
|
dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
|
|
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
|
return r
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
|
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
|
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
|
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
|
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
|
isRegistered <- case mbAid of
|
|
Nothing -> return False
|
|
Just uid -> existsBy $ UniqueExamRegistration eId uid
|
|
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
|
examUrl = CExamR tid ssh csh examName EShowR
|
|
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
|
| otherwise -> return [whamlet|_{label}|]
|
|
-- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
|
-- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
|
-- isRegistered <- case mbAid of
|
|
-- Nothing -> return False
|
|
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
|
|
-- if
|
|
-- | mayRegister -> do
|
|
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
|
-- return $ wrapForm examRegisterForm def
|
|
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
|
-- , formEncoding = examRegisterEnctype
|
|
-- , formSubmit = FormNoSubmit
|
|
-- }
|
|
-- | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
|
-- | otherwise -> return mempty
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
|
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
|
|
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
|
|
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
|
|
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
|
|
, ("registered", SortColumn $ \exam ->
|
|
case mbAid of
|
|
Nothing -> E.false
|
|
Just uid ->
|
|
E.exists $ E.from $ \reg -> do
|
|
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
)
|
|
]
|
|
dbtFilter = Map.empty
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "exams"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
examDBTableValidator = def
|
|
& defaultSorting [SortAscBy "time"]
|
|
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
|
|
|
|
siteLayout (toWgt $ courseName course) $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
|
$(widgetFile "course")
|
|
|
|
getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
|
getCRegisterTemplateR tid ssh csh = do
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh
|
|
let source = (.| C.map entityVal) . E.selectSource . E.from $ \(file `E.InnerJoin` courseAppInstructionFile `E.InnerJoin` course) -> do
|
|
E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
|
|
E.on $ courseAppInstructionFile E.^. CourseAppInstructionFileFile E.==. file E.^. FileId
|
|
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
|
|
return file
|
|
serveSomeFiles archiveName source
|