memory-0.18.0/Data/0000755000000000000000000000000013533102570012146 5ustar0000000000000000memory-0.18.0/Data/ByteArray/0000755000000000000000000000000014305252711014051 5ustar0000000000000000memory-0.18.0/Data/ByteArray/Pack/0000755000000000000000000000000013534062352014732 5ustar0000000000000000memory-0.18.0/Data/Memory/0000755000000000000000000000000013605037576013433 5ustar0000000000000000memory-0.18.0/Data/Memory/Encoding/0000755000000000000000000000000013605037576015161 5ustar0000000000000000memory-0.18.0/Data/Memory/Hash/0000755000000000000000000000000013533102570014301 5ustar0000000000000000memory-0.18.0/Data/Memory/Internal/0000755000000000000000000000000014305252711015173 5ustar0000000000000000memory-0.18.0/Data/Memory/MemMap/0000755000000000000000000000000013533102570014572 5ustar0000000000000000memory-0.18.0/tests/0000755000000000000000000000000013533102570012437 5ustar0000000000000000memory-0.18.0/Data/ByteArray.hs0000644000000000000000000000204213533102570014402 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.18.0/Data/ByteArray/Encoding.hs0000644000000000000000000001475514305252711016147 0ustar0000000000000000-- | -- Module : Data.ByteArray.Encoding -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Base conversions for 'ByteArray'. -- 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 -- $setup -- >>> :set -XOverloadedStrings -- >>> import Data.ByteString -- | The 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. -- -- -- defines a separate Base64 encoding, which is not supported. This format -- requires a newline at least every 76 encoded characters, which works around -- limitations of older email programs that could not handle long lines. -- Be aware that other languages, such as Ruby, encode the RFC 2045 version -- by default. To decode their output, remove all newlines before decoding. -- -- ==== Examples -- -- A quick example to show the differences: -- -- >>> let input = "Is 3 > 2?" :: ByteString -- >>> let convertedTo base = convertToBase base input :: ByteString -- >>> convertedTo Base16 -- "49732033203e20323f" -- >>> convertedTo Base32 -- "JFZSAMZAHYQDEPY=" -- >>> convertedTo Base64 -- "SXMgMyA+IDI/" -- >>> convertedTo Base64URLUnpadded -- "SXMgMyA-IDI_" -- >>> convertedTo Base64OpenBSD -- "QVKeKw.8GBG9" -- 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) -- | Encode some bytes to the equivalent representation in a specific 'Base'. -- -- ==== Examples -- -- Convert a 'ByteString' to base-64: -- -- >>> convertToBase Base64 ("foobar" :: ByteString) :: ByteString -- "Zm9vYmFy" -- 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 decode some bytes from the equivalent representation in a specific 'Base'. -- -- ==== Examples -- -- Successfully convert from base-64 to a 'ByteString': -- -- >>> convertFromBase Base64 ("Zm9vYmFy" :: ByteString) :: Either String ByteString -- Right "foobar" -- -- Trying to decode invalid data will return an error string: -- -- >>> convertFromBase Base64 ("!!!" :: ByteString) :: Either String ByteString -- Left "base64: input: invalid length" -- 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.18.0/Data/ByteArray/Mapping.hs0000644000000000000000000000546513533102570016011 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.18.0/Data/ByteArray/Pack.hs0000644000000000000000000001122713533102570015265 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.18.0/Data/ByteArray/Parse.hs0000644000000000000000000002307714212041404015460 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 CPP #-} {-# LANGUAGE Rank2Types #-} {-# 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 qualified Control.Monad.Fail as Fail 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 v = Parser $ \buf _ ok -> ok buf v (<*>) d e = d >>= \b -> e >>= \a -> return (b a) instance Monad (Parser byteArray) where #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif return = pure m >>= k = Parser $ \buf err ok -> runParser m buf err (\buf' a -> runParser (k a) buf' err ok) instance Fail.MonadFail (Parser byteArray) where fail errorMsg = Parser $ \buf err _ -> err buf ("Parser failed: " ++ errorMsg) 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.18.0/Data/ByteArray/Hash.hs0000644000000000000000000000446413533102570015277 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.18.0/Data/Memory/Endian.hs0000644000000000000000000000636513533102570015162 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.18.0/Data/Memory/PtrMethods.hs0000644000000000000000000000771313605037576016070 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 , memReverse , 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 !d !s n = when (n > 0) $ do peek s >>= poke d . xor v loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1) loopInplace !s n = when (n > 0) $ 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 #-} -- | Reverse a set number of bytes from @src@ to @dst@. Memory -- locations should not overlap. memReverse :: Ptr Word8 -> Ptr Word8 -> Int -> IO () memReverse d s n | n > 0 = do peekByteOff s (n - 1) >>= poke d memReverse (d `plusPtr` 1) s (n - 1) | otherwise = return () -- | Check if two piece of memory are equals memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool memEqual p1 p2 n = loop 0 where loop i | i == n = return True | otherwise = do e <- (==) <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) if e then loop (i+1) else return False -- | Compare two piece of memory and returns how they compare memCompare :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering memCompare p1 p2 n = loop 0 where loop i | i == n = return EQ | otherwise = do e <- compare <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) if e == EQ then loop (i+1) else return e -- | A constant time equality test for 2 Memory buffers -- -- compared to normal equality function, this function will go -- over all the bytes present before yielding a result even when -- knowing the overall result early in the processing. memConstEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool memConstEqual p1 p2 n = loop 0 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.18.0/Data/Memory/ExtendedWords.hs0000644000000000000000000000063213533102570016532 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.18.0/Data/Memory/Encoding/Base16.hs0000644000000000000000000001750714212041647016535 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base16 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Low-level Base16 encoding and decoding. -- -- If you just want to encode or decode some bytes, you probably want to use -- the "Data.ByteArray.Encoding" module. -- {-# 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 Basement.Bits import Basement.IntegralConv import GHC.Prim import GHC.Types import GHC.Word import GHC.Char (chr) 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 !(a, b, c, 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 !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 :: Word8 -> Char wToChar w = chr (integralUpsize 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 !w <- peekByteOff bin i let !(# !w1, !w2 #) = convertByte w pokeByteOff bout (i * 2) w1 pokeByteOff bout (i * 2 + 1) w2 loop (i+1) -- | Convert a value Word# to two Word#s containing -- the hexadecimal representation of the Word# convertByte :: Word8 -> (# Word8, Word8 #) convertByte bwrap = (# r tableHi b, r tableLo b #) where !(W# b) = integralUpsize bwrap r :: Addr# -> Word# -> Word8 r table index = W8# (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, rHi :: Word8 -> Word8 rLo index = W8# (indexWord8OffAddr# tableLo (word2Int# widx)) where !(W# widx) = integralUpsize index rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx)) where !(W# widx) = integralUpsize 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.18.0/Data/Memory/Encoding/Base32.hs0000644000000000000000000002633614212036501016524 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base32 -- License : BSD-style -- Maintainer : Nicolas DI PRIMA -- Stability : experimental -- Portability : unknown -- -- Low-level Base32 encoding and decoding. -- -- If you just want to encode or decode some bytes, you probably want to use -- the "Data.ByteArray.Encoding" module. -- {-# 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.Word import Basement.Bits import Basement.IntegralConv 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 (!i1, !i2, !i3, !i4, !i5) = (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8) where -- 1111 1000 >> 3 !o1 = (i1 .&. 0xF8) .>>. 3 -- 0000 0111 << 2 | 1100 0000 >> 6 !o2 = ((i1 .&. 0x07) .<<. 2) .|. ((i2 .&. 0xC0) .>>. 6) -- 0011 1110 >> 1 !o3 = ((i2 .&. 0x3E) .>>. 1) -- 0000 0001 << 4 | 1111 0000 >> 4 !o4 = ((i2 .&. 0x01) .<<. 4) .|. ((i3 .&. 0xF0) .>>. 4) -- 0000 1111 << 1 | 1000 0000 >> 7 !o5 = ( (i3 .&. 0x0F) .<<. 1) .|. ((i4 .&. 0x80) .>>. 7) -- 0111 1100 >> 2 !o6 = (i4 .&. 0x7C) .>>. 2 -- 0000 0011 << 3 | 1110 0000 >> 5 !o7 = ((i4 .&. 0x03) .<<. 3) .|. ((i5 .&. 0xE0) .>>. 5) -- 0001 1111 !o8 = i5 .&. 0x1F !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# index :: Word8 -> Word8 index idx = W8# (indexWord8OffAddr# set (word2Int# widx)) where !(W# widx) = integralUpsize 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 < 1 = return $ Just 0 | (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 w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) where !(W# widx) = integralUpsize w !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.18.0/Data/Memory/Encoding/Base64.hs0000644000000000000000000003575614212035126016541 0ustar0000000000000000-- | -- Module : Data.Memory.Encoding.Base64 -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Low-level Base64 encoding and decoding. -- -- If you just want to encode or decode some bytes, you probably want to use -- the "Data.ByteArray.Encoding" module. -- {-# 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 Data.Memory.Internal.Compat import Data.Memory.Internal.Imports import Basement.Bits import Basement.IntegralConv (integralUpsize) 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 !a !b !c = let !w = a .>>. 2 !x = ((a .<<. 4) .&. 0x30) .|. (b .>>. 4) !y = ((b .<<. 2) .&. 0x3c) .|. (c .>>. 6) !z = c .&. 0x3f in (index w, index x, index y, index z) where index :: Word8 -> Word8 index !idxb = W8# (indexWord8OffAddr# table (word2Int# idx)) where !(W# idx) = integralUpsize idxb -- | 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 $ Just 0 | (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 !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) where !(W# widx) = integralUpsize w !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 !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) where !(W# widx) = integralUpsize w !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 !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) where !(W# widx) = integralUpsize w !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.18.0/Data/ByteArray/Sized.hs0000644000000000000000000003117013605037621015470 0ustar0000000000000000-- | -- Module : Data.ByteArray.Sized -- License : BSD-style -- Maintainer : Nicolas Di Prima -- Stability : stable -- Portability : Good -- {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE NoStarIsType #-} #endif module Data.ByteArray.Sized ( ByteArrayN(..) , SizedByteArray , unSizedByteArray , sizedByteArray , unsafeSizedByteArray , -- * ByteArrayN operators alloc , create , allocAndFreeze , unsafeCreate , inlineUnsafeCreate , empty , pack , unpack , cons , snoc , xor , index , splitAt , take , drop , append , copy , copyRet , copyAndFreeze , replicate , zero , convert , fromByteArrayAccess , unsafeFromByteArrayAccess ) where import Basement.Imports import Basement.NormalForm import Basement.Nat import Basement.Numerical.Additive ((+)) import Basement.Numerical.Subtractive ((-)) import Basement.Sized.List (ListN, unListN, toListN) import Foreign.Storable import Foreign.Ptr import Data.Maybe (fromMaybe) import Data.Memory.Internal.Compat import Data.Memory.PtrMethods import Data.Proxy (Proxy(..)) import Data.ByteArray.Types (ByteArrayAccess(..), ByteArray) import qualified Data.ByteArray.Types as ByteArray (allocRet) #if MIN_VERSION_basement(0,0,7) import Basement.BlockN (BlockN) import qualified Basement.BlockN as BlockN import qualified Basement.PrimType as Base import Basement.Types.OffsetSize (Countable) #endif -- | Type class to emulate exactly the behaviour of 'ByteArray' but with -- a known length at compile time -- class (ByteArrayAccess c, KnownNat n) => ByteArrayN (n :: Nat) c | c -> n where -- | just like 'allocRet' but with the size at the type level allocRet :: forall p a . Proxy n -> (Ptr p -> IO a) -> IO (a, c) -- | Wrapper around any collection type with the size as type parameter -- newtype SizedByteArray (n :: Nat) ba = SizedByteArray { unSizedByteArray :: ba } deriving (Eq, Show, Typeable, Ord, NormalForm) -- | create a 'SizedByteArray' from the given 'ByteArrayAccess' if the -- size is the same as the target size. -- sizedByteArray :: forall n ba . (KnownNat n, ByteArrayAccess ba) => ba -> Maybe (SizedByteArray n ba) sizedByteArray ba | length ba == n = Just $ SizedByteArray ba | otherwise = Nothing where n = fromInteger $ natVal (Proxy @n) -- | just like the 'sizedByteArray' function but throw an exception if -- the size is invalid. unsafeSizedByteArray :: forall n ba . (ByteArrayAccess ba, KnownNat n) => ba -> SizedByteArray n ba unsafeSizedByteArray = fromMaybe (error "The size is invalid") . sizedByteArray instance (ByteArrayAccess ba, KnownNat n) => ByteArrayAccess (SizedByteArray n ba) where length _ = fromInteger $ natVal (Proxy @n) withByteArray (SizedByteArray ba) = withByteArray ba instance (KnownNat n, ByteArray ba) => ByteArrayN n (SizedByteArray n ba) where allocRet p f = do (a, ba) <- ByteArray.allocRet n f pure (a, SizedByteArray ba) where n = fromInteger $ natVal p #if MIN_VERSION_basement(0,0,7) instance ( ByteArrayAccess (BlockN n ty) , PrimType ty , KnownNat n , Countable ty n , KnownNat nbytes , nbytes ~ (Base.PrimSize ty * n) ) => ByteArrayN nbytes (BlockN n ty) where allocRet _ f = do mba <- BlockN.new @n a <- BlockN.withMutablePtrHint True False mba (f . castPtr) ba <- BlockN.freeze mba return (a, ba) #endif -- | Allocate a new bytearray of specific size, and run the initializer on this memory alloc :: forall n ba p . (ByteArrayN n ba, KnownNat n) => (Ptr p -> IO ()) -> IO ba alloc f = snd <$> allocRet (Proxy @n) f -- | Allocate a new bytearray of specific size, and run the initializer on this memory create :: forall n ba p . (ByteArrayN n ba, KnownNat n) => (Ptr p -> IO ()) -> IO ba create = alloc @n {-# NOINLINE create #-} -- | similar to 'allocN' but hide the allocation and initializer in a pure context allocAndFreeze :: forall n ba p . (ByteArrayN n ba, KnownNat n) => (Ptr p -> IO ()) -> ba allocAndFreeze f = unsafeDoIO (alloc @n f) {-# NOINLINE allocAndFreeze #-} -- | similar to 'createN' but hide the allocation and initializer in a pure context unsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) => (Ptr p -> IO ()) -> ba unsafeCreate f = unsafeDoIO (alloc @n f) {-# NOINLINE unsafeCreate #-} inlineUnsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) => (Ptr p -> IO ()) -> ba inlineUnsafeCreate f = unsafeDoIO (alloc @n f) {-# INLINE inlineUnsafeCreate #-} -- | Create an empty byte array empty :: forall ba . ByteArrayN 0 ba => ba empty = unsafeDoIO (alloc @0 $ \_ -> return ()) -- | Pack a list of bytes into a bytearray pack :: forall n ba . (ByteArrayN n ba, KnownNat n) => ListN n Word8 -> ba pack l = inlineUnsafeCreate @n (fill $ unListN 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 :: forall n ba . (ByteArrayN n ba, KnownNat n, NatWithinBound Int n, ByteArrayAccess ba) => ba -> ListN n Word8 unpack bs = fromMaybe (error "the impossible appened") $ toListN @n $ loop 0 where !len = length bs loop i | i == len = [] | otherwise = let !v = unsafeDoIO $ withByteArray bs (`peekByteOff` i) in v : loop (i+1) -- | prepend a single byte to a byte array cons :: forall ni no bi bo . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi , KnownNat ni, KnownNat no , (ni + 1) ~ no ) => Word8 -> bi -> bo cons b ba = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do pokeByteOff d 0 b memCopy (d `plusPtr` 1) s len where !len = fromInteger $ natVal (Proxy @ni) -- | append a single byte to a byte array snoc :: forall bi bo ni no . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi , KnownNat ni, KnownNat no , (ni + 1) ~ no ) => bi -> Word8 -> bo snoc ba b = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do memCopy d s len pokeByteOff d len b where !len = fromInteger $ natVal (Proxy @ni) -- | Create a xor of bytes between a and b. -- -- the returns byte array is the size of the smallest input. xor :: forall n a b c . ( ByteArrayN n a, ByteArrayN n b, ByteArrayN n c , ByteArrayAccess a, ByteArrayAccess b , KnownNat n ) => a -> b -> c xor a b = unsafeCreate @n $ \pc -> withByteArray a $ \pa -> withByteArray b $ \pb -> memXor pc pa pb n where n = fromInteger (natVal (Proxy @n)) -- | return a specific byte indexed by a number from 0 in a bytearray -- -- unsafe, no bound checking are done index :: forall n na ba . ( ByteArrayN na ba, ByteArrayAccess ba , KnownNat na, KnownNat n , n <= na ) => ba -> Proxy n -> Word8 index b pi = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i) where i = fromInteger $ natVal pi -- | Split a bytearray at a specific length in two bytearray splitAt :: forall nblhs nbi nbrhs bi blhs brhs . ( ByteArrayN nbi bi, ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs , ByteArrayAccess bi , KnownNat nbi, KnownNat nblhs, KnownNat nbrhs , nblhs <= nbi, (nbrhs + nblhs) ~ nbi ) => bi -> (blhs, brhs) splitAt bs = unsafeDoIO $ withByteArray bs $ \p -> do b1 <- alloc @nblhs $ \r -> memCopy r p n b2 <- alloc @nbrhs $ \r -> memCopy r (p `plusPtr` n) (len - n) return (b1, b2) where n = fromInteger $ natVal (Proxy @nblhs) len = length bs -- | Take the first @n@ byte of a bytearray take :: forall nbo nbi bi bo . ( ByteArrayN nbi bi, ByteArrayN nbo bo , ByteArrayAccess bi , KnownNat nbi, KnownNat nbo , nbo <= nbi ) => bi -> bo take bs = unsafeCreate @nbo $ \d -> withByteArray bs $ \s -> memCopy d s m where !m = min len n !len = length bs !n = fromInteger $ natVal (Proxy @nbo) -- | drop the first @n@ byte of a bytearray drop :: forall n nbi nbo bi bo . ( ByteArrayN nbi bi, ByteArrayN nbo bo , ByteArrayAccess bi , KnownNat n, KnownNat nbi, KnownNat nbo , (nbo + n) ~ nbi ) => Proxy n -> bi -> bo drop pn bs = unsafeCreate @nbo $ \d -> withByteArray bs $ \s -> memCopy d (s `plusPtr` ofs) nb where ofs = min len n nb = len - ofs len = length bs n = fromInteger $ natVal pn -- | append one bytearray to the other append :: forall nblhs nbrhs nbout blhs brhs bout . ( ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs, ByteArrayN nbout bout , ByteArrayAccess blhs, ByteArrayAccess brhs , KnownNat nblhs, KnownNat nbrhs, KnownNat nbout , (nbrhs + nblhs) ~ nbout ) => blhs -> brhs -> bout append blhs brhs = unsafeCreate @nbout $ \p -> withByteArray blhs $ \plhs -> withByteArray brhs $ \prhs -> do memCopy p plhs (length blhs) memCopy (p `plusPtr` length blhs) prhs (length brhs) -- | Duplicate a bytearray into another bytearray, and run an initializer on it copy :: forall n bs1 bs2 p . ( ByteArrayN n bs1, ByteArrayN n bs2 , ByteArrayAccess bs1 , KnownNat n ) => bs1 -> (Ptr p -> IO ()) -> IO bs2 copy bs f = alloc @n $ \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 :: forall n bs1 bs2 p a . ( ByteArrayN n bs1, ByteArrayN n bs2 , ByteArrayAccess bs1 , KnownNat n ) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2) copyRet bs f = allocRet (Proxy @n) $ \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 :: forall n bs1 bs2 p . ( ByteArrayN n bs1, ByteArrayN n bs2 , ByteArrayAccess bs1 , KnownNat n ) => bs1 -> (Ptr p -> IO ()) -> bs2 copyAndFreeze bs f = inlineUnsafeCreate @n $ \d -> do copyByteArrayToPtr bs d f (castPtr d) {-# NOINLINE copyAndFreeze #-} -- | Create a bytearray of a specific size containing a repeated byte value replicate :: forall n ba . (ByteArrayN n ba, KnownNat n) => Word8 -> ba replicate b = inlineUnsafeCreate @n $ \ptr -> memSet ptr b (fromInteger $ natVal $ Proxy @n) {-# NOINLINE replicate #-} -- | Create a bytearray of a specific size initialized to 0 zero :: forall n ba . (ByteArrayN n ba, KnownNat n) => ba zero = unsafeCreate @n $ \ptr -> memSet ptr 0 (fromInteger $ natVal $ Proxy @n) {-# NOINLINE zero #-} -- | Convert a bytearray to another type of bytearray convert :: forall n bin bout . ( ByteArrayN n bin, ByteArrayN n bout , KnownNat n ) => bin -> bout convert bs = inlineUnsafeCreate @n (copyByteArrayToPtr bs) -- | Convert a ByteArrayAccess to another type of bytearray -- -- This function returns nothing if the size is not compatible fromByteArrayAccess :: forall n bin bout . ( ByteArrayAccess bin, ByteArrayN n bout , KnownNat n ) => bin -> Maybe bout fromByteArrayAccess bs | l == n = Just $ inlineUnsafeCreate @n (copyByteArrayToPtr bs) | otherwise = Nothing where l = length bs n = fromInteger $ natVal (Proxy @n) -- | Convert a ByteArrayAccess to another type of bytearray unsafeFromByteArrayAccess :: forall n bin bout . ( ByteArrayAccess bin, ByteArrayN n bout , KnownNat n ) => bin -> bout unsafeFromByteArrayAccess bs = case fromByteArrayAccess @n @bin @bout bs of Nothing -> error "Invalid Size" Just v -> v memory-0.18.0/Data/Memory/Internal/Compat.hs0000644000000000000000000000372713533102570016762 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.18.0/Data/Memory/Internal/CompatPrim.hs0000644000000000000000000000350313605037576017617 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 #-} module Data.Memory.Internal.CompatPrim ( be32Prim , le32Prim , byteswap32Prim , booleanPrim ) 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 #-} memory-0.18.0/Data/Memory/Internal/CompatPrim64.hs0000644000000000000000000000701114305252711017753 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# #if __GLASGOW_HASKELL__ < 904 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# #endif 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.18.0/Data/Memory/Internal/DeepSeq.hs0000644000000000000000000000133513533102570017056 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.18.0/Data/Memory/Internal/Imports.hs0000644000000000000000000000101113605037576017171 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, when) import Control.Arrow as X (first, second) import Data.Memory.Internal.DeepSeq as X memory-0.18.0/Data/Memory/Hash/SipHash.hs0000644000000000000000000001703613533102570016203 0ustar0000000000000000-- | -- Module : Data.Memory.Hash.SipHash -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- provide the SipHash algorithm. -- reference: -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} 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 Data.Typeable (Typeable) 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,Typeable) 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.18.0/Data/Memory/Hash/FNV.hs0000644000000000000000000000671614212041622015273 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 Basement.Bits import Basement.IntegralConv import Data.Memory.Internal.Compat () 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) fnv1_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 fnv1_32_Mix8 !w (FnvHash32 acc) = FnvHash32 ((0x01000193 * acc) .^. integralUpsize w) {-# INLINE fnv1_32_Mix8 #-} fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * (acc .^. integralUpsize w)) {-# INLINE fnv1a_32_Mix8 #-} fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 ((0x100000001b3 * acc) .^. integralUpsize w) {-# INLINE fnv1_64_Mix8 #-} fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * (acc .^. integralUpsize w)) {-# INLINE fnv1a_64_Mix8 #-} -- | compute FNV1 (32 bit variant) of a raw piece of memory fnv1 :: Ptr Word8 -> Int -> IO FnvHash32 fnv1 (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 where loop :: FnvHash32 -> Int -> IO FnvHash32 loop !acc !i | i == n = pure $ acc | otherwise = do v <- read8 addr i loop (fnv1_32_Mix8 v acc) (i + 1) -- | compute FNV1a (32 bit variant) of a raw piece of memory fnv1a :: Ptr Word8 -> Int -> IO FnvHash32 fnv1a (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 where loop :: FnvHash32 -> Int -> IO FnvHash32 loop !acc !i | i == n = pure $ acc | otherwise = do v <- read8 addr i loop (fnv1a_32_Mix8 v acc) (i + 1) -- | compute FNV1 (64 bit variant) of a raw piece of memory fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64 fnv1_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 where loop :: FnvHash64 -> Int -> IO FnvHash64 loop !acc !i | i == n = pure $ acc | otherwise = do v <- read8 addr i loop (fnv1_64_Mix8 v acc) (i + 1) -- | compute FNV1a (64 bit variant) of a raw piece of memory fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64 fnv1a_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 where loop :: FnvHash64 -> Int -> IO FnvHash64 loop !acc !i | i == n = pure $ acc | otherwise = do v <- read8 addr i loop (fnv1a_64_Mix8 v acc) (i + 1) read8 :: Addr# -> Int -> IO Word8 read8 addr (I# i) = IO $ \s -> case readWord8OffAddr# addr i s of (# s2, e #) -> (# s2, W8# e #) memory-0.18.0/Data/ByteArray/Pack/Internal.hs0000644000000000000000000000526514212036540017044 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 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 = pure (>>=) = 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.18.0/Data/ByteArray/Types.hs0000644000000000000000000001177114212041501015506 0ustar0000000000000000-- | -- Module : Data.ByteArray.Types -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} 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 import Data.Memory.PtrMethods (memCopy) 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.UArray.Mutable as BaseMutable (withMutablePtrHint) import qualified Basement.Block as Block import qualified Basement.Block.Mutable as Block import Basement.Nat import qualified Basement.Sized.Block as BlockN import Prelude hiding (length) -- | 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 -- | Copy the data of a bytearray to a ptr copyByteArrayToPtr :: ba -> Ptr p -> IO () copyByteArrayToPtr a dst = withByteArray a $ \src -> memCopy (castPtr dst) src (length 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_BASEMENT_SUPPORT baseBlockRecastW8 :: Base.PrimType ty => Block.Block ty -> Block.Block Word8 baseBlockRecastW8 = Block.unsafeCast -- safe with Word8 destination instance Base.PrimType ty => ByteArrayAccess (Block.Block ty) where length a = let Base.CountOf i = Block.length (baseBlockRecastW8 a) in i withByteArray a f = Block.withPtr (baseBlockRecastW8 a) (f . castPtr) copyByteArrayToPtr ba dst = do mb <- Block.unsafeThaw (baseBlockRecastW8 ba) Block.copyToPtr mb 0 (castPtr dst) (Block.length $ baseBlockRecastW8 ba) instance (KnownNat n, Base.PrimType ty, Base.Countable ty n) => ByteArrayAccess (BlockN.BlockN n ty) where length a = let Base.CountOf i = BlockN.lengthBytes a in i withByteArray a f = BlockN.withPtr a (f . castPtr) copyByteArrayToPtr bna = copyByteArrayToPtr (BlockN.toBlock bna) 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) copyByteArrayToPtr ba dst = Base.copyToPtr ba (castPtr dst) 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 (Block.Block ty) where allocRet sz f = do mba <- Block.new $ sizeRecastBytes sz Proxy a <- Block.withMutablePtrHint True False mba (f . castPtr) ba <- Block.unsafeFreeze mba return (a, ba) instance (Ord ty, Base.PrimType ty) => ByteArray (Base.UArray ty) where allocRet sz f = do mba <- Base.new $ sizeRecastBytes sz Proxy a <- BaseMutable.withMutablePtrHint True False mba (f . castPtr) ba <- Base.unsafeFreeze mba return (a, ba) 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 #-} #endif memory-0.18.0/Data/ByteArray/Bytes.hs0000644000000000000000000001444214212037614015500 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 #-} {-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.Bytes ( Bytes ) where #if MIN_VERSION_base(4,15,0) import GHC.Exts (unsafeCoerce#) #endif import GHC.Word import GHC.Char (chr) 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 import Data.Typeable #ifdef MIN_VERSION_basement import Basement.NormalForm #endif import Basement.IntegralConv -- | Simplest Byte Array data Bytes = Bytes (MutableByteArray# RealWorld) deriving (Typeable) 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` () #ifdef MIN_VERSION_basement instance NormalForm Bytes where toNormalForm b = b `seq` () #endif 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 (W8# e1) == (W8# e2) then loop (i +# 1#) s'' else (# s'', False #) {-# INLINE loop #-} bytesCompare :: Bytes -> Bytes -> Ordering bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ loop 0 where !l1 = bytesLength b1 !l2 = bytesLength b2 !len = min l1 l2 loop !i | i == len = if l1 == l2 then pure EQ else if l1 > l2 then pure GT else pure LT | otherwise = do e1 <- read8 m1 i e2 <- read8 m2 i if e1 == e2 then loop (i+1) else if e1 < e2 then pure LT else pure GT read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of (# s2, e #) -> (# s2, W8# e #) 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, chr (integralUpsize (W8# w)) #) {- bytesShowHex :: Bytes -> String bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b) {-# NOINLINE bytesShowHex #-} -} memory-0.18.0/Data/ByteArray/ScrubbedBytes.hs0000644000000000000000000001533314212041675017154 0ustar0000000000000000-- | -- Module : Data.ByteArray.ScrubbedBytes -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : Stable -- Portability : GHC -- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Data.ByteArray.ScrubbedBytes ( ScrubbedBytes ) where import GHC.Types import GHC.Prim import GHC.Ptr import GHC.Word #if MIN_VERSION_base(4,15,0) import GHC.Exts (unsafeCoerce#) #endif #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.Typeable import Data.Memory.PtrMethods import Data.Memory.Internal.CompatPrim import Data.Memory.Internal.Compat (unsafeDoIO) import Data.Memory.Internal.Imports import Data.ByteArray.Types import Foreign.Storable #ifdef MIN_VERSION_basement import Basement.NormalForm #endif -- | 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) deriving (Typeable) 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` () #ifdef MIN_VERSION_basement instance NormalForm ScrubbedBytes where toNormalForm b = b `seq` () #endif 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 (byteArrayContents# (unsafeCoerce# mbarr)) !mba = ScrubbedBytes mbarr in case mkWeak# mbarr () (finalize scrubber mba) s1 of (# s2, _ #) -> (# s2, mba #) where getScrubber :: Addr# -> State# RealWorld -> State# RealWorld getScrubber addr s = let IO scrubBytes = memSet (Ptr addr) 0 (I# sz) in case scrubBytes s of (# s', _ #) -> s' #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 $ loop 0 where !l1 = sizeofScrubbedBytes b1 !l2 = sizeofScrubbedBytes b2 !len = min l1 l2 loop !i | i == len = if l1 == l2 then pure EQ else if l1 > l2 then pure GT else pure LT | otherwise = do e1 <- read8 m1 i e2 <- read8 m2 i if e1 == e2 then loop (i+1) else if e1 < e2 then pure LT else pure GT read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of (# s2, e #) -> (# s2, W8# e #) 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.18.0/Data/ByteArray/Methods.hs0000644000000000000000000002351613533102570016016 0ustar0000000000000000-- | -- Module : Data.ByteArray.Methods -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : stable -- Portability : Good -- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Data.ByteArray.Methods ( alloc , allocAndFreeze , create , unsafeCreate , pack , unpack , uncons , empty , singleton , cons , snoc , null , replicate , zero , copy , take , drop , span , reverse , 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, reverse, concat, replicate, splitAt, null, pred, last, any, all) import qualified Prelude #if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT) import qualified Data.ByteString as SPE (ByteString) import qualified Basement.UArray as SPE (UArray) import qualified Basement.Block as SPE (Block) #endif -- | 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 -- | Reverse a bytearray reverse :: ByteArray bs => bs -> bs reverse bs = unsafeCreate n $ \d -> withByteArray bs $ \s -> memReverse d s n where n = 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 copyByteArrayToPtr x dst 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 copyByteArrayToPtr bs d 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 copyByteArrayToPtr bs d 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 copyByteArrayToPtr bs d 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 bs = inlineUnsafeCreate (length bs) (copyByteArrayToPtr bs) #if defined(WITH_BYTESTRING_SUPPORT) && defined(WITH_BASEMENT_SUPPORT) {-# SPECIALIZE convert :: SPE.ByteString -> SPE.UArray Word8 #-} {-# SPECIALIZE convert :: SPE.UArray Word8 -> SPE.ByteString #-} {-# SPECIALIZE convert :: SPE.ByteString -> SPE.Block Word8 #-} {-# SPECIALIZE convert :: SPE.Block Word8 -> SPE.ByteString #-} #endif memory-0.18.0/Data/ByteArray/MemView.hs0000644000000000000000000000215614305252711015762 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 abstraction 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.18.0/Data/ByteArray/View.hs0000644000000000000000000000710113533102570015315 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.18.0/Data/Memory/MemMap/Windows.hs0000644000000000000000000000056013533102570016561 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.18.0/Data/Memory/MemMap/Posix.hsc0000644000000000000000000001655613533102570016410 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.18.0/tests/Tests.hs0000644000000000000000000002656013533102570014106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Imports import Foundation.Check.Main import Utils import Data.Char (chr) import Data.Word import qualified Data.ByteString as BS 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_BASEMENT_SUPPORT import Basement.Block (Block) import Basement.UArray (UArray) #endif newtype Positive = Positive Word deriving (Show, Eq, Ord) instance Arbitrary Positive where arbitrary = Positive <$> between (0, 255) data Backend = BackendByte | BackendScrubbedBytes #ifdef WITH_BASEMENT_SUPPORT #if MIN_VERSION_basement(0,0,5) | BackendBlock #endif | BackendUArray #endif deriving (Show,Eq,Bounded,Enum) allBackends :: NonEmpty [Backend] allBackends = nonEmpty_ $ enumFrom BackendByte data ArbitraryBS = forall a . ByteArray a => ArbitraryBS a arbitraryBS :: Word -> Gen ArbitraryBS arbitraryBS n = do backend <- elements allBackends case backend of BackendByte -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen Bytes) BackendScrubbedBytes -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen ScrubbedBytes) #ifdef WITH_BASEMENT_SUPPORT #if MIN_VERSION_basement(0,0,5) BackendBlock -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (Block Word8)) #endif BackendUArray -> ArbitraryBS `fmap` ((B.pack `fmap` replicateM (fromIntegral n) arbitrary) :: Gen (UArray Word8)) #endif arbitraryBSof :: Word -> Word -> Gen ArbitraryBS arbitraryBSof minBytes maxBytes = between (minBytes, maxBytes) >>= arbitraryBS newtype SmallList a = SmallList [a] deriving (Show,Eq) instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = between (0,8) >>= \n -> SmallList `fmap` replicateM (fromIntegral n) arbitrary instance Arbitrary ArbitraryBS where arbitrary = arbitraryBSof 0 259 newtype Words8 = Words8 { unWords8 :: [Word8] } deriving (Show,Eq) instance Arbitrary Words8 where arbitrary = between (0, 259) >>= \n -> Words8 <$> replicateM (fromIntegral n) arbitrary testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [Test]) -> Test testGroupBackends x l = Group x [ Group "Bytes" (l withBytesWitness) , Group "ScrubbedBytes" (l withScrubbedBytesWitness) #ifdef WITH_BASEMENT_SUPPORT , Group "Block" (l withBlockWitness) , Group "UArray" (l withUArrayWitness) #endif ] testShowProperty :: IsProperty a => String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> a) -> Test testShowProperty x p = Group x [ Property "Bytes" (p withBytesWitness showLikeString) , Property "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB) ] where showLikeString l = show $ (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 = [ Group "BASE64" [ Group "encode-KAT" encodeKats64 , Group "decode-KAT" decodeKats64 ] , Group "BASE64URL" [ Group "encode-KAT" encodeKats64URLUnpadded , Group "decode-KAT" decodeKats64URLUnpadded ] , Group "BASE32" [ Group "encode-KAT" encodeKats32 , Group "decode-KAT" decodeKats32 ] , Group "BASE16" [ Group "encode-KAT" encodeKats16 , Group "decode-KAT" decodeKats16 ] ] where encodeKats64 = fmap (toTest B.Base64) $ zip [1..] base64Kats decodeKats64 = fmap (toBackTest B.Base64) $ zip [1..] base64Kats encodeKats32 = fmap (toTest B.Base32) $ zip [1..] base32Kats decodeKats32 = fmap (toBackTest B.Base32) $ zip [1..] base32Kats encodeKats16 = fmap (toTest B.Base16) $ zip [1..] base16Kats decodeKats16 = fmap (toBackTest B.Base16) $ zip [1..] base16Kats encodeKats64URLUnpadded = fmap (toTest B.Base64URLUnpadded) $ zip [1..] base64URLKats decodeKats64URLUnpadded = fmap (toBackTest B.Base64URLUnpadded) $ zip [1..] base64URLKats toTest :: B.Base -> (Int, (LString, LString)) -> Test toTest base (i, (inp, out)) = Property (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, (LString, LString)) -> Test toBackTest base (i, (inp, out)) = Property (show i) $ let inpbs = witnessID $ B.pack $ unS inp outbs = B.convertFromBase base $ witnessID $ B.pack $ unS out in Right inpbs === outbs -- check not to touch internal null pointer of the empty ByteString bsNullEncodingTest = Group "BS-null" [ Group "BASE64" [ Property "encode-KAT" $ toTest B.Base64 , Property "decode-KAT" $ toBackTest B.Base64 ] , Group "BASE32" [ Property "encode-KAT" $ toTest B.Base32 , Property "decode-KAT" $ toBackTest B.Base32 ] , Group "BASE16" [ Property "encode-KAT" $ toTest B.Base16 , Property "decode-KAT" $ toBackTest B.Base16 ] ] where toTest base = B.convertToBase base BS.empty === BS.empty toBackTest base = B.convertFromBase base BS.empty === Right BS.empty parsingTests witnessID = [ CheckPlan "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 (_,_,_) -> validate "remaining" $ est === remaining _ -> validate "unexpected result" False ] main = defaultMain $ Group "memory" [ testGroupBackends "basic" basicProperties , bsNullEncodingTest , testGroupBackends "encoding" encodingTests , testGroupBackends "parsing" parsingTests , testGroupBackends "hashing" $ \witnessID -> [ Group "SipHash" $ SipHash.tests witnessID ] , testShowProperty "showing" $ \witnessID expectedShow (Words8 l) -> (show . witnessID . B.pack $ l) == expectedShow l #ifdef WITH_BASEMENT_SUPPORT , testFoundationTypes #endif ] where basicProperties witnessID = [ Property "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l) , Property "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b , Property "add-empty-eq" $ \(Words8 l) -> let b = witnessID $ B.pack l in B.append b B.empty == b , Property "zero" $ \(Positive n) -> let expected = witnessID $ B.pack $ replicate (fromIntegral n) 0 in expected == B.zero (fromIntegral n) , Property "Ord" $ \(Words8 l1) (Words8 l2) -> compare l1 l2 == compare (witnessID $ B.pack l1) (B.pack l2) , Property "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) -> mappend l1 l2 == (B.unpack $ mappend (witnessID $ B.pack l1) (B.pack l2)) , Property "Monoid(mconcat)" $ \(SmallList l) -> mconcat (fmap unWords8 l) == (B.unpack $ mconcat $ fmap (witnessID . B.pack . unWords8) l) , Property "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) , Property "concat l" $ \(SmallList l) -> let chunks = fmap (witnessID . B.pack . unWords8) l expected = concatMap unWords8 l in B.pack expected == witnessID (B.concat chunks) , Property "reverse" $ \(Words8 l) -> let b = witnessID (B.pack l) in reverse l == B.unpack (B.reverse b) , Property "cons b (reverse bs) == reverse (snoc bs b)" $ \(Words8 l) b -> let a = witnessID (B.pack l) in B.cons b (B.reverse a) == B.reverse (B.snoc a b) , Property "all == Prelude.all" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (/= b) in B.all p b1 == all p l , Property "any == Prelude.any" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (== b) in B.any p b1 == any p l , Property "singleton b == pack [b]" $ \b -> witnessID (B.singleton b) == B.pack [b] , Property "span" $ \x (Words8 l) -> let c = witnessID (B.pack l) (a, b) = B.span (== x) c in c == B.append a b , Property "span (const True)" $ \(Words8 l) -> let a = witnessID (B.pack l) in B.span (const True) a == (a, B.empty) , Property "span (const False)" $ \(Words8 l) -> let b = witnessID (B.pack l) in B.span (const False) b == (B.empty, b) ] #ifdef WITH_BASEMENT_SUPPORT testFoundationTypes = Group "Basement" [ CheckPlan "allocRet 4 _ :: UArray Int8 === 4" $ do x <- pick "allocateRet 4 _" $ (B.length :: UArray Int8 -> Int) . snd <$> B.allocRet 4 (const $ return ()) validate "4 === x" $ x === 4 , CheckPlan "allocRet 4 _ :: UArray Int16 === 4" $ do x <- pick "allocateRet 4 _" $ (B.length :: UArray Int16 -> Int) . snd <$> B.allocRet 4 (const $ return ()) validate "4 === x" $ x === 4 , CheckPlan "allocRet 4 _ :: UArray Int32 === 4" $ do x <- pick "allocateRet 4 _" $ (B.length :: UArray Int32 -> Int) . snd <$> B.allocRet 4 (const $ return ()) validate "4 === x" $ x === 4 , CheckPlan "allocRet 4 _ :: UArray Int64 === 8" $ do x <- pick "allocateRet 4 _" $ (B.length :: UArray Int64 -> Int) . snd <$> B.allocRet 4 (const $ return ()) validate "8 === x" $ x === 8 ] #endif memory-0.18.0/tests/Imports.hs0000644000000000000000000000036113533102570014430 0ustar0000000000000000module Imports ( module X ) where import Prelude as X (zip) import Control.Monad as X (replicateM) import Data.List as X (concatMap) import Foundation as X import Foundation.Collection as X (nonEmpty_) import Foundation.Check as X memory-0.18.0/tests/SipHash.hs0000644000000000000000000003144513533102570014341 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# 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 = makeTest <$> numberedList v where makeTest (i, (key,msg,tag)) = Property ("kat " <> show i) $ tag === sipHash key (witnessID $ B.pack $ unS msg) tests witnessID = [ Group "KAT" $ katTests witnessID vectors ] memory-0.18.0/tests/Utils.hs0000644000000000000000000000174713533102570014104 0ustar0000000000000000{-# LANGUAGE CPP #-} module Utils where import Data.Word import Data.ByteArray (Bytes, ScrubbedBytes) #ifdef WITH_BASEMENT_SUPPORT import Basement.Block (Block) import Basement.UArray (UArray) #endif 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 #ifdef WITH_BASEMENT_SUPPORT withBlockWitness :: Block Word8 -> Block Word8 withBlockWitness = withWitness (Witness :: Witness (Block Word8)) withUArrayWitness :: UArray Word8 -> UArray Word8 withUArrayWitness = withWitness (Witness :: Witness (UArray Word8)) #endif numberedList :: [a] -> [(Int, a)] numberedList = zip [1..] memory-0.18.0/README.md0000644000000000000000000000263213533102570012557 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 ------- See [Haskell packages guidelines](https://github.com/vincenthz/haskell-pkg-guidelines/blob/master/README.md#support) memory-0.18.0/CHANGELOG.md0000644000000000000000000000717714305253255013127 0ustar0000000000000000## 0.18 * drop support for ghc < 8.8 * compat with ghc 9.4 ## ... ## 0.14.18 * Branch/Release Snafu ## 0.14.17 * Require basement >= 0.0.7, Fix compilation with GHC 8,6 * Cleanup CPP, dropping support for much older version ## 0.14.16 * Fix compilation with a newer basement (>= 0.0.7) and an older GHC (< 8.0) ## 0.14.15 * Convert tests to foundation checks * Convert CI to haskell-ci * Fix compilation without foundation * Introduce ByteArrayL and associated method, as a type level sized version of ByteArray * Add NormalForm for Bytes and ScrubbedBytes ## 0.14.14 * Fix bounds issues with empty strings in base64 and base32 * Improve tests compatibility w.r.t old basement version ## 0.14.13 * Handle compat SPECIALIZE for older GHC ## 0.14.12 * Optimise copy operations and convert * Add instance of ByteArrayAccess and ByteArray for Block * Add Block and UArray in memory's tests ## 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.18.0/LICENSE0000644000000000000000000000303313533102570012301 0ustar0000000000000000Copyright (c) 2015-2018 Vincent Hanquez Copyright (c) 2017-2018 Nicolas Di Prima All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 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.18.0/Setup.hs0000644000000000000000000000005613533102570012732 0ustar0000000000000000import Distribution.Simple main = defaultMain memory-0.18.0/memory.cabal0000644000000000000000000001056414305253215013600 0ustar0000000000000000Name: memory version: 0.18.0 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_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.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 if impl(ghc < 8.8) buildable: False else build-depends: base , 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 CPP-options: -DWITH_BASEMENT_SUPPORT Build-depends: basement >= 0.0.7 exposed-modules: Data.ByteArray.Sized 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 if impl(ghc < 8.8) buildable: False else build-depends: base Build-Depends: bytestring , memory , basement >= 0.0.7 , foundation ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded default-language: Haskell2010 CPP-options: -DWITH_BASEMENT_SUPPORT -- Test-Suite test-examples -- default-language: Haskell2010 -- type: exitcode-stdio-1.0 -- hs-source-dirs: tests -- ghc-options: -threaded -- Main-is: DocTests.hs -- Build-Depends: base >= 3 && < 5 -- , memory -- , bytestring -- , doctest