From fdbec180dbe3d95b195cf77e1c34da86efcacae5 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 16 Jan 2019 13:36:08 +0100 Subject: [PATCH] Filter Submissions by Course --- routes | 1 + src/Handler/Corrections.hs | 44 ++++++++++++++------ src/Handler/Course.hs | 5 +++ src/Utils/Form.hs | 14 ++++++- templates/table/layout-filter-default.hamlet | 2 + 5 files changed, 52 insertions(+), 14 deletions(-) diff --git a/routes b/routes index 53ff400b2..f26d741f3 100644 --- a/routes +++ b/routes @@ -69,6 +69,7 @@ /users CUsersR GET /users/#CryptoUUIDUser CUserR GET !lecturerANDparticipant /correctors CHiWisR GET + /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector !/ex/new SheetNewR GET POST diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 794d88071..8eb025a30 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -13,18 +13,19 @@ import Handler.Utils.Delete import Utils.Lens +import Data.List (nub) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Text as Text +import qualified Data.CaseInsensitive as CI import Data.Semigroup (Sum(..)) import Data.Monoid (All(..)) -- import Data.Time --- import qualified Data.Text as T -- import Data.Function ((&)) -- -- import Colonnade hiding (fromMaybe, singleton, bool) @@ -91,6 +92,11 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel +colSchool :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) + $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> + anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|] + colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh) @@ -192,8 +198,8 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' dbtParams = do let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _ dbtSQLQuery = correctionsTableQuery whereClause (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> @@ -237,6 +243,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = d , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints ) + , ( "israted" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime + ) , ( "ratingtime" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime ) @@ -276,8 +285,8 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = d E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) ] - , dbtFilterUI = mempty - , dbtStyle = def + , dbtFilterUI = fromMaybe mempty dbtFilterUI + , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (\_ -> defaultDBSFilterLayout) dbtFilterUI } , dbtParams , dbtIdent = "corrections" :: Text } @@ -299,8 +308,8 @@ data ActionCorrectionsData = CorrDownloadData | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent -correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do +correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent +correctionsR whereClause (formColonnade -> displayColumns) dbtFilterUI psValidator actions = do Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) @@ -310,7 +319,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = ((actionRes', table), statistics) <- runDB $ do -- Query for Table - tableRes <- makeCorrectionsTable whereClause displayColumns psValidator return def + tableRes <- makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator return def { dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAddSubmit = True , dbParamsFormAdditional = \frag -> do @@ -466,6 +475,7 @@ postCorrectionsR = do colonnade = mconcat [ colSelect , dbRow + , colSchool , colTerm , colCourse , colSheet @@ -475,10 +485,19 @@ postCorrectionsR = do , colRating , colRated ] -- Continue here + filterUI = Just $ \mPrev -> mconcat + [ Map.singleton "course" . maybeToList <$> aopt (lift `hoistField` selectField courseOptions) (fslI MsgCourse) (Just <$> listToMaybe =<< Map.lookup "course" =<< mPrev) + + ] + courseOptions = runDB $ do + courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessDB (CourseR courseTerm courseSchool courseShorthand CNotesR) False) + optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses + psValidator = def & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") - correctionsR whereClause colonnade psValidator $ Map.fromList + & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] + correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction ] @@ -500,7 +519,7 @@ postCCorrectionsR tid ssh csh = do , colAssigned ] -- Continue here psValidator = def - correctionsR whereClause colonnade psValidator $ Map.fromList + correctionsR whereClause colonnade Nothing psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction @@ -523,7 +542,7 @@ postSSubsR tid ssh csh shn = do , colAssigned ] psValidator = def - correctionsR whereClause colonnade psValidator $ Map.fromList + correctionsR whereClause colonnade Nothing psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid @@ -811,6 +830,7 @@ postCorrectionsGradeR = do let whereClause = ratedBy uid displayColumns = mconcat -- should match getSSubsR for consistent UX [ dbRow + , colSchool , colTerm , colCourse , colSheet @@ -829,7 +849,7 @@ postCorrectionsGradeR = do void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True return i - (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns mempty psValidator dbtProj' $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR , dbParamsFormAddSubmit = True } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a58bbb03b..fea34eb3e 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -620,3 +620,8 @@ getCUserR _tid _ssh _csh uCId = do getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCHiWisR = error "CHiWisR: Not implemented" + +getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +-- NOTE: The route getNotesR is abused for correctorORlecturer access rights! +getCNotesR = error "CNotesR: Not implemented" +postCNotesR = error "CNotesR: Not implemented" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index df055660d..696c10644 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -149,7 +149,7 @@ noValidate = addAttr "formnovalidate" "" inputDisabled :: FieldSettings site -> FieldSettings site inputDisabled = addAttr "disabled" "" - + inputReadonly :: FieldSettings site -> FieldSettings site inputReadonly = addAttr "readonly" "" @@ -340,7 +340,7 @@ reorderField :: ( MonadHandler m , HandlerSite m ~ site , Eq a , Show a - ) => HandlerT site IO (OptionList a) -> Field m [a] + ) => HandlerT site IO (OptionList a) -> Field m [a] -- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result) reorderField optList = Field{..} where @@ -437,3 +437,13 @@ runInputPostMaybe form = do FormSuccess suc -> Just suc _other -> Nothing runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form) + +hoistAForm :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> AForm m b -> AForm n b +hoistAForm f (AForm g) = AForm (\x y z ->f $ g x y z) + +hoistField :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> Field m b -> Field n b +hoistField f Field{..} = Field + { fieldParse = \x y -> f $ fieldParse x y + , fieldView + , fieldEnctype + } diff --git a/templates/table/layout-filter-default.hamlet b/templates/table/layout-filter-default.hamlet index 9291c30fb..05b776a8f 100644 --- a/templates/table/layout-filter-default.hamlet +++ b/templates/table/layout-filter-default.hamlet @@ -2,5 +2,7 @@ $newline never
^{filterWgdt} +