diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for `conduit-aeson` + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Kuleshevich (c) 2021-2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexey Kuleshevich nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,29 @@ +# conduit-aeson + +## Overview + +A simple library that allows streaming parsing of large JSON objects and arrays +using Aeson, Attoparsec and Conduit. + +It is important to note that only the top level elements of arrays and objects +can be streamed, in other words streaming of nested objects is not supported. + +This library is suitable for parsing of very large json files as well as +infinite streams of JSON objects. + +## Status + +| Github Actions | Coveralls | Hackage | Nightly | LTS | +|:--------------:|:---------:|:-------:|:-------:|:---:| +| [![Build Status][GA-badge]][GA-link] | [![Coverage Status][Coveralls-badge]][Coveralls-link] | [![Hackage][Hackage-badge]][Hackage-link] | [![Nightly][Nightly-badge]][Nightly-link] | [![LTS][LTS-badge]][LTS-link] + +[GA-badge]: https://github.com/lehins/conduit-aeson/workflows/CI/badge.svg +[GA-link]: https://github.com/lehins/conduit-aeson/actions +[Coveralls-badge]: https://coveralls.io/repos/github/lehins/conduit-aeson/badge.svg?branch=master +[Coveralls-link]: https://coveralls.io/github/lehins/conduit-aeson?branch=master +[Hackage-badge]: https://img.shields.io/hackage/v/conduit-aeson.svg +[Hackage-link]: https://hackage.haskell.org/package/conduit-aeson +[Nightly-badge]: https://www.stackage.org/package/conduit-aeson/badge/nightly +[Nightly-link]: https://www.stackage.org/nightly/package/conduit-aeson +[LTS-badge]: https://www.stackage.org/package/conduit-aeson/badge/lts +[LTS-link]: https://www.stackage.org/lts/package/conduit-aeson diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain +#endif + diff --git a/conduit-aeson.cabal b/conduit-aeson.cabal new file mode 100644 --- /dev/null +++ b/conduit-aeson.cabal @@ -0,0 +1,91 @@ +name: conduit-aeson +version: 0.1.0.0 +synopsis: Short description +description: Please see the README on GitHub at +homepage: https://github.com/lehins/conduit-aeson +license: BSD3 +license-file: LICENSE +author: Alexey Kuleshevich +maintainer: alexey@kuleshevi.ch +copyright: 2021-2022 Alexey Kuleshevich +category: Algorithms +build-type: Simple +extra-source-files: README.md + , CHANGELOG.md +cabal-version: 1.18 +tested-with: GHC == 8.4.3 + , GHC == 8.4.4 + , GHC == 8.6.3 + , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 + , GHC == 8.8.2 + , GHC == 8.10.1 + +library + hs-source-dirs: src + exposed-modules: Data.Conduit.Aeson + + other-modules: + build-depends: aeson >= 1.0 + , attoparsec + , base >= 4.9 && < 5 + , bytestring + , conduit + , conduit-extra + , text + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + if impl(ghc >= 8.2) + build-depends: attoparsec + , bytestring + , conduit + , conduit-aeson + , doctest-parallel + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -threaded + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Data.Conduit.AesonSpec + , Spec + build-depends: base + , aeson + , conduit + , containers + , conduit-aeson + , hspec + , QuickCheck + , scientific + , text + build-tool-depends: hspec-discover:hspec-discover + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + -with-rtsopts=-N2 + +source-repository head + type: git + location: https://github.com/lehins/conduit-aeson diff --git a/src/Data/Conduit/Aeson.hs b/src/Data/Conduit/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Aeson.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE LambdaCase #-} +-- | +-- Module : Data.Conduit.Aeson +-- Copyright : (c) Alexey Kuleshevich 2021-2022 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Data.Conduit.Aeson + ( ParserError(..) + , conduitArray + , conduitArrayEither + , conduitObject + , conduitObjectEither + -- * Helpers + -- ** Conduit + , conduitArrayParserEither + , conduitArrayParserNoStartEither + , conduitObjectParserEither + , conduitObjectParserNoStartEither + -- ** Attoparsec + , skipSpace + , commaParser + , delimiterParser + , valuePrefixParser + , valueParser + , objectEntryPrefixParser + , objectEntryParser + , objectEntryMaybeParser + ) where + +import Conduit +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.Aeson as Aeson +import qualified Data.Aeson.Parser as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Attoparsec.ByteString as Atto +import qualified Data.Attoparsec.ByteString.Char8 as Atto8 +import Data.Bifunctor (first) +import qualified Data.ByteString as BS +import Data.Conduit.Attoparsec +import qualified Data.Text as T +#if MIN_VERSION_aeson(1,5,0) +import Data.Coerce +#endif + +-- | Various reason for failed parsing. +-- +-- @since 0.1.0 +data ParserError + = AttoParserError ParseError + -- ^ Attoparsec parser failure + | AesonParserError String + -- ^ Aeson parser failure + | NonTerminatedInput + -- ^ Parser failure when end of input was reached without proper termination. + deriving Show +instance Exception ParserError + + +-- | Parse a top level array into a stream of json values. Throws a +-- `ParserError` on invalid input, see `conduitArrayEither` for more graceful +-- error handling. +-- +-- ===__Examples__ +-- +-- >>> :set -XTypeApplications +-- >>> :set -XOverloadedStrings +-- >>> import Conduit +-- >>> runConduit $ yield ("[1,2,3,4]") .| conduitArray @Int .| printC +-- 1 +-- 2 +-- 3 +-- 4 +-- +-- @since 0.1.0 +conduitArray :: + forall v m. (FromJSON v, MonadThrow m) + => ConduitM BS.ByteString v m () +conduitArray = conduitArrayEither .| mapMC (either throwM pure) + +-- | Same as `conduitArray`, parse a top level array into a stream of values, +-- but produce @`Left` `ParserError`@ instead of failing immediately with an +-- exception. +-- +-- @since 0.1.0 +conduitArrayEither :: + forall v m. (FromJSON v, Monad m) + => ConduitM BS.ByteString (Either ParserError v) m () +conduitArrayEither = conduitArrayParserEither .| stopOnNothing .| mapC toValue + where + toValue (Left err) = Left err + toValue (Right (_, v)) = first AesonParserError $ Aeson.parseEither Aeson.parseJSON v + +-- | Parse a top level array as a stream of JSON values. Expects opening and +-- closing braket @'['@ and @']'@ at the beginning and the end of the stream +-- respectfully. `Nothing` indicates terminating closing square braket has been +-- reached, but it does not mean there are no left over bytes in the input stream. +-- +-- @since 0.1.0 +conduitArrayParserEither :: + Monad m + => ConduitM BS.ByteString (Either ParseError (PositionRange, Maybe Value)) m () +conduitArrayParserEither = do + sinkParserEither valuePrefixParser >>= \case + Left err -> yield $ Left err + Right () -> conduitParserEither (valueMaybeParser commaParser) + +-- | Parse a stream of JSON values. Expects that there are no opening or closing +-- top level array braces @[@ and @]@. Could be very useful for consuming +-- infinite streams of log entries, where each entry is formatted as a JSON +-- value. +-- +-- ===__Examples__ +-- +-- Parse a new line delimited JSON values. +-- +-- >>> import Conduit +-- >>> import Data.ByteString.Char8 (ByteString, pack) +-- >>> import Data.Attoparsec.ByteString.Char8 (char8) +-- >>> let input = pack "{\"foo\":1}\n{\"bar\":2}\n" :: ByteString +-- >>> let parser = conduitArrayParserNoStartEither (char8 '\n') +-- >>> runConduit (yield input .| parser .| printC) +-- Right (1:1 (0)-2:1 (10),Object (fromList [("foo",Number 1.0)])) +-- Right (2:1 (10)-3:1 (20),Object (fromList [("bar",Number 2.0)])) +-- +-- Or a simple comma delimited list: +-- +-- >>> runConduit $ yield (pack "1,2,3,\"Haskell\",") .| conduitArrayParserNoStartEither (char8 ',') .| printC +-- Right (1:1 (0)-1:3 (2),Number 1.0) +-- Right (1:3 (2)-1:5 (4),Number 2.0) +-- Right (1:5 (4)-1:7 (6),Number 3.0) +-- Right (1:7 (6)-1:17 (16),String "Haskell") +-- +-- @since 0.1.0 +conduitArrayParserNoStartEither :: + forall m a. Monad m + => Atto.Parser a + -- ^ Delimiter parser (in JSON it is a comma @','@) + -> ConduitM BS.ByteString (Either ParseError (PositionRange, Value)) m () +conduitArrayParserNoStartEither = conduitParserEither . valueParser + + +-- | Parse a top level object into a stream of key/value pairs. Throws a +-- `ParserError` on invalid input, see `conduitObjectEither` for more graceful +-- error handling. +-- +-- ===__Examples__ +-- +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> import Conduit +-- >>> let input = "{ \"foo\": 1, \"bar\": 2, \"baz\": 3 }" +-- >>> runConduit $ yield input .| conduitObject @String @Int .| printC +-- ("foo",1) +-- ("bar",2) +-- ("baz",3) +-- +-- @since 0.1.0 +conduitObject :: + forall k v m. (FromJSONKey k, FromJSON v, MonadThrow m) + => ConduitM BS.ByteString (k, v) m () +conduitObject = conduitObjectEither .| mapMC (either throwM pure) + +-- | Same as `conduitObject`, except fails gracefully. Parse a top level object +-- into a stream of key/value pairs with potential failures as @`Left` `ParserError`@. +-- +-- @since 0.1.0 +conduitObjectEither :: + forall k v m. (FromJSONKey k, FromJSON v, Monad m) + => ConduitM BS.ByteString (Either ParserError (k, v)) m () +conduitObjectEither = conduitObjectParserEither .| stopOnNothing .| mapC toKeyValue + where + _id x = x -- work around an aeson rewrite rule. + toKeyValue (Left err) = Left err + toKeyValue (Right (_, (k, v))) = + first AesonParserError $ do + key <- + case fromJSONKey of +#if MIN_VERSION_aeson(1,5,0) + FromJSONKeyCoerce -> Right $ coerce k +#else + FromJSONKeyCoerce {} + | FromJSONKeyText f <- fmap _id fromJSONKey -> Right $ f k + | otherwise -> error "Impossible: failed to convert coercible FromJSONKeyCoerce" +#endif + FromJSONKeyText f -> Right $ f k + FromJSONKeyTextParser p -> Aeson.parseEither p k + FromJSONKeyValue p -> Aeson.parseEither p (String k) + val <- Aeson.parseEither Aeson.parseJSON v + Right (key, val) + +-- | Parse a top level key value mapping. Expects opening and closing braces +-- @'{'@ and @'}'@. `Nothing` indicates terminating closing curly brace has been +-- reached, but it does not mean there are no left over bytes in the input stream. +-- +-- @since 0.1.0 +conduitObjectParserEither :: + Monad m + => ConduitM BS.ByteString (Either ParseError (PositionRange, Maybe (T.Text, Value))) m () +conduitObjectParserEither = do + sinkParserEither objectEntryPrefixParser >>= \case + Left err -> yield $ Left err + Right () -> conduitParserEither (objectEntryMaybeParser commaParser) + +-- | Parse a stream of key/value pairs. Expects that there are no opening or +-- closing top level curly braces @'{'@ and @'}'@. It is suitable for infinite +-- streams of key value/pairs delimited by a custom character, eg. a new line. +-- +-- ===__Examples__ +-- +-- >>> import Conduit +-- >>> import Data.ByteString.Char8 (ByteString, pack) +-- >>> import Data.Attoparsec.ByteString.Char8 (char8) +-- >>> let input = pack "\"foo\":1|\"bar\":2|" :: ByteString +-- >>> let parser = conduitObjectParserNoStartEither (char8 '|') +-- >>> runConduit (yield input .| parser .| printC) +-- Right (1:1 (0)-1:9 (8),("foo",Number 1.0)) +-- Right (1:9 (8)-1:17 (16),("bar",Number 2.0)) +-- +-- @since 0.1.0 +conduitObjectParserNoStartEither :: + forall m a. Monad m + => Atto.Parser a + -- ^ Delimiter parser (in JSON it is a comma @','@) + -> ConduitM BS.ByteString (Either ParseError (PositionRange, (T.Text, Value))) m () +conduitObjectParserNoStartEither = conduitParserEither . objectEntryParser + + +stopOnNothing :: + Monad m + => ConduitM (Either ParseError (PositionRange, Maybe a)) + (Either ParserError (PositionRange, a)) m () +stopOnNothing = do + await >>= \case + Nothing -> yield $ Left NonTerminatedInput + Just e + | Left err <- e -> yield (Left (AttoParserError err)) >> stopOnNothing + | Right (p, Just r) <- e -> yield (Right (p, r)) >> stopOnNothing + | Right (_, Nothing) <- e -> pure () + +-- Attoparsec + +-- | Skips all spaces and newlines +-- +-- @since 0.1.0 +skipSpace :: Atto.Parser () +skipSpace = Atto.skipWhile $ \w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09 + +-- | Use a comma for delimiter. +-- +-- @since 0.1.0 +commaParser :: + Char + -- ^ Terminating character. + -> Atto.Parser () +commaParser = delimiterParser (Atto.word8 0x2c Atto8. "','") + +-- | Parser for delimiter with terminating character +-- +-- @since 0.1.0 +delimiterParser :: Atto.Parser a -> Char -> Atto.Parser () +delimiterParser dp t = + skipSpace <* (void dp <|> expectTermination) + where + expectTermination = + Atto8.peekChar >>= \case + Just c + | c /= t -> fail $ "Unexpected delimiter: " ++ show c + _ -> pure () + +-- | Consume @'['@ with all preceeding space characters +-- +-- @since 0.1.0 +valuePrefixParser :: Atto.Parser () +valuePrefixParser = skipSpace <* Atto8.char '[' + +-- | Parse a JSON value potentially prefixed by whitespace followed by a suffix +-- +-- @since 0.1.0 +valueParser :: + Atto.Parser a + -- ^ Suffix parser + -> Atto.Parser Aeson.Value +valueParser dp = skipSpace *> json' <* dp + +-- | Parse a JSON value followed either by a delimiter or terminating +-- character @']'@, which is also supplied to the delimiter parser. Nothing is +-- returned when terminating character is reached. +-- +-- @since 0.1.0 +valueMaybeParser :: + (Char -> Atto.Parser a) + -- ^ Delimiter parser (accepts terminating character as argument) + -> Atto.Parser (Maybe Aeson.Value) +valueMaybeParser dp = + let t = ']' + in skipSpace *> ((Nothing <$ Atto8.char t) <|> (Just <$> json' <* dp t)) + +-- | Consume @'{'@ with all preceeding space characters +-- +-- @since 0.1.0 +objectEntryPrefixParser :: Atto.Parser () +objectEntryPrefixParser = skipSpace <* Atto8.char '{' + + +-- | Parse JSON object key followed by a colon +-- +-- @since 0.1.0 +keyParser :: Atto.Parser T.Text +keyParser = + skipSpace *> + (Aeson.jstring Atto. "key") <* + skipSpace <* + (Atto.word8 0x3a Atto. "':'") + +-- | Parse a JSON key value pair followed by a suffix +-- +-- @since 0.1.0 +objectEntryParser :: + Atto.Parser a + -- ^ Suffix parser + -> Atto.Parser (T.Text, Aeson.Value) +objectEntryParser dp = (,) <$> keyParser <*> valueParser dp + + +-- | Parse JSON key value pairs followed either by a delimiter or terminating +-- character @']'@, which is also supplied to the delimiter parser. Nothing is +-- returned when terminating character is reached. +-- +-- @since 0.1.0 +objectEntryMaybeParser :: (Char -> Atto.Parser a) -> Atto.Parser (Maybe (T.Text, Aeson.Value)) +objectEntryMaybeParser dp = + let t = '}' + in skipSpace *> + ((Nothing <$ Atto8.char t) <|> (Just <$> objectEntryParser (dp t))) diff --git a/tests/Data/Conduit/AesonSpec.hs b/tests/Data/Conduit/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Data/Conduit/AesonSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Conduit.AesonSpec (spec) where + +import Conduit +import Data.Aeson +import Data.Conduit.Aeson +import qualified Data.Map.Strict as Map +import Data.Scientific +import qualified Data.Text as T +import GHC.Exts +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary Value where + arbitrary = sized sizedArbitraryValue + +sizedArbitraryValue :: Int -> Gen Value +sizedArbitraryValue n + | n <= 0 = oneof [pure Null, bool, number, string] + | otherwise = resize n' $ oneof [pure Null, bool, number, string, array, object'] + where + n' = n `div` 2 + bool = Bool <$> arbitrary + number = Number <$> (scientific <$> arbitrary <*> arbitrary) + string = String <$> arbitrary + array = Array . fromList <$> arbitrary + object' = listToObject <$> arbitrary + +listToObject :: [(String, Value)] -> Value +listToObject xs = object [(fromString k, v) | (k, v) <- xs] + +spec :: Spec +spec = do + describe "roundtrips" $ do + prop "conduitArray" $ \(xs :: [Value]) -> do + xs' <- + runConduit + (sourceLazy (encode (Array (fromList xs))) .| conduitArray .| sinkList) + xs' `shouldBe` xs + prop "conduitObject" $ \(ls :: [(String, Value)]) -> do + let xs = Map.fromList ls + xs' <- + runConduit + (sourceLazy (encode (listToObject (Map.toAscList xs))) .| + conduitObject .| + sinkList) + Map.fromList xs' `shouldBe` xs diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Spec +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) +import Test.Hspec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP #-} + +module Main where + +#if __GLASGOW_HASKELL__ >= 802 +import Test.DocTest (mainFromCabal) +import System.Environment (getArgs) + +main :: IO () +main = mainFromCabal "conduit-aeson" =<< getArgs +#else + +import System.IO + +main :: IO () +main = hPutStrLn stderr "GHC version older than 8.2 are not supported" + +#endif