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

Fix #215 and other minor improvements

Browse Source
This commit is contained in:
SJost 2019-01-24 14:44:48 +01:00
parent e19540556f
commit f5f9dea342
11 changed files with 60 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de.msg
View File

@ -186,6 +186,7 @@ UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Be
UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -562,6 +563,7 @@ MenuCourseNew: Neuen Kurs anlegen
MenuTermEdit: Semester editieren
MenuCorrection: Korrektur
MenuCorrections: Korrekturen
MenuCorrectionsOwn: Meine Korrekturen
MenuSubmissions: Abgaben
MenuSheetList: Übungsblätter
MenuSheetNew: Neues Übungsblatt anlegen

6
routes
View File

@ -73,10 +73,10 @@
/subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials !corrector
!/ex/new SheetNewR GET POST
/ex-current SheetCurrentR GET !free -- just a redirect
/ex-lastinactive SheetLastInactiveR GET !free -- just a redirect
!/ex/current SheetCurrentR GET !free -- just a redirect
!/ex/lastinactive SheetLastInactiveR GET !free -- just a redirect
/ex/#SheetName SheetR:
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only

35
src/Foundation.hs
View File

@ -689,13 +689,18 @@ evalAccess route isWrite = do
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess
redirectAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> ReaderT (YesodPersistBackend UniWorX) m a
redirectAccessDB url = do
redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
redirectAccess url = do
-- must hide URL if not authorized
access <- evalAccessDB url False
access <- evalAccess url False
case access of
Authorized -> redirect url
_ -> notFound -- permissionDeniedI maybe not always correct?
_ -> permissionDeniedI MsgUnauthorizedRedirect
-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
evalAccessCorrector :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX)
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
-- Please see the documentation for the Yesod typeclass. There are a number
@ -1256,7 +1261,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccess (CourseR tid ssh csh CNotesR) False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
, MenuItem
{ menuItemType = PageActionPrime
@ -1265,7 +1270,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
, menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
let sheetRouteAccess shn = (== Authorized) <$> evalAccess (CSheetR tid ssh csh shn SShowR) False
muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
@ -1286,7 +1291,7 @@ pageActions (CourseR tid ssh csh CShowR) =
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh)
@ -1362,7 +1367,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh)
@ -1370,7 +1375,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, ("corrections-sheet" , CI.original shn)
])
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccess (CourseR tid ssh csh CNotesR) False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
, MenuItem
{ menuItemType = PageActionPrime
@ -1386,7 +1391,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False
@ -1394,7 +1399,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False
@ -1501,14 +1506,14 @@ pageActions (CorrectionsR) =
[E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer )
E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows
return $ (sheetCount :: Int) /= 0
}
@ -1541,14 +1546,14 @@ pageActions (CorrectionsGradeR) =
[E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer )
E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows
return $ (sheetCount :: Int) /= 0
}

9
src/Handler/Corrections.hs
View File

@ -498,16 +498,17 @@ postCorrectionsR = do
[ Map.singleton "course" . maybeToList <$> aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) (Just <$> listToMaybe =<< Map.lookup "course" =<< mPrev)
, Map.singleton "term" . maybeToList <$> aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) (Just <$> listToMaybe =<< Map.lookup "term" =<< mPrev)
, Map.singleton "school" . maybeToList <$> aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) (Just <$> listToMaybe =<< Map.lookup "school" =<< mPrev)
, Map.singleton "israted" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgRatingTime) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "israted" =<< mPrev)
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False)
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
termOptions = runDB $ do
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False)
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
schoolOptions = runDB $ do
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False)
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
@ -655,6 +656,8 @@ postCorrectionR tid ssh csh shn cid = do
let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction")
_ -> notFound
getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid

7
src/Handler/Sheet.hs
View File

@ -154,7 +154,7 @@ getSheetCurrentR tid ssh csh = runDB $ do
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR
(E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound
getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -162,7 +162,7 @@ getSheetLastInactiveR tid ssh csh = runDB $ do
-- TODO: deliver oldest sheet with unassigned submissions instead!!!
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -171,7 +171,7 @@ getSheetLastInactiveR tid ssh csh = runDB $ do
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR
(E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound
@ -386,6 +386,7 @@ getSShowR tid ssh csh shn = do
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
$(widgetFile "sheetShow")
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent

6
src/Handler/Utils/Form.hs
View File

@ -318,7 +318,7 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
data SheetType' = Normal' | Bonus' | Informational' | NotGraded'
data SheetType' = NotGraded' | Normal' | Bonus' | Informational'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetType'
@ -328,7 +328,7 @@ nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetGroup'
@ -498,7 +498,7 @@ secretJsonField = Field{..}
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|]
fieldEnctype = UrlEncoded
funcForm :: forall k v m.
( Finite k, Ord k

6
src/Model/Types.hs
View File

@ -179,10 +179,10 @@ sheetGradeSum gr (Just p) =
data SheetType
= Normal { grading :: SheetGrading }
= NotGraded
| Normal { grading :: SheetGrading }
| Bonus { grading :: SheetGrading }
| Informational { grading :: SheetGrading }
| NotGraded
deriving (Eq, Read, Show, Generic)
deriveJSON defaultOptions
@ -320,7 +320,7 @@ derivePersistField "ExamStatus"
-- | Specify a corrector's workload
data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
= Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload
= Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
}
deriving (Show, Read, Eq, Ord, Generic)

4
src/Utils.hs
View File

@ -353,6 +353,10 @@ maybeT x m = runMaybeT m >>= maybe x return
maybeT_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT
hoistMaybe :: MonadPlus m => Maybe a -> m a
-- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
hoistMaybe = maybe mzero return
catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)

7
templates/correction.hamlet
View File

@ -1,7 +1,12 @@
<section>
^{userCorrection}
<section>
$maybe marktxt <- sheetMarkingText
<section>
<h2>_{MsgSheetMarking}
<p>
#{marktxt}
<section>
<form method=post enctype=#{corrEncoding} action=@{CSubmissionR tid ssh csh shn cid CorrectionR}>
^{corrForm}

10
templates/sheetShow.hamlet
View File

@ -17,8 +17,6 @@ $maybe descr <- sheetDescription sheet
$maybe solution <- solutionFrom <* guard hasSolution
<dt .deflist__dt>_{MsgSheetSolutionFrom}
<dd .deflist__dd>#{solution}
<dt .deflist__dt>_{MsgSheetType}
<dd .deflist__dd>_{sheetType sheet}
<dt .deflist__dt>_{MsgSheetSubmissionMode}
<dd .deflist__dd>_{sheetSubmissionMode sheet}
$case sheetSubmissionMode sheet
@ -37,6 +35,14 @@ $maybe descr <- sheetDescription sheet
<form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
^{generateWidget}
$of _
<dt .deflist__dt>_{MsgSheetType}
<dd .deflist__dd>_{sheetType sheet}
$maybe marktxt <- markingText
<section>
<h2>_{MsgSheetMarking}
<p>
#{marktxt}
$if hasFiles
<section>

2
templates/widgets/gradingSummary.hamlet
View File

@ -36,7 +36,7 @@ $# --
<td .table__td colspan=2>
$maybe _ <- hasPoints
<td .table__td>
<td .table__td>#{display nrNoGrade}
<td .table__td>#{nrNoGrade}
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
<p>_{MsgSheetTypeInfoBonus} #
$maybe _ <- positiveSum $ bonusSummary ^. _achievedPoints