memory-0.14.11/Data/0000755000000000000000000000000013053117003012216 5ustar0000000000000000memory-0.14.11/Data/ByteArray/0000755000000000000000000000000013211773722014134 5ustar0000000000000000memory-0.14.11/Data/ByteArray/Pack/0000755000000000000000000000000013053117003014776 5ustar0000000000000000memory-0.14.11/Data/Memory/0000755000000000000000000000000013077662022013502 5ustar0000000000000000memory-0.14.11/Data/Memory/Encoding/0000755000000000000000000000000013216714260015225 5ustar0000000000000000memory-0.14.11/Data/Memory/Hash/0000755000000000000000000000000013053117003014351 5ustar0000000000000000memory-0.14.11/Data/Memory/Internal/0000755000000000000000000000000013060244054015247 5ustar0000000000000000memory-0.14.11/Data/Memory/MemMap/0000755000000000000000000000000013053117003014642 5ustar0000000000000000memory-0.14.11/tests/0000755000000000000000000000000013116610065012515 5ustar0000000000000000memory-0.14.11/Data/ByteArray.hs0000644000000000000000000000204213053117003014452 0ustar0000000000000000-- | -- Module : Data.ByteArray -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 , module Data.ByteArray.View -- * 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(..)) import Data.ByteArray.View (View, view, takeView, dropView) memory-0.14.11/Data/ByteArray/Encoding.hs0000644000000000000000000001204513053117003016204 0ustar0000000000000000-- | -- Module : Data.ByteArray.Encoding -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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.Base32 import Data.Memory.Encoding.Base64 -- | Different bases that can be used -- -- See for details. -- In particular, Base64 can be standard or -- . URL-safe -- encoding is often used in other specifications without -- characters. data Base = Base16 -- ^ similar to hexadecimal | Base32 | Base64 -- ^ standard Base64 | Base64URLUnpadded -- ^ unpadded URL-safe Base64 | Base64OpenBSD -- ^ Base64 as used in OpenBSD password encoding (such as bcrypt) deriving (Show,Eq) -- | Convert a bytearray to the equivalent representation in a specific Base convertToBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> bout convertToBase base b = case base of Base16 -> doConvert (binLength * 2) toHexadecimal Base32 -> let (q,r) = binLength `divMod` 5 outLen = 8 * (if r == 0 then q else q + 1) in doConvert outLen toBase32 Base64 -> doConvert base64Length toBase64 -- Base64URL -> doConvert base64Length (toBase64URL True) Base64URLUnpadded -> doConvert base64UnpaddedLength (toBase64URL False) Base64OpenBSD -> doConvert base64UnpaddedLength toBase64OpenBSD where binLength = B.length b base64Length = let (q,r) = binLength `divMod` 3 in 4 * (if r == 0 then q else q+1) base64UnpaddedLength = let (q,r) = binLength `divMod` 3 in 4 * q + (if r == 0 then 0 else r+1) doConvert l f = B.unsafeCreate l $ \bout -> B.withByteArray b $ \bin -> f bout bin binLength -- | 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 Base32 b = unsafeDoIO $ withByteArray b $ \bin -> do mDstLen <- unBase32Length bin (B.length b) case mDstLen of Nothing -> return $ Left "base32: input: invalid length" Just dstLen -> do (ret, out) <- B.allocRet dstLen $ \bout -> fromBase32 bout bin (B.length b) case ret of Nothing -> return $ Right out Just ofs -> return $ Left ("base32: 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) convertFromBase Base64URLUnpadded b = unsafeDoIO $ withByteArray b $ \bin -> case unBase64LengthUnpadded (B.length b) of Nothing -> return $ Left "base64URL unpadded: input: invalid length" Just dstLen -> do (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64URLUnpadded bout bin (B.length b) case ret of Nothing -> return $ Right out Just ofs -> return $ Left ("base64URL unpadded: input: invalid encoding at offset: " ++ show ofs) convertFromBase Base64OpenBSD b = unsafeDoIO $ withByteArray b $ \bin -> case unBase64LengthUnpadded (B.length b) of Nothing -> return $ Left "base64 unpadded: input: invalid length" Just dstLen -> do (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64OpenBSD bout bin (B.length b) case ret of Nothing -> return $ Right out Just ofs -> return $ Left ("base64 unpadded: input: invalid encoding at offset: " ++ show ofs) memory-0.14.11/Data/ByteArray/Mapping.hs0000644000000000000000000000546513153257637016104 0ustar0000000000000000-- | -- Module : Data.ByteArray.Mapping -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- module Data.ByteArray.Mapping ( toW64BE , toW64LE , fromW64BE , 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) -- | Serialize a @Word64@ to a @ByteArray@ in big endian format fromW64BE :: (ByteArray ba) => Word64 -> ba fromW64BE n = allocAndFreeze 8 $ \p -> poke p (toBE n) -- | 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) memory-0.14.11/Data/ByteArray/Pack.hs0000644000000000000000000001122713053117003015335 0ustar0000000000000000-- | -- Module : Data.ByteArray.Pack -- License : BSD-Style -- Maintainer : Vincent Hanquez -- 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 -- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05) -- Copyright (c) 2014 Nicolas DI PRIMA -- module Data.ByteArray.Pack ( Packer , Result(..) , fill , 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, ByteArrayAccess, MemView(..)) import qualified Data.ByteArray as B -- | Fill a given sized buffer with the result of the Packer action fill :: ByteArray byteArray => Int -> Packer a -> Either String byteArray fill len packing = 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 -- | Pack the given packer into the given bytestring pack :: ByteArray byteArray => Packer a -> Int -> Either String byteArray pack packing len = fill len packing {-# DEPRECATED pack "use fill instead" #-} 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 :: ByteArrayAccess 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 equivalent to: -- -- > 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 -- > .. <..succesful..> -- > > pack (fillList $ [1..] :: Word32) 1 -- > .. <.. not enough space ..> -- > > pack (fillList $ [1..] :: Word32) 131 -- > .. <.. 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 #-} memory-0.14.11/Data/ByteArray/Parse.hs0000644000000000000000000002265013053117003015533 0ustar0000000000000000-- | -- Module : Data.ByteArray.Parse -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 , hasMore , 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 (Maybe 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 -- | The continuation of the current buffer, and the error string type Failure byteArray r = byteArray -> String -> Result byteArray r -- | The continuation of the next buffer value, and the parsed value 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 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 Monad (Parser byteArray) where fail errorMsg = Parser $ \buf err _ -> err buf ("Parser 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 "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 Alternative (Parser byteArray) where empty = fail "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 (Maybe 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) ------------------------------------------------------------ -- When needing more data, getMore append the next data -- to the current buffer. if no further data, then -- the err callback is called. getMore :: ByteArray byteArray => Parser byteArray () getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk -> case nextChunk of Nothing -> err buf "EOL: need more data" Just nc | B.null nc -> runParser getMore buf err ok | otherwise -> ok (B.append buf nc) () -- Only used by takeAll, which accumulate all the remaining data -- until ParseMore is fed a Nothing value. -- -- getAll cannot fail. getAll :: ByteArray byteArray => Parser byteArray () getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> case nextChunk of Nothing -> ok buf () Just nc -> runParser getAll (B.append buf nc) err ok -- Only used by skipAll, which flush all the remaining data -- until ParseMore is fed a Nothing value. -- -- flushAll cannot fail. flushAll :: ByteArray byteArray => Parser byteArray () flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> case nextChunk of Nothing -> ok buf () Just _ -> runParser flushAll B.empty err ok ------------------------------------------------------------ hasMore :: ByteArray byteArray => Parser byteArray Bool hasMore = Parser $ \buf err ok -> if B.null buf then ParseMore $ \nextChunk -> case nextChunk of Nothing -> ok buf False Just nc -> runParser hasMore nc err ok else ok buf True -- | 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 : got " ++ show c1) -- | 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 memory-0.14.11/Data/ByteArray/Hash.hs0000644000000000000000000000446413053117003015347 0ustar0000000000000000-- | -- Module : Data.ByteArray.Hash -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- provide the SipHash algorithm. -- reference: -- {-# 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) memory-0.14.11/Data/Memory/Endian.hs0000644000000000000000000000636513053117003015232 0ustar0000000000000000-- | -- Module : Data.Memory.Endian -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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.Word (Word8) import Data.Memory.Internal.Compat (unsafeDoIO) import Foreign.Marshal.Alloc import Foreign.Ptr #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 memory-0.14.11/Data/Memory/PtrMethods.hs0000644000000000000000000000726213077662022016136 0ustar0000000000000000-- | -- Module : Data.Memory.PtrMethods -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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, 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 destination !v source bytes | destination == source = loopInplace source bytes | otherwise = loop destination source bytes where loop _ _ 0 = return () loop !d !s !n = do peek s >>= poke d . xor v loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1) loopInplace _ 0 = return () loopInplace !s !n = do peek s >>= poke s . xor v loopInplace (s `plusPtr` 1) (n-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) {-# INLINE memCopy #-} -- | Set @n number of bytes to the same value @v memSet :: Ptr Word8 -> Word8 -> Int -> IO () memSet start v n = c_memset start v (fromIntegral n) >>= \_ -> return () {-# INLINE memSet #-} -- | 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 0 where loop i !acc | i == n = return $! acc == 0 | otherwise = do e <- xor <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) loop (i+1) (acc .|. e) 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 () memory-0.14.11/Data/Memory/ExtendedWords.hs0000644000000000000000000000063213053117003016602 0ustar0000000000000000-- | -- Module : Data.Memory.ExtendedWords -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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) memory-0.14.11/Data/Memory/Encoding/Base16.hs0000644000000000000000000001676013053117003016603 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base16 -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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"# memory-0.14.11/Data/Memory/Encoding/Base32.hs0000644000000000000000000002642513053117003016600 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base32 -- License : BSD-style -- Maintainer : Nicolas DI PRIMA -- Stability : experimental -- Portability : unknown -- -- Base32 -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} module Data.Memory.Encoding.Base32 ( toBase32 , unBase32Length , fromBase32 ) where import Data.Memory.Internal.Compat import Data.Memory.Internal.CompatPrim import Data.Word import Data.Bits ((.|.)) import GHC.Prim import GHC.Word import Control.Monad import Foreign.Storable import Foreign.Ptr (Ptr) -- | Transform a number of bytes pointed by.@src in the base32 binary representation in @dst -- -- destination memory need to be of correct size, otherwise it will lead -- to really bad things. toBase32 :: Ptr Word8 -- ^ input -> Ptr Word8 -- ^ output -> Int -- ^ input len -> IO () toBase32 dst src len = loop 0 0 where eqChar :: Word8 eqChar = 0x3d peekOrZero :: Int -> IO Word8 peekOrZero i | i >= len = return 0 | otherwise = peekByteOff src i pokeOrPadding :: Int -- for the test -> Int -- src index -> Word8 -- the value -> IO () pokeOrPadding i di v | i < len = pokeByteOff dst di v | otherwise = pokeByteOff dst di eqChar loop :: Int -- index input -> Int -- index output -> IO () loop i di | i > len = return () | otherwise = do i1 <- peekByteOff src i i2 <- peekOrZero (i + 1) i3 <- peekOrZero (i + 2) i4 <- peekOrZero (i + 3) i5 <- peekOrZero (i + 4) let (o1,o2,o3,o4,o5,o6,o7,o8) = toBase32Per5Bytes (i1, i2, i3, i4, i5) pokeByteOff dst di o1 pokeByteOff dst (di + 1) o2 pokeOrPadding (i + 1) (di + 2) o3 pokeOrPadding (i + 1) (di + 3) o4 pokeOrPadding (i + 2) (di + 4) o5 pokeOrPadding (i + 3) (di + 5) o6 pokeOrPadding (i + 3) (di + 6) o7 pokeOrPadding (i + 4) (di + 7) o8 loop (i+5) (di+8) toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) toBase32Per5Bytes (W8# i1, W8# i2, W8# i3, W8# i4, W8# i5) = (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8) where -- 1111 1000 >> 3 !o1 = (uncheckedShiftRL# (and# i1 0xF8##) 3#) -- 0000 0111 << 2 | 1100 0000 >> 6 !o2 = or# (uncheckedShiftL# (and# i1 0x07##) 2#) (uncheckedShiftRL# (and# i2 0xC0##) 6#) -- 0011 1110 >> 1 !o3 = (uncheckedShiftRL# (and# i2 0x3E##) 1#) -- 0000 0001 << 4 | 1111 0000 >> 4 !o4 = or# (uncheckedShiftL# (and# i2 0x01##) 4#) (uncheckedShiftRL# (and# i3 0xF0##) 4#) -- 0000 1111 << 1 | 1000 0000 >> 7 !o5 = or# (uncheckedShiftL# (and# i3 0x0F##) 1#) (uncheckedShiftRL# (and# i4 0x80##) 7#) -- 0111 1100 >> 2 !o6 = (uncheckedShiftRL# (and# i4 0x7C##) 2#) -- 0000 0011 << 3 | 1110 0000 >> 5 !o7 = or# (uncheckedShiftL# (and# i4 0x03##) 3#) (uncheckedShiftRL# (and# i5 0xE0##) 5#) -- 0001 1111 !o8 = ((and# i5 0x1F##)) !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# index :: Word# -> Word8 index idx = W8# (indexWord8OffAddr# set (word2Int# idx)) -- | Get the length needed for the destination buffer for a base32 decoding. -- -- if the length is not a multiple of 8, Nothing is returned unBase32Length :: Ptr Word8 -> Int -> IO (Maybe Int) unBase32Length src len | (len `mod` 8) /= 0 = return Nothing | otherwise = do last1Byte <- peekByteOff src (len - 1) last2Byte <- peekByteOff src (len - 2) last3Byte <- peekByteOff src (len - 3) last4Byte <- peekByteOff src (len - 4) last5Byte <- peekByteOff src (len - 5) last6Byte <- peekByteOff src (len - 6) let dstLen = caseByte last1Byte last2Byte last3Byte last4Byte last5Byte last6Byte return $ Just $ (len `div` 8) * 5 - dstLen where caseByte :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Int caseByte last1 last2 last3 last4 last5 last6 | last6 == eqAscii = 4 | last5 == eqAscii = 3 -- error this padding is not expected (error will be detected in fromBase32) | last4 == eqAscii = 3 | last3 == eqAscii = 2 | last2 == eqAscii = 1 -- error this padding is not expected (error will be detected in fromBase32) | last1 == eqAscii = 1 | otherwise = 0 eqAscii :: Word8 eqAscii = 0x3D -- | convert from base32 in @src to binary in @dst, using the number of bytes specified -- -- the user should use unBase32Length to compute the correct length, or check that -- the length specification is proper. no check is done here. fromBase32 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) fromBase32 dst src len | len == 0 = return Nothing | otherwise = loop 0 0 where loop :: Int -- the index dst -> Int -- the index src -> IO (Maybe Int) loop di i | i == (len - 8) = do i1 <- peekByteOff src i i2 <- peekByteOff src (i + 1) i3 <- peekByteOff src (i + 2) i4 <- peekByteOff src (i + 3) i5 <- peekByteOff src (i + 4) i6 <- peekByteOff src (i + 5) i7 <- peekByteOff src (i + 6) i8 <- peekByteOff src (i + 7) let (nbBytes, i3', i4', i5', i6', i7', i8') = case (i3, i4, i5, i6, i7, i8) of (0x3D, 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (6, 0x41, 0x41, 0x41, 0x41, 0x41, 0x41) (0x3D, _ , _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid (_ , 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (5, i3 , 0x41, 0x41, 0x41, 0x41, 0x41) (_ , 0x3D, _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid (_ , _ , 0x3D, 0x3D, 0x3D, 0x3D) -> (4, i3 , i4 , 0x41, 0x41, 0x41, 0x41) (_ , _ , 0x3D, _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid (_ , _ , _ , 0x3D, 0x3D, 0x3D) -> (3, i3 , i4 , i5 , 0x41, 0x41, 0x41) (_ , _ , _ , 0x3D, _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid (_ , _ , _ , _ , 0x3D, 0x3D) -> (2, i3 , i4 , i5 , i6 , 0x41, 0x41) (_ , _ , _ , _ , 0x3D, _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid (_ , _ , _ , _ , _ , 0x3D) -> (1, i3 , i4 , i5 , i6 , i7 , 0x41) (_ , _ , _ , _ , _ , _ ) -> (0 :: Int, i3, i4, i5, i6, i7, i8) case fromBase32Per8Bytes (i1, i2, i3', i4', i5', i6', i7', i8') of Left ofs -> return $ Just (i + ofs) Right (o1, o2, o3, o4, o5) -> do pokeByteOff dst di o1 pokeByteOff dst (di+1) o2 when (nbBytes < 5) $ pokeByteOff dst (di+2) o3 when (nbBytes < 4) $ pokeByteOff dst (di+3) o4 when (nbBytes < 2) $ pokeByteOff dst (di+4) o5 return Nothing | otherwise = do i1 <- peekByteOff src i i2 <- peekByteOff src (i + 1) i3 <- peekByteOff src (i + 2) i4 <- peekByteOff src (i + 3) i5 <- peekByteOff src (i + 4) i6 <- peekByteOff src (i + 5) i7 <- peekByteOff src (i + 6) i8 <- peekByteOff src (i + 7) case fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) of Left ofs -> return $ Just (i + ofs) Right (o1, o2, o3, o4, o5) -> do pokeByteOff dst di o1 pokeByteOff dst (di+1) o2 pokeByteOff dst (di+2) o3 pokeByteOff dst (di+3) o4 pokeByteOff dst (di+4) o5 loop (di+5) (i+8) fromBase32Per8Bytes :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) -> Either Int (Word8, Word8, Word8, Word8, Word8) fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) = case (rset i1, rset i2, rset i3, rset i4, rset i5, rset i6, rset i7, rset i8) of (0xFF, _ , _ , _ , _ , _ , _ , _ ) -> Left 0 (_ , 0xFF, _ , _ , _ , _ , _ , _ ) -> Left 1 (_ , _ , 0xFF, _ , _ , _ , _ , _ ) -> Left 2 (_ , _ , _ , 0xFF, _ , _ , _ , _ ) -> Left 3 (_ , _ , _ , _ , 0xFF, _ , _ , _ ) -> Left 4 (_ , _ , _ , _ , _ , 0xFF, _ , _ ) -> Left 5 (_ , _ , _ , _ , _ , _ , 0xFF, _ ) -> Left 6 (_ , _ , _ , _ , _ , _ , _ , 0xFF) -> Left 7 (ri1 , ri2 , ri3 , ri4 , ri5 , ri6 , ri7 , ri8 ) -> -- 0001 1111 << 3 | 0001 11xx >> 2 let o1 = (ri1 `unsafeShiftL` 3) .|. (ri2 `unsafeShiftR` 2) -- 000x xx11 << 6 | 0001 1111 << 1 | 0001 xxxx >> 4 o2 = (ri2 `unsafeShiftL` 6) .|. (ri3 `unsafeShiftL` 1) .|. (ri4 `unsafeShiftR` 4) -- 000x 1111 << 4 | 0001 111x >> 1 o3 = (ri4 `unsafeShiftL` 4) .|. (ri5 `unsafeShiftR` 1) -- 000x xxx1 << 7 | 0001 1111 << 2 | 0001 1xxx >> 3 o4 = (ri5 `unsafeShiftL` 7) .|. (ri6 `unsafeShiftL` 2) .|. (ri7 `unsafeShiftR` 3) -- 000x x111 << 5 | 0001 1111 o5 = (ri7 `unsafeShiftL` 5) .|. ri8 in Right (o1, o2, o3, o4, o5) where 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\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\x1A\x1B\x1C\x1D\x1E\x1F\xFF\xFF\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\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"# memory-0.14.11/Data/Memory/Encoding/Base64.hs0000644000000000000000000003610313216707150016610 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base64 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Base64 -- {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} module Data.Memory.Encoding.Base64 ( toBase64 , toBase64URL , toBase64OpenBSD , unBase64Length , unBase64LengthUnpadded , fromBase64 , fromBase64URLUnpadded , fromBase64OpenBSD ) 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@ to base64 binary representation in @dst@ -- -- The 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 = toBase64Internal set dst src len True where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# -- | Transform a number of bytes pointed by @src@ to, URL-safe base64 binary -- representation in @dst@. The result will be either padded or unpadded, -- depending on the boolean @padded@ argument. -- -- The destination memory need to be of correct size, otherwise it will lead -- to really bad things. toBase64URL :: Bool -> Ptr Word8 -> Ptr Word8 -> Int -> IO () toBase64URL padded dst src len = toBase64Internal set dst src len padded where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# toBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO () toBase64OpenBSD dst src len = toBase64Internal set dst src len False where !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# toBase64Internal :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> Bool -> IO () toBase64Internal table dst src len padded = loop 0 0 where eqChar = 0x3d :: Word8 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 table a b c pokeByteOff dst di w pokeByteOff dst (di+1) x if i + 1 < len then pokeByteOff dst (di+2) y else when padded (pokeByteOff dst (di+2) eqChar) if i + 2 < len then pokeByteOff dst (di+3) z else when padded (pokeByteOff dst (di+3) eqChar) loop (i+3) (di+4) convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) convert3 table (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 index :: Word# -> Word8 index idx = W8# (indexWord8OffAddr# table (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 < 1 = return Nothing | (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 '=') -- | Get the length needed for the destination buffer for an -- base64 decoding. -- -- If the length of the encoded string is a multiple of 4, plus one, Nothing is -- returned. Any other value can be valid without padding. unBase64LengthUnpadded :: Int -> Maybe Int unBase64LengthUnpadded len = case r of 0 -> Just (3*q) 2 -> Just (3*q + 1) 3 -> Just (3*q + 2) _ -> Nothing where (q, r) = len `divMod` 4 fromBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) fromBase64OpenBSD dst src len = fromBase64Unpadded rsetOpenBSD dst src len fromBase64URLUnpadded :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) fromBase64URLUnpadded dst src len = fromBase64Unpadded rsetURL dst src len fromBase64Unpadded :: (Word8 -> Word8) -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) fromBase64Unpadded rset dst src len = loop 0 0 where loop di i | i == len = return Nothing | i == len - 1 = return Nothing -- Shouldn't happen if len is valid | i == len - 2 = do a <- peekByteOff src i b <- peekByteOff src (i+1) case decode2 a b of Left ofs -> return $ Just (i + ofs) Right x -> do pokeByteOff dst di x return Nothing | i == len - 3 = do a <- peekByteOff src i b <- peekByteOff src (i+1) c <- peekByteOff src (i+2) case decode3 a b c of Left ofs -> return $ Just (i + ofs) Right (x,y) -> do pokeByteOff dst di x pokeByteOff dst (di+1) y 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) decode2 :: Word8 -> Word8 -> Either Int Word8 decode2 a b = case (rset a, rset b) of (0xff, _ ) -> Left 0 (_ , 0xff) -> Left 1 (ra , rb ) -> Right ((ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)) decode3 :: Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8) decode3 a b c = case (rset a, rset b, rset c) of (0xff, _ , _ ) -> Left 0 (_ , 0xff, _ ) -> Left 1 (_ , _ , 0xff) -> Left 2 (ra , rb , rc ) -> let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) in Right (x,y) 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) rsetURL :: Word8 -> Word8 rsetURL (W8# w) | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w)) | otherwise = 0xff where !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\xff\xff\x3e\xff\xff\ \\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\x3f\ \\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"# rsetOpenBSD :: Word8 -> Word8 rsetOpenBSD (W8# w) | booleanPrim (w `leWord#` 0xff##) = W8# (indexWord8OffAddr# rsetTable (word2Int# w)) | otherwise = 0xff where !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\xff\xff\xff\x00\x01\ \\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\xff\xff\xff\xff\xff\xff\ \\xff\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\ \\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\xff\xff\xff\xff\xff\ \\xff\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\ \\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# -- | 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"# memory-0.14.11/Data/Memory/Internal/Compat.hs0000644000000000000000000000372713053117003017032 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.Compat -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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,5,0)) unsafeShiftL :: Bits a => a -> Int -> a unsafeShiftL = shiftL unsafeShiftR :: Bits a => a -> Int -> a unsafeShiftR = shiftR #endif memory-0.14.11/Data/Memory/Internal/CompatPrim.hs0000644000000000000000000000475513053117003017664 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.CompatPrim -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 {-# INLINE booleanPrim #-} -- | 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__ > 704 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 memory-0.14.11/Data/Memory/Internal/CompatPrim64.hs0000644000000000000000000000674413053117003020036 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.CompatPrim -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 #-} #include "MachDeps.h" module Data.Memory.Internal.CompatPrim64 ( Word64# , Int64# , eqInt64# , neInt64# , ltInt64# , leInt64# , gtInt64# , geInt64# , quotInt64# , remInt64# , eqWord64# , neWord64# , ltWord64# , leWord64# , gtWord64# , geWord64# , and64# , or64# , xor64# , not64# , timesWord64# , uncheckedShiftL64# , uncheckedShiftRL64# , int64ToWord64# , word64ToInt64# , intToInt64# , int64ToInt# , wordToWord64# , word64ToWord# , w64# ) where #if WORD_SIZE_IN_BITS == 64 import GHC.Prim hiding (Word64#, Int64#) #if __GLASGOW_HASKELL__ >= 708 type OutBool = Int# #else type OutBool = Bool #endif type Word64# = Word# type Int64# = Int# eqWord64# :: Word64# -> Word64# -> OutBool eqWord64# = eqWord# neWord64# :: Word64# -> Word64# -> OutBool neWord64# = neWord# ltWord64# :: Word64# -> Word64# -> OutBool ltWord64# = ltWord# leWord64# :: Word64# -> Word64# -> OutBool leWord64# = leWord# gtWord64# :: Word64# -> Word64# -> OutBool gtWord64# = gtWord# geWord64# :: Word64# -> Word64# -> OutBool geWord64# = geWord# eqInt64# :: Int64# -> Int64# -> OutBool eqInt64# = (==#) neInt64# :: Int64# -> Int64# -> OutBool neInt64# = (/=#) ltInt64# :: Int64# -> Int64# -> OutBool ltInt64# = (<#) leInt64# :: Int64# -> Int64# -> OutBool leInt64# = (<=#) gtInt64# :: Int64# -> Int64# -> OutBool gtInt64# = (>#) geInt64# :: Int64# -> Int64# -> OutBool geInt64# = (<=#) quotInt64# :: Int64# -> Int64# -> Int64# quotInt64# = quotInt# remInt64# :: Int64# -> Int64# -> Int64# remInt64# = remInt# and64# :: Word64# -> Word64# -> Word64# and64# = and# or64# :: Word64# -> Word64# -> Word64# or64# = or# xor64# :: Word64# -> Word64# -> Word64# xor64# = xor# not64# :: Word64# -> Word64# not64# = not# uncheckedShiftL64# :: Word64# -> Int# -> Word64# uncheckedShiftL64# = uncheckedShiftL# uncheckedShiftRL64# :: Word64# -> Int# -> Word64# uncheckedShiftRL64# = uncheckedShiftL# int64ToWord64# :: Int64# -> Word64# int64ToWord64# = int2Word# word64ToInt64# :: Word64# -> Int64# word64ToInt64# = word2Int# intToInt64# :: Int# -> Int64# intToInt64# w = w int64ToInt# :: Int64# -> Int# int64ToInt# w = w wordToWord64# :: Word# -> Word64# wordToWord64# w = w word64ToWord# :: Word64# -> Word# word64ToWord# w = w timesWord64# :: Word64# -> Word64# -> Word64# timesWord64# = timesWord# w64# :: Word# -> Word# -> Word# -> Word64# w64# w _ _ = w #elif WORD_SIZE_IN_BITS == 32 import GHC.IntWord64 import GHC.Prim (Word#) timesWord64# :: Word64# -> Word64# -> Word64# timesWord64# a b = let !ai = word64ToInt64# a !bi = word64ToInt64# b in int64ToWord64# (timesInt64# ai bi) w64# :: Word# -> Word# -> Word# -> Word64# w64# _ hw lw = let !h = wordToWord64# hw !l = wordToWord64# lw in or64# (uncheckedShiftL64# h 32#) l #else #error "not a supported architecture. supported WORD_SIZE_IN_BITS is 32 bits or 64 bits" #endif memory-0.14.11/Data/Memory/Internal/DeepSeq.hs0000644000000000000000000000133513053117003017126 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.DeepSeq -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 memory-0.14.11/Data/Memory/Internal/Imports.hs0000644000000000000000000000100313053117003017225 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.Imports -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 memory-0.14.11/Data/Memory/Internal/Scrubber.hs0000644000000000000000000000550313053117003017350 0ustar0000000000000000-- | -- Module : Data.Memory.Internal.Scrubber -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Compat -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} #include "MachDeps.h" module Data.Memory.Internal.Scrubber ( getScrubber ) where import GHC.Prim import Data.Memory.Internal.CompatPrim (booleanPrim) getScrubber :: Int# -> (Addr# -> State# RealWorld -> State# RealWorld) getScrubber sz | booleanPrim (sz ==# 4#) = scrub4 | booleanPrim (sz ==# 8#) = scrub8 | booleanPrim (sz ==# 16#) = scrub16 | booleanPrim (sz ==# 32#) = scrub32 | otherwise = scrubBytes sz where scrub4 a = \s -> writeWord32OffAddr# a 0# 0## s {-# INLINE scrub4 #-} #if WORD_SIZE_IN_BITS == 64 scrub8 a = \s -> writeWord64OffAddr# a 0# 0## s {-# INLINE scrub8 #-} scrub16 a = \s1 -> let !s2 = writeWord64OffAddr# a 0# 0## s1 !s3 = writeWord64OffAddr# a 1# 0## s2 in s3 {-# INLINE scrub16 #-} scrub32 a = \s1 -> let !s2 = writeWord64OffAddr# a 0# 0## s1 !s3 = writeWord64OffAddr# a 1# 0## s2 !s4 = writeWord64OffAddr# a 2# 0## s3 !s5 = writeWord64OffAddr# a 3# 0## s4 in s5 {-# INLINE scrub32 #-} #else scrub8 a = \s1 -> let !s2 = writeWord32OffAddr# a 0# 0## s1 !s3 = writeWord32OffAddr# a 1# 0## s2 in s3 {-# INLINE scrub8 #-} scrub16 a = \s1 -> let !s2 = writeWord32OffAddr# a 0# 0## s1 !s3 = writeWord32OffAddr# a 1# 0## s2 !s4 = writeWord32OffAddr# a 2# 0## s3 !s5 = writeWord32OffAddr# a 3# 0## s4 in s5 {-# INLINE scrub16 #-} scrub32 a = \s1 -> let !s2 = writeWord32OffAddr# a 0# 0## s1 !s3 = writeWord32OffAddr# a 1# 0## s2 !s4 = writeWord32OffAddr# a 2# 0## s3 !s5 = writeWord32OffAddr# a 3# 0## s4 !s6 = writeWord32OffAddr# a 4# 0## s5 !s7 = writeWord32OffAddr# a 5# 0## s6 !s8 = writeWord32OffAddr# a 6# 0## s7 !s9 = writeWord32OffAddr# a 7# 0## s8 in s9 {-# INLINE scrub32 #-} #endif scrubBytes :: Int# -> Addr# -> State# RealWorld -> State# RealWorld scrubBytes sz8 addr = \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' {-# INLINE loop #-} {-# INLINE scrubBytes #-} memory-0.14.11/Data/Memory/Hash/SipHash.hs0000644000000000000000000001670713053117003016257 0ustar0000000000000000-- | -- Module : Data.Memory.Hash.SipHash -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- provide the SipHash algorithm. -- reference: -- {-# 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,Ord) 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) memory-0.14.11/Data/Memory/Hash/FNV.hs0000644000000000000000000000766413053117003015353 0ustar0000000000000000-- | -- Module : Data.Memory.Hash.FNV -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) -- -- {-# 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.CompatPrim64 import Data.Memory.Internal.Imports import GHC.Word import GHC.Prim hiding (Word64#, Int64#) import GHC.Types import GHC.Ptr -- | FNV1(a) hash (32 bit variants) newtype FnvHash32 = FnvHash32 Word32 deriving (Show,Eq,Ord,NFData) -- | FNV1(a) hash (64 bit variants) newtype FnvHash64 = FnvHash64 Word64 deriving (Show,Eq,Ord,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 fnv64Const 0# s where loop :: Word64# -> 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 = (fnv64Prime `timesWord64#` acc) `xor64#` (wordToWord64# v) in loop nacc (i +# 1#) s2 fnv64Const :: Word64# !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325## fnv64Prime :: Word64# !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3## -- | 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 fnv64Const 0# s where loop :: Word64# -> 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 = fnv64Prime `timesWord64#` (acc `xor64#` wordToWord64# v) in loop nacc (i +# 1#) s2 fnv64Const :: Word64# !fnv64Const = w64# 0xcbf29ce484222325## 0xcbf29ce4## 0x84222325## fnv64Prime :: Word64# !fnv64Prime = w64# 0x100000001b3## 0x100## 0x000001b3## memory-0.14.11/Data/ByteArray/Pack/Internal.hs0000644000000000000000000000533013053117003017107 0ustar0000000000000000-- | -- Module : Data.ByteArray.Pack.Internal -- License : BSD-Style -- Copyright : Copyright © 2014 Nicolas DI PRIMA -- -- Maintainer : Vincent Hanquez -- 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 #-} memory-0.14.11/Data/ByteArray/Types.hs0000644000000000000000000001313413211773722015576 0ustar0000000000000000-- | -- Module : Data.ByteArray.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Data.ByteArray.Types ( ByteArrayAccess(..) , ByteArray(..) ) where import Foreign.Ptr import Data.Monoid #ifdef WITH_BYTESTRING_SUPPORT import qualified Data.ByteString as Bytestring (length) import qualified Data.ByteString.Internal as Bytestring import Foreign.ForeignPtr (withForeignPtr) #endif #ifdef WITH_FOUNDATION_SUPPORT #if MIN_VERSION_foundation(0,0,14) && MIN_VERSION_basement(0,0,0) # define NO_LEGACY_FOUNDATION_SUPPORT #else # define LEGACY_FOUNDATION_SUPPORT #endif import Data.Proxy (Proxy(..)) import Data.Word (Word8) import qualified Basement.Types.OffsetSize as Base import qualified Basement.UArray as Base import qualified Basement.String as Base (String, toBytes, Encoding(UTF8)) import qualified Basement.PrimType as Base (primSizeInBytes) #ifdef LEGACY_FOUNDATION_SUPPORT import qualified Foundation as F import qualified Foundation.Collection as F import qualified Foundation.String as F (toBytes, Encoding(UTF8)) import qualified Foundation.Array.Internal as F import qualified Foundation.Primitive as F (primSizeInBytes) #endif #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 -- | allocate `n` bytes and perform the given operation allocRet :: Int -- ^ number of bytes to allocate. i.e. might not match the -- size of the given type `ba`. -> (Ptr p -> IO a) -> IO (a, ba) #ifdef WITH_BYTESTRING_SUPPORT instance ByteArrayAccess Bytestring.ByteString where length = Bytestring.length withByteArray (Bytestring.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off) instance ByteArray Bytestring.ByteString where allocRet sz f = do fptr <- Bytestring.mallocByteString sz r <- withForeignPtr fptr (f . castPtr) return (r, Bytestring.PS fptr 0 sz) #endif #ifdef WITH_FOUNDATION_SUPPORT baseUarrayRecastW8 :: Base.PrimType ty => Base.UArray ty -> Base.UArray Word8 baseUarrayRecastW8 = Base.recast instance Base.PrimType ty => ByteArrayAccess (Base.UArray ty) where length a = let Base.CountOf i = Base.length (baseUarrayRecastW8 a) in i withByteArray a f = Base.withPtr (baseUarrayRecastW8 a) (f . castPtr) instance ByteArrayAccess Base.String where length str = let Base.CountOf i = Base.length bytes in i where -- the Foundation's length return a number of elements not a number of -- bytes. For @ByteArrayAccess@, because we are using an @Int@, we -- didn't see that we were returning the wrong @CountOf@. bytes = Base.toBytes Base.UTF8 str withByteArray s f = withByteArray (Base.toBytes Base.UTF8 s) f instance (Ord ty, Base.PrimType ty) => ByteArray (Base.UArray ty) where allocRet sz f = do mba <- Base.new $ sizeRecastBytes sz Proxy a <- Base.withMutablePtr mba (f . castPtr) ba <- Base.unsafeFreeze mba return (a, ba) where sizeRecastBytes :: Base.PrimType ty => Int -> Proxy ty -> Base.CountOf ty sizeRecastBytes w p = Base.CountOf $ let (q,r) = w `Prelude.quotRem` szTy in q + (if r == 0 then 0 else 1) where !(Base.CountOf szTy) = Base.primSizeInBytes p {-# INLINE [1] sizeRecastBytes #-} #ifdef LEGACY_FOUNDATION_SUPPORT uarrayRecastW8 :: F.PrimType ty => F.UArray ty -> F.UArray Word8 uarrayRecastW8 = F.recast instance F.PrimType ty => ByteArrayAccess (F.UArray ty) where #if MIN_VERSION_foundation(0,0,10) length a = let F.CountOf i = F.length (uarrayRecastW8 a) in i #else length = F.length . uarrayRecastW8 #endif withByteArray a f = F.withPtr (uarrayRecastW8 a) (f . castPtr) instance ByteArrayAccess F.String where #if MIN_VERSION_foundation(0,0,10) length str = let F.CountOf i = F.length bytes in i #else length str = F.length bytes #endif where -- the Foundation's length return a number of elements not a number of -- bytes. For @ByteArrayAccess@, because we are using an @Int@, we -- didn't see that we were returning the wrong @CountOf@. bytes = F.toBytes F.UTF8 str withByteArray s f = withByteArray (F.toBytes F.UTF8 s) f instance (Ord ty, F.PrimType ty) => ByteArray (F.UArray ty) where allocRet sz f = do mba <- F.new $ sizeRecastBytes sz Proxy a <- F.withMutablePtr mba (f . castPtr) ba <- F.unsafeFreeze mba return (a, ba) where #if MIN_VERSION_foundation(0,0,10) sizeRecastBytes :: F.PrimType ty => Int -> Proxy ty -> F.CountOf ty sizeRecastBytes w p = F.CountOf $ let (q,r) = w `Prelude.quotRem` szTy in q + (if r == 0 then 0 else 1) where !(F.CountOf szTy) = F.primSizeInBytes p {-# INLINE [1] sizeRecastBytes #-} #else sizeRecastBytes :: F.PrimType ty => Int -> Proxy ty -> F.Size ty sizeRecastBytes w p = F.Size $ let (q,r) = w `Prelude.quotRem` szTy in q + (if r == 0 then 0 else 1) where !(F.Size szTy) = F.primSizeInBytes p {-# INLINE [1] sizeRecastBytes #-} #endif #endif #endif memory-0.14.11/Data/ByteArray/Bytes.hs0000644000000000000000000001377213210020370015547 0ustar0000000000000000-- | -- Module : Data.ByteArray.Bytes -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- -- Simple and efficient byte array types -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module Data.ByteArray.Bytes ( Bytes ) where import GHC.Types import GHC.Prim import GHC.Ptr #if MIN_VERSION_base(4,9,0) import Data.Semigroup import Data.Foldable (toList) #else import Data.Monoid #endif 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 #if MIN_VERSION_base(4,9,0) instance Semigroup Bytes where b1 <> b2 = unsafeDoIO $ bytesAppend b1 b2 sconcat = unsafeDoIO . bytesConcat . toList #endif instance Monoid Bytes where mempty = unsafeDoIO (newBytes 0) #if !(MIN_VERSION_base(4,11,0)) mappend b1 b2 = unsafeDoIO $ bytesAppend b1 b2 mconcat = unsafeDoIO . bytesConcat #endif 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', () #) {-# INLINE touchBytes #-} sizeofBytes :: Bytes -> Int sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba) {-# INLINE sizeofBytes #-} 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 {-# LANGUAGE bytesLength #-} 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 #) {-# INLINE loop #-} 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 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 i return (c : acc) | otherwise = do c <- rChar i 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 #-} -} memory-0.14.11/Data/ByteArray/ScrubbedBytes.hs0000644000000000000000000001461713210020370017220 0ustar0000000000000000-- | -- Module : Data.ByteArray.ScrubbedBytes -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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 #if MIN_VERSION_base(4,9,0) import Data.Semigroup import Data.Foldable (toList) #else import Data.Monoid #endif import Data.String (IsString(..)) import Data.Memory.PtrMethods (memCopy, memConstEqual) import Data.Memory.Internal.CompatPrim import Data.Memory.Internal.Compat (unsafeDoIO) import Data.Memory.Internal.Imports import Data.Memory.Internal.Scrubber (getScrubber) import Data.ByteArray.Types import Foreign.Storable -- | 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 _ = "" instance Eq ScrubbedBytes where (==) = scrubbedBytesEq instance Ord ScrubbedBytes where compare = scrubbedBytesCompare #if MIN_VERSION_base(4,9,0) instance Semigroup ScrubbedBytes where b1 <> b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 sconcat = unsafeDoIO . scrubbedBytesConcat . toList #endif instance Monoid ScrubbedBytes where mempty = unsafeDoIO (newScrubbedBytes 0) #if !(MIN_VERSION_base(4,11,0)) mappend b1 b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 mconcat = unsafeDoIO . scrubbedBytesConcat #endif instance NFData ScrubbedBytes where rnf b = b `seq` () instance IsString ScrubbedBytes where fromString = scrubbedFromChar8 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 sz) (byteArrayContents# (unsafeCoerce# mbarr)) !mba = ScrubbedBytes mbarr in case mkWeak# mbarr () (finalize scrubber mba) s1 of (# s2, _ #) -> (# s2, mba #) where #if __GLASGOW_HASKELL__ >= 800 finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> (# State# RealWorld, () #) finalize scrubber mba@(ScrubbedBytes _) = \s1 -> case scrubber s1 of s2 -> case touch# mba s2 of s3 -> (# s3, () #) #else finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> IO () finalize scrubber mba@(ScrubbedBytes _) = IO $ \s1 -> do case scrubber s1 of s2 -> case touch# mba s2 of s3 -> (# s3, () #) #endif 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 #) scrubbedFromChar8 :: [Char] -> ScrubbedBytes scrubbedFromChar8 l = unsafeDoIO $ scrubbedBytesAlloc len (fill l) where len = Prelude.length l fill :: [Char] -> Ptr Word8 -> IO () fill [] _ = return () fill (x:xs) !p = poke p (fromIntegral $ fromEnum x) >> fill xs (p `plusPtr` 1) memory-0.14.11/Data/ByteArray/Methods.hs0000644000000000000000000002223313077624430016076 0ustar0000000000000000-- | -- Module : Data.ByteArray.Methods -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- {-# LANGUAGE BangPatterns #-} module Data.ByteArray.Methods ( alloc , allocAndFreeze , create , unsafeCreate , pack , unpack , uncons , empty , singleton , cons , snoc , null , replicate , zero , copy , take , drop , span , convert , copyRet , copyAndFreeze , splitAt , xor , index , eq , constEq , any , all , 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, last, any, all) 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 | n < 0 = alloc 0 f | otherwise = snd `fmap` allocRet n f {-# INLINE alloc #-} -- | 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 #-} inlineUnsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a inlineUnsafeCreate !sz f = unsafeDoIO (alloc sz f) {-# INLINE inlineUnsafeCreate #-} -- | Create an empty byte array empty :: ByteArray a => a empty = unsafeDoIO (alloc 0 $ \_ -> return ()) -- | Check if a byte array is empty null :: ByteArrayAccess a => a -> Bool null b = length b == 0 -- | Pack a list of bytes into a bytearray pack :: ByteArray a => [Word8] -> a pack l = inlineUnsafeCreate (Prelude.length l) (fill l) where fill [] _ = return () fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1) {-# INLINE fill #-} {-# NOINLINE pack #-} -- | 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 byte array from a single byte singleton :: ByteArray a => Word8 -> a singleton b = unsafeCreate 1 (\p -> pokeByteOff p 0 b) -- | prepend a single byte to a byte array cons :: ByteArray a => Word8 -> a -> a cons b ba = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do pokeByteOff d 0 b memCopy (d `plusPtr` 1) s len where len = length ba -- | append a single byte to a byte array snoc :: ByteArray a => a -> Word8 -> a snoc ba b = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do memCopy d s len pokeByteOff d len b where len = length ba -- | 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 | i >= len = len | pred (index bs i) = loop (i+1) | otherwise = i len = length bs -- | Concatenate bytearray into a larger bytearray concat :: (ByteArrayAccess bin, ByteArray bout) => [bin] -> bout concat l = unsafeCreate retLen (loopCopy l) where retLen = sum $ map length l loopCopy [] _ = return () loopCopy (x:xs) dst = do withByteArray x $ \src -> memCopy dst src chunkLen loopCopy xs (dst `plusPtr` chunkLen) where !chunkLen = length x -- | 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 = inlineUnsafeCreate (length bs) $ \d -> do withByteArray bs $ \s -> memCopy d s (length bs) f (castPtr d) {-# NOINLINE copyAndFreeze #-} -- | Create a bytearray of a specific size containing a repeated byte value replicate :: ByteArray ba => Int -> Word8 -> ba replicate 0 _ = empty replicate n b | n < 0 = empty | otherwise = inlineUnsafeCreate 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 | n < 0 = empty | otherwise = 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 -- | Check if any element of a byte array satisfies a predicate any :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool any f b | null b = False | otherwise = unsafeDoIO $ withByteArray b $ \p -> loop p 0 where len = length b loop p i | i == len = return False | otherwise = do w <- peekByteOff p i if f w then return True else loop p (i+1) -- | Check if all elements of a byte array satisfy a predicate all :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool all f b = not (any (not . f) b) -- | Convert a bytearray to another type of bytearray convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout convert = flip copyAndFreeze (\_ -> return ()) memory-0.14.11/Data/ByteArray/MemView.hs0000644000000000000000000000215513053117003016030 0ustar0000000000000000-- | -- Module : Data.ByteArray.MemView -- License : BSD-style -- Maintainer : Vincent Hanquez -- 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) memory-0.14.11/Data/ByteArray/View.hs0000644000000000000000000000710113053117003015365 0ustar0000000000000000-- | -- Module : Data.ByteArray.View -- License : BSD-style -- Maintainer : Nicolas DI PRIMA -- Stability : stable -- Portability : Good -- -- a View on a given ByteArrayAccess -- module Data.ByteArray.View ( View , view , takeView , dropView ) where import Data.ByteArray.Methods import Data.ByteArray.Types import Data.Memory.PtrMethods import Data.Memory.Internal.Compat import Foreign.Ptr (plusPtr) import Prelude hiding (length, take, drop) -- | a view on a given bytes -- -- Equality test in constant time data View bytes = View { viewOffset :: !Int , viewSize :: !Int , unView :: !bytes } instance ByteArrayAccess bytes => Eq (View bytes) where (==) = constEq instance ByteArrayAccess bytes => Ord (View bytes) where compare v1 v2 = unsafeDoIO $ withByteArray v1 $ \ptr1 -> withByteArray v2 $ \ptr2 -> do ret <- memCompare ptr1 ptr2 (min (viewSize v1) (viewSize v2)) return $ case ret of EQ | length v1 > length v2 -> GT | length v1 < length v2 -> LT | length v1 == length v2 -> EQ _ -> ret instance ByteArrayAccess bytes => Show (View bytes) where showsPrec p v r = showsPrec p (viewUnpackChars v []) r instance ByteArrayAccess bytes => ByteArrayAccess (View bytes) where length = viewSize withByteArray v f = withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v)) viewUnpackChars :: ByteArrayAccess bytes => View bytes -> String -> String viewUnpackChars v xs = chunkLoop 0 where len = length v chunkLoop :: Int -> [Char] chunkLoop idx | len == idx = [] | (len - idx) > 63 = bytesLoop idx (idx + 64) (chunkLoop (idx + 64)) | otherwise = bytesLoop idx (len - idx) xs bytesLoop :: Int -> Int -> [Char] -> [Char] bytesLoop idx chunkLenM1 paramAcc = loop (idx + chunkLenM1 - 1) paramAcc where loop i acc | i == idx = (rChar i : acc) | otherwise = loop (i - 1) (rChar i : acc) rChar :: Int -> Char rChar idx = toEnum $ fromIntegral $ index v idx -- | create a view on a given bytearray -- -- This function update the offset and the size in order to guarantee: -- -- * offset >= 0 -- * size >= 0 -- * offset < length -- * size =< length - offset -- view :: ByteArrayAccess bytes => bytes -- ^ the byte array we put a view on -> Int -- ^ the offset to start the byte array on -> Int -- ^ the size of the view -> View bytes view b offset'' size'' = View offset size b where -- make sure offset is not negative offset' :: Int offset' = max offset'' 0 -- make sure the offset is not out of bound offset :: Int offset = min offset' (length b - 1) -- make sure length is not negative size' :: Int size' = max size'' 0 -- make sure the length is not out of the bound size :: Int size = min size' (length b - offset) -- | create a view from the given bytearray takeView :: ByteArrayAccess bytes => bytes -- ^ byte aray -> Int -- ^ size of the view -> View bytes takeView b size = view b 0 size -- | create a view from the given byte array -- starting after having dropped the fist n bytes dropView :: ByteArrayAccess bytes => bytes -- ^ byte array -> Int -- ^ the number of bytes do dropped before creating the view -> View bytes dropView b offset = view b offset (length b - offset) memory-0.14.11/Data/Memory/MemMap/Windows.hs0000644000000000000000000000056013053117003016631 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 memory-0.14.11/Data/Memory/MemMap/Posix.hsc0000644000000000000000000001655613053117003016460 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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 #include {-# 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 #if defined(POSIX_MADV_NORMAL) foreign import ccall unsafe "posix_madvise" c_madvise :: Ptr a -> CSize -> CInt -> IO CInt #else foreign import ccall unsafe "madvise" c_madvise :: Ptr a -> CSize -> CInt -> IO CInt #endif 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 #ifndef __HAIKU__ foreign import ccall unsafe "mlock" c_mlock :: Ptr a -> CSize -> IO CInt #else c_mlock :: Ptr a -> CSize -> IO CInt c_mlock _ _ = return (-1) #endif #ifndef __HAIKU__ foreign import ccall unsafe "munlock" c_munlock :: Ptr a -> CSize -> IO CInt #else c_munlock :: Ptr a -> CSize -> IO CInt c_munlock _ _ = return (-1) #endif 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 #if defined(POSIX_MADV_NORMAL) toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL) toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM) toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL) toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED) toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED) #else 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) #endif -- | 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) memory-0.14.11/tests/Tests.hs0000644000000000000000000002311113116610065014151 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} module Main where import Imports import Utils import Data.Char (chr) 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 #ifdef WITH_FOUNDATION_SUPPORT import qualified Foundation as F #endif 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) ] testShowProperty :: Testable a => String -> (forall ba . (Show ba, Eq ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a) -> TestTree testShowProperty x p = testGroup x [ testProperty "Bytes" (p withBytesWitness showLikeString) , testProperty "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB) ] where showLikeString l = show $ map (chr . fromIntegral) l showLikeEmptySB _ = show (withScrubbedBytesWitness B.empty) base64Kats = [ ("pleasure.", "cGxlYXN1cmUu") , ("leasure.", "bGVhc3VyZS4=") , ("easure.", "ZWFzdXJlLg==") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4=") ] base64URLKats = [ ("pleasure.", "cGxlYXN1cmUu") , ("leasure.", "bGVhc3VyZS4") , ("easure.", "ZWFzdXJlLg") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4") , ("\DC4\251\156\ETX\217~", "FPucA9l-") -- From RFC4648 , ("\DC4\251\156\ETX\217\DEL", "FPucA9l_") , ("", "") ] base16Kats = [ ("this is a string", "74686973206973206120737472696e67") ] base32Kats = [ ("-pleasure.", "FVYGYZLBON2XEZJO") , ("pleasure.", "OBWGKYLTOVZGKLQ=") , ("leasure.", "NRSWC43VOJSS4===") , ("easure.", "MVQXG5LSMUXA====") , ("asure.", "MFZXK4TFFY======") , ("sure.", "ON2XEZJO") , ("ure.", "OVZGKLQ=") , ("re.", "OJSS4===") , ("e.", "MUXA====") , (".", "FY======") , ("", "") ] encodingTests witnessID = [ testGroup "BASE64" [ testGroup "encode-KAT" encodeKats64 , testGroup "decode-KAT" decodeKats64 ] , testGroup "BASE64URL" [ testGroup "encode-KAT" encodeKats64URLUnpadded , testGroup "decode-KAT" decodeKats64URLUnpadded ] , testGroup "BASE32" [ testGroup "encode-KAT" encodeKats32 , testGroup "decode-KAT" decodeKats32 ] , 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 encodeKats32 = map (toTest B.Base32) $ zip [1..] base32Kats decodeKats32 = map (toBackTest B.Base32) $ zip [1..] base32Kats encodeKats16 = map (toTest B.Base16) $ zip [1..] base16Kats decodeKats16 = map (toBackTest B.Base16) $ zip [1..] base16Kats encodeKats64URLUnpadded = map (toTest B.Base64URLUnpadded) $ zip [1..] base64URLKats decodeKats64URLUnpadded = map (toBackTest B.Base64URLUnpadded) $ zip [1..] base64URLKats 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 5000) $ testGroupBackends "basic" basicProperties , testGroupBackends "encoding" encodingTests , testGroupBackends "parsing" parsingTests , testGroupBackends "hashing" $ \witnessID -> [ testGroup "SipHash" $ SipHash.tests witnessID ] , testShowProperty "showing" $ \witnessID expectedShow (Words8 l) -> (show . witnessID . B.pack $ l) == expectedShow l #ifdef WITH_FOUNDATION_SUPPORT , testFoundationTypes #endif ] 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 "add-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 == witnessID (B.concat chunks) , testProperty "cons b bs == reverse (snoc (reverse bs) b)" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) b2 = witnessID (B.pack (reverse l)) expected = B.pack (reverse (B.unpack (B.snoc b2 b))) in B.cons b b1 == expected , testProperty "all == Prelude.all" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (/= b) in B.all p b1 == all p l , testProperty "any == Prelude.any" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (== b) in B.any p b1 == any p l , testProperty "singleton b == pack [b]" $ \b -> witnessID (B.singleton b) == B.pack [b] , testProperty "span" $ \x (Words8 l) -> let c = witnessID (B.pack l) (a, b) = B.span (== x) c in c == B.append a b , testProperty "span (const True)" $ \(Words8 l) -> let a = witnessID (B.pack l) in B.span (const True) a == (a, B.empty) , testProperty "span (const False)" $ \(Words8 l) -> let b = witnessID (B.pack l) in B.span (const False) b == (B.empty, b) ] #ifdef WITH_FOUNDATION_SUPPORT testFoundationTypes = testGroup "Foundation" [ testCase "allocRet 4 _ :: F.UArray Int8 === 4" $ do x <- (B.length :: F.UArray F.Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ()) assertEqual "" 4 x , testCase "allocRet 4 _ :: F.UArray Int16 === 4" $ do x <- (B.length :: F.UArray F.Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ()) assertEqual "" 4 x , testCase "allocRet 4 _ :: F.UArray Int32 === 4" $ do x <- (B.length :: F.UArray F.Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ()) assertEqual "" 4 x , testCase "allocRet 4 _ :: F.UArray Int64 === 8" $ do x <- (B.length :: F.UArray F.Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ()) assertEqual "" 8 x ] #endif memory-0.14.11/tests/Imports.hs0000644000000000000000000000040713053117003014501 0ustar0000000000000000module Imports ( module X ) where import Control.Applicative as X import Control.Monad as X import Data.Foldable as X (foldl') import Data.Monoid as X import Test.Tasty as X import Test.Tasty.HUnit as X import Test.Tasty.QuickCheck as X hiding (vector) memory-0.14.11/tests/SipHash.hs0000644000000000000000000003141013053117003014401 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module SipHash (tests) where import Imports import Utils import qualified Data.ByteArray as B import Data.ByteArray.Hash (SipKey(..), SipHash(..), sipHash) katKey = SipKey 0x0706050403020100 0x0f0e0d0c0b0a0908 vectors = [ ( katKey , "" , SipHash 0x726fdb47dd0e0e31 ) , ( katKey , "\x00" , SipHash 0x74f839c593dc67fd ) , ( katKey , "\x00\x01" , SipHash 0x0d6c8009d9a94f5a ) , ( katKey , "\x00\x01\x02" , SipHash 0x85676696d7fb7e2d ) , ( katKey , "\x00\x01\x02\x03" , SipHash 0xcf2794e0277187b7 ) , ( katKey , "\x00\x01\x02\x03\x04" , SipHash 0x18765564cd99a68d ) , ( katKey , "\x00\x01\x02\x03\x04\x05" , SipHash 0xcbc9466e58fee3ce ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06" , SipHash 0xab0200f58b01d137 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07" , SipHash 0x93f5f5799a932462 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08" , SipHash 0x9e0082df0ba9e4b0 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09" , SipHash 0x7a5dbbc594ddb9f3 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a" , SipHash 0xf4b32f46226bada7 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b" , SipHash 0x751e8fbc860ee5fb ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c" , SipHash 0x14ea5627c0843d90 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d" , SipHash 0xf723ca908e7af2ee ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e" , SipHash 0xa129ca6149be45e5 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f" , SipHash 0x3f2acc7f57c29bdb ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10" , SipHash 0x699ae9f52cbe4794 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11" , SipHash 0x4bc1b3f0968dd39c ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12" , SipHash 0xbb6dc91da77961bd ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13" , SipHash 0xbed65cf21aa2ee98 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14" , SipHash 0xd0f2cbb02e3b67c7 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14\x15" , SipHash 0x93536795e3a33e88 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14\x15\x16" , SipHash 0xa80c038ccd5ccec8 ) , ( katKey , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14\x15\x16\x17" , SipHash 0xb8ad50c6f649af94 ) , ( katKey , "\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" , SipHash 0xbce192de8a85b8ea ) , ( katKey , "\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" , SipHash 0x17d835b85bbb15f3 ) , ( katKey , "\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\x1a" , SipHash 0x2f2e6163076bcfad ) , ( katKey , "\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\x1a\x1b" , SipHash 0xde4daaaca71dc9a5 ) , ( katKey , "\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\x1a\x1b\x1c" , SipHash 0xa6a2506687956571 ) , ( katKey , "\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\x1a\x1b\x1c\x1d" , SipHash 0xad87a3535c49ef28 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e" , SipHash 0x32d892fad841c342 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f" , SipHash 0x7127512f72f27cce ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20" , SipHash 0xa7f32346f95978e3 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21" , SipHash 0x12e0b01abb051238 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22" , SipHash 0x15e034d40fa197ae ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23" , SipHash 0x314dffbe0815a3b4 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24" , SipHash 0x027990f029623981 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25" , SipHash 0xcadcd4e59ef40c4d ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26" , SipHash 0x9abfd8766a33735c ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27" , SipHash 0x0e3ea96b5304a7d0 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28" , SipHash 0xad0c42d6fc585992 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29" , SipHash 0x187306c89bc215a9 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a" , SipHash 0xd4a60abcf3792b95 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b" , SipHash 0xf935451de4f21df2 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c" , SipHash 0xa9538f0419755787 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d" , SipHash 0xdb9acddff56ca510 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e" , SipHash 0xd06c98cd5c0975eb ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f" , SipHash 0xe612a3cb9ecba951 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30" , SipHash 0xc766e62cfcadaf96 ) , ( katKey , "\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\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31" , SipHash 0xee64435a9752fe72 ) , ( katKey , "\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\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" , SipHash 0xa192d576b245165a ) , ( katKey , "\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\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" , SipHash 0x0a8787bf8ecb74b2 ) , ( katKey , "\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\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\x34" , SipHash 0x81b3e73d20b49b6f ) , ( katKey , "\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\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\x34\x35" , SipHash 0x7fa8220ba3b2ecea ) , ( katKey , "\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\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\x34\x35\x36" , SipHash 0x245731c13ca42499 ) , ( katKey , "\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\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\x34\x35\x36\x37" , SipHash 0xb78dbfaf3a8d83bd ) , ( katKey , "\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\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\x34\x35\x36\x37\x38" , SipHash 0xea1ad565322a1a0b ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39" , SipHash 0x60e61c23a3795013 ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39\x3a" , SipHash 0x6606d7e446282b93 ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39\x3a\x3b" , SipHash 0x6ca4ecb15c5f91e1 ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c" , SipHash 0x9f626da15c9625f3 ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d" , SipHash 0xe51b38608ef25f57 ) , ( katKey , "\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\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\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e" , SipHash 0x958a324ceb064572 ) ] katTests witnessID v = map makeTest $ numberedList v where makeTest (i, (key,msg,tag)) = testCase ("kat " ++ show i) $ tag @=? sipHash key (witnessID $ B.pack $ unS msg) tests witnessID = [ testGroup "KAT" $ katTests witnessID vectors ] memory-0.14.11/tests/Utils.hs0000644000000000000000000000111613053117003014142 0ustar0000000000000000module Utils where import Data.Word import Data.ByteArray (Bytes, ScrubbedBytes) unS :: String -> [Word8] unS = map (fromIntegral . fromEnum) ascii :: [Word8] -> String ascii = map (toEnum . fromIntegral) -- | similar to proxy data Witness a = Witness withWitness :: Witness a -> a -> a withWitness _ a = a withBytesWitness :: Bytes -> Bytes withBytesWitness = withWitness (Witness :: Witness Bytes) withScrubbedBytesWitness :: ScrubbedBytes -> ScrubbedBytes withScrubbedBytesWitness = id numberedList :: [a] -> [(Int, a)] numberedList = zip [1..] memory-0.14.11/README.md0000644000000000000000000000301013053117003012616 0ustar0000000000000000memory ====== [![Build Status](https://travis-ci.org/vincenthz/hs-memory.png?branch=master)](https://travis-ci.org/vincenthz/hs-memory) [![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) [![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](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, Base32, [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 memory-0.14.11/CHANGELOG.md0000644000000000000000000000537013216744172013201 0ustar0000000000000000## 0.14.11 * Fix issue in unBase64 with an empty bytestring that would cause a segfault ## 0.14.10 * Reintroduce foundation compatibility with old version ## 0.14.9 * Reduce dependency to basement ## 0.14.8 * Fix incompatibility with foundation 0.0.14 ## 0.14.7 * Fix typo in state passing ## 0.14.6 * Fix allocRet using unit of bytes but using as unit of ty directly without adaptation ## 0.14.5 * Fix bug in memXorWith not working as advertised if source different from destination ## 0.14.4 * Add support for foundation uarray creation * optimise memXorWith ## 0.14.3 * Add support for foundation uarray peeking ## 0.14.2 * Fix use of ghc 8.2 touch * Prevent span from reading past buffer * cleanup .prof spam ## 0.14.1 * Fix `Show` instance of Bytes (Oliver Chéron) ## 0.14 * Improve fromW64BE * Add IsString instance for ScrubbedBytes ## 0.13 * Add combinator to check for end of parsing. ## 0.12 * Fix compilation with mkWeak and latest GHC (Lars Kuhtz) ## 0.11 * add support for GHC 8.0.1 ## 0.10 * make memConstEqual more constant not using boolean comparaison ## 0.9 * memConstEqual was comparing length times the first byte instead of comparing all the bytes one to one ## 0.8 * Add Base64 variants (Luke Taylor) * Fix compilation on Haiku (Jessica Hamilton) ## 0.7 * Fix fixed sized scrubber written too hastily, that would zero out memory, as the index was written through byte size, whereas the primitive would consider it as WordX type index. it would helps if Ghc.Prim had better documentation. ## 0.6 * Fix compilation on architecture where endianness is not a compile time define related to their cabal arch(). ## 0.5 * Add Base32 support (Nicolas Di Prima) * Fix build on 32 bit by simplifying scrubber, and adding Word64 type + operations compatibility ## 0.4 * Add Ord instances for SipHash and FnvHash (Nicolas Di Prima) * Fix GHC-7.2 build by defining unsafeShiftL (Adam Bergmark) * Fix show instance of Bytes to properly display each bytes instead of just the end one * Add View type that emulate a view on a ByteArray type (Nicolas Di Prima) ## 0.3 * fix missing modules from tests on sdist ## 0.2 * make concat more generic as to what the output is going to be, and at the same time reduce the constraint on the input to just Access * make all byte array operation safer related to negative size. now replicate, zero, and alloc will returns an empty byte array when asking for negative size * replace 'pack' in Data.ByteArray.Pack by 'fill', as to not conflict with 'Data.ByteArray.pack'. Also swap the length and monadic action to be more naturally used * add a deprecated 'pack' that alias to 'fill' for now * loosen constraint of Data.ByteArray.Pack.putBytes from ByteArray to ByteArrayAccess ## 0.1 * Initial release memory-0.14.11/LICENSE0000644000000000000000000000272313053117003012356 0ustar0000000000000000Copyright (c) 2015 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. 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. memory-0.14.11/Setup.hs0000644000000000000000000000005613053117003013002 0ustar0000000000000000import Distribution.Simple main = defaultMain memory-0.14.11/memory.cabal0000644000000000000000000001037613216744146013667 0ustar0000000000000000Name: memory version: 0.14.11 Synopsis: memory and related abstraction 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. . * Encoding : Base16, Base32, Base64. . * Hashing : FNV, SipHash License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: vincent@snarc.org, Nicolas Di Prima 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.18 extra-doc-files: README.md CHANGELOG.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_foundation Description: add support for foundation strings and unboxed array 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.Base32 Data.Memory.Encoding.Base64 Other-modules: Data.Memory.Internal.Compat Data.Memory.Internal.CompatPrim Data.Memory.Internal.CompatPrim64 Data.Memory.Internal.DeepSeq Data.Memory.Internal.Imports Data.Memory.Internal.Scrubber 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 Data.ByteArray.View 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 >= 1.1 if flag(support_foundation) CPP-options: -DWITH_FOUNDATION_SUPPORT Build-depends: basement, foundation >= 0.0.8 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 Other-modules: Imports SipHash Utils 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 if flag(support_foundation) CPP-options: -DWITH_FOUNDATION_SUPPORT Build-depends: foundation >= 0.0.8