diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2e6525f8a..85d0bba6f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -228,6 +228,8 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) NrColumn: Nr SelectColumn: Auswahl +DBTablePagesize: Einträge +DBTablePagesizeAll: Alle CorrDownload: Herunterladen CorrUploadField: Korrekturen diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b3c2f8cb7..7836b9e88 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -53,6 +53,10 @@ import Data.Foldable (Foldable(foldMap)) import Data.Map (Map, (!)) import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + import Colonnade hiding (bool, fromMaybe, singleton) import qualified Colonnade (singleton) import Colonnade.Encode @@ -63,7 +67,7 @@ import Data.Ratio ((%)) import Control.Lens -import Data.Aeson (Options(..), defaultOptions, decodeStrict') +import Data.Aeson (Options(..), SumEncoding(..), defaultOptions) import Data.Aeson.Text import Data.Aeson.TH (deriveJSON) @@ -143,10 +147,58 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2 | otherwise = go (acc, is3 . (i:)) is2 + +data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll + deriving (Eq, Ord, Read, Show, Generic) + +instance Bounded PagesizeLimit where + minBound = PagesizeLimit minBound + maxBound = PagesizeAll + +instance Enum PagesizeLimit where + toEnum i + | toInteger i >= fromIntegral (minBound :: Int64) + , toInteger i <= fromIntegral (maxBound :: Int64) + = PagesizeLimit $ fromIntegral i + | toInteger i > fromIntegral (maxBound :: Int64) + = PagesizeAll + | otherwise + = error "toEnum PagesizeLimit: out of bounds" + fromEnum (PagesizeLimit i) + | toInteger i >= fromIntegral (minBound :: Int) + , toInteger i <= fromIntegral (maxBound :: Int) + = fromIntegral i + | otherwise + = error "fromEnum PagesizeLimit: out of bounds" + fromEnum PagesizeAll + = error "fromEnum PagesizeLimit: infinite" + + succ (PagesizeLimit i) + | i == maxBound = PagesizeAll + | otherwise = PagesizeLimit $ succ i + succ PagesizeAll = error "succ PagesizeLimit: out of bounds" + pred (PagesizeLimit i) + | i == minBound = error "pred PagesizeLimit: out of bounds" + | otherwise = PagesizeLimit $ pred i + pred PagesizeAll = PagesizeLimit maxBound + +instance PathPiece PagesizeLimit where + toPathPiece PagesizeAll = "all" + toPathPiece (PagesizeLimit n) = toPathPiece n + fromPathPiece str + | CI.mk str == "all" = Just PagesizeAll + | otherwise = PagesizeLimit <$> fromPathPiece str + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue + } ''PagesizeLimit + + data PaginationSettings = PaginationSettings { psSorting :: [SortingSetting] , psFilter :: Map FilterKey [Text] - , psLimit :: Int64 + , psLimit :: PagesizeLimit , psPage :: Int64 } @@ -156,7 +208,7 @@ instance Default PaginationSettings where def = PaginationSettings { psSorting = [] , psFilter = Map.empty - , psLimit = 50 + , psLimit = PagesizeLimit 50 , psPage = 0 } @@ -167,7 +219,7 @@ deriveJSON defaultOptions data PaginationInput = PaginationInput { piSorting :: Maybe [SortingSetting] , piFilter :: Maybe (Map FilterKey [Text]) - , piLimit :: Maybe Int64 + , piLimit :: Maybe PagesizeLimit , piPage :: Maybe Int64 } deriving (Eq, Ord, Show, Read, Generic) @@ -220,9 +272,11 @@ instance Default (PSValidator m x) where l <- asks piLimit case l of - Just l' + Just (PagesizeLimit l') | l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive - | otherwise -> modify $ \ps -> ps { psLimit = l' } + | otherwise -> modify $ \ps -> ps { psLimit = PagesizeLimit l' } + Just PagesizeAll + -> modify $ \ps -> ps { psLimit = PagesizeAll } Nothing -> return () asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p }) @@ -463,27 +517,36 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination") + 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") <*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter) - <*> iopt intField (wIdent "pagesize") + <*> iopt pathPieceField (wIdent "pagesize") <*> iopt intField (wIdent "page") - let filterPi - | FormSuccess PaginationInput{..} <- piPrevious <|> piInput - = def{ piSorting, piLimit } + let prevPi + | FormSuccess pi <- piPreviousRes <|> piInput + = pi | otherwise = def ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,) - <$> areq (jsonField True) "" (Just filterPi) + <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing) <*> dbtFilterUI + ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . renderAForm FormDBTablePagesize $ (,) + <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing) + <*> areq pagesizeField (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just . psLimit . snd . runPSValidator dbtable $ Just prevPi) + <* autosubmitButton + let - piResult = piPrevious <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes <|> piInput + piResult = piPreviousRes + <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes + <|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes + <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit @@ -509,16 +572,25 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db res <- dbtSQLQuery t E.orderBy (map (sqlSortDirection t) psSorting') case previousKeys of - Nothing -> do - E.limit psLimit - E.offset (psPage * psLimit) + Nothing + | PagesizeLimit l <- psLimit + -> do + E.limit l + E.offset (psPage * l) Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps + _other -> return () Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v) + firstRow :: Int64 + firstRow + | PagesizeLimit l <- psLimit + = succ (psPage * l) + | otherwise + = 1 - (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [succ (psPage * psLimit)..] rows' + (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [firstRow..] rows' getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest let @@ -547,6 +619,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db $ setParam (wIdent "page") Nothing . Map.foldrWithKey (\k _ f -> setParam (wIdent $ toPathPiece k) Nothing . f) id dbtFilter + pagesizeAction = tblLink + $ setParam (wIdent "page") Nothing + . setParam (wIdent "pagesize") Nothing + table' :: WriterT x m Widget table' = do @@ -571,7 +647,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return $(widgetFile "table/cell/body") let table = $(widgetFile "table/colonnade") - pageCount = max 1 . ceiling $ rowCount % psLimit + pageCount + | PagesizeLimit l <- psLimit + = max 1 . ceiling $ rowCount % l + | otherwise + = 1 pageNumbers = [0..pred pageCount] return $(widgetFile "table/layout") @@ -611,6 +691,16 @@ dbColonnade :: (Headedness h, Monoid x) -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) dbColonnade = id +pagesizeField :: Field Handler PagesizeLimit +pagesizeField = selectField $ do + MsgRenderer mr <- getMsgRenderer + return . flip OptionList fromPathPiece $ + map (\o -> Option (tshow o) (PagesizeLimit o) . toPathPiece $ PagesizeLimit o) opts ++ [Option (mr MsgDBTablePagesizeAll) PagesizeAll $ toPathPiece PagesizeAll] + where + opts :: [Int64] + opts = filter (> 0) . Set.toAscList . Set.fromList $ opts' <> map (`div` 2) opts' + + opts' = [ 10^n | n <- [1..3]] --- DBCell utility functions diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c754bf227..1c2bf385e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -15,8 +15,12 @@ import Data.Map.Lazy ((!)) import qualified Data.Map.Lazy as Map import qualified Data.Set as Set +import Control.Monad.Trans.Maybe (MaybeT(..)) + import Data.List ((!!)) +import Control.Lens ((&)) + import Web.PathPieces import Data.UUID @@ -28,7 +32,7 @@ import Utils.Message ------------------- -- | Use this type to pass information to the form template -data FormLayout = FormStandard | FormDBTableFilter +data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize renderAForm :: Monad m => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do @@ -144,6 +148,9 @@ inputDisabled = addAttr "disabled" "" inputReadonly :: FieldSettings site -> FieldSettings site inputReadonly = addAttr "readonly" "" +addAutosubmit :: FieldSettings site -> FieldSettings site +addAutosubmit = addAttr "data-autosubmit" "" + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ @@ -229,6 +236,9 @@ combinedButtonField = traverse b2f submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () submitButton = void $ combinedButtonField [BtnSubmit] +autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () +autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing + ------------------- -- Custom Fields -- ------------------- @@ -240,6 +250,12 @@ ciField :: ( Textual t ) => Field m (CI t) ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField +pathPieceField :: ( PathPiece a + , Monad m + , RenderMessage (HandlerSite m) FormMessage + ) => Field m a +pathPieceField = checkMMap (\t -> return . maybe (Left $ MsgInvalidEntry t) Right $ fromPathPiece t) toPathPiece textField + reorderField :: ( MonadHandler m , HandlerSite m ~ site , Eq a @@ -302,3 +318,16 @@ formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Ma formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml) formResultMaybe FormMissing _ = return Nothing formResultMaybe (FormSuccess res) f = f res + +runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a) +runInputGetMaybe form = do + res <- runInputGetResult form + return $ case res of + FormSuccess suc -> Just suc + _other -> Nothing +runInputPostMaybe form = do + res <- runInputPostResult form + return $ case res of + FormSuccess suc -> Just suc + _other -> Nothing +runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form) diff --git a/templates/table/layout.hamlet b/templates/table/layout.hamlet index 1c2fbf863..06f9e51aa 100644 --- a/templates/table/layout.hamlet +++ b/templates/table/layout.hamlet @@ -5,8 +5,11 @@ $else
^{table} $if pageCount > 1 -