diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Petter Bergman + +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 Petter Bergman 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/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/binary-streams.cabal b/binary-streams.cabal new file mode 100644 --- /dev/null +++ b/binary-streams.cabal @@ -0,0 +1,40 @@ +name: binary-streams +version: 0.1.0.0 +synopsis: data serialization/deserialization io-streams library +description: Allow binary serialization/deserialization using io-streams +homepage: http://github.com/jonpetterbergman/binary-streams +bug-reports: http://github.com/jonpetterbergman/binary-streams/issues +license: BSD3 +license-file: LICENSE +author: Petter Bergman +maintainer: jon.petter.bergman@gmail.com +-- copyright: +category: Data, IO-Streams +build-type: Simple +extra-source-files: changelog.md +cabal-version: >=1.10 + +library + exposed-modules: System.IO.Streams.Binary + -- other-modules: + other-extensions: DeriveDataTypeable + build-depends: base >=4.7 && <4.8, + bytestring >=0.9 && <0.11, + binary >=0.6 && <0.8, + io-streams >=1.1.0 && <2.0 + hs-source-dirs: src + default-language: Haskell2010 + +Test-Suite encode-decode + type: detailed-0.9 + test-module: EncodeDecode + build-depends: base >=4.7 && <4.8, + bytestring >=0.9 && <0.11, + Cabal >= 1.9.2, + binary >=0.6 && <0.8, + io-streams >=1.1.0 && <2.0, + binary-streams, + QuickCheck, + cabal-test-quickcheck + hs-source-dirs: test + default-language: Haskell2010 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# Version 0.1.0.0 + - Moved to github. + - Added changelog. diff --git a/src/System/IO/Streams/Binary.hs b/src/System/IO/Streams/Binary.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Streams/Binary.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module System.IO.Streams.Binary + ( -- * Decoding + binaryFromStream + , binaryInputStream + + -- * Encoding + , binaryToStream + , binaryOutputStream + + -- * Decode Exceptions + , DecodeException(..) + ) where + +import Control.Exception (throw,Exception) +import Data.Binary (Binary,get,put) +import Data.Binary.Builder (Builder,toLazyByteString) +import Data.Binary.Get (runGetIncremental, + Decoder(..), + pushEndOfInput, + pushChunk, + ByteOffset) +import Data.Binary.Put (execPut) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.Typeable (Typeable) +import System.IO.Streams (makeInputStream, + makeOutputStream, + InputStream, + OutputStream, + write, + unRead) +import qualified System.IO.Streams as Stream +import System.IO.Streams.ByteString (writeLazyByteString) + + +-- | An Exception raised when decoding fails. +data DecodeException = DecodeException ByteOffset String + deriving (Typeable) + +instance Show DecodeException where + show (DecodeException offset message) = + "Decode exception, offset " ++ show offset ++ ":" ++ show message + +instance Exception DecodeException + +decodeFromStream :: Decoder a + -> InputStream ByteString + -> IO (Maybe a) +decodeFromStream decoder is = + Stream.read is >>= + maybe (return Nothing) + (\s -> if S.null s then go decoder else go $ pushChunk decoder s) + where go (Fail _ offset message) = throw $ DecodeException offset message + go (Done s _ x) = + do + if S.null s then return () else unRead s is + return $ Just x + go decoder' = Stream.read is >>= + maybe (go $ pushEndOfInput decoder') + (\s -> if S.null s then go decoder' else go $ pushChunk decoder' s) + +-- | Read an instance of 'Binary' from an 'InputStream', throwing a +-- 'DecodeException' if the decoding fails. +-- +-- 'binaryFromStream' consumes only as much input as necessary: +-- any unconsumed input is pushed back onto the 'InputStream'. +binaryFromStream :: Binary a + => InputStream ByteString + -> IO (Maybe a) +binaryFromStream = decodeFromStream (runGetIncremental get) + +-- | Transform an 'InputStream' over byte strings to an 'InputStream' yielding +-- values of type a, throwing a 'DecodeException' if the decoding fails. +binaryInputStream :: Binary a + => InputStream ByteString + -> IO (InputStream a) +binaryInputStream = makeInputStream . binaryFromStream + +-- | Write an instance of 'Binary' to an 'InputStream'. +binaryToStream :: Binary a + => OutputStream ByteString + -> Maybe a + -> IO () +binaryToStream os Nothing = write Nothing os +binaryToStream os (Just x) = writeLazyByteString (toLazyByteString $ execPut $ put x) os + +-- | Transform an 'OutputStream' accepting byte strings to an 'OutputStream' +-- accepting values of type a. +binaryOutputStream :: Binary a + => OutputStream ByteString + -> IO (OutputStream a) +binaryOutputStream = makeOutputStream . binaryToStream diff --git a/test/EncodeDecode.hs b/test/EncodeDecode.hs new file mode 100644 --- /dev/null +++ b/test/EncodeDecode.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module EncodeDecode ( tests ) where + +import Control.Exception (catch,evaluate) +import Data.Binary (Binary) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Distribution.TestSuite (Test) +import Distribution.TestSuite.QuickCheck (testProperty) +import System.IO.Streams (write) +import System.IO.Streams.Binary (binaryInputStream, + binaryOutputStream, + DecodeException) +import System.IO.Streams.List (outputToList, + fromList, + toList, + writeList) +import Test.QuickCheck.Property (Property) +import Test.QuickCheck.Monadic (monadicIO, + assert, + run) + + +-- Using binary-streams, decode from a list of bytestrings +decode :: Binary a => [ByteString] -> IO [a] +decode ss = fromList ss >>= binaryInputStream >>= toList + +-- Using binary-streams, encode to a list of bytestrings +encode :: Binary a => [a] -> IO [ByteString] +encode xs = outputToList $ \os -> + do + bos <- binaryOutputStream os + writeList xs bos + write Nothing bos + +-- Encode something, then decode it and make sure we get the same thing back. +encodeDecodeEq :: (Binary a,Eq a) => [a] -> Property +encodeDecodeEq xs = monadicIO $ do + xs' <- run go + assert $ xs == xs' + where go = encode xs >>= decode + +-- corrupt something, remove the last byte of the last bytestring +corrupt :: [ByteString] -> [ByteString] +corrupt = reverse . go . reverse + where go (h:t) = ((S.reverse $ S.drop 1 $ S.reverse h):t) + go [] = [] + +-- Encode something, corrupt the encoded data, and make sure we get a +-- decode error when we try do decode it. +encodeDecodeError :: forall a. (Binary a,Eq a) => [a] -> Property +encodeDecodeError [] = monadicIO $ return () +encodeDecodeError xs = monadicIO $ do + run $ catch go $ \(_ :: DecodeException) -> return () + where go = + do + bList <- encode xs + (xs' :: [a]) <- decode $ corrupt bList + evaluate xs' + fail "decoding succeeded when it should fail" + +tests :: IO [Test] +tests = + return [testProperty "encode-decode-equality Int" + (encodeDecodeEq :: [Int] -> Property), + testProperty "encode-decode-equality String" + (encodeDecodeEq :: [String] -> Property), + testProperty "encode-decode-equality Maybe Int" + (encodeDecodeEq :: [Maybe Int] -> Property), + testProperty "encode-decode-equality Either Int String" + (encodeDecodeEq :: [Either Int String] -> Property), + testProperty "encode-decode-equality (Int,Int)" + (encodeDecodeEq :: [(Int,Int)] -> Property), + testProperty "encode-decode-equality (String,String)" + (encodeDecodeEq :: [(Int,Int)] -> Property), + testProperty "encode-decode-error Int" + (encodeDecodeError :: [Int] -> Property), + testProperty "encode-decode-error String" + (encodeDecodeError :: [String] -> Property), + testProperty "encode-decode-error Maybe Int" + (encodeDecodeError :: [Maybe Int] -> Property), + testProperty "encode-decode-error Either Int String" + (encodeDecodeError :: [Either Int String] -> Property), + testProperty "encode-decode-error (Int,Int)" + (encodeDecodeError :: [(Int,Int)] -> Property), + testProperty "encode-decode-error (String,String)" + (encodeDecodeError :: [(String,String)] -> Property)]