diff --git a/Data/ByteString/Pack.hs b/Data/ByteString/Pack.hs new file mode 100644 --- /dev/null +++ b/Data/ByteString/Pack.hs @@ -0,0 +1,155 @@ +-- | +-- Module : Data.ByteString.Pack +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +module Data.ByteString.Pack + ( Packer + , Result(..) + , pack + -- * Operations + -- ** put + , putStorable + , putByteString + , fillList + , fillUpWith + -- ** skip + , skip + , skipStorable + ) where + +import Data.ByteString.Internal (ByteString(..)) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import Control.Applicative +import Data.Word +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr +import Foreign.Storable +import System.IO.Unsafe (unsafePerformIO) + +-- A little cache to update the data +data Cache = Cache {-# UNPACK #-} !(Ptr Word8) -- pointer in the bytestring + {-# UNPACK #-} !Int -- remaining size + +instance Show Cache where + show (Cache _ l) = show l + +-- | Packing result: +-- +-- * PackerOK a -> means the bytestring has been filled with the given data +-- * PackerMore a cache -> a temporary +data Result a = + PackerMore a Cache + | PackerFail String + deriving (Show) + +-- | Simple Bytestring Packer +newtype Packer a = Packer { runPacker_ :: Cache -> IO (Result a) } + +instance Functor Packer where + fmap = fmapPacker + +instance Applicative Packer where + pure = returnPacker + (<*>) = appendPacker + +instance Monad Packer where + return = returnPacker + (>>=) = bindPacker + +fmapPacker :: (a -> b) -> Packer a -> Packer b +fmapPacker f p = Packer $ \cache -> do + rv <- runPacker_ p cache + return $ case rv of + PackerMore v cache' -> PackerMore (f v) cache' + PackerFail err -> PackerFail err + +returnPacker :: a -> Packer a +returnPacker v = Packer $ \cache -> return $ PackerMore v cache + +bindPacker :: Packer a -> (a -> Packer b) -> Packer b +bindPacker p fp = Packer $ \cache -> do + rv <- runPacker_ p cache + case rv of + PackerMore v cache' -> runPacker_ (fp v) cache' + PackerFail err -> return $ PackerFail err + +appendPacker :: Packer (a -> b) -> Packer a -> Packer b +appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v) + +-- | pack the given packer into the given bytestring +pack :: Packer a -> Int -> Either String ByteString +pack p len = + unsafePerformIO $ do + fptr <- B.mallocByteString len + val <- withForeignPtr fptr $ \ptr -> + runPacker_ p (Cache ptr len) + return $ case val of + PackerMore _ (Cache _ r) -> Right (PS fptr 0 (len - r)) + PackerFail err -> Left err + +-- run a sized action +actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a +actionPacker s action = Packer $ \(Cache ptr size) -> + case compare size s of + LT -> return $ PackerFail "Not enough space in destination" + _ -> do + v <- action ptr + return $ PackerMore v (Cache (ptr `plusPtr` s) (size - s)) + +-- | put a storable from the current position in the stream +putStorable :: Storable storable => storable -> Packer () +putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s) + + +-- | put a Bytestring from the current position in the stream +-- +-- If the ByteString ins null, then do nothing +putByteString :: ByteString -> Packer () +putByteString bs + | neededLength == 0 = return () + | otherwise = actionPacker neededLength (actionPackerByteString bs) + where + neededLength :: Int + neededLength = B.length bs + + actionPackerByteString :: ByteString -> Ptr Word8 -> IO () + actionPackerByteString (PS fptr off _) ptr = + withForeignPtr fptr $ \srcptr -> + B.memcpy ptr (srcptr `plusPtr` off) neededLength + +-- | skip some bytes from the current position in the stream +skip :: Int -> Packer () +skip n = actionPacker n (\_ -> return ()) + +-- | skip the size of a storable from the current position in the stream +skipStorable :: Storable storable => storable -> Packer () +skipStorable = skip . sizeOf + +-- | fill up from the current position in the stream to the end +-- +-- it is basically: +-- > fillUpWith s == fillList (repeat s) +fillUpWith :: Storable storable => storable -> Packer () +fillUpWith s = fillList $ repeat s + +-- | Will put the given storable list from the current position in the stream +-- to the end. +-- +-- This function will fail with not enough storage if the given storable can't +-- be written (not enough space) +-- +-- example: +-- > pack (fillList $ [1..] :: Word8) 9 ==> "\1\2\3\4\5\6\7\8\9" +-- > pack (fillList $ [1..] :: Word32) 4 ==> "\1\0\0\0" +-- > pack (fillList $ [1..] :: Word32) 64 -- will work +-- > pack (fillList $ [1..] :: Word32) 1 -- will fail (not enough space) +-- > pack (fillList $ [1..] :: Word32) 131 -- will fail (not enough space) +fillList :: Storable storable => [storable] -> Packer () +fillList [] = return () +fillList (x:xs) = putStorable x >> fillList xs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Nicolas DI PRIMA + +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 Nicolas DI PRIMA 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/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Tests.Tests.hs +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE OverloadedStrings #-} +import Test.Tasty +import Test.Tasty.HUnit + +import Data.ByteString (ByteString) +import Data.ByteString.Pack +import Data.Word +import Data.Char + +------------------------------------------------------------------------------ +-- Simple packers to test -- +------------------------------------------------------------------------------ + +putWord8 :: Word8 -> Packer () +putWord8 = putStorable + +putWord16 :: Word16 -> Packer () +putWord16 = putStorable + +putWord32 :: Word32 -> Packer () +putWord32 = putStorable + +testPackerOk :: ByteString -> Int -> Packer () -> Assertion +testPackerOk expected size packer = + case pack packer size of + Left err -> assertFailure err + Right result -> assertEqual ("the two given value should be equal: Test(" ++ (show expected) ++ ")") + expected result + +testPackerFail :: Int -> Packer () -> Assertion +testPackerFail size packer = + case pack packer size of + Left _ -> return () + Right result -> assertFailure $ "The given test should not pass: " ++ (show result) + +testCaseOk :: String -> ByteString -> Int -> Packer () -> TestTree +testCaseOk msg expected size packer = testCase msg (testPackerOk expected size packer) + +testCaseFail :: String -> Int -> Packer () -> TestTree +testCaseFail msg size packer = testCase msg (testPackerFail size packer) + +------------------------------------------------------------------------------ +-- Group of tests +------------------------------------------------------------------------------ + +fromChar :: (Num a) => Char -> a +fromChar = fromIntegral . ord + +refTestsOk = testGroup "All these tests must always pass" + [ testCaseOk "put a byte" "B" 1 (putWord8 $ fromChar 'B') + , testCaseOk "write string" "Haskell rocks!" 42 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!") + , testCaseOk "put a 2 bytes" "XY" 2 (putWord16 0x5958) + ] + +refTestsFail = testGroup "Try to see that pack fails properly" + [ testCaseFail "not enough space" 1 (putWord32 42) + , testCaseFail "3 actions, enough for 1" 7 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!") + , testCaseFail "3 actions, enough for 2" 8 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!") + , testCaseFail "3 actions, enough for 2 bis" 9 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!") + ] + +tests = testGroup "bspack test suit" + [ refTestsOk + , refTestsFail + ] + +main = defaultMain tests diff --git a/bspack.cabal b/bspack.cabal new file mode 100644 --- /dev/null +++ b/bspack.cabal @@ -0,0 +1,41 @@ +-- Initial bspack.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: bspack +version: 0.0.1 +synopsis: A simple and fast bytestring packer +description: A simple and fast bytestring packer +homepage: https://github.com/NicolasDP/hs-bspack +license: BSD3 +license-file: LICENSE +author: Nicolas DI PRIMA +maintainer: nicolas@di-prima.fr +-- copyright: +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.ByteString.Pack + -- other-modules: + -- other-extensions: + build-depends: base == 4.* + , bytestring + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans + +Test-Suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: Tests + Main-is: Tests.hs + Build-Depends: base == 4.* + , bytestring + , mtl + , tasty + , tasty-quickcheck + , tasty-hunit + , bspack + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + default-language: Haskell2010