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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-24 17:08:08 +01:00
commit 1ccb8b7c32
15 changed files with 98 additions and 44 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} 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 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 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 EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -562,6 +563,7 @@ MenuCourseNew: Neuen Kurs anlegen
MenuTermEdit: Semester editieren MenuTermEdit: Semester editieren
MenuCorrection: Korrektur MenuCorrection: Korrektur
MenuCorrections: Korrekturen MenuCorrections: Korrekturen
MenuCorrectionsOwn: Meine Korrekturen
MenuSubmissions: Abgaben MenuSubmissions: Abgaben
MenuSheetList: Übungsblätter MenuSheetList: Übungsblätter
MenuSheetNew: Neues Übungsblatt anlegen MenuSheetNew: Neues Übungsblatt anlegen

6
routes
View File

@ -73,10 +73,10 @@
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials !corrector /ex SheetListR GET !registered !materials !corrector
!/ex/new SheetNewR GET POST !/ex/new SheetNewR GET POST
/ex-current SheetCurrentR GET !free -- just a redirect !/ex/current SheetCurrentR GET !free -- just a redirect
/ex-lastinactive SheetLastInactiveR GET !free -- just a redirect !/ex/lastinactive SheetLastInactiveR GET !free -- just a redirect
/ex/#SheetName SheetR: /ex/#SheetName SheetR:
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector /show SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR GET POST /delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only /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 :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess evalAccessDB = evalAccess
redirectAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> ReaderT (YesodPersistBackend UniWorX) m a redirectAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a
redirectAccessDB url = do redirectAccess url = do
-- must hide URL if not authorized -- must hide URL if not authorized
access <- evalAccessDB url False access <- evalAccess url False
case access of case access of
Authorized -> redirect url 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 -- Please see the documentation for the Yesod typeclass. There are a number
@ -1256,7 +1261,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccess (CourseR tid ssh csh CNotesR) False , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
@ -1265,7 +1270,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer , 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 muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do (sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
@ -1286,7 +1291,7 @@ pageActions (CourseR tid ssh csh CShowR) =
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections , menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh) , ("corrections-school", CI.original $ unSchoolKey ssh)
@ -1362,7 +1367,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections , menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh) , ("corrections-school", CI.original $ unSchoolKey ssh)
@ -1370,7 +1375,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, ("corrections-sheet" , CI.original shn) , ("corrections-sheet" , CI.original shn)
]) ])
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccess (CourseR tid ssh csh CNotesR) False , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
@ -1386,7 +1391,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions , menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False , menuItemModal = False
@ -1394,7 +1399,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
} }
, MenuItem , MenuItem
{ menuItemType = PageActionPrime { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections , menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False , menuItemModal = False
@ -1501,14 +1506,14 @@ pageActions (CorrectionsR) =
[E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
isLecturer = E.exists . E.from $ \lecturer -> E.where_ isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer ) E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows return E.countRows
return $ (sheetCount :: Int) /= 0 return $ (sheetCount :: Int) /= 0
} }
@ -1541,14 +1546,14 @@ pageActions (CorrectionsGradeR) =
[E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do [E.Value sheetCount] <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_
$ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
isLecturer = E.exists . E.from $ \lecturer -> E.where_ isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer ) E.&&. ( isCorrector' E.||. isLecturer )
return E.countRows return E.countRows
return $ (sheetCount :: Int) /= 0 return $ (sheetCount :: Int) /= 0
} }

23
src/Handler/Corrections.hs
View File

