ram-0.19.0/0000755000000000000000000000000007346545000010551 5ustar0000000000000000ram-0.19.0/CHANGELOG.md0000644000000000000000000001233407346545000012365 0ustar0000000000000000## 0.19 + Forked from memory + Dropped all dependencies for basement and the like Removed all `basement` package dependencies from the `memory` Haskell library (v0.18.0), replacing them with equivalents from `base`, `ghc-prim`, `deepseq`, and standard libraries. Also rewrote the test suite to eliminate `foundation` and `basement` test framework dependencies. ### Library Changes - `Data.ByteArray.Bytes`: removed `Basement.IntegralConv` (→ `fromIntegral`), removed `Basement.NormalForm` conditional instances - `Data.ByteArray.ScrubbedBytes`: removed `Basement.NormalForm` conditional instances - `Data.ByteArray.Sized`: removed `Basement.Imports`, `Basement.Nat`, `Basement.Sized.List`, `Basement.BlockN`, etc.; defined `ListN` locally; imported from `GHC.TypeLits`, `Data.Proxy`, `Data.Memory.Internal.DeepSeq` - `Data.ByteArray.Types`: removed entire `#ifdef WITH_BASEMENT_SUPPORT` block (Block/UArray/String instances) - `Data.ByteArray.Methods`: removed basement `SPECIALIZE` pragmas - `Data.Memory.Encoding.Base16/32/64`: replaced `Basement.Bits` with `Data.Bits`, replaced `integralUpsize` with `fromIntegral` - `Data.Memory.Hash.FNV`: replaced `.^.` with `xor`, `integralUpsize` with `fromIntegral` ### Test Suite Changes - Replaced `foundation`/`Foundation.Check` test framework with `tasty` + `QuickCheck` - Implemented custom `Test.Tasty.Providers` types (`QCTest`, `IOTest`) in `Imports.hs` to avoid needing `tasty-quickcheck` and `tasty-hunit` (not pre-built in nix store) - Rewrote `Tests.hs`, `SipHash.hs`, `Utils.hs` to use new test framework - Created `/projects/memory/cabal.project` with `tests: True` ## 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 ram-0.19.0/Data/0000755000000000000000000000000007346545000011422 5ustar0000000000000000ram-0.19.0/Data/ByteArray.hs0000644000000000000000000000204207346545000013656 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) ram-0.19.0/Data/ByteArray/0000755000000000000000000000000007346545000013324 5ustar0000000000000000ram-0.19.0/Data/ByteArray/Bytes.hs0000644000000000000000000001411607346545000014751 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 -- | 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` () 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 (fromIntegral (W8# w)) #) {- bytesShowHex :: Bytes -> String bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b) {-# NOINLINE bytesShowHex #-} -} ram-0.19.0/Data/ByteArray/Encoding.hs0000644000000000000000000001475507346545000015422 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) ram-0.19.0/Data/ByteArray/Hash.hs0000644000000000000000000000446407346545000014553 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) ram-0.19.0/Data/ByteArray/Mapping.hs0000644000000000000000000000546507346545000015265 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) ram-0.19.0/Data/ByteArray/MemView.hs0000644000000000000000000000215607346545000015235 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) ram-0.19.0/Data/ByteArray/Methods.hs0000644000000000000000000002243207346545000015266 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 -- | 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) ram-0.19.0/Data/ByteArray/Pack.hs0000644000000000000000000001122707346545000014541 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 #-} ram-0.19.0/Data/ByteArray/Pack/0000755000000000000000000000000007346545000014202 5ustar0000000000000000ram-0.19.0/Data/ByteArray/Pack/Internal.hs0000644000000000000000000000526507346545000016322 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 #-} ram-0.19.0/Data/ByteArray/Parse.hs0000644000000000000000000002307707346545000014743 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 ram-0.19.0/Data/ByteArray/ScrubbedBytes.hs0000644000000000000000000001505007346545000016421 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 -- | 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` () 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) ram-0.19.0/Data/ByteArray/Sized.hs0000644000000000000000000003060107346545000014736 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 BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoStarIsType #-} 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 Prelude hiding (length, splitAt, take, drop, replicate) import Data.Typeable (Typeable) import Data.Word (Word8) import Data.Proxy (Proxy(..)) import Data.Maybe (fromMaybe) import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (<=)) import Data.Memory.Internal.DeepSeq (NFData) import Foreign.Storable import Foreign.Ptr import Data.Memory.Internal.Compat import Data.Memory.PtrMethods import Data.ByteArray.Types (ByteArrayAccess(..), ByteArray) import qualified Data.ByteArray.Types as ByteArray (allocRet) -- | A list with a type-level length. newtype ListN (n :: Nat) a = ListN [a] -- | Extract the underlying list from a 'ListN'. unListN :: ListN n a -> [a] unListN (ListN l) = l -- | Wrap a list in 'ListN' if its length matches the type-level @n@. toListN :: forall n a . KnownNat n => [a] -> Maybe (ListN n a) toListN l = go l (fromIntegral (natVal (Proxy @n)) :: Int) where go [] 0 = Just (ListN l) go [] _ = Nothing go _ 0 = Nothing go (_:xs) k = go xs (k - 1) -- | 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, NFData) -- | 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 -- | 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, 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 ram-0.19.0/Data/ByteArray/Types.hs0000644000000000000000000000414607346545000014771 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 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 ram-0.19.0/Data/ByteArray/View.hs0000644000000000000000000000710107346545000014571 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) ram-0.19.0/Data/Memory/Encoding/0000755000000000000000000000000007346545000014420 5ustar0000000000000000ram-0.19.0/Data/Memory/Encoding/Base16.hs0000644000000000000000000001743407346545000016006 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 Data.Bits ((.|.)) 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 (fromIntegral 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) = fromIntegral 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) = fromIntegral index rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx)) where !(W# widx) = fromIntegral 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"# ram-0.19.0/Data/Memory/Encoding/Base32.hs0000644000000000000000000002645307346545000016005 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 Data.Bits ((.&.), (.|.)) import GHC.Prim import GHC.Word import Control.Monad import Foreign.Storable import Foreign.Ptr (Ptr) -- | Transform a number of bytes pointed by.@src in the base32 binary representation in @dst -- -- destination memory need to be of correct size, otherwise it will lead -- to really bad things. toBase32 :: Ptr Word8 -- ^ input -> Ptr Word8 -- ^ output -> Int -- ^ input len -> IO () toBase32 dst src len = loop 0 0 where eqChar :: Word8 eqChar = 0x3d peekOrZero :: Int -> IO Word8 peekOrZero i | i >= len = return 0 | otherwise = peekByteOff src i pokeOrPadding :: Int -- for the test -> Int -- src index -> Word8 -- the value -> IO () pokeOrPadding i di v | i < len = pokeByteOff dst di v | otherwise = pokeByteOff dst di eqChar loop :: Int -- index input -> Int -- index output -> IO () loop i di | i >= len = return () | otherwise = do i1 <- peekByteOff src i i2 <- peekOrZero (i + 1) i3 <- peekOrZero (i + 2) i4 <- peekOrZero (i + 3) i5 <- peekOrZero (i + 4) let (o1,o2,o3,o4,o5,o6,o7,o8) = toBase32Per5Bytes (i1, i2, i3, i4, i5) pokeByteOff dst di o1 pokeByteOff dst (di + 1) o2 pokeOrPadding (i + 1) (di + 2) o3 pokeOrPadding (i + 1) (di + 3) o4 pokeOrPadding (i + 2) (di + 4) o5 pokeOrPadding (i + 3) (di + 5) o6 pokeOrPadding (i + 3) (di + 6) o7 pokeOrPadding (i + 4) (di + 7) o8 loop (i+5) (di+8) toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) toBase32Per5Bytes (!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) `unsafeShiftR` 3 -- 0000 0111 << 2 | 1100 0000 >> 6 !o2 = ((i1 .&. 0x07) `unsafeShiftL` 2) .|. ((i2 .&. 0xC0) `unsafeShiftR` 6) -- 0011 1110 >> 1 !o3 = ((i2 .&. 0x3E) `unsafeShiftR` 1) -- 0000 0001 << 4 | 1111 0000 >> 4 !o4 = ((i2 .&. 0x01) `unsafeShiftL` 4) .|. ((i3 .&. 0xF0) `unsafeShiftR` 4) -- 0000 1111 << 1 | 1000 0000 >> 7 !o5 = ((i3 .&. 0x0F) `unsafeShiftL` 1) .|. ((i4 .&. 0x80) `unsafeShiftR` 7) -- 0111 1100 >> 2 !o6 = (i4 .&. 0x7C) `unsafeShiftR` 2 -- 0000 0011 << 3 | 1110 0000 >> 5 !o7 = ((i4 .&. 0x03) `unsafeShiftL` 3) .|. ((i5 .&. 0xE0) `unsafeShiftR` 5) -- 0001 1111 !o8 = i5 .&. 0x1F !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# index :: Word8 -> Word8 index idx = W8# (indexWord8OffAddr# set (word2Int# widx)) where !(W# widx) = fromIntegral 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) = fromIntegral 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"# ram-0.19.0/Data/Memory/Encoding/Base64.hs0000644000000000000000000003575307346545000016015 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 Data.Bits ((.&.), (.|.)) import GHC.Prim import GHC.Word import Foreign.Storable import Foreign.Ptr (Ptr) -- | Transform a number of bytes pointed by @src@ to base64 binary representation in @dst@ -- -- The destination memory need to be of correct size, otherwise it will lead -- to really bad things. toBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO () toBase64 dst src len = toBase64Internal set dst src len True where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# -- | Transform a number of bytes pointed by @src@ to, URL-safe base64 binary -- representation in @dst@. The result will be either padded or unpadded, -- depending on the boolean @padded@ argument. -- -- The destination memory need to be of correct size, otherwise it will lead -- to really bad things. toBase64URL :: Bool -> Ptr Word8 -> Ptr Word8 -> Int -> IO () toBase64URL padded dst src len = toBase64Internal set dst src len padded where !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# toBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO () toBase64OpenBSD dst src len = toBase64Internal set dst src len False where !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# toBase64Internal :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> Bool -> IO () toBase64Internal table dst src len padded = loop 0 0 where eqChar = 0x3d :: Word8 loop i di | i >= len = return () | otherwise = do a <- peekByteOff src i b <- if i + 1 >= len then return 0 else peekByteOff src (i+1) c <- if i + 2 >= len then return 0 else peekByteOff src (i+2) let (w,x,y,z) = convert3 table a b c pokeByteOff dst di w pokeByteOff dst (di+1) x if i + 1 < len then pokeByteOff dst (di+2) y else when padded (pokeByteOff dst (di+2) eqChar) if i + 2 < len then pokeByteOff dst (di+3) z else when padded (pokeByteOff dst (di+3) eqChar) loop (i+3) (di+4) convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) convert3 table !a !b !c = let !w = a `unsafeShiftR` 2 !x = ((a `unsafeShiftL` 4) .&. 0x30) .|. (b `unsafeShiftR` 4) !y = ((b `unsafeShiftL` 2) .&. 0x3c) .|. (c `unsafeShiftR` 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) = fromIntegral 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) = fromIntegral 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) = fromIntegral 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) = fromIntegral 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"# ram-0.19.0/Data/Memory/0000755000000000000000000000000007346545000012672 5ustar0000000000000000ram-0.19.0/Data/Memory/Endian.hs0000644000000000000000000000636507346545000014436 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 ram-0.19.0/Data/Memory/ExtendedWords.hs0000644000000000000000000000063207346545000016006 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) ram-0.19.0/Data/Memory/Hash/0000755000000000000000000000000007346545000013555 5ustar0000000000000000ram-0.19.0/Data/Memory/Hash/FNV.hs0000644000000000000000000000664507346545000014555 0ustar0000000000000000-- | -- Module : Data.Memory.Hash.FNV -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : good -- -- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) -- -- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE BangPatterns #-} module Data.Memory.Hash.FNV ( -- * types FnvHash32(..) , FnvHash64(..) -- * methods , fnv1 , fnv1a , fnv1_64 , fnv1a_64 ) where import Data.Bits (xor) 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 (xor (0x01000193 * acc) (fromIntegral w)) {-# INLINE fnv1_32_Mix8 #-} fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * xor acc (fromIntegral w)) {-# INLINE fnv1a_32_Mix8 #-} fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (xor (0x100000001b3 * acc) (fromIntegral w)) {-# INLINE fnv1_64_Mix8 #-} fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * xor acc (fromIntegral 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 #) ram-0.19.0/Data/Memory/Hash/SipHash.hs0000644000000000000000000001703607346545000015457 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) ram-0.19.0/Data/Memory/Internal/0000755000000000000000000000000007346545000014446 5ustar0000000000000000ram-0.19.0/Data/Memory/Internal/Compat.hs0000644000000000000000000000372707346545000016236 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 ram-0.19.0/Data/Memory/Internal/CompatPrim.hs0000644000000000000000000000350307346545000017056 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 #-} ram-0.19.0/Data/Memory/Internal/CompatPrim64.hs0000644000000000000000000000701107346545000017226 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 ram-0.19.0/Data/Memory/Internal/DeepSeq.hs0000644000000000000000000000133507346545000016332 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 ram-0.19.0/Data/Memory/Internal/Imports.hs0000644000000000000000000000101107346545000016430 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 ram-0.19.0/Data/Memory/MemMap/0000755000000000000000000000000007346545000014046 5ustar0000000000000000ram-0.19.0/Data/Memory/MemMap/Posix.hsc0000644000000000000000000001655607346545000015664 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) ram-0.19.0/Data/Memory/MemMap/Windows.hs0000644000000000000000000000056007346545000016035 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 ram-0.19.0/Data/Memory/PtrMethods.hs0000644000000000000000000000771307346545000015327 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 () ram-0.19.0/LICENSE0000644000000000000000000000303307346545000011555 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. ram-0.19.0/README.md0000644000000000000000000000221107346545000012024 0ustar0000000000000000memory ====== [![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) This is a fork of memory. It's open to accept changes from anyone, and aims to use existing well maintained libraries as much as possible. The fork is necessary because the original maintainer decided to exit Haskell. Note that this is /not/ a redesign of memory. It's just here to provide stability so that others can create better alternatives. Documentation: [ram on hackage](http://hackage.haskell.org/package/ram) 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). ram-0.19.0/Setup.hs0000644000000000000000000000005607346545000012206 0ustar0000000000000000import Distribution.Simple main = defaultMain ram-0.19.0/ram.cabal0000644000000000000000000000551007346545000012315 0ustar0000000000000000cabal-version: 3.0 name: ram version: 0.19.0 synopsis: memory and related abstraction stuff description: This is a fork of memory. It's open to accept changes from anyone, and aims to use existing well maintained libraries as much as possible. 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: BSD-3-Clause license-file: LICENSE copyright: Vincent Hanquez author: Vincent Hanquez maintainer: hi@jappie.me category: memory stability: experimental build-type: Simple homepage: https://github.com/jappeace/ram bug-reports: https://github.com/jappeace/ram/issues extra-doc-files: CHANGELOG.md README.md source-repository head type: git location: https://github.com/jappeace/ram library exposed-modules: Data.ByteArray Data.ByteArray.Encoding Data.ByteArray.Hash Data.ByteArray.Mapping Data.ByteArray.Pack Data.ByteArray.Parse Data.Memory.Encoding.Base16 Data.Memory.Encoding.Base32 Data.Memory.Encoding.Base64 Data.Memory.Endian Data.Memory.ExtendedWords Data.Memory.PtrMethods other-modules: Data.ByteArray.Bytes Data.ByteArray.MemView Data.ByteArray.Methods Data.ByteArray.Pack.Internal Data.ByteArray.ScrubbedBytes Data.ByteArray.Types Data.ByteArray.View Data.Memory.Hash.FNV Data.Memory.Hash.SipHash Data.Memory.Internal.Compat Data.Memory.Internal.CompatPrim Data.Memory.Internal.CompatPrim64 Data.Memory.Internal.DeepSeq Data.Memory.Internal.Imports exposed-modules: Data.ByteArray.Sized build-depends: , base <4.23 , bytestring <0.13 , deepseq >=1.1 && <1.17 , ghc-prim <0.14 -- 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 ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 test-suite test-memory type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Tests.hs other-modules: Imports SipHash Utils build-depends: , base <5 , bytestring , memory , QuickCheck , tasty ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded default-language: Haskell2010 ram-0.19.0/tests/0000755000000000000000000000000007346545000011713 5ustar0000000000000000ram-0.19.0/tests/Imports.hs0000644000000000000000000000432507346545000013710 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Imports ( module X , testProperty , testCase , assertBool , assertEqual , (@?=) ) where import Prelude as X import Control.Monad as X (replicateM) import Data.Word as X (Word8) import Test.Tasty as X (TestTree, testGroup, defaultMain, TestName) import Test.QuickCheck as X ( Arbitrary(..), Gen, Property , (===), (.&&.) , elements, choose, forAll, property, ioProperty , Testable ) import Test.Tasty.Providers (singleTest, IsTest(..), testPassed, testFailed) import Test.QuickCheck (quickCheckWithResult, stdArgs, isSuccess, Args(..)) import Control.Exception (SomeException, try) -- | QuickCheck property test provider for tasty newtype QCTest = QCTest Property instance Show QCTest where show _ = "QCTest" instance IsTest QCTest where run _ (QCTest p) _ = do r <- quickCheckWithResult stdArgs { chatty = False } p return $ if isSuccess r then testPassed "" else testFailed (show r) testOptions = pure [] -- | IO unit test provider for tasty newtype IOTest = IOTest (IO ()) instance Show IOTest where show _ = "IOTest" instance IsTest IOTest where run _ (IOTest act) _ = do r <- (try act :: IO (Either SomeException ())) return $ case r of Left ex -> testFailed (show ex) Right () -> testPassed "" testOptions = pure [] testProperty :: Testable p => TestName -> p -> TestTree testProperty name = singleTest name . QCTest . property testCase :: TestName -> IO () -> TestTree testCase name = singleTest name . IOTest assertBool :: String -> Bool -> IO () assertBool msg b = if b then return () else fail msg assertEqual :: (Show a, Eq a) => String -> a -> a -> IO () assertEqual msg expected actual | expected == actual = return () | otherwise = fail (msg ++ "\nexpected: " ++ show expected ++ "\n but got: " ++ show actual) infix 1 @?= (@?=) :: (Show a, Eq a) => a -> a -> IO () actual @?= expected | actual == expected = return () | otherwise = fail ("expected: " ++ show expected ++ "\n but got: " ++ show actual) ram-0.19.0/tests/SipHash.hs0000644000000000000000000002731307346545000013614 0ustar0000000000000000module SipHash (tests) where import Utils (numberedList, unS) import Imports (TestTree, testGroup, testCase, (@?=)) import qualified Data.ByteArray as B import Data.ByteArray.Hash (SipKey(..), SipHash(..), sipHash) katKey :: SipKey katKey = SipKey 0x0706050403020100 0x0f0e0d0c0b0a0908 vectors :: [(SipKey, String, SipHash)] 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 :: [(SipKey, String, SipHash)] -> [TestTree] katTests vs = makeTest <$> numberedList vs where makeTest (i, (key, msg, tag)) = testCase ("kat " ++ show i) $ sipHash key (B.pack (unS msg) :: B.Bytes) @?= tag tests :: B.ByteArray ba => (ba -> ba) -> [TestTree] tests _ = [ testGroup "KAT" $ katTests vectors ] ram-0.19.0/tests/Tests.hs0000644000000000000000000002433707346545000013362 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Imports import Utils import Data.Char (chr) import Data.Typeable (Typeable) 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 newtype Positive = Positive Word deriving (Show, Eq, Ord) instance Arbitrary Positive where arbitrary = Positive . fromIntegral <$> choose (0 :: Int, 255) data Backend = BackendByte | BackendScrubbedBytes deriving (Show, Eq, Bounded, Enum) allBackends :: [Backend] allBackends = [minBound..maxBound] data ArbitraryBS = forall a . (Show a, Eq a, Typeable a, ByteArray a) => ArbitraryBS a arbitraryBS :: Int -> Gen ArbitraryBS arbitraryBS n = do backend <- elements allBackends case backend of BackendByte -> ArbitraryBS <$> (B.pack <$> replicateM n arbitrary :: Gen Bytes) BackendScrubbedBytes -> ArbitraryBS <$> (B.pack <$> replicateM n arbitrary :: Gen ScrubbedBytes) arbitraryBSof :: Int -> Int -> Gen ArbitraryBS arbitraryBSof minBytes maxBytes = choose (minBytes, maxBytes) >>= arbitraryBS newtype SmallList a = SmallList [a] deriving (Show, Eq) instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = choose (0 :: Int, 8) >>= \n -> SmallList <$> replicateM n arbitrary instance Arbitrary ArbitraryBS where arbitrary = arbitraryBSof 0 259 newtype Words8 = Words8 { unWords8 :: [Word8] } deriving (Show, Eq) instance Arbitrary Words8 where arbitrary = choose (0 :: Int, 259) >>= \n -> Words8 <$> replicateM n arbitrary testGroupBackends :: String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [TestTree]) -> TestTree testGroupBackends x l = testGroup x [ testGroup "Bytes" (l withBytesWitness) , testGroup "ScrubbedBytes" (l withScrubbedBytesWitness) ] testShowProperty :: String -> (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> ([Word8] -> String) -> Words8 -> Bool) -> TestTree testShowProperty x p = testGroup x [ testProperty "Bytes" (p withBytesWitness showLikeString) , testProperty "ScrubbedBytes" (p withScrubbedBytesWitness showLikeEmptySB) ] where showLikeString l = show $ (chr . fromIntegral) <$> l showLikeEmptySB _ = show (withScrubbedBytesWitness B.empty) base64Kats :: [(String, String)] base64Kats = [ ("pleasure.", "cGxlYXN1cmUu") , ("leasure.", "bGVhc3VyZS4=") , ("easure.", "ZWFzdXJlLg==") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4=") , ("", "") ] base64URLKats :: [(String, String)] base64URLKats = [ ("pleasure.", "cGxlYXN1cmUu") , ("leasure.", "bGVhc3VyZS4") , ("easure.", "ZWFzdXJlLg") , ("asure.", "YXN1cmUu") , ("sure.", "c3VyZS4") , ("\DC4\251\156\ETX\217~", "FPucA9l-") , ("\DC4\251\156\ETX\217\DEL", "FPucA9l_") , ("", "") ] base16Kats :: [(String, String)] base16Kats = [ ("this is a string", "74686973206973206120737472696e67") ] base32Kats :: [(String, String)] base32Kats = [ ("-pleasure.", "FVYGYZLBON2XEZJO") , ("pleasure.", "OBWGKYLTOVZGKLQ=") , ("leasure.", "NRSWC43VOJSS4===") , ("easure.", "MVQXG5LSMUXA====") , ("asure.", "MFZXK4TFFY======") , ("sure.", "ON2XEZJO") , ("ure.", "OVZGKLQ=") , ("re.", "OJSS4===") , ("e.", "MUXA====") , (".", "FY======") , ("", "") ] encodingTests :: (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [TestTree]) encodingTests witnessID = [ testGroup "BASE64" [ testGroup "encode-KAT" encodeKats64 , testGroup "decode-KAT" decodeKats64 ] , testGroup "BASE64URL" [ testGroup "encode-KAT" encodeKats64URLUnpadded , testGroup "decode-KAT" decodeKats64URLUnpadded ] , testGroup "BASE32" [ testGroup "encode-KAT" encodeKats32 , testGroup "decode-KAT" decodeKats32 ] , testGroup "BASE16" [ testGroup "encode-KAT" encodeKats16 , testGroup "decode-KAT" decodeKats16 ] ] where encodeKats64 = zipWith (toTest B.Base64) [1..] base64Kats decodeKats64 = zipWith (toBackTest B.Base64) [1..] base64Kats encodeKats32 = zipWith (toTest B.Base32) [1..] base32Kats decodeKats32 = zipWith (toBackTest B.Base32) [1..] base32Kats encodeKats16 = zipWith (toTest B.Base16) [1..] base16Kats decodeKats16 = zipWith (toBackTest B.Base16) [1..] base16Kats encodeKats64URLUnpadded = zipWith (toTest B.Base64URLUnpadded) [1..] base64URLKats decodeKats64URLUnpadded = zipWith (toBackTest B.Base64URLUnpadded) [1..] base64URLKats toTest :: B.Base -> Int -> (String, String) -> TestTree toTest base i (inp, out) = testCase (show i) $ let inpbs = witnessID $ B.convertToBase base $ witnessID $ B.pack $ unS inp outbs = witnessID $ B.pack $ unS out in inpbs @?= outbs toBackTest :: B.Base -> Int -> (String, String) -> TestTree toBackTest base i (inp, out) = testCase (show i) $ let inpbs = witnessID $ B.pack $ unS inp outbs = B.convertFromBase base $ witnessID $ B.pack $ unS out in outbs @?= Right inpbs bsNullEncodingTest :: TestTree bsNullEncodingTest = testGroup "BS-null" [ testGroup "BASE64" [ testCase "encode-KAT" $ B.convertToBase B.Base64 BS.empty @?= BS.empty , testCase "decode-KAT" $ (B.convertFromBase B.Base64 BS.empty :: Either String BS.ByteString) @?= Right BS.empty ] , testGroup "BASE32" [ testCase "encode-KAT" $ B.convertToBase B.Base32 BS.empty @?= BS.empty , testCase "decode-KAT" $ (B.convertFromBase B.Base32 BS.empty :: Either String BS.ByteString) @?= Right BS.empty ] , testGroup "BASE16" [ testCase "encode-KAT" $ B.convertToBase B.Base16 BS.empty @?= BS.empty , testCase "decode-KAT" $ (B.convertFromBase B.Base16 BS.empty :: Either String BS.ByteString) @?= Right BS.empty ] ] parsingTests :: (forall ba . (Show ba, Eq ba, Typeable ba, ByteArray ba) => (ba -> ba) -> [TestTree]) parsingTests witnessID = [ testCase "parse" $ do 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 case result of Parse.ParseOK remaining _ -> remaining @?= est _ -> fail "unexpected parse result" ] main :: IO () main = defaultMain $ testGroup "memory" [ testGroupBackends "basic" basicProperties , bsNullEncodingTest , testGroupBackends "encoding" encodingTests , testGroupBackends "parsing" parsingTests , testGroupBackends "hashing" $ \witnessID -> [ testGroup "SipHash" $ SipHash.tests witnessID ] , testShowProperty "showing" $ \witnessID expectedShow (Words8 l) -> (show . witnessID . B.pack $ l) == expectedShow l ] where basicProperties witnessID = [ testProperty "unpack . pack == id" $ \(Words8 l) -> l == (B.unpack . witnessID . B.pack $ l) , testProperty "self-eq" $ \(Words8 l) -> let b = witnessID . B.pack $ l in b == b , testProperty "add-empty-eq" $ \(Words8 l) -> let b = witnessID $ B.pack l in B.append b B.empty == b , testProperty "zero" $ \(Positive n) -> let expected = witnessID $ B.pack $ replicate (fromIntegral n) 0 in expected == B.zero (fromIntegral n) , testProperty "Ord" $ \(Words8 l1) (Words8 l2) -> compare l1 l2 == compare (witnessID $ B.pack l1) (witnessID $ B.pack l2) , testProperty "Monoid(mappend)" $ \(Words8 l1) (Words8 l2) -> mappend l1 l2 == (B.unpack $ mappend (witnessID $ B.pack l1) (B.pack l2)) , testProperty "Monoid(mconcat)" $ \(SmallList l) -> mconcat (fmap unWords8 l) == (B.unpack $ mconcat $ fmap (witnessID . B.pack . unWords8) l) , testProperty "append associativity" $ \(Words8 la) (Words8 lb) (Words8 lc) -> let a = witnessID $ B.pack la b = witnessID $ B.pack lb c = witnessID $ B.pack lc in B.append (B.append a b) c == B.append a (B.append b c) , testProperty "concat l" $ \(SmallList l) -> let chunks = fmap (witnessID . B.pack . unWords8) l expected = concatMap unWords8 l in B.pack expected == witnessID (B.concat chunks) , testProperty "reverse" $ \(Words8 l) -> let b = witnessID (B.pack l) in reverse l == B.unpack (B.reverse b) , testProperty "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) , testProperty "all == Prelude.all" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (/= b) in B.all p b1 == all p l , testProperty "any == Prelude.any" $ \(Words8 l) b -> let b1 = witnessID (B.pack l) p = (== b) in B.any p b1 == any p l , testProperty "singleton b == pack [b]" $ \b -> witnessID (B.singleton b) == B.pack [b] , testProperty "span" $ \x (Words8 l) -> let c = witnessID (B.pack l) (a, b) = B.span (== x) c in c == B.append a b , testProperty "span (const True)" $ \(Words8 l) -> let a = witnessID (B.pack l) in B.span (const True) a == (a, B.empty) , testProperty "span (const False)" $ \(Words8 l) -> let b = witnessID (B.pack l) in B.span (const False) b == (B.empty, b) ] ram-0.19.0/tests/Utils.hs0000644000000000000000000000111607346545000013346 0ustar0000000000000000module Utils where import Data.Word import Data.ByteArray (Bytes, ScrubbedBytes) unS :: String -> [Word8] unS = map (fromIntegral . fromEnum) ascii :: [Word8] -> String ascii = map (toEnum . fromIntegral) -- | similar to proxy data Witness a = Witness withWitness :: Witness a -> a -> a withWitness _ a = a withBytesWitness :: Bytes -> Bytes withBytesWitness = withWitness (Witness :: Witness Bytes) withScrubbedBytesWitness :: ScrubbedBytes -> ScrubbedBytes withScrubbedBytesWitness = id numberedList :: [a] -> [(Int, a)] numberedList = zip [1..]