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

Helpers for PSValidator

Browse Source
This commit is contained in:
Gregor Kleen 2018-06-29 19:18:10 +02:00
parent d33956dfaa
commit f93c3d6e47
4 changed files with 87 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
src/Handler/Corrections.hs
View File

@ -13,6 +13,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Handler.Corrections where module Handler.Corrections where
@ -107,10 +108,12 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId 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 ) makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
=> _ -> Colonnade h r' (DBCell m x) -> Handler (DBResult m x) => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
makeCorrectionsTable whereClause colChoices = do makeCorrectionsTable whereClause colChoices psValidator = 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 _ let tableData :: CorrectionTableExpr -> E.SqlQuery _
tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do tableData ((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 $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet 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) , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
) )
return (submission, sheet, crse, corrector) return (submission, sheet, crse, corrector)
dbTable def $ DBTable dbTable psValidator $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colChoices , dbtColonnade = colChoices
, dbtSorting = [ ( "term" , dbtSorting = [ ( "term"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
) )
, ( "course" , ( "course"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
) )
-- TODO , ( "sheet"
] , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
, dbtFilter = [] {- [ ( "term" )
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if , ( "corrector"
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) )
) ]
] -} , 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 , dbtAttrs = tableDefault
, dbtIdent = "corrections" :: Text , dbtIdent = "corrections" :: Text
} }
@ -157,9 +181,9 @@ instance RenderMessage UniWorX ActionCorrections where
data ActionCorrectionsData = CorrDownloadData data ActionCorrectionsData = CorrDownloadData
| CorrSetCorrectorData (Maybe UserId) | CorrSetCorrectorData (Maybe UserId)
correctionsR :: _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) actions = do correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
(actionRes, action) <- multiAction actions (actionRes, action) <- multiAction actions
@ -243,7 +267,10 @@ postCorrectionsR = do
, colSheet , colSheet
, colSubmissionLink , colSubmissionLink
] -- Continue here ] -- Continue here
correctionsR whereClause colonnade $ Map.fromList psValidator = def
& restrictFilter (\name _ -> name /= "corrector")
& restrictSorting (\name _ -> name /= "corrector")
correctionsR whereClause colonnade psValidator $ Map.fromList
[ downloadAction [ downloadAction
] ]
@ -259,7 +286,8 @@ postCourseCorrectionsR tid csh = do
, colCorrector , colCorrector
, colSubmissionLink , colSubmissionLink
] -- Continue here ] -- Continue here
correctionsR whereClause colonnade $ Map.fromList psValidator = def
correctionsR whereClause colonnade psValidator $ Map.fromList
[ downloadAction [ downloadAction
, assignAction cid , assignAction cid
] ]

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

@ -23,6 +23,8 @@ module Handler.Utils.Table.Pagination
, DBTable(..), IsDBTable(..) , DBTable(..), IsDBTable(..)
, PaginationSettings(..) , PaginationSettings(..)
, PSValidator(..) , PSValidator(..)
, defaultFilter, defaultSorting
, restrictFilter, restrictSorting
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..), sortable
, dbTable , dbTable
, widgetColonnade, formColonnade , widgetColonnade, formColonnade
@ -133,16 +135,16 @@ data DBTable m x = forall a r r' h i t.
) => DBTable ) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a { dbtSQLQuery :: t -> E.SqlQuery a
, dbtColonnade :: Colonnade h r' (DBCell m x) , dbtColonnade :: Colonnade h r' (DBCell m x)
, dbtSorting :: Map Text (SortColumn t) , dbtSorting :: Map (CI Text) (SortColumn t)
, dbtFilter :: Map Text (FilterColumn t) , dbtFilter :: Map (CI Text) (FilterColumn t)
, dbtAttrs :: Attribute -- FIXME: currently unused , dbtAttrs :: Attribute -- FIXME: currently unused
, dbtIdent :: i , dbtIdent :: i
} }
data PaginationSettings = PaginationSettings data PaginationSettings = PaginationSettings
{ psSorting :: [(Text, SortDirection)] { psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map Text [Text] , psFilter :: Map (CI Text) [Text]
, psLimit :: Int64 , psLimit :: Int64
, psPage :: Int64 , psPage :: Int64
, psShortcircuit :: Bool , psShortcircuit :: Bool
@ -168,6 +170,28 @@ instance Default (PSValidator m x) where
modify $ \ps -> ps { psLimit = psLimit def } modify $ \ps -> ps { psLimit = psLimit def }
tell . pure $ SomeMessage MsgPSLimitNonPositive 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 class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
type DBResult m x :: * type DBResult m x :: *
-- type DBResult' m x :: * -- type DBResult' m x :: *
@ -233,7 +257,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
[ Option t' (t, d) t' [ Option t' (t, d) t'
| (t, _) <- mapToList dbtSorting | (t, _) <- mapToList dbtSorting
, d <- [SortAsc, SortDesc] , d <- [SortAsc, SortDesc]
, let t' = t <> "-" <> toPathPiece d , let t' = CI.foldedCase t <> "-" <> toPathPiece d
] ]
(_, defPS) = runPSValidator dbtable Nothing (_, defPS) = runPSValidator dbtable Nothing
wIdent n wIdent n
@ -250,7 +274,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
psResult <- runInputGetResult $ PaginationSettings psResult <- runInputGetResult $ PaginationSettings
<$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) <$> (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 (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")

6
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -11,12 +11,14 @@ import Import hiding (singleton)
import Colonnade import Colonnade
import Colonnade.Encode import Colonnade.Encode
import Data.CaseInsensitive (CI)
data Sortable a = Sortable data Sortable a = Sortable
{ sortableKey :: Maybe Text { sortableKey :: Maybe (CI Text)
, sortableContent :: a , 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) sortable k h = singleton (Sortable k h)
instance Headedness Sortable where instance Headedness Sortable where

4
templates/table/cell/header.hamlet
View File

@ -2,10 +2,10 @@
$maybe flag <- sortableKey $maybe flag <- sortableKey
$case directions $case directions
$of [SortAsc] $of [SortAsc]
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-desc")}> <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-desc")}>
^{widget} ^{widget}
$of _ $of _
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-asc")}> <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-asc")}>
^{widget} ^{widget}
$nothing $nothing
^{widget} ^{widget}