254 lines
16 KiB
Haskell
254 lines
16 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 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
|
|
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
|
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
|
|
<$> pure allocationName
|
|
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
|
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
|