packages feed

cereal-io-streams (empty) → 0.0.1.0

raw patch · 6 files changed

+419/−0 lines, 6 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, cereal, cereal-conduit, cereal-io-streams, conduit, conduit-extra, criterion, derive, io-streams, mtl, tasty, tasty-hunit, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Michael Xavier++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 Michael Xavier 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+module Main+    ( main+    ) where++-------------------------------------------------------------------------------+import           Criterion.Main+import           Data.ByteString          (ByteString)+import           Data.Conduit+import qualified Data.Conduit.Cereal as Conduit+import qualified Data.Conduit.List as Conduit+import qualified Data.Conduit.Binary as Conduit+import           Data.Monoid+import           Data.Serialize+import           GHC.Generics+-------------------------------------------------------------------------------+import qualified System.IO.Streams        as Streams+import           System.IO.Streams.Cereal+-------------------------------------------------------------------------------++main :: IO ()+main = do+  let lstring = mconcat $ map (runPutLazy . put) foos+      foos = replicate 1000 exFoo+      exFoo = Foo 42 "oh look, a Foo!"+  defaultMain+    [ bgroup "getEachStream cereal-io-streams" [+         bench "1000 items" $ whnfIO $ benchCIS lstring ]+    , bgroup "getEachStream cereal-conduit" [+         bench "1000 items" $ whnfIO $ benchCC lstring ]+    ]+ where+++benchCIS lstring = do+  os <- Streams.nullOutput+  Streams.connectTo os =<< getEachStream get' =<< Streams.fromLazyByteString lstring++benchCC lstring = do+  Conduit.sourceLbs lstring $= Conduit.conduitGet get' $$ Conduit.sinkNull+++get' :: Get Foo+get' = get+++-------------------------------------------------------------------------------+data Foo = Foo Int ByteString deriving (Generic,Show,Eq)++instance Serialize Foo
+ cereal-io-streams.cabal view
@@ -0,0 +1,67 @@+name:                cereal-io-streams+version:             0.0.1.0+synopsis:            io-streams support for the cereal binary serialization library+description:+    io-streams support for the cereal binary serialization library+    .+license:             BSD3+license-file:        LICENSE+author:              Michael Xavier+maintainer:          michael.xavier@soostone.com+copyright:           Soostone Inc+category:            Data, Parsing, IO-Streams+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:+    System.IO.Streams.Cereal+  build-depends:+      base >= 4 && < 5+    , bytestring+    , cereal >= 0.4 && < 0.6+    , io-streams >= 1.1 && < 1.4+  hs-source-dirs: src+  default-language:    Haskell2010+++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  build-depends:+      cereal-io-streams+    , cereal+    , bytestring+    , io-streams+    , QuickCheck+    , HUnit+    , tasty+    , tasty-quickcheck+    , tasty-hunit+    , derive+    , base+    , mtl+  hs-source-dirs: test+  default-language:    Haskell2010++benchmark bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: bench+  default-language:    Haskell2010+  build-depends:+      base+    , cereal-io-streams+    , criterion >= 1.0.2.0+    , io-streams+    , bytestring+    , cereal+    , cereal-conduit+    , conduit+    , conduit-extra+  ghc-options: -rtsopts+  ghc-prof-options: -rtsopts -caf-all -auto-all++source-repository head+  type:     git+  location: git://github.com/Soostone/cereal-io-streams.git
+ src/System/IO/Streams/Cereal.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Sytem.IO.Streams.Cereal+-- Copyright   :  Soostone Inc+-- License     :  BSD3+--+-- Maintainer  :  Michael Xavier+-- Stability   :  experimental+--+-- io-streams interface to the cereal binary serialization library.+----------------------------------------------------------------------------+module System.IO.Streams.Cereal+    ( getFromStream+    , putToStream+    , getEachStream+    , putEachStream+    , contramapPut+    , GetException(..)+    ) where++-------------------------------------------------------------------------------+import           Control.Applicative+import           Control.Exception      (Exception, throwIO)+import           Control.Monad+import           Data.ByteString        (ByteString)+import qualified Data.ByteString.Char8  as S+import           Data.Monoid+import           Data.Serialize+import           Data.Typeable+import qualified System.IO.Streams      as Streams+import           System.IO.Streams.Core+-------------------------------------------------------------------------------++data GetException = GetException String+  deriving (Typeable)++instance Show GetException where+    show (GetException s) = "Get exception: " ++ s++instance Exception GetException++++-------------------------------------------------------------------------------+-- | Convert a 'Put' into an 'InputStream'+--+-- Example:+--+-- >>> putToStream (put False)+putToStream :: Put -> IO (InputStream ByteString)+putToStream = Streams.fromLazyByteString . runPutLazy+{-# INLINE putToStream #-}+++-------------------------------------------------------------------------------+-- | Convert a stream of individual serialized 'ByteString's to a stream+-- of Results. Throws a GetException on error.+--+-- Example:+--+-- >>> Streams.toList =<< getEachStream (get :: Get String) =<< Streams.fromList (map (runPut . put) ["foo", "bar"])+-- ["foo","bar"]+getEachStream :: Get r -> InputStream ByteString -> IO (InputStream r)+getEachStream g is = makeInputStream $ do+  atEnd <- atEOF is+  if atEnd+    then return Nothing+    else Just <$> getFromStream g is+{-# INLINE getEachStream #-}+++-------------------------------------------------------------------------------+-- | Convert a stream of serializable objects into a stream of+-- individual 'ByteString's+-- Example:+--+-- >>> Streams.toList =<< getEachStream (get :: Get String) =<< putEachStream put =<< Streams.fromList ["foo","bar"]+-- ["foo","bar"]+putEachStream :: Putter r -> InputStream r -> IO (InputStream ByteString)+putEachStream p = Streams.map (runPut . p)+{-# INLINE putEachStream #-}+++-------------------------------------------------------------------------------+-- | Take a 'Get' and an 'InputStream' and deserialize a+-- value. Consumes only as much input as necessary to deserialize the+-- value. Unconsumed input is left on the 'InputStream'. If there is+-- an error while deserializing, a 'GetException' is thrown.+--+-- Examples:+--+-- >>> getFromStream (get :: Get String) =<< putToStream (put "serialize me")+-- "serialize me"+-- >>> getFromStream (get :: Get String) =<< Streams.fromByteString (Data.ByteString.drop 1 $ runPut $ put ("serialize me" :: String))+-- *** Exception: Get exception: too few bytes+-- From:	demandInput+-- <BLANKLINE>+-- <BLANKLINE>+getFromStream :: Get r -> InputStream ByteString -> IO r+getFromStream = getFromStreamInternal runGetPartial feed+{-# INLINE getFromStream #-}+++-------------------------------------------------------------------------------+-- | Take an output stream of serializable values and create an output+-- stream of bytestrings, one for each value.+contramapPut :: Putter r -> OutputStream ByteString -> IO (OutputStream r)+contramapPut p = Streams.contramap (runPut . p)++-------------------------------------------------------------------------------+feed :: Result r -> ByteString -> Result r+feed (Partial f) bs = f bs+feed (Done r x) bs = Done r $ x <> bs+feed (Fail s x) bs = Fail s $ x <> bs++-------------------------------------------------------------------------------+getFromStreamInternal+    :: (Get r -> ByteString -> Result r)+    -> (Result r -> ByteString -> Result r)+    -> Get r+    -> InputStream ByteString+    -> IO r+getFromStreamInternal getFunc feedFunc g is =+    Streams.read is >>=+    maybe (finish $ getFunc g "")+          (\s -> if S.null s+                   then getFromStreamInternal getFunc feedFunc g is+                   else go $! getFunc g s)+  where+    leftover x = unless (S.null x) $ Streams.unRead x is++    finish k = let k' = feedFunc (feedFunc k "") ""+               in case k' of+                    Fail _ x -> leftover x >> err k'+                    Partial _  -> err k' -- should be impossible+                    Done r x   -> leftover x >> return r++    err r = let (Left s) = eitherResult r in throwIO $ GetException s+    eitherResult (Done _ r)     = Right r+    eitherResult (Fail msg _)   = Left msg+    eitherResult _              = Left "Result: incomplete input"++    go r@(Fail _ x) = leftover x >> err r+    go (Done r x)     = leftover x >> return r+    go r              = Streams.read is >>=+                        maybe (finish r)+                              (\s -> if S.null s+                                       then go r+                                       else go $! feedFunc r s)
+ test/Main.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+module Main+    ( main+    ) where++-------------------------------------------------------------------------------+import           Control.Exception        hiding (assert)+import qualified Data.ByteString          as BS+import           Data.DeriveTH+import           Data.Monoid+import           Data.Serialize+import           GHC.Generics+import           System.IO.Streams        hiding (map)+import qualified System.IO.Streams        as Streams+import           Test.QuickCheck.Monadic+import           Test.Tasty+import           Test.Tasty.HUnit         hiding (assert)+import           Test.Tasty.QuickCheck++import Control.Monad+import qualified Data.ByteString.Lazy          as LBS+import qualified Data.ByteString.Char8          as BS8+import qualified Control.Monad.State as MS+-------------------------------------------------------------------------------+import           System.IO.Streams.Cereal+-------------------------------------------------------------------------------+++main :: IO ()+main = defaultMain testSuite+++testSuite :: TestTree+testSuite = testGroup "cereal-io-streams"+  [+    testProperty "serialization roundtrips Foo" prop_roundtrip_Foo++  , testProperty "serialization roundtrips Foo unpredictable chunking" prop_roundtrip_Foo_chunking++  , testCase "partial input" test_partial+  , testCase "excess preceding input" test_excess_head+  , testCase "excess remaining input left in stream" test_excess_tail+  ]+++-------------------------------------------------------------------------------+prop_roundtrip_Foo = monadicIO $ do+    a   <- (pick arbitrary :: PropertyM IO Foo)+    res <- run $+      getFromStream get =<< putToStream (put a)+    assert $ a == res+++-------------------------------------------------------------------------------+prop_roundtrip_Foo_chunking = monadicIO $ do+    as   <- (pick arbitrary :: PropertyM IO [Foo])+    Positive csize <- pick arbitrary+    res <- run $ do+      lbs <- fmap (LBS.fromChunks . rechunk csize . mconcat) . Streams.toList =<< putEachStream put =<< Streams.fromList as+      is <- fromLazyByteString lbs+      Streams.toList =<< getEachStream get is+    assert $ as == res+++-------------------------------------------------------------------------------+test_partial = do+  let s = mutatePut $ BS.drop 1+  assertGetException $ getFromStream (get :: Get Foo) =<< fromByteString s++-------------------------------------------------------------------------------+test_excess_tail = do+  let s = mutatePut $ (<> "extra")+  inS <- fromByteString s+  getFromStream (get :: Get Foo) inS+  remainder <- smappend inS+  remainder @?= "extra"++-------------------------------------------------------------------------------+smappend = Streams.fold mappend mempty++-------------------------------------------------------------------------------+test_excess_head = do+  let s = mutatePut $ ("extra" <>)+  assertGetException $ getFromStream (get :: Get Foo) =<< fromByteString s+++-------------------------------------------------------------------------------+mutatePut f = f $ runPut $ put $ Foo 42 "yup"+++-------------------------------------------------------------------------------+rechunk :: Int -> BS.ByteString -> [BS.ByteString]+rechunk n bs = fst $ MS.execState go ([], bs)+  where+    go :: MS.State ([BS.ByteString], BS.ByteString) ()+    go = do+      (chunks, rmning) <- MS.get+      unless (BS.null rmning) $ do+        let (chunk, rmning') = BS.splitAt n rmning+        MS.put (chunks ++ [chunk], rmning')+        go+++-------------------------------------------------------------------------------+assertGetException a = do+  res <- try a+  case res of+    Left (GetException _) -> return ()+    (Right r)             -> assertFailure $ "Expected a GetException but got " ++ show r+++-------------------------------------------------------------------------------+data Foo = Foo Int String deriving (Generic,Show,Eq)++instance Serialize Foo+$(derive makeArbitrary ''Foo)