fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compiles, fixes #162, but DB Migration is still missing.

Browse Source
This commit is contained in:
SJost 2018-08-22 14:58:11 +02:00
parent 5810dc5182
commit 1755edbfcf
8 changed files with 98 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

@ -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. 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 FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid} TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
CourseListTitle: Alle Kurse CourseListTitle: Alle Kurse
TermCourseListTitle tid@TermId: Kurse #{display tid} TermCourseListTitle tid@TermId: Kurse #{display tid}
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
CourseNewHeading: Neuen Kurs anlegen CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
CourseEditTitle: Kurs editieren/anlegen CourseEditTitle: Kurs editieren/anlegen

4
models
View File

@ -74,8 +74,8 @@ Course
deregisterUntil UTCTime Maybe deregisterUntil UTCTime Maybe
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool materialFree Bool
CourseTermSchoolShort term school shorthand TermSchoolCourseShort term school shorthand
CourseTermSchoolName term school name TermSchoolCourseName term school name
CourseEdit CourseEdit
user UserId user UserId
time UTCTime time UTCTime

2
routes
View File

@ -46,7 +46,7 @@
/terms/edit TermEditR GET POST /terms/edit TermEditR GET POST
/terms/#TermId/edit TermEditExistR GET /terms/#TermId/edit TermEditExistR GET
!/terms/#TermId TermCourseListR GET !free !/terms/#TermId TermCourseListR GET !free
!/terms/#TermId/#SchoolId SchoolCourseListR GET !free !/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation

34
src/Foundation.hs
View File

