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

Expose runPaginationSettings'

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-24 16:21:30 +01:00
parent 795dd29aa3
commit a03577f970
1 changed files with 48 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -17,6 +17,7 @@ module Handler.Utils.Table.Pagination
, defaultFilter, defaultSorting
, restrictFilter, restrictSorting
, ToSortable(..), Sortable(..)
, runPaginationSettings'
, dbTable
, dbTableWidget, dbTableWidget'
, widgetColonnade, formColonnade, dbColonnade
@ -212,6 +213,7 @@ data PaginationSettings = PaginationSettings
, psFilter :: Map FilterKey [Text]
, psLimit :: PagesizeLimit
, psPage :: Int64
, psShortcircuit :: Bool
}
makeLenses_ ''PaginationSettings
@ -222,6 +224,7 @@ instance Default PaginationSettings where
, psFilter = Map.empty
, psLimit = PagesizeLimit 50
, psPage = 0
, psShortcircuit = False
}
deriveJSON defaultOptions
@ -554,29 +557,17 @@ instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let
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
}
data PaginationState = PaginationState
{ filterWdgt, pagesizeWdgt :: Widget
, filterEnc, pagesizeEnc :: Enctype
, paginationInput :: PaginationInput
}
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")
let piPreviousRes = maybe FormMissing FormSuccess piPrevious
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
piInput <- lift . runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
@ -609,7 +600,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
let
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
((errs, paginationSettings), paginationInput)
| FormSuccess pi <- piResult
, not $ piIsUnset pi
= (, pi) . runPSValidator dbtable $ Just pi
@ -617,10 +608,45 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= (, def) . first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
| otherwise
= (, def) $ runPSValidator dbtable Nothing
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
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
res <- dbtSQLQuery t
E.orderBy (map (sqlSortDirection t) psSorting')