Backend work for #116

2018-12-14 21:39:56 +01:00 · 2018-12-14 21:39:56 +01:00 · ca5f9bffe0
commit ca5f9bffe0
parent c21b645446
9 changed files with 223 additions and 62 deletions
--- 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
--- 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

--- 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)
--- a/templates/table/layout.hamlet
+++ b/templates/table/layout.hamlet
@ -5,8 +5,11 @@ $else
  <div .scrolltable>
    ^{table}
  $if pageCount > 1
-    <ul ##{wIdent "pagination"} .pagination>
-      $forall p <- pageNumbers
-        <li .pagination-link :p == psPage:.current>
-          <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
-            _{MsgPage (succ p)}
+    <div .pagination>
+      <form .pagesize method=GET enctype=#{pagesizeEnc} action=#{pagesizeAction}>
+        ^{pagesizeWdgt}
+      <ul ##{wIdent "pagination"} .pages>
+        $forall p <- pageNumbers
+          <li .page-link :p == psPage:.current>
+            <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+              _{MsgPage (succ p)}
--- a/templates/table/layout.julius
+++ b/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) {
--- a/templates/table/layout.lucius
+++ b/templates/table/layout.lucius
@ -1,39 +1,51 @@
 /* PAGINATION */
 .pagination {
-  margin-top: 20px;
-  text-align: center;
+    margin-top: 20px;
+    display: flex;
+    flex-direction: row;

-  .pagination-link {
-    margin: 0 7px;
-    display: inline-block;
-    background-color: var(--color-grey);
-
-    a {
-      color: var(--color-lightwhite);
-      padding: 7px 13px;
-      display: inline-block;
+    .pagesize {
+        float: left;
+        flex-grow: 0;
    }

-    &:not(.current):hover {
-      background-color: var(--color-lighter);
+    .pages {
+        text-align: center;
+        flex-grow: 1;
+        margin: 0;

-      a {
-        color: var(--color-lightwhite);
-      }
+        .page-link {
+          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;
-    }
-  }
 }
--- a/templates/widgets/form.hamlet
+++ b/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
--- a/templates/widgets/form.julius
+++ b/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 }))
+});
--- a/templates/widgets/form.lucius
+++ b/templates/widgets/form.lucius
@ -17,3 +17,8 @@ fieldset {
  opacity: 0;
  margin: 0;
 }
+
+.select--pagesize {
+  width: 5em;
+  min-width: 75px;
+}