diff --git a/Data/Packer.hs b/Data/Packer.hs new file mode 100644 --- /dev/null +++ b/Data/Packer.hs @@ -0,0 +1,305 @@ +-- | +-- Module : Data.Packer +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/Packer/Endian.hs b/Data/Packer/Endian.hs new file mode 100644 --- /dev/null +++ b/Data/Packer/Endian.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Data.Packer.Endian +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/Packer/IO.hs b/Data/Packer/IO.hs new file mode 100644 --- /dev/null +++ b/Data/Packer/IO.hs @@ -0,0 +1,37 @@ +-- | +-- Module : Data.Packer.IO +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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' + diff --git a/Data/Packer/Internal.hs b/Data/Packer/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Packer/Internal.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module : Data.Packer.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Data/Packer/Unsafe.hs b/Data/Packer/Unsafe.hs new file mode 100644 --- /dev/null +++ b/Data/Packer/Unsafe.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Data.Packer.Unsafe +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2013 Vincent Hanquez + +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. 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,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) + ] + ] diff --git a/packer.cabal b/packer.cabal new file mode 100644 --- /dev/null +++ b/packer.cabal @@ -0,0 +1,42 @@ +Name: packer +Version: 0.1.0 +Description: Fast byte serializer and unserializer +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +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 +