diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Renzo Carbonara + +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 Renzo Carbonara 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,11 @@ +# pipes-cborg + +Utilities to encode and decode binary streams using the **pipes** and +**cborg** and **serialise** libraries. + +Check the source or rendered Haddocks for extensive documentation. + +This code is licensed under the terms of the so called **3-clause BSD +license**. Read the file named ``LICENSE`` found in this same directory +for details. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# Version 0.1 + +* Initial version. diff --git a/pipes-cborg.cabal b/pipes-cborg.cabal new file mode 100644 --- /dev/null +++ b/pipes-cborg.cabal @@ -0,0 +1,57 @@ +name: pipes-cborg +version: 0.1 +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) Renzo Carbonara 2019 +author: Renzo Carbonara +maintainer: renλren.zone +stability: Experimental +homepage: https://github.com/k0001/pipes-cborg +bug-reports: https://github.com/k0001/pipes-cborg/issues +category: Pipes +build-type: Simple +synopsis: Encode and decode cborg streams using the pipes and cborg libraries. +cabal-version: >=1.8 +extra-source-files: README.md changelog.md +description: + Encode and decode binary Pipes streams using the @cborg@ library. + . + See the @changelog.md@ file in the source distribution to learn about any + important changes between version. + +source-repository head + type: git + location: git://github.com/k0001/pipes-cborg.git + +library + hs-source-dirs: src + exposed-modules: Pipes.CBOR + ghc-options: -Wall -O2 + ghcjs-options: -Wall -O3 + build-depends: + base >=4.5 && <5 + , cborg + , bytestring + , ghc-prim + , pipes + , pipes-parse + , pipes-bytestring + , serialise + , transformers + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + build-depends: + base + , cborg + , bytestring + , pipes + , pipes-bytestring + , pipes-cborg + , serialise + , QuickCheck + , tasty + , tasty-quickcheck + , transformers diff --git a/src/Pipes/CBOR.hs b/src/Pipes/CBOR.hs new file mode 100644 --- /dev/null +++ b/src/Pipes/CBOR.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | [pipes](https://hackage.haskell.org/package/pipes) utilities for encoding +-- and decoding values as byte streams in CBOR format using the +-- [cborg](https://hackage.haskell.org/package/cborg) library. + +module Pipes.CBOR ( + -- * Encoding + serialise + , encode + -- * Decoding + , deserialise + , decode + ) where + +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.ST (stToIO) +import qualified Control.Monad.Trans.State.Strict as S +import qualified Codec.CBOR.Decoding as CBOR (Decoder) +import qualified Codec.CBOR.Encoding as CBOR (Encoding) +import qualified Codec.CBOR.Read as CBOR + (IDecode(..), ByteOffset, DeserialiseFailure, deserialiseIncremental) +import qualified Codec.CBOR.Write as CBOR (toLazyByteString) +import qualified Codec.Serialise as Ser +import qualified Data.ByteString as B +import qualified Pipes as P +import qualified Pipes.ByteString as Pb +import qualified Pipes.Parse as Pp + +-------------------------------------------------------------------------------- + +-- | Renders @x@ to a byte stream using its 'Ser.Serialise' instance. +serialise + :: (Ser.Serialise x, Monad m) + => x -- ^ + -> P.Producer' B.ByteString m () +serialise = encode . Ser.encode +{-# INLINE serialise #-} + +-- | Renders an 'CBOR.Encoding' to a byte stream. +encode + :: Monad m + => CBOR.Encoding -- ^ + -> P.Producer' B.ByteString m () +encode = Pb.fromLazy . CBOR.toLazyByteString +{-# INLINE encode #-} + +-------------------------------------------------------------------------------- + +-- | Parses @x@ from a byte stream using its 'Ser.Serialise' instance. +-- +-- Also returns the number of bytes consumed in order to to decode the value. +-- +-- Implementation note: No, ideally this function shouldn't run in 'IO'. But +-- unfortunately, the underlying 'CBOR.deserialiseIncremental' and its use of +-- 'Control.Monad.ST.ST', which becomes both covariant and contravariant in +-- 'Pp.Parser', make removing the 'IO' tricky. The only 'IO' this function +-- performs is 'stToIO'. +deserialise + :: (MonadIO m, Ser.Serialise a) + => Pp.Parser B.ByteString m (Either CBOR.DeserialiseFailure (CBOR.ByteOffset, a)) -- ^ +deserialise = decode Ser.decode +{-# INLINE deserialise #-} + +-- | Parses @x“ from a byte stream using the given 'CBOR.Decoder'. +-- +-- Also returns the number of bytes consumed in order to to decode the value. +-- +-- Implementation note: No, ideally this function shouldn't run in 'IO'. But +-- unfortunately, the underlying 'CBOR.deserialiseIncremental' and its use of +-- 'Control.Monad.ST.ST', which becomes both covariant and contravariant in +-- 'Pp.Parser', make removing the 'IO' tricky. The only 'IO' this function +-- performs is 'stToIO'. +decode + :: MonadIO m + => (forall s. CBOR.Decoder s x) + -> Pp.Parser B.ByteString m (Either CBOR.DeserialiseFailure (CBOR.ByteOffset, x)) -- ^ +decode dec = S.StateT (go id (CBOR.deserialiseIncremental dec)) + where + go diffP m = \p0 -> do + idec <- liftIO (stToIO m) + case idec of + CBOR.Fail _ _ err -> pure (Left err, diffP p0) + CBOR.Done bs off a -> pure (Right (off, a), P.yield bs >> p0) + CBOR.Partial k -> do + x <- nextSkipEmpty p0 + case x of + Left e -> go diffP (k Nothing) (pure e) + Right (bs, p1) -> go (diffP . (P.yield bs >>)) (k (Just bs)) p1 +{-# INLINABLE decode #-} + +-------------------------------------------------------------------------------- + +-- | Like 'P.next', except it skips leading 'B.null' chunks. +nextSkipEmpty + :: Monad m + => P.Producer B.ByteString m r + -> m (Either r (B.ByteString, P.Producer B.ByteString m r)) +nextSkipEmpty = go + where + go p0 = do + x <- P.next p0 + case x of + Left _ -> pure x + Right (a, p1) + | B.null a -> go p1 + | otherwise -> pure x +{-# INLINABLE nextSkipEmpty #-} + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.Runners as Tasty +import qualified Test.Tasty.QuickCheck as QC + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State.Strict (runStateT) +import qualified Codec.CBOR.Read as CBOR + (ByteOffset, deserialiseFromBytesWithSize) +import qualified Codec.Serialise as Ser +import qualified Data.ByteString.Lazy as BL +import qualified Pipes as P +import qualified Pipes.CBOR as Pc +import qualified Pipes.ByteString as Pb +import qualified Pipes.Prelude as P + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] tests + + +tests :: Tasty.TestTree +tests = Tasty.testGroup "root" + [ testPipesCborg + ] + +-- Just an arbitrary type that can be generated by QuickCheck +type FunnyType = (String, (Double, (Int, (Maybe Int, Either Bool Int)))) + +testPipesCborg :: Tasty.TestTree +testPipesCborg = Tasty.testGroup "pipes-cborg" + [ QC.testProperty "Pipes.CBOR.serialaise ~ Codec.Serialise.serialise" $ do + QC.forAll QC.arbitrary $ \(x :: FunnyType) -> + Ser.serialise x == BL.fromChunks (P.toList (Pc.serialise x)) + + , QC.testProperty "Pipes.CBOR.deserialise ~ Codec.Serialise.deserialise" $ do + QC.forAll QC.arbitrary $ \(x :: FunnyType) -> QC.ioProperty $ do + let bl :: BL.ByteString = Ser.serialise x + o1s :: Either Ser.DeserialiseFailure + (BL.ByteString, CBOR.ByteOffset, FunnyType) + o1s = CBOR.deserialiseFromBytesWithSize Ser.decode bl + (o2,p2) <- runStateT (Pc.decode Ser.decode) (Pb.fromLazy bl) + s2 <- BL.fromChunks <$> P.toListM p2 + pure (o1s QC.=== fmap (\(a,b) -> (s2,a,b)) o2) + ]