From f93c3d6e470cd65118673e563d44d67ca7c6ae15 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 29 Jun 2018 19:18:10 +0200 Subject: [PATCH] Helpers for PSValidator --- src/Handler/Corrections.hs | 74 ++++++++++++++------- src/Handler/Utils/Table/Pagination.hs | 36 ++++++++-- src/Handler/Utils/Table/Pagination/Types.hs | 6 +- templates/table/cell/header.hamlet | 4 +- 4 files changed, 87 insertions(+), 33 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2021c54a6..bc01e3051 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -13,6 +13,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Handler.Corrections where @@ -106,11 +107,13 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId + +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)) makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h ) - => _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x) -makeCorrectionsTable whereClause colChoices = do - let tableData :: (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) -> E.SqlQuery _ + => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) +makeCorrectionsTable whereClause colChoices psValidator = do + let tableData :: CorrectionTableExpr -> E.SqlQuery _ tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet @@ -122,23 +125,44 @@ makeCorrectionsTable whereClause colChoices = do , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) ) return (submission, sheet, crse, corrector) - dbTable def $ DBTable + dbTable psValidator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colChoices - , dbtSorting = [ ( "term" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm - ) - , ( "course" - , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand - ) - -- TODO - ] - , dbtFilter = [] {- [ ( "term" - , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - ] -} + , dbtSorting = [ ( "term" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm + ) + , ( "course" + , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand + ) + , ( "sheet" + , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName + ) + , ( "corrector" + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName + ) + ] + , dbtFilter = [ ( "term" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if + | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) + ) + , ( "course" + , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if + | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs) + ) + , ( "sheet" + , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if + | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns) + ) + , ( "corrector" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if + | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool) + | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) + E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) + ) + ] , dbtAttrs = tableDefault , dbtIdent = "corrections" :: Text } @@ -157,9 +181,9 @@ instance RenderMessage UniWorX ActionCorrections where data ActionCorrectionsData = CorrDownloadData | CorrSetCorrectorData (Maybe UserId) -correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent -correctionsR whereClause (formColonnade -> displayColumns) actions = do - tableForm <- makeCorrectionsTable whereClause displayColumns +correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent +correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do + tableForm <- makeCorrectionsTable whereClause displayColumns psValidator ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (actionRes, action) <- multiAction actions @@ -243,7 +267,10 @@ postCorrectionsR = do , colSheet , colSubmissionLink ] -- Continue here - correctionsR whereClause colonnade $ Map.fromList + psValidator = def + & restrictFilter (\name _ -> name /= "corrector") + & restrictSorting (\name _ -> name /= "corrector") + correctionsR whereClause colonnade psValidator $ Map.fromList [ downloadAction ] @@ -259,7 +286,8 @@ postCourseCorrectionsR tid csh = do , colCorrector , colSubmissionLink ] -- Continue here - correctionsR whereClause colonnade $ Map.fromList + psValidator = def + correctionsR whereClause colonnade psValidator $ Map.fromList [ downloadAction , assignAction cid ] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 6e7444051..13a94ad51 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -23,6 +23,8 @@ module Handler.Utils.Table.Pagination , DBTable(..), IsDBTable(..) , PaginationSettings(..) , PSValidator(..) + , defaultFilter, defaultSorting + , restrictFilter, restrictSorting , ToSortable(..), Sortable(..), sortable , dbTable , widgetColonnade, formColonnade @@ -133,16 +135,16 @@ data DBTable m x = forall a r r' h i t. ) => DBTable { dbtSQLQuery :: t -> E.SqlQuery a , dbtColonnade :: Colonnade h r' (DBCell m x) - , dbtSorting :: Map Text (SortColumn t) - , dbtFilter :: Map Text (FilterColumn t) + , dbtSorting :: Map (CI Text) (SortColumn t) + , dbtFilter :: Map (CI Text) (FilterColumn t) , dbtAttrs :: Attribute -- FIXME: currently unused , dbtIdent :: i } data PaginationSettings = PaginationSettings - { psSorting :: [(Text, SortDirection)] - , psFilter :: Map Text [Text] + { psSorting :: [(CI Text, SortDirection)] + , psFilter :: Map (CI Text) [Text] , psLimit :: Int64 , psPage :: Int64 , psShortcircuit :: Bool @@ -168,6 +170,28 @@ instance Default (PSValidator m x) where modify $ \ps -> ps { psLimit = psLimit def } tell . pure $ SomeMessage MsgPSLimitNonPositive +defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x +defaultFilter psFilter (runPSValidator -> f) = PSValidator g + where + g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing + g dbTable x = f dbTable x + +defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x +defaultSorting psSorting (runPSValidator -> f) = PSValidator g + where + g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing + g dbTable x = f dbTable x + +restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x +restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps + where + restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p } + +restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x +restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps + where + restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } + class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where type DBResult m x :: * -- type DBResult' m x :: * @@ -233,7 +257,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), [ Option t' (t, d) t' | (t, _) <- mapToList dbtSorting , d <- [SortAsc, SortDesc] - , let t' = t <> "-" <> toPathPiece d + , let t' = CI.foldedCase t <> "-" <> toPathPiece d ] (_, defPS) = runPSValidator dbtable Nothing wIdent n @@ -250,7 +274,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), psResult <- runInputGetResult $ PaginationSettings <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) - <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ wIdent k) dbtFilter) + <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> ireq checkBoxField (wIdent "table-only") diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index 416079055..0a0b6c1c2 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -11,12 +11,14 @@ import Import hiding (singleton) import Colonnade import Colonnade.Encode +import Data.CaseInsensitive (CI) + data Sortable a = Sortable - { sortableKey :: Maybe Text + { sortableKey :: Maybe (CI Text) , sortableContent :: a } -sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c +sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c sortable k h = singleton (Sortable k h) instance Headedness Sortable where diff --git a/templates/table/cell/header.hamlet b/templates/table/cell/header.hamlet index d8e5b6cd4..0a87cda2c 100644 --- a/templates/table/cell/header.hamlet +++ b/templates/table/cell/header.hamlet @@ -2,10 +2,10 @@ $maybe flag <- sortableKey $case directions $of [SortAsc] - "-desc")}> + "-desc")}> ^{widget} $of _ - "-asc")}> + "-asc")}> ^{widget} $nothing ^{widget}