diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# aeson-commit + +## Parse Aeson data with commitment + +Aeson parsers backtracks too much for some use cases. The commit +parser forbids backtracking for already committed parses. diff --git a/aeson-commit.cabal b/aeson-commit.cabal new file mode 100644 --- /dev/null +++ b/aeson-commit.cabal @@ -0,0 +1,48 @@ +cabal-version: >=1.10 +name: aeson-commit +version: 1.0 +license: BSD3 +copyright: 2020 Cross Compass Ltd. +maintainer: jonascarpay@gmail.com +author: + Viktor Kronvall , Jonas Carpay + +synopsis: Parse Aeson data with commitment +description: + Aeson parsers backtracks too much for some use cases. + The commit parser forbids backtracking for already committed parses. + +category: Web +build-type: Simple +extra-source-files: README.md + +library + exposed-modules: Data.Aeson.Commit + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing + build-depends: + aeson >=1.5.4.1 && <2 + , base >=4.13.0.0 && <5 + , mtl >=2.2.2 && <3 + , text >=1.2.4.0 && <2 + +test-suite tasty + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/tasty + default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing + build-depends: + aeson >=1.5.4.1 && <2 + , aeson-commit + , aeson-qq >=0.8.3 && <1 + , base >=4.13.0.0 && <5 + , containers >=0.6.2.1 && <1 + , hspec >=2.7.4 && <3 + , mtl >=2.2.2 && <3 + , some >=1.0.1 && <2 + , tasty >=1.3.1 && <2 + , tasty-hspec >=1.1.5.1 && <2 + , text >=1.2.4.0 && <2 + , transformers >=0.5.6.2 && <1 diff --git a/src/Data/Aeson/Commit.hs b/src/Data/Aeson/Commit.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Commit.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +{-| + Commitment mechanism for aeson parsers. + This is comes up when you e.g. want to make a distinction between missing keys and malformed keys. + As an example, this parser will look for a key @"nested"@, and if present try to read the embedded @"value"@, or alternatively look for a top level @"value"@: + + > parse o = (o .:> "nested") (withObject "nestedObj" (.: "value")) + > <|> tryParser (o .: "value") + + > { value: "foo", otherField: "bar" } + > -> Right "foo" + > + > { value: "foo", nested: { value: "bar" } } + > -> Right "bar" + > + > { value: "foo", nested: { bar: 9 } } + > -> Left "Error in $.nested: key \"value\" not found" + > + > { value: "foo", nested: 9 } + > -> Left "Error in $.nested: parsing nestedObj failed, expected Object, but encountered Number" + > + > {} + > -> Left + > "Error in $: No match, + > - key \"value\" not found" + > - key \"nested\" not found" + +-} +module Data.Aeson.Commit where + +import Control.Applicative (Alternative (..)) +import Control.Monad.Except +import Data.Aeson.Types +import Data.Text (Text) +import Data.Void (Void, absurd) + +-- | A 'Parser' that has _two_ failure modes; recoverable and non-recoverable. +-- The default, recoverable failure is the equivalent to aeson's default 'Parser' behavior. +-- The non-recoverable failure mode is used to commit to a branch; to commit means that every subsequent failure is non-recoverable. +-- +-- You turn a commit back into a normal 'Parser' using 'runCommit'. +-- As an additional benefit, if no commit succeeded the parser error message will contain all encountered errors. +-- +-- The implementation works by capturing failure in either the 'ExceptT' or in the underlying 'Parser'. +-- The derived 'Alternative' instance will only recover from failures in the 'ExceptT'. +-- This means that as soon as we successfully construct a 'Right' value, the 'Alternative' considers the 'Commit' a success, even though the underlying parser might have failed. +-- The 'Void' represents the guarantee that we only collect error values. +newtype Commit a = Commit {unCommit :: ExceptT [Parser Void] Parser a} + deriving (Monad, Functor, Applicative, Alternative) + +-- | Construct a commit. +-- If the first parser succeeds, the 'Commit' is a success, and any failures in the inner action will be preserved. +commit :: Parser a -> (a -> Parser b) -> Commit b +commit pre post = Commit $ do + a <- ExceptT $ captureError pre + lift $ post a + where + captureError :: Parser b -> Parser (Either [Parser Void] b) + captureError p = Right <$> p <|> pure (Left [fmap (const undefined) p]) + +-- | Recommended way of turning a 'Commit' back into a regular 'Parser'. +runCommit :: Commit a -> Parser a +runCommit (Commit f) = runExceptT f >>= either handleErrors pure + where + handleErrors :: [Parser Void] -> Parser a + handleErrors [] = fail "No parsers tried" + handleErrors (p:ps) = fmap absurd (go (p:ps) [] []) + where + go [] path errors = parserThrowError path ("No match,\n" <> unlines (fmap ("- " <>) errors)) + go (y:ys) _ msgs = parserCatchError y $ \path msg -> + go ys path (msg:msgs) + -- TODO: how do we handle the multiple JSONPaths? + -- Right now the rightmost failure's path is used when presenting + -- the error message. Ideally one path per error would be preferable but + -- `aeson` doesn't support such a thing. When errors are reported in `aeson` + -- a single JSONPath defines how the error message is presented. + +-- | Convenience wrapper around 'commit' for when the commit is checking whether a key is present in some object. +-- If it is, it will commit and append the key to the JSONPath of the inner context through '', which will give nicer error messages. +(.:>) :: FromJSON a => Object -> Text -> (a -> Parser b) -> Commit b +(o .:> k) cont = commit (o .: k) (\v -> cont v Key k) + +-- | Try to parse with a 'Parser' and commit if it parses successfully. +-- Unlike 'liftParser', the parser's failure is recoverable. +-- +-- > tryParser empty <|> p = p +tryParser :: Parser a -> Commit a +tryParser p = commit p pure + +-- | Turn a 'Parser' into a 'Commit'. +-- Unlike 'tryParser', the parser's failure is _not_ recoverable, i.e. the parse is always committed. +-- +-- > liftParser empty <|> p = empty +liftParser :: Parser a -> Commit a +liftParser p = commit (pure ()) (const p) diff --git a/test/tasty/Main.hs b/test/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/test/tasty/Main.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Aeson.QQ +import Data.Aeson.Types +import Data.Aeson.Commit +import Control.Applicative +import Data.Text (Text) +import Test.Tasty +import Test.Tasty.Hspec + +tests :: Spec +tests = testParserWithCases pNested + [ ( "fails" + , [aesonQQ| {} |] + , Left $ unlines + [ "Error in $: No match," + , "- key \"value\" not found" + , "- key \"nested\" not found" + ] + ) + , ( "succeeds unnested" + , [aesonQQ| { value: "top" } |] + , Right "top" + ) + , ( "succeeds and prefers nested" + , [aesonQQ| { value: "top" , nested: { value: "nest" } } |] + , Right "nest" + ) + , ( "fails on malformed nested" + , [aesonQQ| { value: "top", nested: { foo: 9 } } |] + , Left "Error in $.nested: key \"value\" not found" + ) + , ( "fails on nested type mismatch" + , [aesonQQ| { value: "top", nested: 9 } |] + , Left "Error in $.nested: parsing nestedObj failed, expected Object, but encountered Number" + ) + ] + where + pNested :: Value -> Parser Text + pNested = withObject "topLevel" $ \o -> + runCommit + $ (o .:> "nested") (withObject "nestedObj" (.: "value")) + <|> tryParser (o .: "value") + +testParserWithCases + :: (Eq a, Show a) + => (v -> Parser a) + -> [(String, v, Either String a)] + -> Spec +testParserWithCases p = + mapM_ ( \(name, v, result) -> it name (parseEither p v `shouldBe` result)) + +main :: IO () +main = testSpecs tests >>= defaultMain . testGroup "aeson-commit"