diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +# hcobs + +[![Build Status](https://travis-ci.org/berdario/hcobs.svg?branch=master)](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] diff --git a/bench/MainBench.hs b/bench/MainBench.hs new file mode 100644 --- /dev/null +++ b/bench/MainBench.hs @@ -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 + ] diff --git a/hcobs.cabal b/hcobs.cabal new file mode 100644 --- /dev/null +++ b/hcobs.cabal @@ -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 diff --git a/src/Data/Stuffed.hs b/src/Data/Stuffed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stuffed.hs @@ -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 diff --git a/src/Data/Stuffed/Internal.hs b/src/Data/Stuffed/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Stuffed/Internal.hs @@ -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]" ) + diff --git a/test/Allocation.hs b/test/Allocation.hs new file mode 100644 --- /dev/null +++ b/test/Allocation.hs @@ -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 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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) +