Fix handling of URL-encoded jsonFields

See #392
This commit is contained in:
Gregor Kleen 2019-06-04 10:08:57 +02:00
parent 39485f7243
commit 332e83a111
3 changed files with 24 additions and 13 deletions

View File

@ -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|

View File

@ -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

View File

@ -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)