335 lines
21 KiB
Haskell
335 lines
21 KiB
Haskell
module Handler.Course.Show
|
|
( getCShowR
|
|
, getCRegisterTemplateR, courseRegisterTemplateSource
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Course
|
|
import Utils.Form
|
|
import Utils.Schedule
|
|
import Handler.Utils
|
|
import Handler.Utils.Course
|
|
import Handler.Utils.Tutorial
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Handler.Course.Register
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import Handler.Exam.List (mkExamTable)
|
|
|
|
|
|
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCShowR tid ssh csh = do
|
|
mbAuth <- maybeAuthPair
|
|
now <- liftIO getCurrentTime
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
(cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mCourseScheduleOpt,mayReRegister,(mayViewSheets,mayViewAnySheet),(mayViewMaterials,mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
|
|
[(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
|
|
<- 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 (fst <$> mbAuth) E.==. participant E.?. CourseParticipantUser
|
|
E.&&. participant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
|
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.SqlExpr (E.Value Int)
|
|
numParticipants = E.subSelectCount . E.from $ \part ->
|
|
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. part E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (course, courseIsVisible now course Nothing, school E.^. SchoolName, numParticipants, participant, courseAllocationRegistrationOpen now (course E.^. CourseId) Nothing)
|
|
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.^. UserDisplayEmail, 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.^. UserDisplayEmail, 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.^. UserDisplayEmail, 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
|
|
mApplicationTemplate <- runMaybeT $ do
|
|
guard hasApplicationTemplate
|
|
lift . lift . toTextUrl $ CourseR tid ssh csh CRegisterTemplateR
|
|
mApplication <- lift . fmap (listToMaybe =<<) . for mbAuth $ \(uid,_) -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
|
news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
|
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
|
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
|
|
cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
|
|
guardM . lift . lift . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
|
|
let visible = cTime >= NTop courseNewsVisibleFrom
|
|
files' <- lift . lift . E.select . E.from $ \newsFile -> do
|
|
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
|
return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle)
|
|
let files'' = files'
|
|
& over (mapped . _1) E.unValue
|
|
& over (mapped . _2) E.unValue
|
|
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
|
|
mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
|
mayDelete <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
|
|
|
|
files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath
|
|
archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR
|
|
|
|
return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl)
|
|
|
|
mCourseScheduleOpt <- case mbAuth of
|
|
Just (uid,_) -> lift $ getBy $ UniqueCourseScheduleOpt cid uid
|
|
Nothing -> return Nothing
|
|
|
|
events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do
|
|
E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid
|
|
let showRoom = maybe E.false (flip showCourseEventRoom courseEvent . E.val . view _1) mbAuth
|
|
E.||. E.not_ (courseEvent E.^. CourseEventRoomHidden)
|
|
return (courseEvent, showRoom)
|
|
events <- forM events' $ \(Entity evId ev, E.Value showRoom) -> do
|
|
evId' <- encrypt evId
|
|
shouldBeDisplayedInSchedule <- lift $ E.selectExists . E.from $ \(c `E.InnerJoin` cEv) -> do
|
|
E.on $ c E.^. CourseId E.==. cEv E.^. CourseEventCourse
|
|
E.where_ $ cEv E.^. CourseEventId E.==. E.val evId
|
|
E.&&. courseEventShouldBeDisplayedInSchedule (view _1 <$> mbAuth) ata c cEv
|
|
mCourseEventScheduleOpt <- case mbAuth of
|
|
Just (aid,_) -> lift $ getBy $ UniqueCourseEventScheduleOpt evId aid
|
|
Nothing -> return Nothing
|
|
return (evId', ev, showRoom, shouldBeDisplayedInSchedule, mCourseEventScheduleOpt)
|
|
|
|
hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
|
|
submissionGroup' <- lift . for mbAuth $ \(uid,_) ->
|
|
fmap (listToMaybe . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
return $ submissionGroup E.^. SubmissionGroupName
|
|
let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup'
|
|
|
|
mayReRegister <- lift . courseMayReRegister $ Entity cid course
|
|
|
|
mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR
|
|
sheets <- lift . E.select . E.from $ \sheet -> do
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
return $ sheet E.^. SheetName
|
|
mayViewAnySheet <- lift . anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
|
|
|
|
mayViewMaterials <- lift . hasReadAccessTo $ CourseR tid ssh csh MaterialListR
|
|
materials <- lift . E.select . E.from $ \material -> do
|
|
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
|
return $ material E.^. MaterialName
|
|
mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
|
|
|
|
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mCourseScheduleOpt,mayReRegister,(mayViewSheets,mayViewAnySheet),(mayViewMaterials,mayViewAnyMaterial))
|
|
|
|
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
|
|
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
|
|
|
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
|
mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
|
|
<$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
|
regForm <- if
|
|
| is _Just mbAuth -> 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
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
let
|
|
tutorialDBTable = DBTable{..}
|
|
where
|
|
resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial)
|
|
resultTutorial = _dbrOutput . _1
|
|
resultShowRoom = _dbrOutput . _2
|
|
|
|
dbtSQLQuery tutorial = do
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
let showRoom = maybe E.false (flip showTutorialRoom tutorial . E.val . view _1) mbAuth
|
|
E.||. E.not_ (tutorial E.^. TutorialRoomHidden)
|
|
return (tutorial, showRoom)
|
|
dbtRowKey = (E.^. TutorialId)
|
|
dbtProj = over (_dbrOutput . _2) E.unValue <$> dbtProjId
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType
|
|
, sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
|
, sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \(view $ resultTutorial . _entityKey -> 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) $ \res -> if
|
|
| res ^. resultShowRoom -> maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res
|
|
| otherwise -> i18nCell MsgTutorialRoomIsHidden & addCellClass ("explanation" :: Text)
|
|
, sortable Nothing (i18nCell MsgTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime
|
|
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom
|
|
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo
|
|
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil
|
|
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \(view resultTutorial -> Entity tutid Tutorial{..}) -> case tutorialCapacity of
|
|
Nothing -> mempty
|
|
Just tutorialCapacity' -> sqlCell $ do
|
|
freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe)
|
|
. E.select $ let numParticipants :: E.SqlExpr (E.Value Int)
|
|
numParticipants = E.subSelectCount . E.from $ \participant ->
|
|
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
|
in return $ E.val tutorialCapacity' E.-. numParticipants
|
|
return . toWidget $ tshow freeCapacity
|
|
, sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \(view resultTutorial -> Entity tutId Tutorial{..}) -> sqlCell $ do
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
|
isRegistered <- case mbAuth of
|
|
Nothing -> return False
|
|
Just (uid,_) -> existsBy $ UniqueTutorialParticipant tutId uid
|
|
tutRegister <- if
|
|
| mayRegister -> do
|
|
(tutRegisterForm, tutRegisterEnctype) <- liftHandler . 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
|
|
tutScheduleOptSet <- if
|
|
| Just (uid,_) <- mbAuth -> do
|
|
shouldBeDisplayedInSchedule <- E.selectExists . E.from $ \(c `E.InnerJoin` tut) -> do
|
|
E.on $ c E.^. CourseId E.==. tut E.^. TutorialCourse
|
|
E.where_ $ tut E.^. TutorialId E.==. E.val tutId
|
|
E.&&. tutorialShouldBeDisplayedInSchedule (Just uid) ata c tut
|
|
(tutScheduleForm, tutScheduleEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnScheduleOptIn] [BtnScheduleOptOut] shouldBeDisplayedInSchedule
|
|
return $ wrapForm tutScheduleForm def
|
|
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName (TScheduleOptSetR $ not shouldBeDisplayedInSchedule)
|
|
, formEncoding = tutScheduleEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
| otherwise -> return mempty
|
|
tutScheduleOptDel <- if
|
|
| Just (uid,_) <- mbAuth -> do
|
|
mScheduleOpt <- getBy $ UniqueTutorialScheduleOpt tutId uid
|
|
if is _Just mScheduleOpt
|
|
then do
|
|
(tutScheduleOptDelForm, tutScheduleOptDelEnctype) <- liftHandler . generateFormPost . buttonForm' $ [BtnScheduleOptDel]
|
|
return $ wrapForm tutScheduleOptDelForm def
|
|
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TScheduleOptDelR
|
|
, formEncoding = tutScheduleOptDelEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
else return mempty
|
|
| otherwise -> return mempty
|
|
return $ tutRegister <> tutScheduleOptSet <> tutScheduleOptDel
|
|
]
|
|
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 )
|
|
, ( "tutors"
|
|
, SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
return . E.min_ $ user E.^. UserSurname
|
|
)
|
|
]
|
|
dbtFilter = Map.empty
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "tutorials"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
tutorialDBTableValidator = def
|
|
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
|
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
|
|
|
(Any hasExams, examTable) <- runDB . mkExamTable $ Entity cid course
|
|
|
|
let visibleNews = any (view _3) news
|
|
showNewsFiles fs = and
|
|
[ not $ null fs
|
|
, length fs <= 3
|
|
, all (views (_1 . _2) $ notElem pathSeparator) fs
|
|
]
|
|
hiddenEventNotes = all (\(_,CourseEvent{..},_,_,_) -> is _Nothing courseEventNote) events
|
|
Course{courseVisibleFrom,courseVisibleTo} = course
|
|
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
|
|
mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR
|
|
mayEdit <- hasWriteAccessTo $ CourseR tid ssh csh CEditR
|
|
|
|
let courseScheduleOptToggleValue User{userScheduleOccurrenceDisplayDefault} = maybe
|
|
( userScheduleOccurrenceDisplayDefault
|
|
&& ( is _Just registration )
|
|
)
|
|
(courseScheduleOptOpt . entityVal)
|
|
mCourseScheduleOpt
|
|
|
|
let heading = [whamlet|
|
|
$newline never
|
|
^{courseName course}
|
|
$if not courseVisible && mayEdit
|
|
\ #{iconInvisible}
|
|
|]
|
|
|
|
siteLayout heading $ do
|
|
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
|
$(widgetFile "course")
|
|
|
|
courseRegisterTemplateSource :: TermId -> SchoolId -> CourseShorthand -> ConduitT () CourseAppInstructionFile (YesodDB UniWorX) ()
|
|
courseRegisterTemplateSource tid ssh csh = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do
|
|
E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
|
|
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 courseAppInstructionFile
|
|
|
|
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
|
|
serveSomeFiles archiveName $ courseRegisterTemplateSource tid ssh csh
|