@ -21,6 +21,7 @@ import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive (CI)
import Data.Semigroup (Sum(..)) import Data.Semigroup (Sum(..))
import Data.Monoid (All(..)) import Data.Monoid (All(..))
@ -281,6 +282,11 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
| Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
) )
, ( "sheet-search"
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
)
, ( "corrector" , ( "corrector"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
| Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
@ -495,19 +501,20 @@ postCorrectionsR = do
, colRated , colRated
] -- Continue here ] -- Continue here
filterUI = Just $ \mPrev -> mconcat filterUI = Just $ \mPrev -> mconcat
[ Map.singleton "course" . maybeToList <$> aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) (Just <$> listToMaybe =<< Map.lookup "course" =<< mPrev) [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse)
, Map.singleton "term" . maybeToList <$> aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) (Just <$> listToMaybe =<< Map.lookup "term" =<< mPrev) , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm)
, Map.singleton "school" . maybeToList <$> aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) (Just <$> listToMaybe =<< Map.lookup "school" =<< mPrev) , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool)
, Map.singleton "israted" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgRatingTime) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "israted" =<< mPrev) , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` searchField False) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime)
] ]
courseOptions = runDB $ do 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 optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
termOptions = runDB $ do 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 optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
schoolOptions = runDB $ do 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 optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def psValidator = def
@ -655,6 +662,8 @@ postCorrectionR tid ssh csh shn cid = do
let userCorrection = $(widgetFile "correction-user") let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction") $(widgetFile "correction")
_ -> notFound _ -> notFound
getCorrectionUserR tid ssh csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid

4
src/Handler/Course.hs
View File

@ -176,8 +176,8 @@ makeCourseTable whereClause colChoices psValidator = do
) )
] ]
, dbtFilterUI = \mPrev -> mconcat $ catMaybes , dbtFilterUI = \mPrev -> mconcat $ catMaybes
[ Just $ Map.singleton "search" . maybeToList <$> aopt (searchField True) (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev) [ Just $ prismAForm (singletonFilter "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch)
, muid $> (Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev)) , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
] ]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = def , dbtParams = def

7
src/Handler/Sheet.hs
View File

@ -154,7 +154,7 @@ getSheetCurrentR tid ssh csh = runDB $ do
E.limit 1 E.limit 1
return $ sheet E.^. SheetName return $ sheet E.^. SheetName
case sheets of case sheets of
(E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR (E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound _ -> notFound
getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -162,7 +162,7 @@ getSheetLastInactiveR tid ssh csh = runDB $ do
-- TODO: deliver oldest sheet with unassigned submissions instead!!! -- TODO: deliver oldest sheet with unassigned submissions instead!!!
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do 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.where_ $ sheet E.^. SheetActiveTo E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
@ -171,7 +171,7 @@ getSheetLastInactiveR tid ssh csh = runDB $ do
E.limit 1 E.limit 1
return $ sheet E.^. SheetName return $ sheet E.^. SheetName
case sheets of case sheets of
(E.Value shn):_ -> redirectAccessDB $ CSheetR tid ssh csh shn SShowR (E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound _ -> notFound
@ -386,6 +386,7 @@ getSShowR tid ssh csh shn = do
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent 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" <>) embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
data SheetType' = Normal' | Bonus' | Informational' | NotGraded' data SheetType' = NotGraded' | Normal' | Bonus' | Informational'
deriving (Eq, Ord, Read, Show, Enum, Bounded) deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetType' instance Universe SheetType'
@ -328,7 +328,7 @@ nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
deriving (Eq, Ord, Read, Show, Enum, Bounded) deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetGroup' instance Universe SheetGroup'
@ -498,7 +498,7 @@ secretJsonField = Field{..}
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}> <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|] |]
fieldEnctype = UrlEncoded fieldEnctype = UrlEncoded
funcForm :: forall k v m. funcForm :: forall k v m.
( Finite k, Ord k ( Finite k, Ord k

18
src/Handler/Utils/Table/Pagination.hs
View File

@ -9,6 +9,7 @@ module Handler.Utils.Table.Pagination
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..) , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..) , DBTable(..), IsDBTable(..), DBCell(..)
, singletonFilter
, DBParams(..) , DBParams(..)
, cellAttrs, cellContents , cellAttrs, cellContents
, PagesizeLimit(..) , PagesizeLimit(..)
@ -205,7 +206,7 @@ deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue , sumEncoding = UntaggedValue
} ''PagesizeLimit } ''PagesizeLimit
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [SortingSetting] { psSorting :: [SortingSetting]
@ -358,6 +359,15 @@ defaultDBSFilterLayout :: Widget -- ^ Filter UI
-> Widget -> Widget
defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default") defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default")
singletonFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe v)
-- ^ for use with @prismAForm@
singletonFilter key = prism' fromInner (fmap Just . fromOuter)
where
fromInner = maybe Map.empty $ Map.singleton key . pure
fromOuter = Map.lookup key >=> listToMaybe
data DBTable m x = forall a r r' h i t k k'. data DBTable m x = forall a r r' h i t k k'.
( ToSortable h, Functor h ( ToSortable h, Functor h
, E.SqlSelect a r, SqlIn k k', DBTableKey k' , E.SqlSelect a r, SqlIn k k', DBTableKey k'
@ -723,7 +733,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParams :: Text -> [Text] -> QueryText -> QueryText setParams :: Text -> [Text] -> QueryText -> QueryText
setParams key vs qt = map ((key, ) . Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ] setParams key vs qt = map ((key, ) . Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ]
setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList setParam key = setParams key . maybeToList
@ -756,7 +766,7 @@ pagesizeField psLim = selectField $ do
optText (PagesizeLimit l) = tshow l optText (PagesizeLimit l) = tshow l
optText PagesizeAll = mr MsgDBTablePagesizeAll optText PagesizeAll = mr MsgDBTablePagesizeAll
toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList
return $ toOptionList limOpts return $ toOptionList limOpts
where where
limOpts :: [PagesizeLimit] limOpts :: [PagesizeLimit]
@ -852,7 +862,7 @@ formCell resLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash) mkUnique (toPathPiece -> name) = name <> "-" <> decodeUtf8 (Base64.encode rowKeyHash)
where where
rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey rowKeyHash = (BA.convert :: HMAC (SHAKE256 264) -> ByteString) . hmac hashKey . LBS.toStrict $ B.encode dbrKey
(edit, w) <- genForm input mkUnique (edit, w) <- genForm input mkUnique
return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w) return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
} }

6
src/Model/Types.hs
View File

@ -179,10 +179,10 @@ sheetGradeSum gr (Just p) =
data SheetType data SheetType
= Normal { grading :: SheetGrading } = NotGraded
| Normal { grading :: SheetGrading }
| Bonus { grading :: SheetGrading } | Bonus { grading :: SheetGrading }
| Informational { grading :: SheetGrading } | Informational { grading :: SheetGrading }
| NotGraded
deriving (Eq, Read, Show, Generic) deriving (Eq, Read, Show, Generic)
deriveJSON defaultOptions deriveJSON defaultOptions
@ -320,7 +320,7 @@ derivePersistField "ExamStatus"
-- | Specify a corrector's workload -- | Specify a corrector's workload
data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } 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 , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
} }
deriving (Show, Read, Eq, Ord, Generic) 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_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT 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 :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero) catchIfMaybeT p act = catchIf p (lift act) (const mzero)

6
src/Utils/Form.hs
View File

@ -447,3 +447,9 @@ hoistField f Field{..} = Field
, fieldView , fieldView
, fieldEnctype , fieldEnctype
} }
prismAForm :: Monad m => Prism' s a -> Maybe s -> (Maybe a -> AForm m a) -> AForm m s
-- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
prismAForm p outer form = review p <$> form inner
where
inner = outer >>= preview p

6
src/Utils/Lens.hs
View File

@ -10,6 +10,12 @@ import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
_unValue :: Lens' (E.Value a) a _unValue :: Lens' (E.Value a) a
_unValue f (E.Value a) = E.Value <$> f a _unValue f (E.Value a) = E.Value <$> f a
_PathPiece :: PathPiece v => Prism' Text v
_PathPiece = prism' toPathPiece fromPathPiece
maybePrism :: Prism' a b -> Prism' (Maybe a) (Maybe b)
maybePrism p = prism' (fmap $ review p) (fmap $ preview p )
_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s _InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
_InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l

7
templates/correction.hamlet
View File

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

10
templates/sheetShow.hamlet
View File

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

2
templates/widgets/gradingSummary.hamlet
View File

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