hcobs (empty) → 0.1.0.0
raw patch · 8 files changed
+387/−0 lines, 8 filesdep +basedep +base64-bytestringdep +bytestring
Dependencies added: base, base64-bytestring, bytestring, containers, criterion, deepseq, ghc-prim, hcobs, hedgehog, mmorph, mtl, reflection, weigh
Files
- LICENSE +26/−0
- README.md +26/−0
- bench/MainBench.hs +29/−0
- hcobs.cabal +91/−0
- src/Data/Stuffed.hs +72/−0
- src/Data/Stuffed/Internal.hs +20/−0
- test/Allocation.hs +45/−0
- test/Spec.hs +78/−0
+ LICENSE view
@@ -0,0 +1,26 @@+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 Author name here 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.
+ README.md view
@@ -0,0 +1,26 @@+# hcobs++[](https://travis-ci.org/berdario/hcobs)++Haskell implementation of the [Consistent Overhead Byte Stuffing](https://en.wikipedia.org/wiki/Consistent_Overhead_Byte_Stuffing) algorithm.++It provides a `Stuffed` newtype wrapper for Lazy Bytestrings, which is parametrized on the Byte (Word8, representated as a type-level Nat) to be encoded away.++The implementation tries to be as efficient as possible, type safe and easy to use. If you have a "sink" like+++ sink :: Stuffed 0 -> IO ()+ sink = undefined++You'd then simply be able to encode a Bytestring with `sink $ stuff bytes`.++You can try this out in ghci with:++ > :set -XOverloadedStrings+ > :set -XDataKinds+ > import Data.Stuffed+ > let stuffedBytes = stuff "a\0b\0c" :: Stuffed 0+ > unpack $ unwrap stuffedBytes -- directly access the underlying bytestring+ [2,97,2,98,2,99]+ > unpack $ unstuff stuffedBytes+ [97,0,98,0,99]
+ bench/MainBench.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}++import Criterion.Main+import Data.ByteString (useAsCStringLen, packCStringLen)+import Data.ByteString.Lazy hiding (replicate)+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Base64 (encode, decode)+import Data.Stuffed+import Prelude hiding (concat)+import System.IO.Unsafe (unsafePerformIO)++stuffedRt = unstuff . (stuff :: _ -> Stuffed 0)+cStringRt = fromStrict . unsafePerformIO . flip useAsCStringLen packCStringLen . toStrict+base64Rt = fromStrict . (\(Right x) -> x) . decode . encode . toStrict++benchStuffing :: (ByteString -> ByteString) -> [Benchmark]+benchStuffing roundTrip =+ [ bench "empty" $ nf roundTrip ""+ , bench "allbytes" $ nf roundTrip $ concat $ replicate 40 $ pack [0..255]+ , bench "allzeros" $ nf roundTrip $ BSL.replicate 10000 0+ ]++main = defaultMain [+ bgroup "stuff/unstuff" $ benchStuffing stuffedRt+ , bgroup "base64" $ benchStuffing base64Rt+ , bgroup "asCString/packCString" $ benchStuffing cStringRt+ ]
+ hcobs.cabal view
@@ -0,0 +1,91 @@+name: hcobs+version: 0.1.0.0+synopsis: An implementation of the Consistent Overhead Byte Stuffing algorithm+description: An implementation of the Consistent Overhead Byte Stuffing algorithm.+homepage: https://github.com/berdario/hcobs#readme+license: BSD3+license-file: LICENSE+author: Dario Bertini+maintainer: berdario@gmail.com+copyright: 2017 Dario Bertini+category: Codec+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.Stuffed+ , Data.Stuffed.Internal+ build-depends: base >= 4.7 && < 5+ , bytestring+ , containers+ , reflection+ , ghc-prim+ ghc-options: -Weverything+ -Wno-missing-exported-signatures+ -Wno-missing-import-lists+ -Wno-missed-specialisations+ -Wno-all-missed-specialisations+ -Wno-unsafe+ -Wno-safe+ -Wno-missing-local-signatures+ -Wno-monomorphism-restriction++ default-language: Haskell2010++test-suite hcobs-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , hcobs+ , hedgehog >= 0.5+ , bytestring+ , reflection+ , mtl+ , mmorph+ , ghc-prim+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ -Weverything+ -Wno-missing-exported-signatures+ -Wno-missing-import-lists+ -Wno-missed-specialisations+ -Wno-all-missed-specialisations+ -Wno-unsafe+ -Wno-safe+ -Wno-missing-local-signatures+ -Wno-monomorphism-restriction+ default-language: Haskell2010+++test-suite hcobs-weigh+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Allocation.hs+ build-depends: base+ , hcobs+ , weigh+ , bytestring+ , deepseq+ , base64-bytestring+ default-language: Haskell2010++benchmark mainbench+ type: exitcode-stdio-1.0+ hs-source-dirs: src, bench+ other-modules: Data.Stuffed+ main-is: MainBench.hs+ build-depends: base+ , bytestring+ , reflection+ , ghc-prim+ , criterion+ , base64-bytestring+ ghc-options: -Wall+ -O2+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/berdario/hcobs
+ src/Data/Stuffed.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Data.Stuffed+ ( Stuffed+ , stuff+ , unstuff+ , unwrap+ )+ where++import qualified Data.ByteString as B+import Data.ByteString.Builder (Builder, byteString, toLazyByteString)+import Data.ByteString.Lazy (ByteString, fromChunks, splitAt,+ toStrict)+import Data.Int (Int64)+import Data.Proxy (Proxy (..))+import Data.Reflection (reflect)+import Data.Semigroup (Semigroup)+import Data.Word (Word8)+import GHC.Generics (Generic)+import GHC.Types (Nat)+import Prelude hiding (concat, length, null, splitAt)++import Data.Stuffed.Internal (IsByte)++newtype Stuffed (a :: Nat) = Stuffed ByteString+ deriving (Eq, Ord, Show, Semigroup, Monoid, Generic)++splitEvery :: Int64 -> ByteString -> [B.ByteString]+splitEvery _ "" = []+splitEvery n bs = toStrict start : splitEvery n rest+ where+ (start, rest) = splitAt n bs++stuff :: forall a. IsByte a => ByteString -> Stuffed a+stuff bs = Stuffed $ fromChunks chunks+ where+ excluded = fromIntegral (reflect (Proxy :: Proxy a) :: Integer)+ chunks = map (buildStuffed excluded) $ splitEvery 254 bs++buildStuffed :: Word8 -> B.ByteString -> B.ByteString+buildStuffed excluded bs = B.cons last stuffed+ where+ excludedOffset = fromIntegral excluded + 1+ swapExcluded n current | current == excluded = (excludedOffset, n)+ | otherwise = (n + 1, current)+ (last, stuffed) = B.mapAccumR swapExcluded excludedOffset bs++unstuff :: forall a. IsByte a => Stuffed a -> ByteString+unstuff (Stuffed bs) = toLazyByteString $ mconcat chunks+ where+ excluded = fromIntegral (reflect (Proxy :: Proxy a) :: Integer)+ rebuild bytes = rebuildChunk excluded (B.uncons bytes) mempty+ chunks = map rebuild $ splitEvery 255 bs++rebuildChunk :: Word8 -> Maybe (Word8, B.ByteString) -> Builder -> Builder+rebuildChunk _ Nothing b = b+rebuildChunk excluded (Just (starting_offset, rest)) _ = byteString $ snd $ B.mapAccumL swapExcluded (starting_offset - 1) rest+ where+ swapExcluded n current | n == excluded = (current - 1, excluded)+ | otherwise = (n - 1, current)++unwrap :: Stuffed a -> ByteString+unwrap (Stuffed bs) = bs
+ src/Data/Stuffed/Internal.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++module Data.Stuffed.Internal+ (IsByte)+ where++import GHC.TypeLits (CmpNat, ErrorMessage (..), KnownNat, TypeError)+import GHC.Types (Nat)++type IsByte a = (KnownNat a, IsByteLT a (CmpNat a 256) ~ 'True)++type family IsByteLT (n :: Nat) x where+ IsByteLT n 'LT = 'True+ IsByteLT n _ = TypeError (Text "Stuffed can be parametrized only on bytes" :$$:+ Text "(" :<>: ShowType n :<>: Text " is not within range [0, 255]" )+
+ test/Allocation.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE OverloadedStrings #-}++import Data.ByteString.Lazy hiding (replicate)+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Base64 (encode, decode)+import Data.Stuffed+import Control.DeepSeq --(NFData)+import Control.Exception+import Prelude hiding (concat)+import Weigh (mainWith, func)++instance NFData (Stuffed a)++stuffZero :: _ -> Stuffed 0+stuffZero = stuff++main :: IO ()+main = do+ let stuffedAll = stuffZero allBytes+ let stuffedZeros = stuffZero zeros+ let base64All = encode $ toStrict allBytes+ let base64Zeros = encode $ toStrict zeros+ evaluate $!! stuffZero allBytes+ evaluate $!! stuffZero zeros+ evaluate $!! encode $ toStrict allBytes+ evaluate $!! encode $ toStrict zeros+ mainWith $ do+ func "stuff/empty" stuffZero ""+ func "stuff/allbytes" stuffZero allBytes+ func "stuff/allzeros" stuffZero zeros+ func "base64encode/empty" encode ""+ func "base64encode/allbytes" encode $ toStrict allBytes+ func "base64encode/allzeros" encode $ toStrict zeros+ func "unstuff/empty" unstuff $ stuffZero ""+ func "unstuff/allbytes" unstuff stuffedAll+ func "unstuff/allzeros" unstuff stuffedZeros+ func "base64decode/empty" decode $ encode ""+ func "base64decode/allbytes" decode base64All+ func "base64decode/allzeros" decode base64Zeros+ where+ allBytes = concat $ replicate 40 $ pack [0..255]+ zeros = BSL.replicate 10000 0+
+ test/Spec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ConstraintKinds #-}++import Control.Monad (unless)+import Control.Monad.Identity (Identity)+import Control.Monad.Morph (generalize, hoist)+import Data.ByteString.Lazy (ByteString, length, notElem, fromStrict)+import Data.Proxy (Proxy(..))+import Data.Reflection (Reifies, reflect, reifyNat)+import Data.Word (Word8)+import GHC.Exts (Constraint)+import GHC.TypeLits (KnownNat, CmpNat)+import Hedgehog+import Hedgehog.Gen (bytes, word8)+import Hedgehog.Range (constant, constantBounded)+import Prelude hiding (length, notElem)+import System.Exit (exitFailure)+import Unsafe.Coerce (unsafeCoerce)+import System.IO.Unsafe++import Data.Stuffed (Stuffed, stuff, unstuff, unwrap)++data Dict (c :: Constraint) where+ Dict :: (c) => Dict c++main :: IO ()+main = do+ result <- checkParallel $ Group "Stuffed properties"+ [ ("roundtrips",+ stuffedProperty (bytesAndExclusion 0) (const roundTrips))+ , ("1 byte bigger every 254",+ withTests 1000 $+ stuffedProperty (bytesAndExclusion 1) (const biggerBy1Every254))+ , ("Doesn't contain the excluded byte",+ stuffedProperty (bytesAndExclusion 0) notContains) ]+ unless result exitFailure++type Generator = Gen (ByteString, Word8)++bytesAndExclusion :: Int -> Generator+bytesAndExclusion minSize = (,) <$> (fromStrict <$> bytes (constant minSize 1100)) <*> word8 constantBounded++smallerThan256 :: forall a. (KnownNat a) => Maybe (Dict (KnownNat a, CmpNat a 256 ~ 'LT))+smallerThan256 = if n < 256+ then Just $ unsafeCoerce (Dict :: Dict (KnownNat a, 'LT ~ 'LT))+ else Nothing+ where+ n = reflect (Proxy :: Proxy a)++stuffedProperty :: Generator -> (forall a. (KnownNat a, CmpNat a 256 ~ 'LT) => Word8 -> ByteString -> Proxy a -> PropertyT Identity ()) -> Property+stuffedProperty gen prop = property $ hoist generalize $ do+ (x, w) <- forAll gen+ reifyNat (fromIntegral w) $ \(p :: Proxy n) ->+ case smallerThan256 of+ Nothing -> failure+ (Just (Dict :: Dict (KnownNat n, CmpNat n 256 ~ 'LT))) -> prop w x p++++roundTrips :: forall a. (KnownNat a, CmpNat a 256 ~ 'LT) => ByteString -> Proxy a -> PropertyT Identity ()+roundTrips bs _ = bs === unstuff (stuff bs :: Stuffed a)++biggerBy1Every254 :: forall a. (KnownNat a, CmpNat a 256 ~ 'LT) => ByteString -> Proxy a -> PropertyT Identity ()+biggerBy1Every254 bs _ = length stf === inputL + ((inputL `div` 255) + inputL) `div` 255 + 1+ where+ stf = unwrap (stuff bs :: Stuffed a)+ inputL = length bs+++notContains :: forall a. (KnownNat a, CmpNat a 256 ~ 'LT) => Word8 -> ByteString -> Proxy a -> PropertyT Identity ()+notContains i bs _ = assert $ i `notElem` stf+ where+ stf = unwrap (stuff bs :: Stuffed a)+