diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 108242b67..5a4b65e10 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -18,7 +18,6 @@ module Handler.Utils.Table.Pagination , defaultFilter, defaultSorting , restrictFilter, restrictSorting , ToSortable(..), Sortable(..) - , runPaginationSettings' , dbTable , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade @@ -214,7 +213,6 @@ data PaginationSettings = PaginationSettings , psFilter :: Map FilterKey [Text] , psLimit :: PagesizeLimit , psPage :: Int64 - , psShortcircuit :: Bool } makeLenses_ ''PaginationSettings @@ -225,7 +223,6 @@ instance Default PaginationSettings where , psFilter = Map.empty , psLimit = PagesizeLimit 50 , psPage = 0 - , psShortcircuit = False } deriveJSON defaultOptions @@ -567,17 +564,29 @@ instance IsDBTable m a => IsString (DBCell m a) where fromString = cell . fromString -data PaginationState = PaginationState - { filterWdgt, pagesizeWdgt :: Widget - , filterEnc, pagesizeEnc :: Enctype - , paginationInput :: PaginationInput - } +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 + } -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") @@ -610,7 +619,7 @@ runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toP psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit let - ((errs, paginationSettings), paginationInput) + ((errs, PaginationSettings{..}), paginationInput@PaginationInput{..}) | FormSuccess pi <- piResult , not $ piIsUnset pi = (, pi) . runPSValidator dbtable $ Just pi @@ -618,45 +627,10 @@ runPaginationSettings PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toP = (, 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')