Helpers for PSValidator
This commit is contained in:
Gregor Kleen
parent
d33956dfaa
commit
f93c3d6e47
@ -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
|
||||
]
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -2,10 +2,10 @@
|
||||
$maybe flag <- sortableKey
|
||||
$case directions
|
||||
$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}
|
||||
$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}
|
||||
$nothing
|
||||
^{widget}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user