parent
14c8aa5e30
commit
9879c9f0d5
@ -17,7 +17,6 @@ module Handler.Utils.Table.Pagination
|
|||||||
, defaultFilter, defaultSorting
|
, defaultFilter, defaultSorting
|
||||||
, restrictFilter, restrictSorting
|
, restrictFilter, restrictSorting
|
||||||
, ToSortable(..), Sortable(..)
|
, ToSortable(..), Sortable(..)
|
||||||
, runPaginationSettings'
|
|
||||||
, dbTable
|
, dbTable
|
||||||
, dbTableWidget, dbTableWidget'
|
, dbTableWidget, dbTableWidget'
|
||||||
, widgetColonnade, formColonnade, dbColonnade
|
, widgetColonnade, formColonnade, dbColonnade
|
||||||
@ -213,7 +212,6 @@ data PaginationSettings = PaginationSettings
|
|||||||
, psFilter :: Map FilterKey [Text]
|
, psFilter :: Map FilterKey [Text]
|
||||||
, psLimit :: PagesizeLimit
|
, psLimit :: PagesizeLimit
|
||||||
, psPage :: Int64
|
, psPage :: Int64
|
||||||
, psShortcircuit :: Bool
|
|
||||||
}
|
}
|
||||||
|
|
||||||
makeLenses_ ''PaginationSettings
|
makeLenses_ ''PaginationSettings
|
||||||
@ -224,7 +222,6 @@ instance Default PaginationSettings where
|
|||||||
, psFilter = Map.empty
|
, psFilter = Map.empty
|
||||||
, psLimit = PagesizeLimit 50
|
, psLimit = PagesizeLimit 50
|
||||||
, psPage = 0
|
, psPage = 0
|
||||||
, psShortcircuit = False
|
|
||||||
}
|
}
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
@ -557,17 +554,29 @@ instance IsDBTable m a => IsString (DBCell m a) where
|
|||||||
fromString = cell . fromString
|
fromString = cell . fromString
|
||||||
|
|
||||||
|
|
||||||
data PaginationState = PaginationState
|
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
|
||||||
{ filterWdgt, pagesizeWdgt :: Widget
|
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
||||||
, filterEnc, pagesizeEnc :: Enctype
|
let
|
||||||
, paginationInput :: PaginationInput
|
sortingOptions = mkOptionList
|
||||||
}
|
[ Option t' (SortingSetting t d) t'
|
||||||
|
| (t, _) <- mapToList dbtSorting
|
||||||
|
, d <- [SortAsc, SortDesc]
|
||||||
|
, let t' = toPathPiece $ SortingSetting t d
|
||||||
|
]
|
||||||
|
wIdent :: Text -> Text
|
||||||
|
wIdent = toPathPiece . WithIdent dbtIdent
|
||||||
|
dbsAttrs'
|
||||||
|
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
||||||
|
| otherwise = dbsAttrs
|
||||||
|
multiTextField = Field
|
||||||
|
{ fieldParse = \ts _ -> return . Right $ Just ts
|
||||||
|
, fieldView = error "multiTextField: should not be rendered"
|
||||||
|
, fieldEnctype = UrlEncoded
|
||||||
|
}
|
||||||
|
|
||||||
runPaginationSettings :: (MonadHandler m', HandlerSite m' ~ UniWorX) => PSValidator m x -> DBTable m x -> ReaderT (YesodPersistBackend UniWorX) m' (PaginationSettings, PaginationState)
|
|
||||||
runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), .. } = hoist liftHandlerT $ do
|
|
||||||
|
|
||||||
piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
|
piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
|
||||||
let piPreviousRes = maybe FormMissing FormSuccess piPrevious
|
let piPreviousRes = maybe FormMissing FormSuccess piPrevious
|
||||||
|
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
|
||||||
|
|
||||||
piInput <- lift . runInputGetResult $ PaginationInput
|
piInput <- lift . runInputGetResult $ PaginationInput
|
||||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||||
@ -600,7 +609,7 @@ runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toP
|
|||||||
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
||||||
|
|
||||||
let
|
let
|
||||||
((errs, paginationSettings), paginationInput)
|
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
|
||||||
| FormSuccess pi <- piResult
|
| FormSuccess pi <- piResult
|
||||||
, not $ piIsUnset pi
|
, not $ piIsUnset pi
|
||||||
= (, pi) . runPSValidator dbtable $ Just pi
|
= (, pi) . runPSValidator dbtable $ Just pi
|
||||||
@ -608,45 +617,10 @@ runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toP
|
|||||||
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
||||||
| otherwise
|
| otherwise
|
||||||
= (, def) $ runPSValidator dbtable Nothing
|
= (, def) $ runPSValidator dbtable Nothing
|
||||||
|
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
|
||||||
|
|
||||||
mapM_ (addMessageI Warning) errs
|
mapM_ (addMessageI Warning) errs
|
||||||
|
|
||||||
return (paginationSettings{ psShortcircuit }, PaginationState{..})
|
|
||||||
where
|
|
||||||
wIdent :: Text -> Text
|
|
||||||
wIdent = toPathPiece . WithIdent dbtIdent
|
|
||||||
sortingOptions = mkOptionList
|
|
||||||
[ Option t' (SortingSetting t d) t'
|
|
||||||
| (t, _) <- mapToList dbtSorting
|
|
||||||
, d <- [SortAsc, SortDesc]
|
|
||||||
, let t' = toPathPiece $ SortingSetting t d
|
|
||||||
]
|
|
||||||
multiTextField = Field
|
|
||||||
{ fieldParse = \ts _ -> return . Right $ Just ts
|
|
||||||
, fieldView = error "multiTextField: should not be rendered"
|
|
||||||
, fieldEnctype = UrlEncoded
|
|
||||||
}
|
|
||||||
|
|
||||||
runPaginationSettings' :: forall m' m x. (MonadHandler m', HandlerSite m' ~ UniWorX)
|
|
||||||
=> PSValidator m x -> DBTable m x -> ReaderT (YesodPersistBackend UniWorX) m' PaginationSettings
|
|
||||||
runPaginationSettings' psValidator dbtable = fst <$> runPaginationSettings psValidator dbtable
|
|
||||||
|
|
||||||
|
|
||||||
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
|
|
||||||
dbTable psValidator dbtable@DBTable{ dbtIdent = toPathPiece -> dbtIdent, dbtStyle = DBStyle{..}, .. } = do
|
|
||||||
let
|
|
||||||
wIdent :: Text -> Text
|
|
||||||
wIdent = toPathPiece . WithIdent dbtIdent
|
|
||||||
dbsAttrs'
|
|
||||||
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
|
||||||
| otherwise = dbsAttrs
|
|
||||||
|
|
||||||
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
|
|
||||||
|
|
||||||
(PaginationSettings{..}, PaginationState{ paginationInput = paginationInput@PaginationInput{..}, .. })
|
|
||||||
<- runPaginationSettings psValidator dbtable
|
|
||||||
let psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
|
|
||||||
|
|
||||||
rows' <- E.select . E.from $ \t -> do
|
rows' <- E.select . E.from $ \t -> do
|
||||||
res <- dbtSQLQuery t
|
res <- dbtSQLQuery t
|
||||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user