packages feed

ram (empty) → 0.19.0

raw patch · 38 files changed

+4841/−0 lines, 38 filesdep +QuickCheckdep +basedep +bytestringsetup-changed

Dependencies added: QuickCheck, base, bytestring, deepseq, ghc-prim, memory, tasty

Files

+ CHANGELOG.md view
@@ -0,0 +1,182 @@+## 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
+ Data/ByteArray.hs view
@@ -0,0 +1,34 @@+-- |+-- Module      : Data.ByteArray+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : Good+--+-- Simple and efficient byte array types+--+-- This module should be imported qualified.+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Data.ByteArray+    (+    -- * ByteArray Classes+      module Data.ByteArray.Types+    -- * ByteArray built-in types+    , module Data.ByteArray.Bytes+    , module Data.ByteArray.ScrubbedBytes+    , module Data.ByteArray.MemView+    , 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)
+ Data/ByteArray/Bytes.hs view
@@ -0,0 +1,208 @@+-- |+-- Module      : Data.ByteArray.Bytes+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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 #-}+-}
+ Data/ByteArray/Encoding.hs view
@@ -0,0 +1,162 @@+-- |+-- Module      : Data.ByteArray.Encoding+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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 <http://tools.ietf.org/html/rfc4648 RFC4648> for details.+-- In particular, Base64 can be standard or+-- <http://tools.ietf.org/html/rfc4648#section-5 URL-safe>. URL-safe+-- encoding is often used in other specifications without+-- <http://tools.ietf.org/html/rfc4648#section-3.2 padding> characters.+--+-- <https://www.ietf.org/rfc/rfc2045.txt RFC 2045>+-- 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)+
+ Data/ByteArray/Hash.hs view
@@ -0,0 +1,78 @@+-- |+-- Module      : Data.ByteArray.Hash+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+{-# LANGUAGE BangPatterns #-}+module Data.ByteArray.Hash+    (+    -- * SipHash+      SipKey(..)+    , SipHash(..)+    , sipHash+    , sipHashWith+    -- * FNV1 and FNV1a (32 and 64 bits)+    , FnvHash32(..)+    , FnvHash64(..)+    , fnv1Hash+    , fnv1aHash+    , fnv1_64Hash+    , fnv1a_64Hash+    ) where++import           Data.Memory.Internal.Compat+import           Data.Memory.Hash.SipHash+import           Data.Memory.Hash.FNV+import qualified Data.ByteArray.Types   as B++-- | Compute the SipHash tag of a byte array for a given key.+--+-- 'sipHash` is equivalent to 'sipHashWith 2 4'+sipHash :: B.ByteArrayAccess ba+        => SipKey+        -> ba+        -> SipHash+sipHash key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hash key p (B.length ba)++-- | Compute the SipHash tag of a byte array for a given key.+--+-- The user can choose the C and D numbers of rounds.+--+-- calling 'sipHash` is equivalent to 'sipHashWith 2 4'+sipHashWith :: B.ByteArrayAccess ba+            => Int    -- ^ c rounds+            -> Int    -- ^ d rounds+            -> SipKey -- ^ key+            -> ba     -- ^ data to hash+            -> SipHash+sipHashWith c d key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hashWith c d key p (B.length ba)+++-- | Compute the FNV1 32 bit hash value of a byte array+fnv1Hash :: B.ByteArrayAccess ba+         => ba+         -> FnvHash32+fnv1Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1 p (B.length ba)++-- | Compute the FNV1a 32 bit hash value of a byte array+fnv1aHash :: B.ByteArrayAccess ba+          => ba+          -> FnvHash32+fnv1aHash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a p (B.length ba)++-- | Compute the FNV1 64 bit hash value of a byte array+fnv1_64Hash :: B.ByteArrayAccess ba+            => ba+            -> FnvHash64+fnv1_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1_64 p (B.length ba)++-- | Compute the FNV1a 64 bit hash value of a byte array+fnv1a_64Hash :: B.ByteArrayAccess ba+             => ba+             -> FnvHash64+fnv1a_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a_64 p (B.length ba)
+ Data/ByteArray/Mapping.hs view
@@ -0,0 +1,84 @@+-- |+-- Module      : Data.ByteArray.Mapping+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Data/ByteArray/MemView.hs view
@@ -0,0 +1,38 @@+-- |+-- Module      : Data.ByteArray.MemView+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : Good+--+module Data.ByteArray.MemView+    ( MemView(..)+    , memViewPlus+    ) where++import           Foreign.Ptr+import           Data.ByteArray.Types+import           Data.Memory.Internal.Imports++-- | A simple abstraction to a piece of memory.+--+-- Do beware that garbage collection related to+-- piece of memory could be triggered before this+-- is used.+--+-- Only use with the appropriate handler has been+-- used (e.g. withForeignPtr on ForeignPtr)+--+data MemView = MemView {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !Int+    deriving (Show,Eq)++instance ByteArrayAccess MemView where+    length (MemView _ l) = l+    withByteArray (MemView p _) f = f (castPtr p)++-- | Increase the memory view while reducing the size of the window+--+-- this is useful as an 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)
+ Data/ByteArray/Methods.hs view
@@ -0,0 +1,301 @@+-- |+-- Module      : Data.ByteArray.Methods+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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)
+ Data/ByteArray/Pack.hs view
@@ -0,0 +1,145 @@+-- |+-- Module      : Data.ByteArray.Pack+-- License     : BSD-Style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Simple Byte Array packer+--+-- Simple example:+--+-- > > flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32)+-- > Right (ABCD *\NUL\NUL\NUL")+--+-- Original code from <https://hackage.haskell.org/package/bspack>+-- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05)+-- Copyright (c) 2014 Nicolas DI PRIMA+--+module Data.ByteArray.Pack+    ( Packer+    , Result(..)+    , 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 #-}
+ Data/ByteArray/Pack/Internal.hs view
@@ -0,0 +1,88 @@+-- |+-- Module      : Data.ByteArray.Pack.Internal+-- License     : BSD-Style+-- Copyright   : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+module Data.ByteArray.Pack.Internal+    ( Result(..)+    , Packer(..)+    , actionPacker+    , actionPackerWithRemain+    ) where++import           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 #-}
+ Data/ByteArray/Parse.hs view
@@ -0,0 +1,258 @@+-- |+-- Module      : Data.ByteArray.Parse+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- A very simple bytearray parser related to Parsec and Attoparsec+--+-- Simple example:+--+-- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest"+-- > ParseOK "est" ("xx", 116)+--+{-# LANGUAGE 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
+ Data/ByteArray/ScrubbedBytes.hs view
@@ -0,0 +1,198 @@+-- |+-- Module      : Data.ByteArray.ScrubbedBytes+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : Stable+-- Portability : GHC+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE CPP #-}+{-# 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 _ = "<scrubbed-bytes>"++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)
+ Data/ByteArray/Sized.hs view
@@ -0,0 +1,383 @@+-- |+-- Module      : Data.ByteArray.Sized+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- 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
+ Data/ByteArray/Types.hs view
@@ -0,0 +1,66 @@+-- |+-- Module      : Data.ByteArray.Types+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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+
+ Data/ByteArray/View.hs view
@@ -0,0 +1,128 @@+-- |+-- Module      : Data.ByteArray.View+-- License     : BSD-style+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- 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)
+ Data/Memory/Encoding/Base16.hs view
@@ -0,0 +1,175 @@+-- |+-- Module      : Data.Memory.Encoding.Base16+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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"#
+ Data/Memory/Encoding/Base32.hs view
@@ -0,0 +1,255 @@+-- |+-- Module      : Data.Memory.Encoding.Base32+-- License     : BSD-style+-- Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- 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"#
+ Data/Memory/Encoding/Base64.hs view
@@ -0,0 +1,327 @@+-- |+-- Module      : Data.Memory.Encoding.Base64+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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+-- <http://tools.ietf.org/html/rfc4648#section-3.2 unpadded> 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"#
+ Data/Memory/Endian.hs view
@@ -0,0 +1,121 @@+-- |+-- Module      : Data.Memory.Endian+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : good+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Memory.Endian+    ( Endianness(..)+    , getSystemEndianness+    , BE(..), LE(..)+    , fromBE, toBE+    , fromLE, toLE+    , ByteSwap+    ) where++import Data.Word (Word16, Word32, Word64)+import Foreign.Storable+#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)+import Data.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
+ Data/Memory/ExtendedWords.hs view
@@ -0,0 +1,17 @@+-- |+-- Module      : Data.Memory.ExtendedWords+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Extra Word size+--+module Data.Memory.ExtendedWords+    ( Word128(..)+    ) where++import Data.Word (Word64)++-- | A simple Extended Word128 composed of 2 Word64+data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq)
+ Data/Memory/Hash/FNV.hs view
@@ -0,0 +1,105 @@+-- |+-- Module      : Data.Memory.Hash.FNV+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions)+-- <http://en.wikipedia.org/wiki/Fowler%E2%80%93Noll%E2%80%93Vo_hash_function>+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE BangPatterns               #-}+module Data.Memory.Hash.FNV+    (+    -- * types+      FnvHash32(..)+    , FnvHash64(..)+    -- * methods+    , fnv1+    , fnv1a+    , fnv1_64+    , fnv1a_64+    ) where++import           Data.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 #)
+ Data/Memory/Hash/SipHash.hs view
@@ -0,0 +1,163 @@+-- |+-- Module      : Data.Memory.Hash.SipHash+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : good+--+-- provide the SipHash algorithm.+-- reference: <http://131002.net/siphash/siphash.pdf>+--+{-# LANGUAGE BangPatterns #-}+{-# 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)
+ Data/Memory/Internal/Compat.hs view
@@ -0,0 +1,76 @@+-- |+-- Module      : Data.Memory.Internal.Compat+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : Good+--+-- This module try to keep all the difference between versions of base+-- or other needed packages, so that modules don't need to use CPP+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.Compat+    ( unsafeDoIO+    , popCount+    , unsafeShiftL+    , unsafeShiftR+    , byteSwap64+    , byteSwap32+    , byteSwap16+    ) where++import System.IO.Unsafe+import Data.Word+import Data.Bits++-- | perform io for hashes that do allocation and ffi.+-- unsafeDupablePerformIO is used when possible as the+-- computation is pure and the output is directly linked+-- to the input. we also do not modify anything after it has+-- been returned to the user.+unsafeDoIO :: IO a -> a+#if __GLASGOW_HASKELL__ > 704+unsafeDoIO = unsafeDupablePerformIO+#else+unsafeDoIO = unsafePerformIO+#endif++#if !(MIN_VERSION_base(4,5,0))+popCount :: Word64 -> Int+popCount n = loop 0 n+  where loop c 0 = c+        loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap64 :: Word64 -> Word64+byteSwap64 w =+        (w `shiftR` 56)                  .|. (w `shiftL` 56)+    .|. ((w `shiftR` 40) .&. 0xff00)     .|. ((w .&. 0xff00) `shiftL` 40)+    .|. ((w `shiftR` 24) .&. 0xff0000)   .|. ((w .&. 0xff0000) `shiftL` 24)+    .|. ((w `shiftR` 8)  .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap32 :: Word32 -> Word32+byteSwap32 w =+        (w `shiftR` 24)+    .|. (w `shiftL` 24)+    .|. ((w `shiftR` 8) .&. 0xff00)+    .|. ((w .&. 0xff00) `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,7,0))+byteSwap16 :: Word16 -> Word16+byteSwap16 w =+    (w `shiftR` 8) .|. (w `shiftL` 8)+#endif++#if !(MIN_VERSION_base(4,5,0))+unsafeShiftL :: Bits a => a -> Int -> a+unsafeShiftL = shiftL++unsafeShiftR :: Bits a => a -> Int -> a+unsafeShiftR = shiftR+#endif+
+ Data/Memory/Internal/CompatPrim.hs view
@@ -0,0 +1,70 @@+-- |+-- Module      : Data.Memory.Internal.CompatPrim+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : Compat+--+-- This module try to keep all the difference between versions of ghc primitive+-- or other needed packages, so that modules don't need to use CPP.+--+-- Note that MagicHash and CPP conflicts in places, making it "more interesting"+-- to write compat code for primitives+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+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 #-}
+ Data/Memory/Internal/CompatPrim64.hs view
@@ -0,0 +1,169 @@+-- |+-- Module      : Data.Memory.Internal.CompatPrim+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : stable+-- Portability : Compat+--+-- This module try to keep all the difference between versions of ghc primitive+-- or other needed packages, so that modules don't need to use CPP.+--+-- Note that MagicHash and CPP conflicts in places, making it "more interesting"+-- to write compat code for primitives+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+#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
+ Data/Memory/Internal/DeepSeq.hs view
@@ -0,0 +1,28 @@+-- |+-- Module      : Data.Memory.Internal.DeepSeq+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- Simple abstraction module to allow compilation without deepseq+-- by defining our own NFData class if not compiling with deepseq+-- support.+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.DeepSeq+    ( NFData(..)+    ) where++#ifdef WITH_DEEPSEQ_SUPPORT+import Control.DeepSeq+#else+import Data.Word++class NFData a where rnf :: a -> ()++instance NFData Word8 where rnf w = w `seq` ()+instance NFData Word16 where rnf w = w `seq` ()+instance NFData Word32 where rnf w = w `seq` ()+instance NFData Word64 where rnf w = w `seq` ()+#endif
+ Data/Memory/Internal/Imports.hs view
@@ -0,0 +1,17 @@+-- |+-- Module      : Data.Memory.Internal.Imports+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+{-# LANGUAGE CPP #-}+module Data.Memory.Internal.Imports+    ( module X+    ) where++import Data.Word                    as X+import Control.Applicative          as X+import Control.Monad                as X (forM, forM_, void, when)+import Control.Arrow                as X (first, second)+import Data.Memory.Internal.DeepSeq as X
+ Data/Memory/MemMap/Posix.hsc view
@@ -0,0 +1,222 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Memory.MemMap.Posix+-- Copyright   :  (c) Vincent Hanquez 2014+-- License     :  BSD-style+--+-- Maintainer  :  Vincent Hanquez+-- Stability   :  provisional+-- Portability :  non-portable (requires POSIX)+--+-- Functions defined by the POSIX standards for manipulating memory maps+--+-- When a function that calls an underlying POSIX function fails, the errno+-- code is converted to an 'IOError' using 'Foreign.C.Error.errnoToIOError'.+-- For a list of which errno codes may be generated, consult the POSIX+-- documentation for the underlying function.+--+-----------------------------------------------------------------------------++#include <sys/mman.h>+#include <unistd.h>++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}+module Data.Memory.MemMap.Posix+    ( memoryMap+    , memoryUnmap+    , memoryAdvise+    , memoryLock+    , memoryUnlock+    , memoryProtect+    , memorySync+    -- * Flags types+    , MemoryMapFlag(..)+    , MemoryProtection(..)+    , MemoryAdvice(..)+    , MemorySyncFlag(..)+    -- * system page size+    , sysconfPageSize+    ) where++import System.Posix.Types+import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.Error+import Data.Bits++foreign import ccall unsafe "mmap"+    c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)++foreign import ccall unsafe "munmap"+    c_munmap :: Ptr a -> CSize -> IO CInt++#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)
+ Data/Memory/MemMap/Windows.hs view
@@ -0,0 +1,12 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Memory.MemMap.Windows+-- Copyright   :  (c) Vincent Hanquez 2014+-- License     :  BSD-style+-- Maintainer  :  Vincent Hanquez+-- Stability   :  provisional+-- Portability :  non-portable (requires Windows)+--+module Data.Memory.MemMap.Windows+    (+    ) where
+ Data/Memory/PtrMethods.hs view
@@ -0,0 +1,120 @@+-- |+-- Module      : Data.Memory.PtrMethods+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unknown+--+-- methods to manipulate raw memory representation+--+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Data.Memory.PtrMethods+    ( memCreateTemporary+    , memXor+    , memXorWith+    , memCopy+    , memSet+    , 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 ()
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2015-2018 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2017-2018 Nicolas Di Prima <nicolas@primetype.co.uk>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,29 @@+memory+======++[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses)+[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org)++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).+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ram.cabal view
@@ -0,0 +1,113 @@+cabal-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 <vincent@snarc.org>+author:          Vincent Hanquez <vincent@snarc.org>+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
+ tests/Imports.hs view
@@ -0,0 +1,73 @@+{-# 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)
+ tests/SipHash.hs view
@@ -0,0 +1,89 @@+module 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+    ]
+ tests/Tests.hs view
@@ -0,0 +1,251 @@+{-# 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)+        ]
+ tests/Utils.hs view
@@ -0,0 +1,25 @@+module 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..]