Compiles, fixes #162, but DB Migration is still missing.
This commit is contained in:
SJost
parent
5810dc5182
commit
1755edbfcf
@ -44,8 +44,10 @@ CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs
|
||||
CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
FFSheetName: Name
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
|
||||
CourseListTitle: Alle Kurse
|
||||
TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
|
||||
CourseNewHeading: Neuen Kurs anlegen
|
||||
CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
|
||||
4
models
4
models
@ -74,8 +74,8 @@ Course
|
||||
deregisterUntil UTCTime Maybe
|
||||
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
||||
materialFree Bool
|
||||
CourseTermSchoolShort term school shorthand
|
||||
CourseTermSchoolName term school name
|
||||
TermSchoolCourseShort term school shorthand
|
||||
TermSchoolCourseName term school name
|
||||
CourseEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
|
||||
2
routes
2
routes
@ -46,7 +46,7 @@
|
||||
/terms/edit TermEditR GET POST
|
||||
/terms/#TermId/edit TermEditExistR GET
|
||||
!/terms/#TermId TermCourseListR GET !free
|
||||
!/terms/#TermId/#SchoolId SchoolCourseListR GET !free
|
||||
!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
|
||||
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
|
||||
@ -331,12 +331,12 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
guard $ maybe False (== authId) submissionRatingBy
|
||||
return Authorized
|
||||
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard $ cid `Set.member` Map.keysSet resMap
|
||||
return Authorized
|
||||
_ -> do
|
||||
@ -345,7 +345,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
)
|
||||
,("time", APDB $ \route _ -> case route of
|
||||
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
@ -365,7 +365,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
return Authorized
|
||||
|
||||
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
guard $ NTop courseRegisterFrom <= cTime
|
||||
&& NTop courseRegisterTo >= cTime
|
||||
@ -389,7 +389,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
)
|
||||
,("capacity", APDB $ \route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
@ -397,7 +397,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
)
|
||||
,("materials", APDB $ \route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate "materials" r
|
||||
@ -488,7 +488,7 @@ instance Yesod UniWorX where
|
||||
|
||||
now <- liftIO $ getCurrentTime
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
cid <- MaybeT . getKeyBy $ CourseTermSchoolShort tid ssh csh
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
user <- MaybeT $ get uid
|
||||
let courseFavourite = CourseFavourite uid now cid
|
||||
|
||||
@ -671,11 +671,11 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
|
||||
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
|
||||
|
||||
breadcrumb (SchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurse" , Just HomeR)
|
||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||
breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ SchoolCourseListR tid ssh)
|
||||
breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
-- (CourseR tid ssh csh CRegisterR) -- is POST only
|
||||
breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR)
|
||||
@ -848,7 +848,7 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
|
||||
muid <- maybeAuthId
|
||||
(sheets,lecturer) <- runDB $ do
|
||||
cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
|
||||
lecturer <- case muid of
|
||||
Nothing -> return False
|
||||
@ -984,6 +984,10 @@ pageHeading (TermEditExistR tid)
|
||||
= Just $ i18nHeading $ MsgTermEditTid tid
|
||||
pageHeading (TermCourseListR tid)
|
||||
= Just . i18nHeading . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh)
|
||||
= Just $ do
|
||||
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
||||
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading (CourseListR)
|
||||
= Just $ i18nHeading $ MsgCourseListTitle
|
||||
@ -991,7 +995,7 @@ pageHeading CourseNewR
|
||||
= Just $ i18nHeading MsgCourseNewHeading
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
toWidget courseName
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid ssh csh CEditR)
|
||||
@ -1059,21 +1063,21 @@ routeNormalizers =
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
ncSchool = maybeOrig $ \route -> do
|
||||
SchoolCourseListR tid ssh <- return route
|
||||
TermSchoolCourseListR tid ssh <- return route
|
||||
let schoolShort :: SchoolShorthand
|
||||
schoolShort = unSchoolKey ssh
|
||||
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
||||
(hasChanged `on` unSchoolKey)ssh ssh'
|
||||
return $ SchoolCourseListR tid ssh'
|
||||
return $ TermSchoolCourseListR tid ssh'
|
||||
ncCourse = maybeOrig $ \route -> do
|
||||
CourseR tid ssh csh subRoute <- return route
|
||||
Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
hasChanged csh courseShorthand
|
||||
(hasChanged `on` unSchoolKey) ssh courseSchool
|
||||
return $ CourseR tid courseSchool courseShorthand subRoute
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid ssh csh shn subRoute <- return route
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
hasChanged shn sheetName
|
||||
return $ CSheetR tid ssh csh sheetName subRoute
|
||||
|
||||
@ -86,17 +86,19 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|]
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|]
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
@ -106,13 +108,14 @@ colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
shn = sheetName $ entityVal sheet
|
||||
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh shn cid SubShowR
|
||||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
@ -125,12 +128,13 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
|
||||
|
||||
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
-- shn = sheetName
|
||||
mkRoute = do
|
||||
cid <- encrypt subId
|
||||
return $ CSubmissionR tid csh sheetName cid CorrectionR
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
@ -340,10 +344,10 @@ postCorrectionsR = do
|
||||
[ downloadAction
|
||||
]
|
||||
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
postCCorrectionsR tid ssh csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let whereClause = courseIs cid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do
|
||||
, assignAction (Left cid)
|
||||
]
|
||||
|
||||
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid csh shn
|
||||
postSSubsR tid ssh csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let whereClause = sheetIs shid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
@ -380,26 +384,26 @@ postSSubsR tid csh shn = do
|
||||
, autoAssignAction shid
|
||||
]
|
||||
|
||||
correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
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.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
||||
|
||||
return (course, sheet, submission, corrector)
|
||||
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
|
||||
postCorrectionR tid csh shn cid = do
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid ssh csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
||||
postCorrectionR tid ssh csh shn cid = do
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid csh shn sub
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
|
||||
case results of
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
|
||||
@ -424,14 +428,14 @@ postCorrectionR tid csh shn cid = do
|
||||
|
||||
let rated = isJust $ void ratingPoints <|> void ratingComment
|
||||
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
, SubmissionRatingTime =. (now <$ guard rated)
|
||||
, SubmissionRatingPoints =. ratingPoints
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
, SubmissionRatingTime =. (now <$ guard rated)
|
||||
, SubmissionRatingPoints =. ratingPoints
|
||||
, SubmissionRatingComment =. ratingComment
|
||||
]
|
||||
|
||||
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||||
redirect $ CSubmissionR tid csh shn cid CorrectionR
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
case uploadResult of
|
||||
FormMissing -> return ()
|
||||
@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do
|
||||
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||
|
||||
addMessageI "success" MsgRatingFilesUpdated
|
||||
redirect $ CSubmissionR tid csh shn cid CorrectionR
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
defaultLayout $ do
|
||||
let userCorrection = $(widgetFile "correction-user")
|
||||
$(widgetFile "correction")
|
||||
_ -> notFound
|
||||
getCorrectionUserR tid csh shn cid = do
|
||||
getCorrectionUserR tid ssh csh shn cid = do
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid csh shn sub
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
|
||||
case results of
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
|
||||
|
||||
@ -81,12 +81,12 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
|
||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
|
||||
|
||||
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
|
||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
|
||||
|
||||
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
|
||||
@ -201,6 +201,30 @@ getTermCurrentR = do
|
||||
(Just (maximum -> tid)) -> -- getTermCourseListR tid
|
||||
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
|
||||
|
||||
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
|
||||
getTermSchoolCourseListR tid ssh = do
|
||||
void . runDB $ get404 tid -- Just ensure the term exists
|
||||
School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
|
||||
muid <- maybeAuthId
|
||||
let colonnade = widgetColonnade $ mconcat
|
||||
[ dbRow
|
||||
, colCShortDescr
|
||||
, colRegFrom
|
||||
, colRegTo
|
||||
, colParticipants
|
||||
, maybe mempty (const colRegistered) muid
|
||||
]
|
||||
whereClause = \(course, _, _) ->
|
||||
course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
validator = def
|
||||
& defaultSorting [("cshort", SortAsc)]
|
||||
((), coursesTable) <- makeCourseTable whereClause colonnade validator
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
||||
$(widgetFile "courses")
|
||||
|
||||
|
||||
getTermCourseListR :: TermId -> Handler Html
|
||||
getTermCourseListR tid = do
|
||||
void . runDB $ get404 tid -- Just ensure the term exists
|
||||
@ -226,7 +250,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
dependent <- (,,)
|
||||
<$> get (courseSchool course) -- join -- just fetch full school name here
|
||||
<*> count [CourseParticipantCourse ==. cid] -- join
|
||||
@ -262,7 +286,7 @@ postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid ssh csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, course, registered) <- runDB $ do
|
||||
(Entity cid course) <- getBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
|
||||
return (cid, course, registered)
|
||||
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
||||
@ -289,12 +313,12 @@ postCourseNewR = courseEditHandler False Nothing
|
||||
|
||||
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler True course
|
||||
|
||||
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler False course
|
||||
|
||||
|
||||
|
||||
@ -159,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
Entity cid _ <- runDB . getBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
|
||||
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
||||
@ -411,7 +411,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
saveOkay <- runDB $ do
|
||||
actTime <- liftIO getCurrentTime
|
||||
cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
|
||||
@ -29,7 +29,7 @@ fetchSheetAux prj tid ssh csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
|
||||
in cachedBy cachId $ do
|
||||
-- Mit Yesod:
|
||||
-- cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh
|
||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- getBy404 $ CourseSheet cid shn
|
||||
-- Mit Esqueleto:
|
||||
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user