@ -331,12 +331,12 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
guard $ maybe False (== authId) submissionRatingBy guard $ maybe False (== authId) submissionRatingBy
return Authorized return Authorized
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do 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 Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized return Authorized
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do 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 guard $ cid `Set.member` Map.keysSet resMap
return Authorized return Authorized
_ -> do _ -> do
@ -345,7 +345,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
) )
,("time", APDB $ \route _ -> case route of ,("time", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do 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 Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let let
@ -365,7 +365,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do 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 cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= 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 ,("capacity", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do 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 ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized 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 ,("materials", APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do 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 guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate "materials" r r -> $unsupportedAuthPredicate "materials" r
@ -488,7 +488,7 @@ instance Yesod UniWorX where
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
cid <- MaybeT . getKeyBy $ CourseTermSchoolShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid let courseFavourite = CourseFavourite uid now cid
@ -671,11 +671,11 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR) 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 CourseListR = return ("Kurse" , Just HomeR)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) 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 -- (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 CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",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) let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
muid <- maybeAuthId muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do (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] sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
lecturer <- case muid of lecturer <- case muid of
Nothing -> return False Nothing -> return False
@ -984,6 +984,10 @@ pageHeading (TermEditExistR tid)
= Just $ i18nHeading $ MsgTermEditTid tid = Just $ i18nHeading $ MsgTermEditTid tid
pageHeading (TermCourseListR tid) pageHeading (TermCourseListR tid)
= Just . i18nHeading . MsgTermCourseListHeading $ tid = Just . i18nHeading . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh)
= Just $ do
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (CourseListR) pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle = Just $ i18nHeading $ MsgCourseListTitle
@ -991,7 +995,7 @@ pageHeading CourseNewR
= Just $ i18nHeading MsgCourseNewHeading = Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid ssh csh CShowR) pageHeading (CourseR tid ssh csh CShowR)
= Just $ do = Just $ do
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermSchoolShort tid ssh csh Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
toWidget courseName toWidget courseName
-- (CourseR tid csh CRegisterR) -- just for POST -- (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid ssh csh CEditR) pageHeading (CourseR tid ssh csh CEditR)
@ -1059,21 +1063,21 @@ routeNormalizers =
tell $ Any True tell $ Any True
| otherwise = return () | otherwise = return ()
ncSchool = maybeOrig $ \route -> do ncSchool = maybeOrig $ \route -> do
SchoolCourseListR tid ssh <- return route TermSchoolCourseListR tid ssh <- return route
let schoolShort :: SchoolShorthand let schoolShort :: SchoolShorthand
schoolShort = unSchoolKey ssh schoolShort = unSchoolKey ssh
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
(hasChanged `on` unSchoolKey)ssh ssh' (hasChanged `on` unSchoolKey)ssh ssh'
return $ SchoolCourseListR tid ssh' return $ TermSchoolCourseListR tid ssh'
ncCourse = maybeOrig $ \route -> do ncCourse = maybeOrig $ \route -> do
CourseR tid ssh csh subRoute <- return route 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 csh courseShorthand
(hasChanged `on` unSchoolKey) ssh courseSchool (hasChanged `on` unSchoolKey) ssh courseSchool
return $ CourseR tid courseSchool courseShorthand subRoute return $ CourseR tid courseSchool courseShorthand subRoute
ncSheet = maybeOrig $ \route -> do ncSheet = maybeOrig $ \route -> do
CSheetR tid ssh csh shn subRoute <- return route 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 Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName hasChanged shn sheetName
return $ CSheetR tid ssh csh sheetName subRoute return $ CSheetR tid ssh csh sheetName subRoute

78
src/Handler/Corrections.hs
View File

@ -86,17 +86,19 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] ssh = course ^. _4
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid 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}|]) in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) 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 :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
-- shn = sheetName -- shn = sheetName
mkRoute = do mkRoute = do
cid <- encrypt subId cid <- encrypt subId
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") 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)) 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 [ downloadAction
] ]
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid csh = do postCCorrectionsR tid ssh csh = do
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
let whereClause = courseIs cid let whereClause = courseIs cid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do
, assignAction (Left cid) , assignAction (Left cid)
] ]
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSSubsR = postSSubsR getSSubsR = postSSubsR
postSSubsR tid csh shn = do postSSubsR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid csh shn shid <- runDB $ fetchSheetId tid ssh csh shn
let whereClause = sheetIs shid let whereClause = sheetIs shid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -380,26 +384,26 @@ postSSubsR tid csh shn = do
, autoAssignAction shid , 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 $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
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.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. submission E.^. SubmissionId E.==. E.val sub E.&&. submission E.^. SubmissionId E.==. E.val sub
return (course, sheet, submission, corrector) return (course, sheet, submission, corrector)
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid csh shn cid = do getCorrectionR tid ssh csh shn cid = do
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
postCorrectionR tid csh shn cid = do postCorrectionR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do [(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 let rated = isJust $ void ratingPoints <|> void ratingComment
update sub [ SubmissionRatingBy =. (uid <$ guard rated) update sub [ SubmissionRatingBy =. (uid <$ guard rated)
, SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints , SubmissionRatingPoints =. ratingPoints
, SubmissionRatingComment =. ratingComment , SubmissionRatingComment =. ratingComment
] ]
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of case uploadResult of
FormMissing -> return () FormMissing -> return ()
@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI "success" MsgRatingFilesUpdated addMessageI "success" MsgRatingFilesUpdated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
defaultLayout $ do defaultLayout $ do
let userCorrection = $(widgetFile "correction-user") let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction") $(widgetFile "correction")
_ -> notFound _ -> notFound
getCorrectionUserR tid csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do

36
src/Handler/Course.hs
View File

@ -81,12 +81,12 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> $ \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 :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> $ \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 :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
@ -201,6 +201,30 @@ getTermCurrentR = do
(Just (maximum -> tid)) -> -- getTermCourseListR tid (Just (maximum -> tid)) -> -- getTermCourseListR tid
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. 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 :: TermId -> Handler Html
getTermCourseListR tid = do getTermCourseListR tid = do
void . runDB $ get404 tid -- Just ensure the term exists void . runDB $ get404 tid -- Just ensure the term exists
@ -226,7 +250,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do (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 <- (,,) dependent <- (,,)
<$> get (courseSchool course) -- join -- just fetch full school name here <$> get (courseSchool course) -- join -- just fetch full school name here
<*> count [CourseParticipantCourse ==. cid] -- join <*> count [CourseParticipantCourse ==. cid] -- join
@ -262,7 +286,7 @@ postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do postCRegisterR tid ssh csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (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) registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
return (cid, course, registered) return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
@ -289,12 +313,12 @@ postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR tid ssh csh = do getCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler True course courseEditHandler True course
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCEditR tid ssh csh = do postCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermSchoolShort tid ssh csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler False course courseEditHandler False course

4
src/Handler/Sheet.hs
View File

@ -159,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ CourseTermSchoolShort tid ssh csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let 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 :: 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 sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
@ -411,7 +411,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
(FormSuccess SheetForm{..}) -> do (FormSuccess SheetForm{..}) -> do
saveOkay <- runDB $ do saveOkay <- runDB $ do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let newSheet = Sheet let newSheet = Sheet
{ sheetCourse = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName

2
src/Handler/Utils/Sheet.hs
View File

@ -29,7 +29,7 @@ fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn) let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
in cachedBy cachId $ do in cachedBy cachId $ do
-- Mit Yesod: -- Mit Yesod:
-- cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- getBy404 $ CourseSheet cid shn -- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto: -- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do