packages feed

packer (empty) → 0.1.0

raw patch · 9 files changed

+861/−0 lines, 9 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, mtl, packer, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ Data/Packer.hs view
@@ -0,0 +1,305 @@+-- |+-- Module      : Data.Packer+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Simple packing module.+--+-- This is a tradeoff between a more pure / builder (binary, cereal, builder)+-- and direct access to Storable or pointer manipulation+--+{-# LANGUAGE CPP #-}+module Data.Packer+    (+    -- * Types+      Packing+    , Unpacking+    , OutOfBoundUnpacking(..)+    , OutOfBoundPacking(..)+    , Hole+    -- * Main methods+    , runUnpacking+    , tryUnpacking+    , runPacking+    -- * Unpacking functions+    , unpackSkip+    , unpackSetPosition+    , unpackGetPosition+    , getWord8+    , getWord16+    , getWord16LE+    , getWord16BE+    , getWord32+    , getWord32LE+    , getWord32BE+    , getWord64+    , getWord64LE+    , getWord64BE+    , getBytes+    , getBytesCopy+    , getBytesWhile+    , getRemaining+    , getRemainingCopy+    , getStorable+    -- * Packing functions+    , packGetPosition+    , putWord8+    , putWord16+    , putWord16LE+    , putWord16BE+    , putWord32+    , putWord32LE+    , putWord32BE+    , putHoleWord32+    , putHoleWord32LE+    , putHoleWord32BE+    , putWord64+    , putWord64LE+    , putWord64BE+    , putHoleWord64+    , putHoleWord64LE+    , putHoleWord64BE+    , putBytes+    , putStorable+    , fillHole+    ) where++import Control.Applicative+import Data.Packer.Internal+import Data.Packer.Unsafe+import Data.Packer.IO+import Data.Packer.Endian+import Foreign.Ptr+import Foreign.ForeignPtr+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B (memcpy, unsafeCreate, toForeignPtr, fromForeignPtr)+import Data.Word+import Foreign.Storable+import System.IO.Unsafe+import qualified Control.Exception as E++#if __GLASGOW_HASKELL__ > 704+unsafeDoIO = unsafeDupablePerformIO+#else+unsafeDoIO = unsafePerformIO+#endif++-- | Peek and do an action on the result. just for convenience+{-# INLINE peekAnd #-}+peekAnd :: Storable a => (a -> b) -> Ptr a -> IO b+peekAnd f p = f <$> peek p++-- | Skip bytes+unpackSkip :: Int -> Unpacking ()+unpackSkip n = unpackCheckAct n (\_ -> return ())++-- | Get a Word8+getWord8 :: Unpacking Word8+getWord8 = unpackCheckAct 1 peek+{-# INLINE getWord8 #-}++-- | Get a Word16 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when unserializing format.+getWord16 :: Unpacking Word16+getWord16 = unpackCheckAct 2 (peek . castPtr)+{-# INLINE getWord16 #-}++-- | Get a Word16 serialized in little endian.+getWord16LE :: Unpacking Word16+getWord16LE = unpackCheckAct 2 (peekAnd le16Host . castPtr)+{-# INLINE getWord16LE #-}++-- | Get a Word16 serialized in big endian.+getWord16BE :: Unpacking Word16+getWord16BE = unpackCheckAct 2 (peekAnd be16Host . castPtr)+{-# INLINE getWord16BE #-}++-- | Get a Word32 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when unserializing format.+getWord32 :: Unpacking Word32+getWord32 = unpackCheckAct 4 (peek . castPtr)+{-# INLINE getWord32 #-}++-- | Get a Word32 serialized in little endian.+getWord32LE :: Unpacking Word32+getWord32LE = unpackCheckAct 4 (peekAnd le32Host . castPtr)+{-# INLINE getWord32LE #-}++-- | Get a Word32 serialized in big endian.+getWord32BE :: Unpacking Word32+getWord32BE = unpackCheckAct 4 (peekAnd be32Host . castPtr)+{-# INLINE getWord32BE #-}++-- | Get a Word64 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when unserializing format.+getWord64 :: Unpacking Word64+getWord64 = unpackCheckAct 8 (peek . castPtr)+{-# INLINE getWord64 #-}++-- | Get a Word64 serialized in little endian.+getWord64LE :: Unpacking Word64+getWord64LE = unpackCheckAct 8 (peekAnd le64Host . castPtr)+{-# INLINE getWord64LE #-}++-- | Get a Word64 serialized in big endian.+getWord64BE :: Unpacking Word64+getWord64BE = unpackCheckAct 8 (peekAnd be64Host . castPtr)+{-# INLINE getWord64BE #-}++-- | Get a number of bytes in bytestring format.+--+-- The original block of memory is expected to live for the life of this bytestring,+-- and this is done so by holding the original ForeignPtr.+getBytes :: Int -> Unpacking ByteString+getBytes n = unpackCheckActRef n $ \fptr ptr -> do+                    o <- withForeignPtr fptr $ \origPtr -> return (ptr `minusPtr` origPtr)+                    return $ B.fromForeignPtr fptr o n++-- | Similar to 'getBytes' but copy the bytes to a new bytestring without making reference+-- to the original memory after the copy. this allow the original block of memory to go away.+getBytesCopy :: Int -> Unpacking ByteString+getBytesCopy n = B.copy <$> getBytes n++-- | Get the remaining bytes.+getRemaining :: Unpacking ByteString+getRemaining = unpackGetNbRemaining >>= getBytes++-- | Get the remaining bytes but copy the bytestring and drop any+-- reference from the original function.+getRemainingCopy :: Unpacking ByteString+getRemainingCopy = B.copy <$> getRemaining++-- | Get a number of bytes until in bytestring format.+--+-- this could be made more efficient+getBytesWhile :: (Word8 -> Bool) -> Unpacking (Maybe ByteString)+getBytesWhile predicate = unpackLookahead searchEnd >>= \mn -> maybe (return Nothing) (\n -> Just <$> getBytes n) mn+    where searchEnd :: Ptr Word8 -> Int -> IO (Maybe Int)+          searchEnd ptr sz = loop 0+            where loop :: Int -> IO (Maybe Int)+                  loop i+                     | i >= sz   = return $ Nothing+                     | otherwise = do w <- peek (ptr `plusPtr` i)+                                      if predicate w+                                          then loop (i+1)+                                          else return $ Just i++-- | Get an arbitrary type with the Storable class constraint.+getStorable :: Storable a => Unpacking a+getStorable = get_ undefined+    where get_ :: Storable a => a -> Unpacking a+          get_ undefA = unpackCheckAct (sizeOf undefA) (peek . castPtr)++-- | Put a Word8+putWord8 :: Word8 -> Packing ()+putWord8 w = packCheckAct 1 (\ptr -> poke (castPtr ptr) w)++-- | Put a Word16 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when serializing format.+putWord16 :: Word16 -> Packing ()+putWord16 w = packCheckAct 2 (\ptr -> poke (castPtr ptr) w)+{-# INLINE putWord16 #-}++-- | Put a Word16 serialized in little endian.+putWord16LE :: Word16 -> Packing ()+putWord16LE w = putWord16 (le16Host w)++-- | Put a Word16 serialized in big endian.+putWord16BE :: Word16 -> Packing ()+putWord16BE w = putWord16 (be16Host w)++-- | Put a Word32 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when serializing format.+putWord32 :: Word32 -> Packing ()+putWord32 w = packCheckAct 4 (\ptr -> poke (castPtr ptr) w)+{-# INLINE putWord32 #-}++-- | Put a Word32 serialized in little endian.+putWord32LE :: Word32 -> Packing ()+putWord32LE w = putWord32 (le32Host w)++-- | Put a Word32 serialized in big endian.+putWord32BE :: Word32 -> Packing ()+putWord32BE w = putWord32 (be32Host w)++-- | Put a Word32 Hole+putHoleWord32_ :: (Word32 -> Word32) -> Packing (Hole Word32)+putHoleWord32_ f = packHole 4 (\ptr w -> poke (castPtr ptr) (f w))++putHoleWord32, putHoleWord32BE, putHoleWord32LE :: Packing (Hole Word32)+-- | Put a Word32 Hole in host endian+putHoleWord32 = putHoleWord32_ id++-- | Put a Word32 Hole in big endian+putHoleWord32BE = putHoleWord32_ be32Host++-- | Put a Word32 Hole in little endian+putHoleWord32LE = putHoleWord32_ le32Host++-- | Put a Word64 in the host endianess.+--+-- It's recommended to use an explicit endianness (LE or BE)+-- when serializing format.+putWord64 :: Word64 -> Packing ()+putWord64 w = packCheckAct 8 (\ptr -> poke (castPtr ptr) w)+{-# INLINE putWord64 #-}++-- | Put a Word64 serialized in little endian.+putWord64LE :: Word64 -> Packing ()+putWord64LE w = putWord64 (le64Host w)++-- | Put a Word64 serialized in big endian.+putWord64BE :: Word64 -> Packing ()+putWord64BE w = putWord64 (be64Host w)++-- | Put a Word64 Hole+putHoleWord64_ :: (Word64 -> Word64) -> Packing (Hole Word64)+putHoleWord64_ f = packHole 8 (\ptr w -> poke (castPtr ptr) (f w))++putHoleWord64, putHoleWord64BE, putHoleWord64LE :: Packing (Hole Word64)+-- | Put a Word64 Hole in host endian+putHoleWord64 = putHoleWord64_ id++-- | Put a Word64 Hole in big endian+putHoleWord64BE = putHoleWord64_ be64Host++-- | Put a Word64 Hole in little endian+putHoleWord64LE = putHoleWord64_ le64Host+++-- | Put a Bytestring.+putBytes :: ByteString -> Packing ()+putBytes bs =+    packCheckAct len $ \ptr ->+    withForeignPtr fptr $ \ptr2 ->+    B.memcpy ptr (ptr2 `plusPtr` o) len+  where (fptr,o,len) = B.toForeignPtr bs++-- | Put an arbitrary type with the Storable class constraint.+putStorable :: Storable a => a -> Packing ()+putStorable a = packCheckAct (sizeOf a) (\ptr -> poke (castPtr ptr) a)++-- | Unpack a bytestring using a monadic unpack action.+runUnpacking :: Unpacking a -> ByteString -> a+runUnpacking action bs = unsafeDoIO $ runUnpackingIO bs action++-- | Similar to 'runUnpacking' but returns an Either type with an exception type in case of failure.+tryUnpacking :: Unpacking a -> ByteString -> Either E.SomeException a+tryUnpacking action bs = unsafeDoIO $ tryUnpackingIO bs action++-- | Run packing with a buffer created internally with a monadic action and return the bytestring+runPacking :: Int -> Packing () -> ByteString+runPacking sz action = unsafeDoIO $ runPackingIO sz action
+ Data/Packer/Endian.hs view
@@ -0,0 +1,95 @@+-- |+-- Module      : Data.Packer.Endian+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Simple module to handle endianness swapping,+-- but GHC should provide (some day) primitives to call+-- into a cpu optimised version (e.g. bswap for x86)+--+{-# LANGUAGE CPP #-}+module Data.Packer.Endian+    ( le16Host+    , le32Host+    , le64Host+    , be16Host+    , be32Host+    , be64Host+    ) where++import Data.Bits+import Data.Word++#if BITS_IS_OLD+shr :: Bits a => a -> Int -> a+shr = shiftR+shl :: Bits a => a -> Int -> a+shl = shiftL+#else+shr :: Bits a => a -> Int -> a+shr = unsafeShiftR+shl :: Bits a => a -> Int -> a+shl = unsafeShiftL+#endif++-- | swap endianness on a Word64+-- 56 48 40 32 24 16  8  0+--  a  b  c  d  e  f  g  h +--  h  g  f  e  d  c  b  a+swap64 :: Word64 -> Word64+swap64 w =+        (w `shr` 56)                  .|. (w `shl` 56)+    .|. ((w `shr` 40) .&. 0xff00)     .|. ((w .&. 0xff00) `shl` 40)+    .|. ((w `shr` 24) .&. 0xff0000)   .|. ((w .&. 0xff0000) `shl` 24)+    .|. ((w `shr` 8)  .&. 0xff000000) .|. ((w .&. 0xff000000) `shl` 8)+{-+    .|. ((w `shr` 48) .&. 0xff00)     .|. ((w .&. 0xff00) `shl` 48)+    .|. ((w `shr` 40) .&. 0xff0000)   .|. ((w .&. 0xff0000) `shl` 40)+    .|. ((w `shr` 32) .&. 0xff000000) .|. ((w .&. 0xff000000) `shl` 32)+-}++-- | swap endianness on a Word32+swap32 :: Word32 -> Word32+swap32 w =+        (w `shr` 24)             .|. (w `shl` 24)+    .|. ((w `shr` 8) .&. 0xff00) .|. ((w .&. 0xff00) `shl` 8)++-- | swap endianness on a Word16+swap16 :: Word16 -> Word16+swap16 w = (w `shr` 8) .|. (w `shl` 8)++#ifdef CPU_BIG_ENDIAN+{-# INLINE be16Host #-}+be16Host :: Word16 -> Word16+be16Host = id+{-# INLINE be32Host #-}+be32Host :: Word32 -> Word32+be32Host = id+{-# INLINE be64Host #-}+be64Host :: Word64 -> Word64+be64Host = id+le16Host :: Word16 -> Word16+le16Host w = swap16 w+le32Host :: Word32 -> Word32+le32Host w = swap32 w+le64Host :: Word64 -> Word64+le64Host w = swap64 w+#else+{-# INLINE le16Host #-}+le16Host :: Word16 -> Word16+le16Host = id+{-# INLINE le32Host #-}+le32Host :: Word32 -> Word32+le32Host = id+{-# INLINE le64Host #-}+le64Host :: Word64 -> Word64+le64Host = id+be16Host :: Word16 -> Word16+be16Host w = swap16 w+be32Host :: Word32 -> Word32+be32Host w = swap32 w+be64Host :: Word64 -> Word64+be64Host w = swap64 w+#endif
+ Data/Packer/IO.hs view
@@ -0,0 +1,37 @@+-- |+-- Module      : Data.Packer.IO+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+module Data.Packer.IO+    ( runPackingIO+    , runUnpackingIO+    , tryUnpackingIO+    ) where++import Data.Packer.Internal+import Data.Packer.Unsafe+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as B (ByteString(..), mallocByteString, toForeignPtr)+import Foreign.ForeignPtr+import qualified Control.Exception as E++-- | Unpack a bytestring using a monadic unpack action in the IO monad.+runUnpackingIO :: ByteString -> Unpacking a -> IO a+runUnpackingIO bs action = runUnpackingAt fptr o len action+  where (fptr,o,len) = B.toForeignPtr bs++-- | Similar to 'runUnpackingIO' but catch exception and return an Either type.+tryUnpackingIO :: ByteString -> Unpacking a -> IO (Either E.SomeException a)+tryUnpackingIO bs action = E.try $ runUnpackingIO bs action++-- | Run packing with a buffer created internally with a monadic action and return the bytestring+runPackingIO :: Int -> Packing () -> IO ByteString+runPackingIO sz action = createUptoN sz $ \ptr -> runPackingAt ptr sz action+    where -- copy of bytestring createUptoN as it's only been added 2012-09+          createUptoN l f = do fp <- B.mallocByteString l+                               l' <- withForeignPtr fp $ \p -> f p+                               return $! B.PS fp 0 l'+
+ Data/Packer/Internal.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module      : Data.Packer.Internal+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Internal of packer which is a simple state monad that hold+-- a memory pointer and a size of the memory pointed.+--+module Data.Packer.Internal+    ( Packing(..)+    , Hole+    , Unpacking(..)+    , Memory(..)+    , UnpackSt(..)+    , PackSt(..)+    , OutOfBoundUnpacking(..)+    , OutOfBoundPacking(..)+    , HoleInPacking(..)+    , unpackUnsafeActRef+    , unpackCheckActRef+    , unpackUnsafeAct+    , unpackCheckAct+    , unpackLookahead+    , unpackSetPosition+    , unpackGetPosition+    , unpackGetNbRemaining+    , packCheckAct+    , packHole+    , packGetPosition+    , fillHole+    ) where++import Foreign.Ptr+import Foreign.ForeignPtr+import Data.Data+import Data.Word+import Control.Exception (Exception, throw)+import Control.Monad.State+import Control.Applicative (Applicative, (<$>), (<*>))++-- | Represent a memory block with a ptr as beginning+data Memory = Memory {-# UNPACK #-} !(Ptr Word8)+                     {-# UNPACK #-} !Int++-- | Unpacking state+data UnpackSt = UnpackSt !(ForeignPtr Word8) !Memory {-# UNPACK #-} !Memory++-- | Packing state+data PackSt = PackSt (Ptr Word8) !Int !Memory++-- | Packing monad+newtype Packing a = Packing { runPacking_ :: StateT PackSt IO a }+                  deriving (Functor,Applicative,Monad,MonadIO)++-- | Unpacking monad+newtype Unpacking a = Unpacking { runUnpacking_ :: StateT UnpackSt IO a }+                 deriving (Functor,Applicative,Monad,MonadIO)++-- | Exception when trying to put bytes out of the memory bounds.+data OutOfBoundPacking = OutOfBoundPacking Int -- position relative to the end+                                           Int -- number of bytes requested+    deriving (Show,Eq,Data,Typeable)++-- | Exception when trying to finalize the packing monad that still have holes open.+data HoleInPacking = HoleInPacking Int+    deriving (Show,Eq,Data,Typeable)++-- | Exception when trying to get bytes out of the memory bounds.+data OutOfBoundUnpacking = OutOfBoundUnpacking Int -- position+                                               Int -- number of bytes requested+    deriving (Show,Eq,Data,Typeable)++instance Exception OutOfBoundPacking+instance Exception HoleInPacking+instance Exception OutOfBoundUnpacking++-- TODO not firing probably because of earlier inlining ?+{-# RULES+"check/check merged" forall n m f g.+  (unpackCheckAct n f) <*> (unpackCheckAct m g) = unpackCheckAct (n+m) (\ptr -> f ptr <*> g (ptr `plusPtr` n))+"checkRef/checkRef merged" forall n m f g.+  (unpackCheckActRef n f) <*> (unpackCheckActRef m g) = unpackCheckActRef (n+m) (\r ptr -> f r ptr <*> g r (ptr `plusPtr` n))+  #-}++unpackUnsafeActRef :: Int -> (ForeignPtr Word8 -> Ptr Word8 -> IO a) -> Unpacking a+unpackUnsafeActRef n act = Unpacking $ do+    (UnpackSt fptr iniBlock (Memory ptr sz)) <- get+    r <- lift (act fptr ptr)+    put (UnpackSt fptr iniBlock (Memory (ptr `plusPtr` n) (sz - n)))+    return r++unpackCheckActRef :: Int -> (ForeignPtr Word8 -> Ptr Word8 -> IO a) -> Unpacking a+unpackCheckActRef n act = Unpacking $ do+    (UnpackSt fptr iniBlock@(Memory iniPtr _) (Memory ptr sz)) <- get+    when (sz < n) (lift $ throw $ OutOfBoundUnpacking (ptr `minusPtr` iniPtr) n)+    r <- lift (act fptr ptr)+    put (UnpackSt fptr iniBlock (Memory (ptr `plusPtr` n) (sz - n)))+    return r++unpackUnsafeAct :: Int -> (Ptr Word8 -> IO a) -> Unpacking a+unpackUnsafeAct n act = unpackUnsafeActRef n (\_ -> act)++unpackCheckAct :: Int -> (Ptr Word8 -> IO a) -> Unpacking a+unpackCheckAct n act = unpackCheckActRef n (\_ -> act)++-- | Set the new position from the beginning in the memory block.+-- This is useful to skip bytes or when using absolute offsets from a header or some such.+unpackSetPosition :: Int -> Unpacking ()+unpackSetPosition pos = Unpacking $ do+    (UnpackSt fptr iniBlock@(Memory iniPtr sz) _) <- get+    when (pos < 0 || pos >= sz) (lift $ throw $ OutOfBoundUnpacking pos 0)+    put (UnpackSt fptr iniBlock (Memory (iniPtr `plusPtr` pos) (sz-pos)))++-- | Get the position in the memory block.+unpackGetPosition :: Unpacking Int+unpackGetPosition = Unpacking $ gets (\(UnpackSt _ (Memory iniPtr _) (Memory ptr _)) -> ptr `minusPtr` iniPtr)++unpackGetNbRemaining :: Unpacking Int+unpackGetNbRemaining = Unpacking $ gets (\(UnpackSt _ _ (Memory _ sz)) -> sz)++-- | Allow to look into the memory.+-- This is inherently unsafe+unpackLookahead :: (Ptr Word8 -> Int -> IO a) -- ^ callback with current position and byte left+                -> Unpacking a+unpackLookahead f = Unpacking $ do+    (UnpackSt _ _ (Memory ptr sz)) <- get+    lift $ f ptr sz++withPackMemory :: Int -> (Ptr Word8 -> IO a) -> StateT PackSt IO a+withPackMemory n act = do+    (PackSt iPos holes (Memory ptr sz)) <- get+    when (sz < n) (lift $ throw $ OutOfBoundPacking sz n)+    r <- lift (act ptr)+    put $ PackSt iPos holes (Memory (ptr `plusPtr` n) (sz - n))+    return r++modifyHoles :: (Int -> Int) -> Packing ()+modifyHoles f = Packing $ modify (\(PackSt iPos holes mem) -> PackSt iPos (f holes) mem)++packCheckAct :: Int -> (Ptr Word8 -> IO a) -> Packing a+packCheckAct n act = Packing (withPackMemory n act)++-- | Get the position in the memory block.+packGetPosition :: Packing Int+packGetPosition = Packing $ gets (\(PackSt iniPtr _ (Memory ptr _)) -> ptr `minusPtr` iniPtr)++-- | A Hole represent something that need to be filled+-- later, for example a CRC, a prefixed size, etc.+--+-- They need to be filled before the end of the package,+-- otherwise an exception will be raised.+newtype Hole a = Hole (a -> IO ())++-- | Put a Hole of a specific size for filling later.+packHole :: Int -> (Ptr Word8 -> a -> IO ()) -> Packing (Hole a)+packHole n f = do+    r <- packCheckAct n (\ptr -> return $ Hole (\w -> f ptr w))+    modifyHoles (1 +)+    return r++-- | Fill a hole with a value+--+-- TODO: user can use one hole many times leading to wrong counting.+fillHole :: Hole a -> a -> Packing ()+fillHole (Hole closure) a = modifyHoles (\i -> i - 1) >> Packing (lift $ closure a)
+ Data/Packer/Unsafe.hs view
@@ -0,0 +1,49 @@+-- |+-- Module      : Data.Packer.Unsafe+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Access to lower primitive that allow to use Packing and Unpacking,+-- on mmap type of memory. Potentially unsafe, as it can't check if+-- any of value passed are valid.+--+module Data.Packer.Unsafe+    ( runPackingAt+    , runUnpackingAt+    ) where++import Data.Word+import Data.Packer.Internal+import Foreign.Ptr+import Foreign.ForeignPtr+import Control.Monad.State+import Control.Exception++-- | Run packing on an arbitrary buffer with a size.+--+-- This is available, for example to run on mmap typed memory, and this is highly unsafe,+-- as the user need to make sure the pointer and size passed to this function are correct.+runPackingAt :: Ptr Word8  -- ^ Pointer to the beginning of the memory+             -> Int        -- ^ Size of the memory+             -> Packing () -- ^ Packing action+             -> IO Int     -- ^ Number of bytes filled+runPackingAt ptr sz action = do+    (PackSt _ holes (Memory _ leftSz)) <- execStateT (runPacking_ action) (PackSt ptr 0 $ Memory ptr sz)+    when (holes > 0) (throwIO $ HoleInPacking holes)+    return $ sz - leftSz++-- | Run unpacking on an arbitrary buffer with a size.+--+-- This is available, for example to run on mmap typed memory, and this is highly unsafe,+-- as the user need to make sure the pointer and size passed to this function are correct.+runUnpackingAt :: ForeignPtr Word8 -- ^ The initial block of memory+               -> Int              -- ^ Starting offset in the block of memory+               -> Int              -- ^ Size+               -> Unpacking a      -- ^ Unpacking action+               -> IO a+runUnpackingAt fptr offset sz action =+    withForeignPtr fptr $ \ptr ->+      let m = Memory (ptr `plusPtr` offset) sz+       in evalStateT (runUnpacking_ action) (UnpackSt fptr m m)
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2013 Vincent Hanquez <vincent@snarc.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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
+ Tests/Tests.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit (testCase)++import Test.QuickCheck+import Test.HUnit+import Control.Applicative ((<$>))+import Control.Monad+import Control.Exception++import qualified Data.ByteString as B++import Data.Packer+import Data.Word++--instance Arbitrary a where++endiannessCases :: [ (String, (Word64 -> Packing ()), Unpacking Word64, B.ByteString, Word64) ]+endiannessCases =+    [ ("16LE", putWord16LE . fromIntegral, (fromIntegral <$> getWord16LE), B.pack [1,2], 0x0201)+    , ("16BE", putWord16BE . fromIntegral, (fromIntegral <$> getWord16BE), B.pack [2,1], 0x0201)+    , ("32LE", putWord32LE . fromIntegral, (fromIntegral <$> getWord32LE), B.pack [1,2,3,4], 0x04030201)+    , ("32BE", putWord32BE . fromIntegral, (fromIntegral <$> getWord32BE), B.pack [4,3,2,1], 0x04030201)+    , ("64LE", putWord64LE . fromIntegral, (fromIntegral <$> getWord64LE), B.pack [1,2,3,4,5,6,7,8], 0x0807060504030201)+    , ("64BE", putWord64BE . fromIntegral, (fromIntegral <$> getWord64BE), B.pack [8,7,6,5,4,3,2,1], 0x0807060504030201)+    ]++toEndianCase (n, pAct, gAct, bs, v) =+    [ testCase ("put" ++ n) (runPacking 8 (pAct v) @=? bs)+    , testCase ("get" ++ n) (runUnpacking gAct bs @=? v)+    ]++data DataAtom = W8    Word8+              | W16   Word16+              | W16BE Word16+              | W16LE Word16+              | W32   Word32+              | W32BE Word32+              | W32LE Word32+              | W64   Word64+              | W64BE Word64+              | W64LE Word64+              | Bytes B.ByteString+              deriving (Show,Eq)++newtype DataStream = DataStream [DataAtom]+    deriving (Show,Eq)++arbitraryBS =+        choose (0,257)+    >>= \sz -> replicateM sz (fromIntegral <$> (choose (0,255) :: Gen Int))+    >>= return . B.pack++instance Arbitrary DataAtom where+    arbitrary = oneof+        [ W8    <$> arbitrary+        , W16   <$> arbitrary+        , W16BE <$> arbitrary+        , W16LE <$> arbitrary+        , W32   <$> arbitrary+        , W32BE <$> arbitrary+        , W32LE <$> arbitrary+        , W64   <$> arbitrary+        , W64BE <$> arbitrary+        , W64LE <$> arbitrary+        , Bytes <$> arbitraryBS+        ]++instance Arbitrary DataStream where+    arbitrary = choose (0,2048)+            >>= \sz -> replicateM sz arbitrary+            >>= return . DataStream++packDataStream (DataStream atoms) = runPacking (foldl sumLen 0 atoms) (mapM_ process atoms)+    where process :: DataAtom -> Packing ()+          process (W8 w)    = putWord8 w+          process (W16 w)   = putWord16 w+          process (W32 w)   = putWord32 w+          process (W64 w)   = putWord64 w+          process (W16LE w) = putWord16LE w+          process (W32LE w) = putWord32LE w+          process (W64LE w) = putWord64LE w+          process (W16BE w) = putWord16BE w+          process (W32BE w) = putWord32BE w+          process (W64BE w) = putWord64BE w+          process (Bytes b) = putBytes b++          sumLen a (W8 _)    = a + 1+          sumLen a (W16 _)   = a + 2+          sumLen a (W16LE _) = a + 2+          sumLen a (W16BE _) = a + 2+          sumLen a (W32 _)   = a + 4+          sumLen a (W32LE _) = a + 4+          sumLen a (W32BE _) = a + 4+          sumLen a (W64 _)   = a + 8+          sumLen a (W64LE _) = a + 8+          sumLen a (W64BE _) = a + 8+          sumLen a (Bytes b) = a + B.length b++unpackDataStream :: DataStream -> B.ByteString -> DataStream+unpackDataStream (DataStream atoms) bs = DataStream $ runUnpacking (mapM process atoms) bs+    where process :: DataAtom -> Unpacking DataAtom+          process (W8 _)    = W8 <$> getWord8+          process (W16 _)   = W16 <$> getWord16+          process (W32 _)   = W32 <$> getWord32+          process (W64 _)   = W64 <$> getWord64+          process (W16LE _) = W16LE <$> getWord16LE+          process (W32LE _) = W32LE <$> getWord32LE+          process (W64LE _) = W64LE <$> getWord64LE+          process (W16BE _) = W16BE <$> getWord16BE+          process (W32BE _) = W32BE <$> getWord32BE+          process (W64BE _) = W64BE <$> getWord64BE+          process (Bytes b) = Bytes <$> getBytes (B.length b)++assertException msg filterE act =+    handleJust filterE (\_ -> return ()) (evaluate act >> assertFailure (msg ++ " didn't raise the proper exception"))++main :: IO ()+main = defaultMain+    [ testGroup "serialization"+        [ testGroup "basic cases"+            [ testCase "packing 4 bytes" (runPacking 4 (mapM_ putWord8 [1,2,3,4]) @=? B.pack [1,2,3,4])+            , testCase "packing out of bounds" (assertException "packing" (\(OutOfBoundPacking _ _) -> Just ())+                                                    (runPacking 1 (mapM_ putWord8 [1,2])))+            , testCase "unpacking out of bounds" (assertException "unpacking" (\(OutOfBoundUnpacking _ _) -> Just ())+                                                    (runUnpacking (mapM_ (\_ -> getWord8 >> return ()) [1,2]) (B.singleton 1)))+            , testCase "unpacking set pos before" (assertException "unpacking position" (\(OutOfBoundUnpacking _ _) -> Just ())+                                                    (runUnpacking (unpackSetPosition 2) (B.singleton 1)))+            , testCase "unpacking set pos after" (assertException "unpacking position" (\(OutOfBoundUnpacking _ _) -> Just ())+                                                    (runUnpacking (unpackSetPosition (-1)) (B.singleton 1)))+            ]+        , testGroup "endianness cases" $ concatMap toEndianCase endiannessCases+        , testProperty "unpacking.packing=id" (\ds -> unpackDataStream ds (packDataStream ds) == ds)+        ]+    ]
+ packer.cabal view
@@ -0,0 +1,42 @@+Name:                packer+Version:             0.1.0+Description:         Fast byte serializer and unserializer+License:             BSD3+License-file:        LICENSE+Copyright:           Vincent Hanquez <vincent@snarc.org>+Author:              Vincent Hanquez <vincent@snarc.org>+Maintainer:          Vincent Hanquez <vincent@snarc.org>+Synopsis:            Fast byte serializer and unserializer+Build-Type:          Simple+Category:            Data+stability:           experimental+Cabal-Version:       >=1.8+Homepage:            http://github.com/vincenthz/hs-packer++Library+  Build-Depends:     base >= 3 && < 5+                   , bytestring+                   , mtl+  Exposed-modules:   Data.Packer+                     Data.Packer.Unsafe+                     Data.Packer.IO+  Other-modules:     Data.Packer.Internal+                     Data.Packer.Endian++Test-Suite test-packer+  type:              exitcode-stdio-1.0+  hs-source-dirs:    Tests+  Main-Is:           Tests.hs+  Build-depends:     base >= 4 && < 5+                   , bytestring+                   , HUnit+                   , QuickCheck >= 2+                   , test-framework >= 0.3.3+                   , test-framework-quickcheck2 >= 0.2.9+                   , test-framework-hunit+                   , packer++source-repository head+  type:     git+  location: git://github.com/vincenthz/hs-packer+