From 332e83a111fae491f8240e2d30c5c97f7b1baabe Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Tue, 4 Jun 2019 10:08:57 +0200
Subject: [PATCH] Fix handling of URL-encoded jsonFields

See #392
---
 src/Handler/Utils/Form.hs             |  2 +-
 src/Handler/Utils/Table/Pagination.hs |  8 ++++++--
 src/Utils/Form.hs                     | 27 +++++++++++++++++----------
 3 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 0b661e87e..0b6850b24 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -689,7 +689,7 @@ jsonField hide = Field{..}
     inputType
       | hide      = "hidden"
       | otherwise = "text"
-    fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
+    fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v)
     fieldParse [] [] = return $ Right Nothing
     fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
     fieldView theId name attrs val isReq = liftWidgetT [whamlet|
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 52c1b3ec8..e87d4a405 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -641,8 +641,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
       , fieldEnctype = UrlEncoded
       }
 
-  piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
-  let piPreviousRes = maybe FormMissing FormSuccess piPrevious
+  piPreviousPost <- lift . runInputPost $ iopt (jsonField True) (wIdent "pagination")
+  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField True) (wIdent "pagination")
+  let
+    piPreviousRes = maybe FormMissing FormSuccess $ piPreviousPost <|> piPreviousGet
+  $logDebugS "dbTable" [st|#{wIdent "pagination"}: #{tshow piPreviousRes}|]
+
   previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
 
   piInput <- lift . runInputGetResult $ PaginationInput
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 2c04192ec..629e82de8 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -621,18 +621,25 @@ formResult' (FormFailure _) = Nothing
 formResult' (FormSuccess x) = Just x
 
 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
+runInputGetMaybe = fmap formResult' . runInputGetResult
+runInputPostMaybe = fmap formResult' . runInputPostResult
 runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)
 
+runInputResult :: MonadHandler m => FormInput m a -> m (FormResult a)
+runInputResult form = do
+  postRes <- runInputPostResult form
+  getRes  <- runInputGetResult form
+  return $ case (postRes, getRes) of
+    (FormSuccess a, _) -> FormSuccess a 
+    (_, FormSuccess b) -> FormSuccess b
+    (postRes', _)      -> postRes'
+
+runInput :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => FormInput m a -> m a
+runInput = runInputResult >=> \case
+  FormFailure errs -> invalidArgs errs
+  FormMissing      -> invalidArgsI [MsgValueRequired]
+  FormSuccess a    -> return a
+
 hoistAForm :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> AForm m b -> AForm n b
 hoistAForm f (AForm g) = AForm (\x y z ->f $ g x y z)