Backend work for #116

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

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
+  let prevPi
-        | FormSuccess PaginationInput{..} <- piPrevious <|> piInput
+        | FormSuccess pi <- piPreviousRes <|> piInput
-          = def{ piSorting, piLimit }
+          = 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
+      Nothing
-        E.limit psLimit
+        | PagesizeLimit l <- psLimit
-        E.offset (psPage * 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
 

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)

templates/table/layout.hamlet

@@ -5,8 +5,11 @@ $else
   <div .scrolltable>
     ^{table}
   $if pageCount > 1
-    <ul ##{wIdent "pagination"} .pagination>
+    <div .pagination>
-      $forall p <- pageNumbers
+      <form .pagesize method=GET enctype=#{pagesizeEnc} action=#{pagesizeAction}>
-        <li .pagination-link :p == psPage:.current>
+        ^{pagesizeWdgt}
-          <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+      <ul ##{wIdent "pagination"} .pages>
-            _{MsgPage (succ p)}
+        $forall p <- pageNumbers
+          <li .page-link :p == psPage:.current>
+            <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+              _{MsgPage (succ p)}

templates/table/layout.julius

@@ -22,7 +22,7 @@
       });
 
       if (pagination) {
-        Array.from(pagination.querySelectorAll('.pagination-link'))
+        Array.from(pagination.querySelectorAll('.page-link'))
           .forEach(function(p) {
             p.addEventListener('click', clickHandler);
           });
@@ -32,12 +32,6 @@
         event.preventDefault();
         var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
         updateTableFrom(url);
-
-
-        ths.forEach(function(th) {
-          // th.removeEventListener('click', clickHandler);
-          console.log('removed handler from', th);
-        });
       }
 
       function getClickDestination(el) {

templates/table/layout.lucius

@@ -1,39 +1,51 @@
 /* PAGINATION */
 .pagination {
-  margin-top: 20px;
+    margin-top: 20px;
-  text-align: center;
+    display: flex;
+    flex-direction: row;
 
-  .pagination-link {
+    .pagesize {
-    margin: 0 7px;
+        float: left;
-    display: inline-block;
+        flex-grow: 0;
-    background-color: var(--color-grey);
-
-    a {
-      color: var(--color-lightwhite);
-      padding: 7px 13px;
-      display: inline-block;
     }
 
-    &:not(.current):hover {
+    .pages {
-      background-color: var(--color-lighter);
+        text-align: center;
+        flex-grow: 1;
+        margin: 0;
 
-      a {
+        .page-link {
-        color: var(--color-lightwhite);
+          margin: 0 7px;
-      }
+          display: inline-block;
+          background-color: var(--color-grey);
+
+          a {
+            color: var(--color-lightwhite);
+            padding: 7px 13px;
+            display: inline-block;
+          }
+
+          &:not(.current):hover {
+            background-color: var(--color-lighter);
+
+            a {
+              color: var(--color-lightwhite);
+            }
+          }
+
+          &.current {
+            pointer-events: none;
+            background-color: var(--color-light);
+
+            a {
+              text-decoration: underline;
+              pointer-events: none;
+            }
+          }
+
+          &:last-child {
+            margin-right: 0;
+          }
+        }
     }
-
-    &.current {
-      pointer-events: none;
-      background-color: var(--color-light);
-
-      a {
-        text-decoration: underline;
-        pointer-events: none;
-      }
-    }
-
-    &:last-child {
-      margin-right: 0;
-    }
-  }
 }

templates/widgets/form.hamlet

@@ -1,6 +1,9 @@
 $newline never
 #{fragment}
 $case formLayout
+  $of FormDBTablePagesize
+    $forall view <- views
+      ^{fvInput view}
   $of _
     $forall view <- views
       $# TODO: add class 'form-group--submit' if this is the submit-button view

templates/widgets/form.julius

@@ -102,3 +102,26 @@ document.addEventListener('setup', function(e) {
 document.addEventListener('DOMContentLoaded', function() {
   document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'showHide' }, bubbles: true, cancelable: true }))
 });
+
+
+document.addEventListener('setup', function(e) {
+    if (e.detail.module && e.detail.module !== 'autoSubmit')
+        return;
+
+    Array.from(e.detail.scope.querySelectorAll('[data-autosubmit]:not(.js-initialized)')).forEach(function(elem) {
+        if ((elem instanceof HTMLInputElement && elem.type == 'submit') || (elem instanceof HTMLButtonElement && elem.type == 'submit')) {
+            var ancestor = elem.closest('.form-group');
+            var target = ancestor || elem;
+
+            target.classList.add('hidden');
+        } else if (elem.form) {
+            elem.addEventListener('change', function () { elem.form.submit() })
+        }
+
+        elem.classList.add('.js-initalized');
+    });
+});
+
+document.addEventListener('DOMContentLoaded', function() {
+  document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'autoSubmit' }, bubbles: true, cancelable: true }))
+});

templates/widgets/form.lucius

@@ -17,3 +17,8 @@ fieldset {
   opacity: 0;
   margin: 0;
 }
+
+.select--pagesize {
+  width: 5em;
+  min-width: 75px;
+}