memory (empty) → 0.1
raw patch · 30 files changed
+2921/−0 lines, 30 filesdep +basedep +bytestringdep +deepseqsetup-changed
Dependencies added: base, bytestring, deepseq, ghc-prim, memory, tasty, tasty-hunit, tasty-quickcheck
Files
- Data/ByteArray.hs +32/−0
- Data/ByteArray/Bytes.hs +180/−0
- Data/ByteArray/Encoding.hs +62/−0
- Data/ByteArray/Hash.hs +78/−0
- Data/ByteArray/Mapping.hs +79/−0
- Data/ByteArray/MemView.hs +38/−0
- Data/ByteArray/Methods.hs +228/−0
- Data/ByteArray/Pack.hs +130/−0
- Data/ByteArray/Pack/Internal.hs +89/−0
- Data/ByteArray/Parse.hs +221/−0
- Data/ByteArray/ScrubbedBytes.hs +166/−0
- Data/ByteArray/Types.hs +46/−0
- Data/Memory/Encoding/Base16.hs +168/−0
- Data/Memory/Encoding/Base64.hs +161/−0
- Data/Memory/Endian.hs +118/−0
- Data/Memory/ExtendedWords.hs +17/−0
- Data/Memory/Hash/FNV.hs +93/−0
- Data/Memory/Hash/SipHash.hs +161/−0
- Data/Memory/Internal/Compat.hs +76/−0
- Data/Memory/Internal/CompatPrim.hs +89/−0
- Data/Memory/Internal/DeepSeq.hs +28/−0
- Data/Memory/Internal/Imports.hs +17/−0
- Data/Memory/MemMap/Posix.hsc +200/−0
- Data/Memory/MemMap/Windows.hs +12/−0
- Data/Memory/PtrMethods.hs +112/−0
- LICENSE +28/−0
- README.md +58/−0
- Setup.hs +2/−0
- memory.cabal +95/−0
- tests/Tests.hs +137/−0
+ Data/ByteArray.hs view
@@ -0,0 +1,32 @@+-- |+-- Module : Data.ByteArray+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+-- Simple and efficient byte array types+--+-- This module should be imported qualified.+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Data.ByteArray+ (+ -- * ByteArray Classes+ module Data.ByteArray.Types+ -- * ByteArray built-in types+ , module Data.ByteArray.Bytes+ , module Data.ByteArray.ScrubbedBytes+ , module Data.ByteArray.MemView+ -- * ByteArray methods+ , module Data.ByteArray.Methods+ ) where++import Data.ByteArray.Types+import Data.ByteArray.Methods+import Data.ByteArray.ScrubbedBytes (ScrubbedBytes)+import Data.ByteArray.Bytes (Bytes)+import Data.ByteArray.MemView (MemView(..))
+ Data/ByteArray/Bytes.hs view
@@ -0,0 +1,180 @@+-- |+-- Module : Data.ByteArray.Bytes+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+-- Simple and efficient byte array types+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Data.ByteArray.Bytes+ ( Bytes+ ) where++import GHC.Types+import GHC.Prim+import GHC.Ptr+import Data.Monoid+import Data.Memory.PtrMethods+import Data.Memory.Internal.Imports+import Data.Memory.Internal.CompatPrim+import Data.Memory.Internal.Compat (unsafeDoIO)+import Data.ByteArray.Types++-- | Simplest Byte Array+data Bytes = Bytes (MutableByteArray# RealWorld)++instance Show Bytes where+ showsPrec p b r = showsPrec p (bytesUnpackChars b []) r+instance Eq Bytes where+ (==) = bytesEq+instance Ord Bytes where+ compare = bytesCompare+instance Monoid Bytes where+ mempty = unsafeDoIO (newBytes 0)+ mappend b1 b2 = unsafeDoIO $ bytesAppend b1 b2+ mconcat = unsafeDoIO . bytesConcat+instance NFData Bytes where+ rnf b = b `seq` ()+instance ByteArrayAccess Bytes where+ length = bytesLength+ withByteArray = withBytes+instance ByteArray Bytes where+ allocRet = bytesAllocRet++------------------------------------------------------------------------+newBytes :: Int -> IO Bytes+newBytes (I# sz)+ | booleanPrim (sz <# 0#) = error "Bytes: size must be >= 0"+ | otherwise = IO $ \s ->+ case newAlignedPinnedByteArray# sz 8# s of+ (# s', mbarr #) -> (# s', Bytes mbarr #)++touchBytes :: Bytes -> IO ()+touchBytes (Bytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #)++sizeofBytes :: Bytes -> Int+sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba)++withPtr :: Bytes -> (Ptr p -> IO a) -> IO a+withPtr b@(Bytes mba) f = do+ a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba)))+ touchBytes b+ return a+------------------------------------------------------------------------++bytesAlloc :: Int -> (Ptr p -> IO ()) -> IO Bytes+bytesAlloc sz f = do+ ba <- newBytes sz+ withPtr ba f+ return ba++bytesConcat :: [Bytes] -> IO Bytes+bytesConcat l = bytesAlloc retLen (copy l)+ where+ retLen = sum $ map bytesLength l++ copy [] _ = return ()+ copy (x:xs) dst = do+ withPtr x $ \src -> memCopy dst src chunkLen+ copy xs (dst `plusPtr` chunkLen)+ where+ chunkLen = bytesLength x++bytesAppend :: Bytes -> Bytes -> IO Bytes+bytesAppend b1 b2 = bytesAlloc retLen $ \dst -> do+ withPtr b1 $ \s1 -> memCopy dst s1 len1+ withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2+ where+ len1 = bytesLength b1+ len2 = bytesLength b2+ retLen = len1 + len2++bytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, Bytes)+bytesAllocRet sz f = do+ ba <- newBytes sz+ r <- withPtr ba f+ return (r, ba)++bytesLength :: Bytes -> Int+bytesLength = sizeofBytes++withBytes :: Bytes -> (Ptr p -> IO a) -> IO a+withBytes = withPtr++bytesEq :: Bytes -> Bytes -> Bool+bytesEq b1@(Bytes m1) b2@(Bytes m2)+ | l1 /= l2 = False+ | otherwise = unsafeDoIO $ IO $ \s -> loop 0# s+ where+ !l1@(I# len) = bytesLength b1+ !l2 = bytesLength b2++ loop i s+ | booleanPrim (i ==# len) = (# s, True #)+ | otherwise =+ case readWord8Array# m1 i s of+ (# s', e1 #) -> case readWord8Array# m2 i s' of+ (# s'', e2 #) ->+ if booleanPrim (eqWord# e1 e2)+ then loop (i +# 1#) s''+ else (# s', False #)++bytesCompare :: Bytes -> Bytes -> Ordering+bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ IO $ \s -> loop 0# s+ where+ !l1 = bytesLength b1+ !l2 = bytesLength b2+ !(I# len) = min l1 l2++ loop i s1+ | booleanPrim (i ==# len) =+ if l1 == l2+ then (# s1, EQ #)+ else if l1 > l2 then (# s1, GT #)+ else (# s1, LT #)+ | otherwise =+ case readWord8Array# m1 i s1 of+ (# s2, e1 #) -> case readWord8Array# m2 i s2 of+ (# s3, e2 #) ->+ if booleanPrim (eqWord# e1 e2)+ then loop (i +# 1#) s3+ else if booleanPrim (ltWord# e1 e2) then (# s3, LT #)+ else (# s3, GT #)++bytesUnpackChars :: Bytes -> String -> String+bytesUnpackChars (Bytes mba) xs = chunkLoop 0#+ where+ !len = sizeofMutableByteArray# mba+ -- chunk 64 bytes at a time+ chunkLoop :: Int# -> [Char]+ chunkLoop idx+ | booleanPrim (len ==# idx) = []+ | booleanPrim ((len -# idx) ># 63#) =+ bytesLoop idx (idx +# 64#) (chunkLoop (idx +# 64#))+ | otherwise =+ bytesLoop idx (len -# idx) xs++ bytesLoop idx chunkLenM1 paramAcc = unsafeDoIO $+ loop (idx +# chunkLenM1 -# 1#) paramAcc+ where loop i acc+ | booleanPrim (i ==# idx) = do+ c <- rChar idx+ return (c : acc)+ | otherwise = do+ c <- rChar idx+ loop (i -# 1#) (c : acc)++ rChar :: Int# -> IO Char+ rChar idx = IO $ \s ->+ case readWord8Array# mba idx s of+ (# s2, w #) -> (# s2, C# (chr# (word2Int# w)) #)++{-+bytesShowHex :: Bytes -> String+bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b)+{-# NOINLINE bytesShowHex #-}+-}
+ Data/ByteArray/Encoding.hs view
@@ -0,0 +1,62 @@+-- |+-- Module : Data.ByteArray.Encoding+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- ByteArray base converting+--+module Data.ByteArray.Encoding+ ( convertToBase+ , convertFromBase+ , Base(..)+ ) where++import Data.ByteArray.Types+import qualified Data.ByteArray.Types as B+import qualified Data.ByteArray.Methods as B+import Data.Memory.Internal.Compat+import Data.Memory.Encoding.Base16+import Data.Memory.Encoding.Base64++-- | Different bases that can be used+data Base = Base16 -- ^ similar to hexadecimal+ | Base64+ deriving (Show,Eq)++-- | Convert a bytearray to the equivalent representation in a specific Base+convertToBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> bout+convertToBase Base16 b =+ B.unsafeCreate (B.length b * 2) $ \bout ->+ B.withByteArray b $ \bin ->+ toHexadecimal bout bin (B.length b)+convertToBase Base64 b =+ B.unsafeCreate outLen $ \bout ->+ withByteArray b $ \bin ->+ toBase64 bout bin (B.length b)+ where (q,r) = B.length b `divMod` 3+ outLen = 4 * (if r == 0 then q else q+1)++-- | Try to Convert a bytearray from the equivalent representation in a specific Base+convertFromBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> Either String bout+convertFromBase Base16 b+ | odd (B.length b) = Left "base16: input: invalid length"+ | otherwise = unsafeDoIO $ do+ (ret, out) <-+ B.allocRet (B.length b `div` 2) $ \bout ->+ B.withByteArray b $ \bin ->+ fromHexadecimal bout bin (B.length b)+ case ret of+ Nothing -> return $ Right out+ Just ofs -> return $ Left ("base16: input: invalid encoding at offset: " ++ show ofs)+convertFromBase Base64 b = unsafeDoIO $+ withByteArray b $ \bin -> do+ mDstLen <- unBase64Length bin (B.length b)+ case mDstLen of+ Nothing -> return $ Left "base64: input: invalid length"+ Just dstLen -> do+ (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64 bout bin (B.length b)+ case ret of+ Nothing -> return $ Right out+ Just ofs -> return $ Left ("base64: input: invalid encoding at offset: " ++ show ofs)
+ Data/ByteArray/Hash.hs view
@@ -0,0 +1,78 @@+-- |+-- Module : Data.ByteArray.Hash+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+{-# LANGUAGE BangPatterns #-}+module Data.ByteArray.Hash+ (+ -- * SipHash+ SipKey(..)+ , SipHash(..)+ , sipHash+ , sipHashWith+ -- * FNV1 and FNV1a (32 and 64 bits)+ , FnvHash32(..)+ , FnvHash64(..)+ , fnv1Hash+ , fnv1aHash+ , fnv1_64Hash+ , fnv1a_64Hash+ ) where++import Data.Memory.Internal.Compat+import Data.Memory.Hash.SipHash+import Data.Memory.Hash.FNV+import qualified Data.ByteArray.Types as B++-- | Compute the SipHash tag of a byte array for a given key.+--+-- 'sipHash` is equivalent to 'sipHashWith 2 4'+sipHash :: B.ByteArrayAccess ba+ => SipKey+ -> ba+ -> SipHash+sipHash key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hash key p (B.length ba)++-- | Compute the SipHash tag of a byte array for a given key.+--+-- The user can choose the C and D numbers of rounds.+--+-- calling 'sipHash` is equivalent to 'sipHashWith 2 4'+sipHashWith :: B.ByteArrayAccess ba+ => Int -- ^ c rounds+ -> Int -- ^ d rounds+ -> SipKey -- ^ key+ -> ba -- ^ data to hash+ -> SipHash+sipHashWith c d key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hashWith c d key p (B.length ba)+++-- | Compute the FNV1 32 bit hash value of a byte array+fnv1Hash :: B.ByteArrayAccess ba+ => ba+ -> FnvHash32+fnv1Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1 p (B.length ba)++-- | Compute the FNV1a 32 bit hash value of a byte array+fnv1aHash :: B.ByteArrayAccess ba+ => ba+ -> FnvHash32+fnv1aHash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a p (B.length ba)++-- | Compute the FNV1 64 bit hash value of a byte array+fnv1_64Hash :: B.ByteArrayAccess ba+ => ba+ -> FnvHash64+fnv1_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1_64 p (B.length ba)++-- | Compute the FNV1a 64 bit hash value of a byte array+fnv1a_64Hash :: B.ByteArrayAccess ba+ => ba+ -> FnvHash64+fnv1a_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a_64 p (B.length ba)
+ Data/ByteArray/Mapping.hs view
@@ -0,0 +1,79 @@+-- |+-- Module : Data.ByteArray.Mapping+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+module Data.ByteArray.Mapping+ ( toW64BE+ , toW64LE+ , mapAsWord64+ , mapAsWord128+ ) where++import Data.ByteArray.Types+import Data.ByteArray.Methods+import Data.Memory.Internal.Compat+import Data.Memory.Internal.Imports hiding (empty)+import Data.Memory.Endian+import Data.Memory.ExtendedWords+import Foreign.Storable+import Foreign.Ptr++import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred)++-- | Transform a bytearray at a specific offset into+-- a Word64 tagged as BE (Big Endian)+--+-- no bounds checking. unsafe+toW64BE :: ByteArrayAccess bs => bs -> Int -> BE Word64+toW64BE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)++-- | Transform a bytearray at a specific offset into+-- a Word64 tagged as LE (Little Endian)+--+-- no bounds checking. unsafe+toW64LE :: ByteArrayAccess bs => bs -> Int -> LE Word64+toW64LE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)++-- | map blocks of 128 bits of a bytearray, creating a new bytestring+-- of equivalent size where each blocks has been mapped through @f +--+-- no length checking is done. unsafe+mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs+mapAsWord128 f bs =+ unsafeCreate len $ \dst ->+ withByteArray bs $ \src ->+ loop (len `div` 16) dst src+ where+ len = length bs+ loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO ()+ loop 0 _ _ = return ()+ loop i d s = do+ w1 <- peek s+ w2 <- peek (s `plusPtr` 8)+ let (Word128 r1 r2) = f (Word128 (fromBE w1) (fromBE w2))+ poke d (toBE r1)+ poke (d `plusPtr` 8) (toBE r2)+ loop (i-1) (d `plusPtr` 16) (s `plusPtr` 16)++-- | map blocks of 64 bits of a bytearray, creating a new bytestring+-- of equivalent size where each blocks has been mapped through @f +--+-- no length checking is done. unsafe+mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs+mapAsWord64 f bs =+ unsafeCreate len $ \dst ->+ withByteArray bs $ \src ->+ loop (len `div` 8) dst src+ where+ len = length bs++ loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO ()+ loop 0 _ _ = return ()+ loop i d s = do+ w <- peek s+ let r = f (fromBE w)+ poke d (toBE r)+ loop (i-1) (d `plusPtr` 8) (s `plusPtr` 8)
+ Data/ByteArray/MemView.hs view
@@ -0,0 +1,38 @@+-- |+-- Module : Data.ByteArray.MemView+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+module Data.ByteArray.MemView+ ( MemView(..)+ , memViewPlus+ ) where++import Foreign.Ptr+import Data.ByteArray.Types+import Data.Memory.Internal.Imports++-- | A simple abstraction to a piece of memory.+--+-- Do beware that garbage collection related to+-- piece of memory could be triggered before this+-- is used.+--+-- Only use with the appropriate handler has been+-- used (e.g. withForeignPtr on ForeignPtr)+--+data MemView = MemView {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !Int+ deriving (Show,Eq)++instance ByteArrayAccess MemView where+ length (MemView _ l) = l+ withByteArray (MemView p _) f = f (castPtr p)++-- | Increase the memory view while reducing the size of the window+--+-- this is useful as an abtraction to represent the current offset+-- in a buffer, and the remaining bytes left.+memViewPlus :: MemView -> Int -> MemView+memViewPlus (MemView p len) n = MemView (p `plusPtr` n) (len - n)
+ Data/ByteArray/Methods.hs view
@@ -0,0 +1,228 @@+-- |+-- Module : Data.ByteArray.Methods+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+{-# LANGUAGE BangPatterns #-}+module Data.ByteArray.Methods+ ( alloc+ , allocAndFreeze+ , create+ , unsafeCreate+ , pack+ , unpack+ , uncons+ , empty+ , null+ , replicate+ , zero+ , copy+ , take+ , drop+ , span+ , convert+ , copyRet+ , copyAndFreeze+ , splitAt+ , xor+ , index+ , eq+ , constEq+ , append+ , concat+ ) where++import Data.ByteArray.Types+import Data.Memory.Internal.Compat+import Data.Memory.Internal.Imports hiding (empty)+import Data.Memory.PtrMethods+import Data.Monoid+import Foreign.Storable+import Foreign.Ptr++import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred)+import qualified Prelude++-- | Allocate a new bytearray of specific size, and run the initializer on this memory+alloc :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba+alloc n f = snd `fmap` allocRet n f++-- | Allocate a new bytearray of specific size, and run the initializer on this memory+create :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba+create n f = alloc n f++-- | similar to 'alloc' but hide the allocation and initializer in a pure context+allocAndFreeze :: ByteArray a => Int -> (Ptr p -> IO ()) -> a+allocAndFreeze sz f = unsafeDoIO (alloc sz f)+{-# NOINLINE allocAndFreeze #-}++-- | similar to 'create' but hide the allocation and initializer in a pure context+unsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a+unsafeCreate sz f = unsafeDoIO (alloc sz f)+{-# NOINLINE unsafeCreate #-}++-- | Create an empty byte array+empty :: ByteArray a => a+empty = unsafeDoIO (alloc 0 $ \_ -> return ())++-- | Check if a byte array is empty+null :: ByteArray a => a -> Bool+null b = length b == 0++-- | Pack a list of bytes into a bytearray+pack :: ByteArray a => [Word8] -> a+pack l = unsafeCreate (Prelude.length l) (fill 0 l)+ where fill _ [] _ = return ()+ fill i (x:xs) p = pokeByteOff p i x >> fill (i+1) xs p++-- | Un-pack a bytearray into a list of bytes+unpack :: ByteArrayAccess a => a -> [Word8]+unpack bs = loop 0+ where !len = length bs+ loop i+ | i == len = []+ | otherwise =+ let !v = unsafeDoIO $ withByteArray bs (\p -> peekByteOff p i)+ in v : loop (i+1)++-- | returns the first byte, and the remaining bytearray if the bytearray is not null+uncons :: ByteArray a => a -> Maybe (Word8, a)+uncons a+ | null a = Nothing+ | otherwise = Just (index a 0, drop 1 a)++-- | Create a xor of bytes between a and b.+--+-- the returns byte array is the size of the smallest input.+xor :: (ByteArrayAccess a, ByteArrayAccess b, ByteArray c) => a -> b -> c+xor a b =+ unsafeCreate n $ \pc ->+ withByteArray a $ \pa ->+ withByteArray b $ \pb ->+ memXor pc pa pb n+ where+ n = min la lb+ la = length a+ lb = length b++-- | return a specific byte indexed by a number from 0 in a bytearray+--+-- unsafe, no bound checking are done+index :: ByteArrayAccess a => a -> Int -> Word8+index b i = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i)++-- | Split a bytearray at a specific length in two bytearray+splitAt :: ByteArray bs => Int -> bs -> (bs, bs)+splitAt n bs+ | n <= 0 = (empty, bs)+ | n >= len = (bs, empty)+ | otherwise = unsafeDoIO $ do+ withByteArray bs $ \p -> do+ b1 <- alloc n $ \r -> memCopy r p n+ b2 <- alloc (len - n) $ \r -> memCopy r (p `plusPtr` n) (len - n)+ return (b1, b2)+ where len = length bs++-- | Take the first @n byte of a bytearray+take :: ByteArray bs => Int -> bs -> bs+take n bs+ | n <= 0 = empty+ | otherwise = unsafeCreate m $ \d -> withByteArray bs $ \s -> memCopy d s m+ where+ m = min len n+ len = length bs++-- | drop the first @n byte of a bytearray+drop :: ByteArray bs => Int -> bs -> bs+drop n bs+ | n < 0 = bs+ | nb == 0 = empty+ | otherwise = unsafeCreate nb $ \d -> withByteArray bs $ \s -> memCopy d (s `plusPtr` ofs) nb+ where+ ofs = min len n+ nb = len - ofs+ len = length bs++-- | Split a bytearray at the point where @pred becomes invalid+span :: ByteArray bs => (Word8 -> Bool) -> bs -> (bs, bs)+span pred bs+ | null bs = (bs, bs)+ | otherwise = let n = loop 0 in (take n bs, drop n bs)+ where loop !i+ | pred (index bs i) = loop (i+1)+ | otherwise = i++-- | Concatenate bytearray into a larger bytearray+concat :: ByteArray bs => [bs] -> bs+concat = mconcat++-- | append one bytearray to the other+append :: ByteArray bs => bs -> bs -> bs+append = mappend++-- | Duplicate a bytearray into another bytearray, and run an initializer on it+copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2+copy bs f =+ alloc (length bs) $ \d -> do+ withByteArray bs $ \s -> memCopy d s (length bs)+ f (castPtr d)++-- | Similar to 'copy' but also provide a way to return a value from the initializer+copyRet :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2)+copyRet bs f =+ allocRet (length bs) $ \d -> do+ withByteArray bs $ \s -> memCopy d s (length bs)+ f (castPtr d)++-- | Similiar to 'copy' but expect the resulting bytearray in a pure context+copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2+copyAndFreeze bs f =+ unsafeCreate (length bs) $ \d -> do+ withByteArray bs $ \s -> memCopy d s (length bs)+ f (castPtr d)++-- | Create a bytearray of a specific size containing a repeated byte value+replicate :: ByteArray ba => Int -> Word8 -> ba+replicate 0 _ = empty+replicate n b = unsafeCreate n $ \ptr -> memSet ptr b n+{-# NOINLINE replicate #-}++-- | Create a bytearray of a specific size initialized to 0+zero :: ByteArray ba => Int -> ba+zero 0 = empty+zero n = unsafeCreate n $ \ptr -> memSet ptr 0 n+{-# NOINLINE zero #-}++-- | Check if two bytearray are equals+--+-- This is not constant time, as soon some byte differs the function will+-- returns. use 'constEq' in sensitive context where timing matters.+eq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool+eq b1 b2+ | l1 /= l2 = False+ | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memEqual p1 p2 l1+ where+ l1 = length b1+ l2 = length b2++-- | A constant time equality test for 2 ByteArrayAccess values.+--+-- If values are of 2 different sizes, the function will abort early+-- without comparing any bytes.+--+-- compared to == , this function will go over all the bytes+-- present before yielding a result even when knowing the+-- overall result early in the processing.+constEq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool+constEq b1 b2+ | l1 /= l2 = False+ | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memConstEqual p1 p2 l1+ where+ l1 = length b1+ l2 = length b2++-- | Convert a bytearray to another type of bytearray+convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout+convert = flip copyAndFreeze (\_ -> return ())
+ Data/ByteArray/Pack.hs view
@@ -0,0 +1,130 @@+-- |+-- Module : Data.ByteArray.Pack+-- License : BSD-Style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Simple Byte Array packer+--+-- Simple example:+--+-- > > flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32)+-- > Right (ABCD *\NUL\NUL\NUL")+--+-- Original code from <https://hackage.haskell.org/package/bspack>+-- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05)+-- Copyright (c) 2014 Nicolas DI PRIMA+--+module Data.ByteArray.Pack+ ( Packer+ , Result(..)+ , pack+ -- * Operations+ -- ** put+ , putWord8+ , putWord16+ , putWord32+ , putStorable+ , putBytes+ , fillList+ , fillUpWith+ -- ** skip+ , skip+ , skipStorable+ ) where++import Data.Word+import Foreign.Ptr+import Foreign.Storable+import Data.Memory.Internal.Imports ()+import Data.Memory.Internal.Compat+import Data.Memory.PtrMethods+import Data.ByteArray.Pack.Internal+import Data.ByteArray (ByteArray, MemView(..))+import qualified Data.ByteArray as B++-- | pack the given packer into the given bytestring+pack :: ByteArray byteArray => Packer a -> Int -> Either String byteArray+pack packing len = unsafeDoIO $ do+ (val, out) <- B.allocRet len $ \ptr -> runPacker_ packing (MemView ptr len)+ case val of + PackerMore _ (MemView _ r)+ | r == 0 -> return $ Right out+ | otherwise -> return $ Left ("remaining unpacked bytes " ++ show r ++ " at the end of buffer")+ PackerFail err -> return $ Left err++fillUpWithWord8' :: Word8 -> Packer ()+fillUpWithWord8' w = Packer $ \(MemView ptr size) -> do+ memSet ptr w size+ return $ PackerMore () (MemView (ptr `plusPtr` size) 0)++-- | 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 Byte Array from the current position in the stream+--+-- If the ByteArray is null, then do nothing+putBytes :: ByteArray ba => ba -> Packer ()+putBytes bs+ | neededLength == 0 = return ()+ | otherwise =+ actionPacker neededLength $ \dstPtr -> B.withByteArray bs $ \srcPtr ->+ memCopy dstPtr srcPtr neededLength+ where+ neededLength = B.length bs++-- | 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+{-# RULES "fillUpWithWord8" forall s . fillUpWith s = fillUpWithWord8' s #-}+{-# NOINLINE fillUpWith #-}++-- | 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++------------------------------------------------------------------------------+-- Common packer --+------------------------------------------------------------------------------++-- | put Word8 in the current position in the stream+putWord8 :: Word8 -> Packer ()+putWord8 = putStorable+{-# INLINE putWord8 #-}++-- | put Word16 in the current position in the stream+-- /!\ use Host Endianness+putWord16 :: Word16 -> Packer ()+putWord16 = putStorable+{-# INLINE putWord16 #-}++-- | put Word32 in the current position in the stream+-- /!\ use Host Endianness+putWord32 :: Word32 -> Packer ()+putWord32 = putStorable+{-# INLINE putWord32 #-}
+ Data/ByteArray/Pack/Internal.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Data.ByteArray.Pack.Internal+-- License : BSD-Style+-- Copyright : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Data.ByteArray.Pack.Internal+ ( Result(..)+ , Packer(..)+ , actionPacker+ , actionPackerWithRemain+ ) where++import Data.Word+import Foreign.Ptr (Ptr)+import Data.ByteArray.MemView+import Data.Memory.Internal.Imports++-- | Packing result:+--+-- * PackerMore: the next state of Packing with an arbitrary value+-- * PackerFail: an error happened+data Result a =+ PackerMore a MemView+ | PackerFail String+ deriving (Show)++-- | Simple ByteArray Packer+newtype Packer a = Packer { runPacker_ :: MemView -> 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+{-# INLINE fmapPacker #-}++returnPacker :: a -> Packer a+returnPacker v = Packer $ \cache -> return $ PackerMore v cache+{-# INLINE returnPacker #-}++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+{-# INLINE bindPacker #-}++appendPacker :: Packer (a -> b) -> Packer a -> Packer b+appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)+{-# INLINE appendPacker #-}++-- | run a sized action+actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a+actionPacker s action = Packer $ \m@(MemView ptr size) ->+ case compare size s of+ LT -> return $ PackerFail "Not enough space in destination"+ _ -> do+ v <- action ptr+ return $ PackerMore v (m `memViewPlus` s)+{-# INLINE actionPacker #-}++-- | run a sized action+actionPackerWithRemain :: Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a+actionPackerWithRemain s action = Packer $ \m@(MemView ptr size) ->+ case compare size s of+ LT -> return $ PackerFail "Not enough space in destination"+ _ -> do+ (remain, v) <- action ptr size+ return $ if remain > s+ then PackerFail "remaining bytes higher than the destination's size"+ else PackerMore v (m `memViewPlus` (s+remain))+{-# INLINE actionPackerWithRemain #-}
+ Data/ByteArray/Parse.hs view
@@ -0,0 +1,221 @@+-- |+-- Module : Data.ByteArray.Parse+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : portable+--+-- A very simple bytearray parser related to Parsec and Attoparsec+--+-- Simple example:+--+-- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest"+-- > ParseOK "est" ("xx", 116)+--+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.ByteArray.Parse+ ( Parser+ , Result(..)+ -- * run the Parser+ , parse+ , parseFeed+ -- * Parser methods+ , byte+ , anyByte+ , bytes+ , take+ , takeWhile+ , takeAll+ , skip+ , skipWhile+ , skipAll+ , takeStorable+ ) where++import Control.Monad+import Foreign.Storable (Storable, peek, sizeOf)+import Data.Word++import Data.Memory.Internal.Imports+import Data.Memory.Internal.Compat+import Data.ByteArray.Types (ByteArrayAccess, ByteArray)+import qualified Data.ByteArray.Types as B+import qualified Data.ByteArray.Methods as B++import Prelude hiding (take, takeWhile)++-- | Simple parsing result, that represent respectively:+--+-- * failure: with the error message+--+-- * continuation: that need for more input data+--+-- * success: the remaining unparsed data and the parser value+data Result byteArray a =+ ParseFail String+ | ParseMore (byteArray -> Result byteArray a)+ | ParseOK byteArray a++instance (Show ba, Show a) => Show (Result ba a) where+ show (ParseFail err) = "ParseFailure: " ++ err+ show (ParseMore _) = "ParseMore _"+ show (ParseOK b a) = "ParseOK " ++ show a ++ " " ++ show b++type Failure byteArray r = byteArray -> String -> Result byteArray r+type Success byteArray a r = byteArray -> a -> Result byteArray r++-- | Simple ByteString parser structure+newtype Parser byteArray a = Parser+ { runParser :: forall r . byteArray -> Failure byteArray r -> Success byteArray a r -> Result byteArray r }++instance Monad (Parser byteArray) where+ fail errorMsg = Parser $ \buf err _ -> err buf ("failed: " ++ errorMsg)+ return v = Parser $ \buf _ ok -> ok buf v+ m >>= k = Parser $ \buf err ok ->+ runParser m buf err (\buf' a -> runParser (k a) buf' err ok)+instance MonadPlus (Parser byteArray) where+ mzero = fail "Parser.MonadPlus.mzero"+ mplus f g = Parser $ \buf err ok ->+ -- rewrite the err callback of @f to call @g+ runParser f buf (\_ _ -> runParser g buf err ok) ok+instance Functor (Parser byteArray) where+ fmap f p = Parser $ \buf err ok ->+ runParser p buf err (\b a -> ok b (f a))+instance Applicative (Parser byteArray) where+ pure = return+ (<*>) d e = d >>= \b -> e >>= \a -> return (b a)+instance Alternative (Parser byteArray) where+ empty = fail "Parser.Alternative.empty"+ (<|>) = mplus++-- | Run a parser on an @initial byteArray.+--+-- If the Parser need more data than available, the @feeder function+-- is automatically called and fed to the More continuation.+parseFeed :: (ByteArrayAccess byteArray, Monad m)+ => m byteArray -> Parser byteArray a -> byteArray -> m (Result byteArray a)+parseFeed feeder p initial = loop $ parse p initial+ where loop (ParseMore k) = feeder >>= (loop . k)+ loop r = return r++-- | Run a Parser on a ByteString and return a 'Result'+parse :: ByteArrayAccess byteArray+ => Parser byteArray a -> byteArray -> Result byteArray a+parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a)++------------------------------------------------------------+getMore :: ByteArray byteArray => Parser byteArray ()+getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+ if B.null nextChunk+ then err buf "EOL: need more data"+ else ok (B.append buf nextChunk) ()++getAll :: ByteArray byteArray => Parser byteArray ()+getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+ if B.null nextChunk+ then ok buf ()+ else runParser getAll (B.append buf nextChunk) err ok++flushAll :: ByteArray byteArray => Parser byteArray ()+flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk ->+ if B.null nextChunk+ then ok buf ()+ else runParser getAll B.empty err ok++------------------------------------------------------------++-- | Get the next byte from the parser+anyByte :: ByteArray byteArray => Parser byteArray Word8+anyByte = Parser $ \buf err ok ->+ case B.uncons buf of+ Nothing -> runParser (getMore >> anyByte) buf err ok+ Just (c1,b2) -> ok b2 c1++-- | Parse a specific byte at current position+--+-- if the byte is different than the expected on,+-- this parser will raise a failure.+byte :: ByteArray byteArray => Word8 -> Parser byteArray ()+byte w = Parser $ \buf err ok ->+ case B.uncons buf of+ Nothing -> runParser (getMore >> byte w) buf err ok+ Just (c1,b2) | c1 == w -> ok b2 ()+ | otherwise -> err buf ("byte " ++ show w ++ " : failed")++-- | Parse a sequence of bytes from current position+--+-- if the following bytes don't match the expected+-- bytestring completely, the parser will raise a failure+bytes :: (Show ba, Eq ba, ByteArray ba) => ba -> Parser ba ()+bytes allExpected = consumeEq allExpected+ where errMsg = "bytes " ++ show allExpected ++ " : failed"++ -- partially consume as much as possible or raise an error.+ consumeEq expected = Parser $ \actual err ok ->+ let eLen = B.length expected in+ if B.length actual >= eLen+ then -- enough data for doing a full match+ let (aMatch,aRem) = B.splitAt eLen actual+ in if aMatch == expected+ then ok aRem ()+ else err actual errMsg+ else -- not enough data, match as much as we have, and then recurse.+ let (eMatch, eRem) = B.splitAt (B.length actual) expected+ in if actual == eMatch+ then runParser (getMore >> consumeEq eRem) B.empty err ok+ else err actual errMsg++------------------------------------------------------------++-- | Take a storable from the current position in the stream+takeStorable :: (ByteArray byteArray, Storable d)+ => Parser byteArray d+takeStorable = anyStorable undefined+ where+ anyStorable :: ByteArray byteArray => Storable d => d -> Parser byteArray d+ anyStorable a = do+ buf <- take (sizeOf a)+ return $ unsafeDoIO $ B.withByteArray buf $ \ptr -> peek ptr++-- | Take @n bytes from the current position in the stream+take :: ByteArray byteArray => Int -> Parser byteArray byteArray+take n = Parser $ \buf err ok ->+ if B.length buf >= n+ then let (b1,b2) = B.splitAt n buf in ok b2 b1+ else runParser (getMore >> take n) buf err ok++-- | Take bytes while the @predicate hold from the current position in the stream+takeWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray byteArray+takeWhile predicate = Parser $ \buf err ok ->+ let (b1, b2) = B.span predicate buf+ in if B.null b2+ then runParser (getMore >> takeWhile predicate) buf err ok+ else ok b2 b1++-- | Take the remaining bytes from the current position in the stream+takeAll :: ByteArray byteArray => Parser byteArray byteArray+takeAll = Parser $ \buf err ok ->+ runParser (getAll >> returnBuffer) buf err ok+ where+ returnBuffer = Parser $ \buf _ ok -> ok B.empty buf++-- | Skip @n bytes from the current position in the stream+skip :: ByteArray byteArray => Int -> Parser byteArray ()+skip n = Parser $ \buf err ok ->+ if B.length buf >= n+ then ok (B.drop n buf) ()+ else runParser (getMore >> skip (n - B.length buf)) B.empty err ok++-- | Skip bytes while the @predicate hold from the current position in the stream+skipWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray ()+skipWhile p = Parser $ \buf err ok ->+ let (_, b2) = B.span p buf + in if B.null b2+ then runParser (getMore >> skipWhile p) B.empty err ok+ else ok b2 ()++-- | Skip all the remaining bytes from the current position in the stream+skipAll :: ByteArray byteArray => Parser byteArray ()+skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok
+ Data/ByteArray/ScrubbedBytes.hs view
@@ -0,0 +1,166 @@+-- |+-- Module : Data.ByteArray.ScrubbedBytes+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : Stable+-- Portability : GHC+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+module Data.ByteArray.ScrubbedBytes+ ( ScrubbedBytes+ ) where++import GHC.Types+import GHC.Prim+import GHC.Ptr+import Data.Monoid+import Data.Memory.PtrMethods (memCopy, memConstEqual)+import Data.Memory.Internal.CompatPrim+import Data.Memory.Internal.Compat (unsafeDoIO)+import Data.Memory.Internal.Imports+import Data.ByteArray.Types++-- | ScrubbedBytes is a memory chunk which have the properties of:+--+-- * Being scrubbed after its goes out of scope.+--+-- * A Show instance that doesn't actually show any content+--+-- * A Eq instance that is constant time+--+data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld)++instance Show ScrubbedBytes where+ show _ = "<scrubbed-bytes>"++instance Eq ScrubbedBytes where+ (==) = scrubbedBytesEq+instance Ord ScrubbedBytes where+ compare = scrubbedBytesCompare+instance Monoid ScrubbedBytes where+ mempty = unsafeDoIO (newScrubbedBytes 0)+ mappend b1 b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2+ mconcat = unsafeDoIO . scrubbedBytesConcat+instance NFData ScrubbedBytes where+ rnf b = b `seq` ()++instance ByteArrayAccess ScrubbedBytes where+ length = sizeofScrubbedBytes+ withByteArray = withPtr++instance ByteArray ScrubbedBytes where+ allocRet = scrubbedBytesAllocRet++newScrubbedBytes :: Int -> IO ScrubbedBytes+newScrubbedBytes (I# sz)+ | booleanPrim (sz <# 0#) = error "ScrubbedBytes: size must be >= 0"+ | booleanPrim (sz ==# 0#) = IO $ \s ->+ case newAlignedPinnedByteArray# 0# 8# s of+ (# s2, mba #) -> (# s2, ScrubbedBytes mba #)+ | otherwise = IO $ \s ->+ case newAlignedPinnedByteArray# sz 8# s of+ (# s1, mbarr #) ->+ let !scrubber = getScrubber+ !mba = ScrubbedBytes mbarr+ in case mkWeak# mbarr () (scrubber (byteArrayContents# (unsafeCoerce# mbarr)) >> touchScrubbedBytes mba) s1 of+ (# s2, _ #) -> (# s2, mba #)+ where+ getScrubber :: Addr# -> IO ()+ getScrubber = eitherDivideBy8# sz scrubber64 scrubber8++ scrubber64 :: Int# -> Addr# -> IO ()+ scrubber64 sz64 addr = IO $ \s -> (# loop sz64 addr s, () #)+ where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld+ loop n a s+ | booleanPrim (n ==# 0#) = s+ | otherwise =+ case writeWord64OffAddr# a 0# 0## s of+ s' -> loop (n -# 1#) (plusAddr# a 8#) s'++ scrubber8 :: Int# -> Addr# -> IO ()+ scrubber8 sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)+ where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld+ loop n a s+ | booleanPrim (n ==# 0#) = s+ | otherwise =+ case writeWord8OffAddr# a 0# 0## s of+ s' -> loop (n -# 1#) (plusAddr# a 1#) s'++scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes)+scrubbedBytesAllocRet sz f = do+ ba <- newScrubbedBytes sz+ r <- withPtr ba f+ return (r, ba)++scrubbedBytesAlloc :: Int -> (Ptr p -> IO ()) -> IO ScrubbedBytes+scrubbedBytesAlloc sz f = do+ ba <- newScrubbedBytes sz+ withPtr ba f+ return ba++scrubbedBytesConcat :: [ScrubbedBytes] -> IO ScrubbedBytes+scrubbedBytesConcat l = scrubbedBytesAlloc retLen (copy l)+ where+ retLen = sum $ map sizeofScrubbedBytes l++ copy [] _ = return ()+ copy (x:xs) dst = do+ withPtr x $ \src -> memCopy dst src chunkLen+ copy xs (dst `plusPtr` chunkLen)+ where+ chunkLen = sizeofScrubbedBytes x++scrubbedBytesAppend :: ScrubbedBytes -> ScrubbedBytes -> IO ScrubbedBytes+scrubbedBytesAppend b1 b2 = scrubbedBytesAlloc retLen $ \dst -> do+ withPtr b1 $ \s1 -> memCopy dst s1 len1+ withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2+ where+ len1 = sizeofScrubbedBytes b1+ len2 = sizeofScrubbedBytes b2+ retLen = len1 + len2+++sizeofScrubbedBytes :: ScrubbedBytes -> Int+sizeofScrubbedBytes (ScrubbedBytes mba) = I# (sizeofMutableByteArray# mba)++withPtr :: ScrubbedBytes -> (Ptr p -> IO a) -> IO a+withPtr b@(ScrubbedBytes mba) f = do+ a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba)))+ touchScrubbedBytes b+ return a++touchScrubbedBytes :: ScrubbedBytes -> IO ()+touchScrubbedBytes (ScrubbedBytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #)++scrubbedBytesEq :: ScrubbedBytes -> ScrubbedBytes -> Bool+scrubbedBytesEq a b+ | l1 /= l2 = False+ | otherwise = unsafeDoIO $ withPtr a $ \p1 -> withPtr b $ \p2 -> memConstEqual p1 p2 l1+ where+ l1 = sizeofScrubbedBytes a+ l2 = sizeofScrubbedBytes b++scrubbedBytesCompare :: ScrubbedBytes -> ScrubbedBytes -> Ordering+scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ IO $ \s -> loop 0# s+ where+ !l1 = sizeofScrubbedBytes b1+ !l2 = sizeofScrubbedBytes b2+ !(I# len) = min l1 l2++ loop i s1+ | booleanPrim (i ==# len) =+ if l1 == l2+ then (# s1, EQ #)+ else if l1 > l2 then (# s1, GT #)+ else (# s1, LT #)+ | otherwise =+ case readWord8Array# m1 i s1 of+ (# s2, e1 #) -> case readWord8Array# m2 i s2 of+ (# s3, e2 #) ->+ if booleanPrim (eqWord# e1 e2)+ then loop (i +# 1#) s3+ else if booleanPrim (ltWord# e1 e2) then (# s3, LT #)+ else (# s3, GT #)
+ Data/ByteArray/Types.hs view
@@ -0,0 +1,46 @@+-- |+-- Module : Data.ByteArray.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+{-# LANGUAGE CPP #-}+module Data.ByteArray.Types+ ( ByteArrayAccess(..)+ , ByteArray(..)+ ) where++import Foreign.Ptr+import Data.Monoid++#ifdef WITH_BYTESTRING_SUPPORT+import qualified Data.ByteString as B (length)+import qualified Data.ByteString.Internal as B+import Foreign.ForeignPtr (withForeignPtr)+#endif++-- | Class to Access size properties and data of a ByteArray+class ByteArrayAccess ba where+ -- | Return the length in bytes of a bytearray+ length :: ba -> Int+ -- | Allow to use using a pointer+ withByteArray :: ba -> (Ptr p -> IO a) -> IO a++-- | Class to allocate new ByteArray of specific size+class (Eq ba, Ord ba, Monoid ba, ByteArrayAccess ba) => ByteArray ba where+ allocRet :: Int -> (Ptr p -> IO a) -> IO (a, ba)++#ifdef WITH_BYTESTRING_SUPPORT+instance ByteArrayAccess B.ByteString where+ length = B.length+ withByteArray b f = withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)+ where (fptr, off, _) = B.toForeignPtr b++instance ByteArray B.ByteString where+ allocRet sz f = do+ fptr <- B.mallocByteString sz+ r <- withForeignPtr fptr (f . castPtr)+ return (r, B.PS fptr 0 sz)+#endif+
+ Data/Memory/Encoding/Base16.hs view
@@ -0,0 +1,168 @@+-- |+-- Module : Data.Memory.Encoding.Base16+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Hexadecimal escaper+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+module Data.Memory.Encoding.Base16+ ( showHexadecimal+ , toHexadecimal+ , fromHexadecimal+ ) where++import Data.Memory.Internal.Compat+import Data.Word+import Data.Bits ((.|.))+import GHC.Prim+import GHC.Types+import GHC.Word+import Control.Monad+import Foreign.Storable+import Foreign.Ptr (Ptr)++-- | Transform a raw memory to an hexadecimal 'String'+-- +-- user beware, no checks are made+showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object+ -> Int -- ^ length in bytes+ -> String+showHexadecimal withPtr = doChunks 0+ where+ doChunks ofs len+ | len < 4 = doUnique ofs len+ | otherwise = do+ let !(W8# a, W8# b, W8# c, W8# d) = unsafeDoIO $ withPtr (read4 ofs)+ !(# w1, w2 #) = convertByte a+ !(# w3, w4 #) = convertByte b+ !(# w5, w6 #) = convertByte c+ !(# w7, w8 #) = convertByte d+ in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4+ : wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8+ : doChunks (ofs + 4) (len - 4)++ doUnique ofs len+ | len == 0 = []+ | otherwise =+ let !(W8# b) = unsafeDoIO $ withPtr (byteIndex ofs)+ !(# w1, w2 #) = convertByte b+ in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1)++ read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)+ read4 ofs p =+ liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p)+ (byteIndex (ofs+2) p) (byteIndex (ofs+3) p)++ wToChar :: Word# -> Char+ wToChar w = toEnum (I# (word2Int# w))++ byteIndex :: Int -> Ptr Word8 -> IO Word8+ byteIndex i p = peekByteOff p i++-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst+--+-- destination memory need to be of correct size, otherwise it will lead+-- to really bad things.+toHexadecimal :: Ptr Word8 -- ^ destination memory+ -> Ptr Word8 -- ^ source memory+ -> Int -- ^ number of bytes+ -> IO ()+toHexadecimal bout bin n = loop 0+ where loop i+ | i == n = return ()+ | otherwise = do+ (W8# w) <- peekByteOff bin i+ let !(# w1, w2 #) = convertByte w+ pokeByteOff bout (i * 2) (W8# w1)+ pokeByteOff bout (i * 2 + 1) (W8# w2)+ loop (i+1)++-- | Convert a value Word# to two Word#s containing+-- the hexadecimal representation of the Word#+convertByte :: Word# -> (# Word#, Word# #)+convertByte b = (# r tableHi b, r tableLo b #)+ where+ r :: Addr# -> Word# -> Word#+ r table index = indexWord8OffAddr# table (word2Int# index)++ !tableLo =+ "0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef\+ \0123456789abcdef0123456789abcdef"#+ !tableHi =+ "00000000000000001111111111111111\+ \22222222222222223333333333333333\+ \44444444444444445555555555555555\+ \66666666666666667777777777777777\+ \88888888888888889999999999999999\+ \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\+ \ccccccccccccccccdddddddddddddddd\+ \eeeeeeeeeeeeeeeeffffffffffffffff"#+{-# INLINE convertByte #-}++-- | convert a base16 @src in @dst.+--+-- n need to even+fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)+fromHexadecimal dst src n+ | odd n = error "fromHexadecimal: invalid odd length."+ | otherwise = loop 0 0+ where loop di i+ | i == n = return Nothing+ | otherwise = do+ a <- rHi `fmap` peekByteOff src i+ b <- rLo `fmap` peekByteOff src (i+1)+ if a == 0xff || b == 0xff+ then return $ Just i+ else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2)++ rLo (W8# index) = W8# (indexWord8OffAddr# tableLo (word2Int# index))+ rHi (W8# index) = W8# (indexWord8OffAddr# tableHi (word2Int# index))+ + !tableLo =+ "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\+ \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#+ !tableHi =+ "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\+ \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#+
+ Data/Memory/Encoding/Base64.hs view
@@ -0,0 +1,161 @@+-- |+-- Module : Data.Memory.Encoding.Base64+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Base64+--+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Rank2Types #-}+module Data.Memory.Encoding.Base64+ ( toBase64+ , unBase64Length+ , fromBase64+ ) where++import Control.Monad+import Data.Memory.Internal.Compat+import Data.Memory.Internal.CompatPrim+import Data.Memory.Internal.Imports+import Data.Bits ((.|.))+import GHC.Prim+import GHC.Word+import Foreign.Storable+import Foreign.Ptr (Ptr)++-- | Transform a number of bytes pointed by.@src in the base64 binary representation in @dst+--+-- destination memory need to be of correct size, otherwise it will lead+-- to really bad things.+toBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+toBase64 dst src len = loop 0 0+ where+ eqChar = 0x3d++ loop i di+ | i >= len = return ()+ | otherwise = do+ a <- peekByteOff src i+ b <- if i + 1 >= len then return 0 else peekByteOff src (i+1)+ c <- if i + 2 >= len then return 0 else peekByteOff src (i+2)++ let (w,x,y,z) = convert3 a b c++ pokeByteOff dst di w+ pokeByteOff dst (di+1) x+ pokeByteOff dst (di+2) (if i + 1 >= len then eqChar else y)+ pokeByteOff dst (di+3) (if i + 2 >= len then eqChar else z)++ loop (i+3) (di+4)++convert3 :: Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8)+convert3 (W8# a) (W8# b) (W8# c) =+ let !w = narrow8Word# (uncheckedShiftRL# a 2#)+ !x = or# (and# (uncheckedShiftL# a 4#) 0x30##) (uncheckedShiftRL# b 4#)+ !y = or# (and# (uncheckedShiftL# b 2#) 0x3c##) (uncheckedShiftRL# c 6#)+ !z = and# c 0x3f##+ in (index w, index x, index y, index z)+ where+ !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#++ index :: Word# -> Word8+ index idx = W8# (indexWord8OffAddr# set (word2Int# idx))++-- | Get the length needed for the destination buffer for a base64 decoding.+--+-- if the length is not a multiple of 4, Nothing is returned+unBase64Length :: Ptr Word8 -> Int -> IO (Maybe Int)+unBase64Length src len+ | (len `mod` 4) /= 0 = return Nothing+ | otherwise = do+ last1Byte <- peekByteOff src (len - 1)+ last2Byte <- peekByteOff src (len - 2)+ let dstLen = if last1Byte == eqAscii+ then if last2Byte == eqAscii then 2 else 1+ else 0+ return $ Just $ (len `div` 4) * 3 - dstLen+ where+ eqAscii :: Word8+ eqAscii = fromIntegral (fromEnum '=')++-- | convert from base64 in @src to binary in @dst, using the number of bytes specified+--+-- the user should use unBase64Length to compute the correct length, or check that+-- the length specification is proper. no check is done here.+fromBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)+fromBase64 dst src len+ | len == 0 = return Nothing+ | otherwise = loop 0 0+ where loop di i+ | i == (len-4) = do+ a <- peekByteOff src i+ b <- peekByteOff src (i+1)+ c <- peekByteOff src (i+2)+ d <- peekByteOff src (i+3)++ let (nbBytes, c',d') =+ case (c,d) of+ (0x3d, 0x3d) -> (2, 0x30, 0x30)+ (0x3d, _ ) -> (0, c, d) -- invalid: automatically 'c' will make it error out+ (_ , 0x3d) -> (1, c, 0x30)+ (_ , _ ) -> (0 :: Int, c, d)+ case decode4 a b c' d' of+ Left ofs -> return $ Just (i + ofs)+ Right (x,y,z) -> do+ pokeByteOff dst di x+ when (nbBytes < 2) $ pokeByteOff dst (di+1) y+ when (nbBytes < 1) $ pokeByteOff dst (di+2) z+ return Nothing+ | otherwise = do+ a <- peekByteOff src i+ b <- peekByteOff src (i+1)+ c <- peekByteOff src (i+2)+ d <- peekByteOff src (i+3)++ case decode4 a b c d of+ Left ofs -> return $ Just (i + ofs)+ Right (x,y,z) -> do+ pokeByteOff dst di x+ pokeByteOff dst (di+1) y+ pokeByteOff dst (di+2) z+ loop (di + 3) (i + 4)++ decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8)+ decode4 a b c d =+ case (rset a, rset b, rset c, rset d) of+ (0xff, _ , _ , _ ) -> Left 0+ (_ , 0xff, _ , _ ) -> Left 1+ (_ , _ , 0xff, _ ) -> Left 2+ (_ , _ , _ , 0xff) -> Left 3+ (ra , rb , rc , rd ) ->+ let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)+ y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2)+ z = (rc `unsafeShiftL` 6) .|. rd+ in Right (x,y,z)++ rset :: Word8 -> Word8+ rset (W8# w)+ | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w))+ | otherwise = 0xff++ !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\xff\x3f\+ \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\+ \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\+ \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\xff\+ \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\+ \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
+ Data/Memory/Endian.hs view
@@ -0,0 +1,118 @@+-- |+-- Module : Data.Memory.Endian+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : good+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Memory.Endian+ ( Endianness(..)+ , getSystemEndianness+ , BE(..), LE(..)+ , fromBE, toBE+ , fromLE, toLE+ , ByteSwap+ ) where++import Data.Word (Word16, Word32, Word64)+import Foreign.Storable+#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)+import Data.Memory.Internal.Compat (unsafeDoIO)+#endif++import Data.Memory.Internal.Compat (byteSwap64, byteSwap32, byteSwap16)++-- | represent the CPU endianness+--+-- Big endian system stores bytes with the MSB as the first byte.+-- Little endian system stores bytes with the LSB as the first byte.+--+-- middle endian is purposely avoided.+data Endianness = LittleEndian+ | BigEndian+ deriving (Show,Eq)++-- | Return the system endianness+getSystemEndianness :: Endianness+#ifdef ARCH_IS_LITTLE_ENDIAN+getSystemEndianness = LittleEndian+#elif ARCH_IS_BIG_ENDIAN+getSystemEndianness = BigEndian+#else+getSystemEndianness+ | isLittleEndian = LittleEndian+ | isBigEndian = BigEndian+ | otherwise = error "cannot determine endianness"+ where+ isLittleEndian = endianCheck == 2+ isBigEndian = endianCheck == 1+ endianCheck = unsafeDoIO $ alloca $ \p -> do+ poke p (0x01000002 :: Word32)+ peek (castPtr p :: Ptr Word8)+#endif++-- | Little Endian value+newtype LE a = LE { unLE :: a }+ deriving (Show,Eq,Storable)++-- | Big Endian value+newtype BE a = BE { unBE :: a }+ deriving (Show,Eq,Storable)++-- | Convert a value in cpu endianess to big endian+toBE :: ByteSwap a => a -> BE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toBE = BE . byteSwap+#elif ARCH_IS_BIG_ENDIAN+toBE = BE+#else+toBE = BE . (if getSystemEndianness == LittleEndian then byteSwap else id)+#endif+{-# INLINE toBE #-}++-- | Convert from a big endian value to the cpu endianness+fromBE :: ByteSwap a => BE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromBE (BE a) = byteSwap a+#elif ARCH_IS_BIG_ENDIAN+fromBE (BE a) = a+#else+fromBE (BE a) = if getSystemEndianness == LittleEndian then byteSwap a else a+#endif+{-# INLINE fromBE #-}++-- | Convert a value in cpu endianess to little endian+toLE :: ByteSwap a => a -> LE a+#ifdef ARCH_IS_LITTLE_ENDIAN+toLE = LE+#elif ARCH_IS_BIG_ENDIAN+toLE = LE . byteSwap+#else+toLE = LE . (if getSystemEndianness == LittleEndian then id else byteSwap)+#endif+{-# INLINE toLE #-}++-- | Convert from a little endian value to the cpu endianness+fromLE :: ByteSwap a => LE a -> a+#ifdef ARCH_IS_LITTLE_ENDIAN+fromLE (LE a) = a+#elif ARCH_IS_BIG_ENDIAN+fromLE (LE a) = byteSwap a+#else+fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap a+#endif+{-# INLINE fromLE #-}++-- | Class of types that can be byte-swapped.+--+-- e.g. Word16, Word32, Word64+class Storable a => ByteSwap a where+ byteSwap :: a -> a+instance ByteSwap Word16 where+ byteSwap = byteSwap16+instance ByteSwap Word32 where+ byteSwap = byteSwap32+instance ByteSwap Word64 where+ byteSwap = byteSwap64
+ Data/Memory/ExtendedWords.hs view
@@ -0,0 +1,17 @@+-- |+-- Module : Data.Memory.ExtendedWords+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Extra Word size+--+module Data.Memory.ExtendedWords+ ( Word128(..)+ ) where++import Data.Word (Word64)++-- | A simple Extended Word128 composed of 2 Word64+data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq)
+ Data/Memory/Hash/FNV.hs view
@@ -0,0 +1,93 @@+-- |+-- Module : Data.Memory.Hash.FNV+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : good+--+-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions)+-- <http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function>+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+module Data.Memory.Hash.FNV+ (+ -- * types+ FnvHash32(..)+ , FnvHash64(..)+ -- * methods+ , fnv1+ , fnv1a+ , fnv1_64+ , fnv1a_64+ ) where++import Data.Memory.Internal.Compat ()+import Data.Memory.Internal.CompatPrim+import Data.Memory.Internal.Imports+import GHC.Word+import GHC.Prim+import GHC.Types+import GHC.Ptr++-- | FNV1(a) hash (32 bit variants)+newtype FnvHash32 = FnvHash32 Word32+ deriving (Show,Eq,NFData)++-- | FNV1(a) hash (64 bit variants)+newtype FnvHash64 = FnvHash64 Word64+ deriving (Show,Eq,NFData)++-- | compute FNV1 (32 bit variant) of a raw piece of memory+fnv1 :: Ptr Word8 -> Int -> IO FnvHash32+fnv1 (Ptr addr) (I# n) = IO $ \s -> loop 0x811c9dc5## 0# s+ where + loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash32 #)+ loop !acc i s+ | booleanPrim (i ==# n) = (# s, FnvHash32 $ W32# (narrow32Word# acc) #)+ | otherwise =+ case readWord8OffAddr# addr i s of+ (# s2, v #) ->+ let !nacc = (0x01000193## `timesWord#` acc) `xor#` v+ in loop nacc (i +# 1#) s2++-- | compute FNV1a (32 bit variant) of a raw piece of memory+fnv1a :: Ptr Word8 -> Int -> IO FnvHash32+fnv1a (Ptr addr) (I# n) = IO $ \s -> loop 0x811c9dc5## 0# s+ where + loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash32 #)+ loop !acc i s+ | booleanPrim (i ==# n) = (# s, FnvHash32 $ W32# (narrow32Word# acc) #)+ | otherwise =+ case readWord8OffAddr# addr i s of+ (# s2, v #) ->+ let !nacc = 0x01000193## `timesWord#` (acc `xor#` v)+ in loop nacc (i +# 1#) s2++-- | compute FNV1 (64 bit variant) of a raw piece of memory+fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64+fnv1_64 (Ptr addr) (I# n) = IO $ \s -> loop 0xcbf29ce484222325## 0# s+ where + loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash64 #)+ loop !acc i s+ | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #)+ | otherwise =+ case readWord8OffAddr# addr i s of+ (# s2, v #) ->+ let !nacc = (0x100000001b3## `timesWord#` acc) `xor#` v+ in loop nacc (i +# 1#) s2++-- | compute FNV1a (64 bit variant) of a raw piece of memory+fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64+fnv1a_64 (Ptr addr) (I# n) = IO $ \s -> loop 0xcbf29ce484222325## 0# s+ where + loop :: Word# -> Int# -> State# s -> (# State# s, FnvHash64 #)+ loop !acc i s+ | booleanPrim (i ==# n) = (# s, FnvHash64 $ W64# acc #)+ | otherwise =+ case readWord8OffAddr# addr i s of+ (# s2, v #) ->+ let !nacc = 0x100000001b3## `timesWord#` (acc `xor#` v)+ in loop nacc (i +# 1#) s2
+ Data/Memory/Hash/SipHash.hs view
@@ -0,0 +1,161 @@+-- |+-- Module : Data.Memory.Hash.SipHash+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+{-# LANGUAGE BangPatterns #-}+module Data.Memory.Hash.SipHash+ ( SipKey(..)+ , SipHash(..)+ , hash+ , hashWith+ ) where++import Data.Memory.Endian+import Data.Memory.Internal.Compat+import Data.Word+import Data.Bits+import Control.Monad+import Foreign.Ptr+import Foreign.Storable++-- | SigHash Key+data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64++-- | Siphash tag value+newtype SipHash = SipHash Word64+ deriving (Show,Eq)++data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64++-- | produce a siphash with a key and a memory pointer + length.+hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash+hash = hashWith 2 4++-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest.+hashWith :: Int -- ^ siphash C+ -> Int -- ^ siphash D+ -> SipKey -- ^ key for the hash+ -> Ptr Word8 -- ^ memory pointer+ -> Int -- ^ length of the data+ -> IO SipHash+hashWith c d key startPtr totalLen = runHash (initSip key) startPtr totalLen+ where runHash !st !ptr l+ | l > 7 = peek (castPtr ptr) >>= \v -> runHash (process st (fromLE v)) (ptr `plusPtr` 8) (l-8)+ | otherwise = do+ let !lengthBlock = (fromIntegral totalLen `mod` 256) `unsafeShiftL` 56+ (finish . process st) `fmap` case l of+ 0 -> do return lengthBlock+ 1 -> do v0 <- peekByteOff ptr 0+ return (lengthBlock .|. to64 v0)+ 2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1)+ return (lengthBlock+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ 3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)+ return ( lengthBlock+ .|. (to64 v2 `unsafeShiftL` 16)+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ 4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)+ (peekByteOff ptr 3)+ return ( lengthBlock+ .|. (to64 v3 `unsafeShiftL` 24)+ .|. (to64 v2 `unsafeShiftL` 16)+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ 5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2)+ (peekByteOff ptr 3) (peekByteOff ptr 4)+ return ( lengthBlock+ .|. (to64 v4 `unsafeShiftL` 32)+ .|. (to64 v3 `unsafeShiftL` 24)+ .|. (to64 v2 `unsafeShiftL` 16)+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ 6 -> do v0 <- peekByteOff ptr 0+ v1 <- peekByteOff ptr 1+ v2 <- peekByteOff ptr 2+ v3 <- peekByteOff ptr 3+ v4 <- peekByteOff ptr 4+ v5 <- peekByteOff ptr 5+ return ( lengthBlock+ .|. (to64 v5 `unsafeShiftL` 40)+ .|. (to64 v4 `unsafeShiftL` 32)+ .|. (to64 v3 `unsafeShiftL` 24)+ .|. (to64 v2 `unsafeShiftL` 16)+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ 7 -> do v0 <- peekByteOff ptr 0+ v1 <- peekByteOff ptr 1+ v2 <- peekByteOff ptr 2+ v3 <- peekByteOff ptr 3+ v4 <- peekByteOff ptr 4+ v5 <- peekByteOff ptr 5+ v6 <- peekByteOff ptr 6+ return ( lengthBlock+ .|. (to64 v6 `unsafeShiftL` 48)+ .|. (to64 v5 `unsafeShiftL` 40)+ .|. (to64 v4 `unsafeShiftL` 32)+ .|. (to64 v3 `unsafeShiftL` 24)+ .|. (to64 v2 `unsafeShiftL` 16)+ .|. (to64 v1 `unsafeShiftL` 8)+ .|. to64 v0)+ _ -> error "siphash: internal error: cannot happens"++ {-# INLINE to64 #-}+ to64 :: Word8 -> Word64+ to64 = fromIntegral++ {-# INLINE process #-}+ process istate m = newState+ where newState = postInject $! runRoundsCompression $! preInject istate+ preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m)+ postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3++ {-# INLINE finish #-}+ finish istate = getDigest $! runRoundsDigest $! preInject istate+ where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3)+ preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3++ {-# INLINE doRound #-}+ doRound (InternalState v0 v1 v2 v3) =+ let !v0' = v0 + v1+ !v2' = v2 + v3+ !v1' = v1 `rotateL` 13+ !v3' = v3 `rotateL` 16+ !v1'' = v1' `xor` v0'+ !v3'' = v3' `xor` v2'+ !v0'' = v0' `rotateL` 32+ !v2'' = v2' + v1''+ !v0''' = v0'' + v3''+ !v1''' = v1'' `rotateL` 17+ !v3''' = v3'' `rotateL` 21+ !v1'''' = v1''' `xor` v2''+ !v3'''' = v3''' `xor` v0'''+ !v2''' = v2'' `rotateL` 32+ in InternalState v0''' v1'''' v2''' v3''''++ {-# INLINE runRoundsCompression #-}+ runRoundsCompression st+ | c == 2 = doRound $! doRound st+ | otherwise = loopRounds c st++ {-# INLINE runRoundsDigest #-}+ runRoundsDigest st+ | d == 4 = doRound $! doRound $! doRound $! doRound st+ | otherwise = loopRounds d st++ {-# INLINE loopRounds #-}+ loopRounds 1 !v = doRound v+ loopRounds n !v = loopRounds (n-1) (doRound v)++ {-# INLINE initSip #-}+ initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575)+ (k1 `xor` 0x646f72616e646f6d)+ (k0 `xor` 0x6c7967656e657261)+ (k1 `xor` 0x7465646279746573)
+ Data/Memory/Internal/Compat.hs view
@@ -0,0 +1,76 @@+-- |+-- Module : Data.Memory.Internal.Compat+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Good+--+-- This module try to keep all the difference between versions of base+-- or other needed packages, so that modules don't need to use CPP+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.Compat+ ( unsafeDoIO+ , popCount+ , unsafeShiftL+ , unsafeShiftR+ , byteSwap64+ , byteSwap32+ , byteSwap16+ ) where++import System.IO.Unsafe+import Data.Word+import Data.Bits++-- | perform io for hashes that do allocation and ffi.+-- unsafeDupablePerformIO is used when possible as the+-- computation is pure and the output is directly linked+-- to the input. we also do not modify anything after it has+-- been returned to the user.+unsafeDoIO :: IO a -> a+#if __GLASGOW_HASKELL__ > 704+unsafeDoIO = unsafeDupablePerformIO+#else+unsafeDoIO = unsafePerformIO+#endif++#if !(MIN_VERSION_base(4,5,0))+popCount :: Word64 -> Int+popCount n = loop 0 n+ where loop c 0 = c+ loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap64 :: Word64 -> Word64+byteSwap64 w =+ (w `shiftR` 56) .|. (w `shiftL` 56)+ .|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40)+ .|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24)+ .|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap32 :: Word32 -> Word32+byteSwap32 w =+ (w `shiftR` 24)+ .|. (w `shiftL` 24)+ .|. ((w `shiftR` 8) .&. 0xff00)+ .|. ((w .&. 0xff00) `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap16 :: Word16 -> Word16+byteSwap16 w =+ (w `shiftR` 8) .|. (w `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,4,0))+unsafeShiftL :: Bits a => a -> Int -> a+unsafeShiftL = shiftL++unsafeShiftR :: Bits a => a -> Int -> a+unsafeShiftR = shiftR+#endif+
+ Data/Memory/Internal/CompatPrim.hs view
@@ -0,0 +1,89 @@+-- |+-- Module : Data.Memory.Internal.CompatPrim+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : stable+-- Portability : Compat+--+-- This module try to keep all the difference between versions of ghc primitive+-- or other needed packages, so that modules don't need to use CPP.+--+-- Note that MagicHash and CPP conflicts in places, making it "more interesting"+-- to write compat code for primitives+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Data.Memory.Internal.CompatPrim+ ( be32Prim+ , le32Prim+ , byteswap32Prim+ , booleanPrim+ , eitherDivideBy8#+ ) where++import GHC.Prim++-- | byteswap Word# to or from Big Endian+--+-- on a big endian machine, this function is a nop.+be32Prim :: Word# -> Word#+#ifdef ARCH_IS_LITTLE_ENDIAN+be32Prim = byteswap32Prim+#else+be32Prim w = w+#endif++-- | byteswap Word# to or from Little Endian+--+-- on a little endian machine, this function is a nop.+le32Prim :: Word# -> Word#+#ifdef ARCH_IS_LITTLE_ENDIAN+le32Prim w = w+#else+le32Prim = byteswap32Prim+#endif++-- | Simple compatibility for byteswap the lower 32 bits of a Word#+-- at the primitive level+byteswap32Prim :: Word# -> Word#+#if __GLASGOW_HASKELL__ >= 708+byteswap32Prim w = byteSwap32# w+#else+byteswap32Prim w =+ let !a = uncheckedShiftL# w 24#+ !b = and# (uncheckedShiftL# w 8#) 0x00ff0000##+ !c = and# (uncheckedShiftRL# w 8#) 0x0000ff00##+ !d = and# (uncheckedShiftRL# w 24#) 0x000000ff##+ in or# a (or# b (or# c d))+#endif++-- | Simple wrapper to handle pre 7.8 and future, where+-- most comparaison functions don't returns a boolean+-- anymore.+#if __GLASGOW_HASKELL__ >= 708+booleanPrim :: Int# -> Bool+booleanPrim v = tagToEnum# v+#else+booleanPrim :: Bool -> Bool+booleanPrim b = b+#endif++-- | Apply or or another function if 8 divides the number of bytes+eitherDivideBy8# :: Int# -- ^ number of bytes+ -> (Int# -> a) -- ^ if it divided by 8, the argument is the number of 8 bytes words+ -> (Int# -> a) -- ^ if it doesn't, just the number of bytes+ -> a+#if __GLASGOW_HASKELL__ >= 740+eitherDivideBy8# v f8 f1 =+ let !(# q, r #) = quotRemInt v 8#+ in if booleanPrim (r ==# 0)+ then f8 q+ else f1 v+#else+eitherDivideBy8# v f8 f1 =+ if booleanPrim ((remInt# v 8#) ==# 0#)+ then f8 (quotInt# v 8#)+ else f1 v+#endif
+ Data/Memory/Internal/DeepSeq.hs view
@@ -0,0 +1,28 @@+-- |+-- Module : Data.Memory.Internal.DeepSeq+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Simple abstraction module to allow compilation without deepseq+-- by defining our own NFData class if not compiling with deepseq+-- support.+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.DeepSeq+ ( NFData(..)+ ) where++#ifdef WITH_DEEPSEQ_SUPPORT+import Control.DeepSeq+#else+import Data.Word++class NFData a where rnf :: a -> ()++instance NFData Word8 where rnf w = w `seq` ()+instance NFData Word16 where rnf w = w `seq` ()+instance NFData Word32 where rnf w = w `seq` ()+instance NFData Word64 where rnf w = w `seq` ()+#endif
+ Data/Memory/Internal/Imports.hs view
@@ -0,0 +1,17 @@+-- |+-- Module : Data.Memory.Internal.Imports+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.Imports+ ( module X+ ) where++import Data.Word as X+import Control.Applicative as X+import Control.Monad as X (forM, forM_, void)+import Control.Arrow as X (first, second)+import Data.Memory.Internal.DeepSeq as X
+ Data/Memory/MemMap/Posix.hsc view
@@ -0,0 +1,200 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Memory.MemMap.Posix+-- Copyright : (c) Vincent Hanquez 2014+-- License : BSD-style+--+-- Maintainer : Vincent Hanquez+-- Stability : provisional+-- Portability : non-portable (requires POSIX)+--+-- Functions defined by the POSIX standards for manipulating memory maps+--+-- When a function that calls an underlying POSIX function fails, the errno+-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.+-- For a list of which errno codes may be generated, consult the POSIX+-- documentation for the underlying function.+--+-----------------------------------------------------------------------------++#include <sys/mman.h>+#include <unistd.h>++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+module Data.Memory.MemMap.Posix+ ( memoryMap+ , memoryUnmap+ , memoryAdvise+ , memoryLock+ , memoryUnlock+ , memoryProtect+ , memorySync+ -- * Flags types+ , MemoryMapFlag(..)+ , MemoryProtection(..)+ , MemoryAdvice(..)+ , MemorySyncFlag(..)+ -- * system page size+ , sysconfPageSize+ ) where++import System.Posix.Types+import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.Error+import Data.Bits++foreign import ccall unsafe "mmap"+ c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)++foreign import ccall unsafe "munmap"+ c_munmap :: Ptr a -> CSize -> IO CInt++foreign import ccall unsafe "madvise"+ c_madvise :: Ptr a -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "msync"+ c_msync :: Ptr a -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "mprotect"+ c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt++foreign import ccall unsafe "mlock"+ c_mlock :: Ptr a -> CSize -> IO CInt++foreign import ccall unsafe "munlock"+ c_munlock :: Ptr a -> CSize -> IO CInt++foreign import ccall unsafe "sysconf"+ c_sysconf :: CInt -> CLong++-- | Mapping flag+data MemoryMapFlag =+ MemoryMapShared -- ^ memory changes are shared between process+ | MemoryMapPrivate -- ^ memory changes are private to process+ deriving (Show,Read,Eq)++-- | Memory protection+data MemoryProtection =+ MemoryProtectionNone+ | MemoryProtectionRead+ | MemoryProtectionWrite+ | MemoryProtectionExecute+ deriving (Show,Read,Eq)++-- | Advice to put on memory.+--+-- only define the posix one.+data MemoryAdvice =+ MemoryAdviceNormal -- ^ no specific advice, the default.+ | MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur.+ | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively.+ | MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early+ | MemoryAdviceDontNeed -- ^ Do not expect access in the near future.+ deriving (Show,Read,Eq)++-- | Memory synchronization flags+data MemorySyncFlag =+ MemorySyncAsync -- ^ perform asynchronous write.+ | MemorySyncSync -- ^ perform synchronous write.+ | MemorySyncInvalidate -- ^ invalidate cache data.+ deriving (Show,Read,Eq)++cvalueOfMemoryProts :: [MemoryProtection] -> CInt+cvalueOfMemoryProts = foldl (.|.) 0 . map toProt+ where toProt :: MemoryProtection -> CInt+ toProt MemoryProtectionNone = (#const PROT_NONE)+ toProt MemoryProtectionRead = (#const PROT_READ)+ toProt MemoryProtectionWrite = (#const PROT_WRITE)+ toProt MemoryProtectionExecute = (#const PROT_EXEC)++cvalueOfMemorySync :: [MemorySyncFlag] -> CInt+cvalueOfMemorySync = foldl (.|.) 0 . map toSync+ where toSync MemorySyncAsync = (#const MS_ASYNC)+ toSync MemorySyncSync = (#const MS_SYNC)+ toSync MemorySyncInvalidate = (#const MS_INVALIDATE)++-- | Map pages of memory.+--+-- If fd is present, this memory will represent the file associated.+-- Otherwise, the memory will be an anonymous mapping.+--+-- use 'mmap'+memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used.+ -> CSize -- ^ The length of the mapping+ -> [MemoryProtection] -- ^ the memory protection associated with the mapping+ -> MemoryMapFlag -- ^ + -> Maybe Fd+ -> COff+ -> IO (Ptr a)+memoryMap initPtr sz prots flag mfd off =+ throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off)+ where m1ptr = nullPtr `plusPtr` (-1)+ fd = maybe (-1) (\(Fd v) -> v) mfd+ cprot = cvalueOfMemoryProts prots+ cflags = maybe cMapAnon (const 0) mfd+ .|. maybe 0 (const cMapFixed) initPtr+ .|. toMapFlag flag++#ifdef __APPLE__+ cMapAnon = (#const MAP_ANON)+#else+ cMapAnon = (#const MAP_ANONYMOUS)+#endif+ cMapFixed = (#const MAP_FIXED)++ toMapFlag MemoryMapShared = (#const MAP_SHARED)+ toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE)++-- | Unmap pages of memory+--+-- use 'munmap'+memoryUnmap :: Ptr a -> CSize -> IO ()+memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz)++-- | give advice to the operating system about use of memory+--+-- call 'madvise'+memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO ()+memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv)+ where cadv = toAdvice adv++ toAdvice MemoryAdviceNormal = (#const MADV_NORMAL)+ toAdvice MemoryAdviceRandom = (#const MADV_RANDOM)+ toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL)+ toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED)+ toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED)++-- | lock a range of process address space+--+-- call 'mlock'+memoryLock :: Ptr a -> CSize -> IO ()+memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz)++-- | unlock a range of process address space+--+-- call 'munlock'+memoryUnlock :: Ptr a -> CSize -> IO ()+memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz)++-- | set protection of memory mapping+--+-- call 'mprotect'+memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO ()+memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot)+ where cprot = cvalueOfMemoryProts prots++-- | memorySync synchronize memory with physical storage.+--+-- On an anonymous mapping this function doesn't have any effect.+-- call 'msync'+memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO ()+memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags)+ where cflags = cvalueOfMemorySync flags++-- | Return the operating system page size.+-- +-- call 'sysconf'+sysconfPageSize :: Int+sysconfPageSize = fromIntegral $ c_sysconf (#const _SC_PAGESIZE)
+ Data/Memory/MemMap/Windows.hs view
@@ -0,0 +1,12 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Memory.MemMap.Windows+-- Copyright : (c) Vincent Hanquez 2014+-- License : BSD-style+-- Maintainer : Vincent Hanquez+-- Stability : provisional+-- Portability : non-portable (requires Windows)+--+module Data.Memory.MemMap.Windows+ (+ ) where
+ Data/Memory/PtrMethods.hs view
@@ -0,0 +1,112 @@+-- |+-- Module : Data.Memory.PtrMethods+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- methods to manipulate raw memory representation+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Memory.PtrMethods+ ( memCreateTemporary+ , memXor+ , memXorWith+ , memCopy+ , memSet+ , memEqual+ , memConstEqual+ , memCompare+ ) where++import Data.Memory.Internal.Imports+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek, poke, pokeByteOff, peekByteOff)+import Foreign.C.Types+import Foreign.Marshal.Alloc (allocaBytesAligned)+import Data.Bits (xor)++-- | Create a new temporary buffer+memCreateTemporary :: Int -> (Ptr Word8 -> IO a) -> IO a+memCreateTemporary size f = allocaBytesAligned size 8 f++-- | xor bytes from source1 and source2 to destination+-- +-- d = s1 xor s2+--+-- s1, nor s2 are modified unless d point to s1 or s2+memXor :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memXor _ _ _ 0 = return ()+memXor d s1 s2 n = do+ (xor <$> peek s1 <*> peek s2) >>= poke d+ memXor (d `plusPtr` 1) (s1 `plusPtr` 1) (s2 `plusPtr` 1) (n-1)++-- | xor bytes from source with a specific value to destination+--+-- d = replicate (sizeof s) v `xor` s+memXorWith :: Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO ()+memXorWith d v s n = loop 0+ where+ loop i+ | i == n = return ()+ | otherwise = do+ (xor v <$> peekByteOff s i) >>= pokeByteOff d i+ loop (i+1)++-- | Copy a set number of bytes from @src to @dst+memCopy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memCopy dst src n = c_memcpy dst src (fromIntegral n)++-- | Set @n number of bytes to the same value @v+memSet :: Ptr Word8 -> Word8 -> Int -> IO ()+memSet start v n = c_memset start (fromIntegral v) (fromIntegral n) >>= \_ -> return ()++-- | Check if two piece of memory are equals+memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool+memEqual p1 p2 n = loop 0+ where+ loop i+ | i == n = return True+ | otherwise = do+ e <- (==) <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8)+ if e then loop (i+1) else return False++-- | Compare two piece of memory and returns how they compare+memCompare :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering+memCompare p1 p2 n = loop 0+ where+ loop i+ | i == n = return EQ+ | otherwise = do+ e <- compare <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8)+ if e == EQ then loop (i+1) else return e++-- | A constant time equality test for 2 Memory buffers+--+-- compared to normal equality function, this function will go+-- over all the bytes present before yielding a result even when+-- knowing the overall result early in the processing.+memConstEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool+memConstEqual p1 p2 n = loop 0 True+ where+ loop i !ret+ | i == n = return ret+ | otherwise = do+ e <- (==) <$> peek p1 <*> peek p2+ loop (i+1) (ret &&! e)++ -- Bool == Bool+ (&&!) :: Bool -> Bool -> Bool+ True &&! True = True+ True &&! False = False+ False &&! True = False+ False &&! False = False++foreign import ccall unsafe "memset"+ c_memset :: Ptr Word8 -> Word8 -> CSize -> IO ()++foreign import ccall unsafe "memcpy"+ c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO ()
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015 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.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++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.
+ README.md view
@@ -0,0 +1,58 @@+memory+======++[](https://travis-ci.org/vincenthz/hs-memory)+[](http://en.wikipedia.org/wiki/BSD_licenses)+[](http://haskell.org)++Documentation: [memory on hackage](http://hackage.haskell.org/package/memory)++A generic memory and related abstraction for haskell:++* A polymorphic byte array abstraction and function similar to strict ByteString.+* Different type of byte array abstraction.+* Raw memory IO operations (memory set, memory copy, ..)+* Aliasing with endianness support.++Also provides some useful helpers:++* Fast Hashing : [SipHash](https://131002.net/siphash/), [FNV1](http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function).+* Built-in base encoding : Base16, [Base64](http://en.wikipedia.org/wiki/Base64).++Versioning+----------++Development versions are an incremental number prefixed by 0.+No specific meaning is associated with the versions, specially+no API stability.++Production versions : TBD++Coding Style+------------++The coding style of this project mostly follows:+[haskell-style](https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md)++Support+-------++memory supports the following platform:++* Windows >= 7+* OSX >= 10.8+* Linux++On the following architectures:++* x86-64+* i386++On the following haskell versions:++* GHC 7.0.x+* GHC 7.4.x+* GHC 7.6.x+* GHC 7.8.x+* GHC 7.10.x+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ memory.cabal view
@@ -0,0 +1,95 @@+Name: memory+Version: 0.1+Synopsis: memory and related abtraction stuff+Description:+ Chunk of memory, polymorphic byte array management and manipulation+ .+ * A polymorphic byte array abstraction and function similar to strict ByteString.+ * Different type of byte array abstraction.+ * Raw memory IO operations (memory set, memory copy, ..)+ * Aliasing with endianness support.+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: vincent@snarc.org+Category: memory+Stability: experimental+Build-Type: Simple+Homepage: https://github.com/vincenthz/hs-memory+Bug-Reports: https://github.com/vincenthz/hs-memory/issues+Cabal-Version: >=1.10+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/vincenthz/hs-memory++Flag support_bytestring+ Description: add non-orphan bytearray support for bytestring+ Default: True+ Manual: True++Flag support_deepseq+ Description: add deepseq instances for memory types+ Default: True+ Manual: True++Library+ Exposed-modules: Data.ByteArray+ Data.ByteArray.Encoding+ Data.ByteArray.Mapping+ Data.ByteArray.Pack+ Data.ByteArray.Parse+ Data.ByteArray.Hash+ Data.Memory.Endian+ Data.Memory.PtrMethods+ Data.Memory.ExtendedWords+ Data.Memory.Encoding.Base16+ Data.Memory.Encoding.Base64+ Other-modules: Data.Memory.Internal.Compat+ Data.Memory.Internal.CompatPrim+ Data.Memory.Internal.DeepSeq+ Data.Memory.Internal.Imports+ Data.Memory.Hash.SipHash+ Data.Memory.Hash.FNV+ Data.ByteArray.Pack.Internal+ Data.ByteArray.Types+ Data.ByteArray.Bytes+ Data.ByteArray.ScrubbedBytes+ Data.ByteArray.Methods+ Data.ByteArray.MemView+ Build-depends: base >= 4 && < 5+ , ghc-prim+ -- FIXME armel or mispel is also little endian.+ -- might be a good idea to also add a runtime autodetect mode.+ -- ARCH_ENDIAN_UNKNOWN+ if (arch(i386) || arch(x86_64))+ CPP-options: -DARCH_IS_LITTLE_ENDIAN+ if os(windows)+ Other-modules: Data.Memory.MemMap.Windows+ else+ Other-modules: Data.Memory.MemMap.Posix++ -- optional support bytearray instance for bytestring+ if flag(support_bytestring)+ CPP-options: -DWITH_BYTESTRING_SUPPORT+ Build-depends: bytestring+ if flag(support_deepseq)+ CPP-options: -DWITH_DEEPSEQ_SUPPORT+ Build-depends: deepseq++ ghc-options: -Wall -fwarn-tabs+ default-language: Haskell2010++Test-Suite test-memory+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ Main-is: Tests.hs+ Build-Depends: base >= 3 && < 5+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , memory+ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded+ default-language: Haskell2010
+ tests/Tests.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+module Main where++import Imports+import Utils+import Data.Word+import Data.ByteArray (Bytes, ScrubbedBytes, ByteArray)+import qualified Data.ByteArray as B+import qualified Data.ByteArray.Encoding as B+import qualified Data.ByteArray.Parse as Parse++import qualified SipHash++data Backend = BackendByte | BackendScrubbedBytes+ deriving (Show,Eq,Bounded,Enum)++allBackends :: [Backend]+allBackends = enumFrom BackendByte++data ArbitraryBS = forall a . ByteArray a => ArbitraryBS a++arbitraryBS :: Int -> Gen ArbitraryBS+arbitraryBS n = do+ backend <- elements allBackends+ case backend of+ BackendByte -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM n arbitrary) :: Gen Bytes)+ BackendScrubbedBytes -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM n arbitrary) :: Gen ScrubbedBytes)++arbitraryBSof :: Int -> Int -> Gen ArbitraryBS+arbitraryBSof minBytes maxBytes = choose (minBytes, maxBytes) >>= arbitraryBS++newtype SmallList a = SmallList [a]+ deriving (Show,Eq)++instance Arbitrary a => Arbitrary (SmallList a) where+ arbitrary = choose (0,8) >>= \n -> SmallList `fmap` replicateM n arbitrary++instance Arbitrary ArbitraryBS where+ arbitrary = arbitraryBSof 0 259++newtype Words8 = Words8 { unWords8 :: [Word8] }+ deriving (Show,Eq)++instance Arbitrary Words8 where+ arbitrary = choose (0, 259) >>= \n -> Words8 <$> replicateM n arbitrary++testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, ByteArray ba) => (ba -> ba) -> [TestTree]) -> TestTree+testGroupBackends x l =+ testGroup x+ [ testGroup "Bytes" (l withBytesWitness)+ , testGroup "ScrubbedBytes" (l withScrubbedBytesWitness)+ ]++base64Kats =+ [ ("pleasure.", "cGxlYXN1cmUu")+ , ("leasure.", "bGVhc3VyZS4=")+ , ("easure.", "ZWFzdXJlLg==")+ , ("asure.", "YXN1cmUu")+ , ("sure.", "c3VyZS4=")+ ]++base16Kats =+ [ ("this is a string", "74686973206973206120737472696e67") ]++encodingTests witnessID =+ [ testGroup "BASE64"+ [ testGroup "encode-KAT" encodeKats64+ , testGroup "decode-KAT" decodeKats64+ ]+ , testGroup "BASE16"+ [ testGroup "encode-KAT" encodeKats16+ , testGroup "decode-KAT" decodeKats16+ ]+ ]+ where+ encodeKats64 = map (toTest B.Base64) $ zip [1..] base64Kats+ decodeKats64 = map (toBackTest B.Base64) $ zip [1..] base64Kats+ encodeKats16 = map (toTest B.Base16) $ zip [1..] base16Kats+ decodeKats16 = map (toBackTest B.Base16) $ zip [1..] base16Kats++ toTest :: B.Base -> (Int, (String, String)) -> TestTree+ toTest base (i, (inp, out)) = testCase (show i) $+ let inpbs = witnessID $ B.convertToBase base $ witnessID $ B.pack $ unS inp+ outbs = witnessID $ B.pack $ unS out+ in outbs @=? inpbs+ toBackTest :: B.Base -> (Int, (String, String)) -> TestTree+ toBackTest base (i, (inp, out)) = testCase (show i) $+ let inpbs = witnessID $ B.pack $ unS inp+ outbs = B.convertFromBase base $ witnessID $ B.pack $ unS out+ in Right inpbs @=? outbs++parsingTests witnessID =+ [ testCase "parse" $+ let input = witnessID $ B.pack $ unS "xx abctest"+ abc = witnessID $ B.pack $ unS "abc"+ est = witnessID $ B.pack $ unS "est"+ result = Parse.parse ((,,) <$> Parse.take 2 <*> Parse.byte 0x20 <*> (Parse.bytes abc *> Parse.anyByte)) input+ in case result of+ Parse.ParseOK remaining (_,_,_) -> est @=? remaining+ _ -> assertFailure ""+ ]++main = defaultMain $ testGroup "memory"+ [ localOption (QuickCheckTests 500) $ testGroupBackends "basic" basicProperties+ , testGroupBackends "encoding" encodingTests+ , testGroupBackends "parsing" parsingTests+ , testGroupBackends "hashing" $ \witnessID ->+ [ testGroup "SipHash" $ SipHash.tests witnessID+ ]+ ]+ where+ basicProperties witnessID =+ [ testProperty "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l)+ , testProperty "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b+ , testProperty "empty-eq" $ \(Words8 l) ->+ let b = witnessID $ B.pack l+ in B.append b B.empty == b+ , testProperty "zero" $ \(Positive n) ->+ let expected = witnessID $ B.pack $ replicate n 0+ in expected == B.zero n+ , testProperty "Ord" $ \(Words8 l1) (Words8 l2) ->+ compare l1 l2 == compare (witnessID $ B.pack l1) (B.pack l2)+ , testProperty "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) ->+ mappend l1 l2 == (B.unpack $ mappend (witnessID $ B.pack l1) (B.pack l2))+ , testProperty "Monoid(mconcat)" $ \(SmallList l) ->+ mconcat (map unWords8 l) == (B.unpack $ mconcat $ map (witnessID . B.pack . unWords8) l)+ , testProperty "append (append a b) c == append a (append b c)" $ \(Words8 la) (Words8 lb) (Words8 lc) ->+ let a = witnessID $ B.pack la+ b = witnessID $ B.pack lb+ c = witnessID $ B.pack lc+ in B.append (B.append a b) c == B.append a (B.append b c)+ , testProperty "concat l" $ \(SmallList l) ->+ let chunks = map (witnessID . B.pack . unWords8) l+ expected = concatMap unWords8 l+ in B.pack expected == B.concat chunks+ ]