diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/Data/ByteArray.hs b/Data/ByteArray.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Data.ByteArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple and efficient byte array types +-- +-- This module should be imported qualified. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Data.ByteArray + ( + -- * ByteArray Classes + module Data.ByteArray.Types + -- * ByteArray built-in types + , module Data.ByteArray.Bytes + , module Data.ByteArray.ScrubbedBytes + , module Data.ByteArray.MemView + , module Data.ByteArray.View + -- * ByteArray methods + , module Data.ByteArray.Methods + ) where + +import Data.ByteArray.Types +import Data.ByteArray.Methods +import Data.ByteArray.ScrubbedBytes (ScrubbedBytes) +import Data.ByteArray.Bytes (Bytes) +import Data.ByteArray.MemView (MemView(..)) +import Data.ByteArray.View (View, view, takeView, dropView) diff --git a/Data/ByteArray/Bytes.hs b/Data/ByteArray/Bytes.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Bytes.hs @@ -0,0 +1,208 @@ +-- | +-- Module : Data.ByteArray.Bytes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- Simple and efficient byte array types +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ByteArray.Bytes + ( Bytes + ) where + +#if MIN_VERSION_base(4,15,0) +import GHC.Exts (unsafeCoerce#) +#endif +import GHC.Word +import GHC.Char (chr) +import GHC.Types +import GHC.Prim +import GHC.Ptr +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +import Data.Foldable (toList) +#else +import Data.Monoid +#endif +import Data.Memory.PtrMethods +import Data.Memory.Internal.Imports +import Data.Memory.Internal.CompatPrim +import Data.Memory.Internal.Compat (unsafeDoIO) +import Data.ByteArray.Types +import Data.Typeable + + +-- | Simplest Byte Array +data Bytes = Bytes (MutableByteArray# RealWorld) + deriving (Typeable) + +instance Show Bytes where + showsPrec p b r = showsPrec p (bytesUnpackChars b []) r +instance Eq Bytes where + (==) = bytesEq +instance Ord Bytes where + compare = bytesCompare +#if MIN_VERSION_base(4,9,0) +instance Semigroup Bytes where + b1 <> b2 = unsafeDoIO $ bytesAppend b1 b2 + sconcat = unsafeDoIO . bytesConcat . toList +#endif +instance Monoid Bytes where + mempty = unsafeDoIO (newBytes 0) +#if !(MIN_VERSION_base(4,11,0)) + mappend b1 b2 = unsafeDoIO $ bytesAppend b1 b2 + mconcat = unsafeDoIO . bytesConcat +#endif +instance NFData Bytes where + rnf b = b `seq` () +instance ByteArrayAccess Bytes where + length = bytesLength + withByteArray = withBytes +instance ByteArray Bytes where + allocRet = bytesAllocRet + +------------------------------------------------------------------------ +newBytes :: Int -> IO Bytes +newBytes (I# sz) + | booleanPrim (sz <# 0#) = error "Bytes: size must be >= 0" + | otherwise = IO $ \s -> + case newAlignedPinnedByteArray# sz 8# s of + (# s', mbarr #) -> (# s', Bytes mbarr #) + +touchBytes :: Bytes -> IO () +touchBytes (Bytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #) +{-# INLINE touchBytes #-} + +sizeofBytes :: Bytes -> Int +sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba) +{-# INLINE sizeofBytes #-} + +withPtr :: Bytes -> (Ptr p -> IO a) -> IO a +withPtr b@(Bytes mba) f = do + a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba))) + touchBytes b + return a +------------------------------------------------------------------------ + +bytesAlloc :: Int -> (Ptr p -> IO ()) -> IO Bytes +bytesAlloc sz f = do + ba <- newBytes sz + withPtr ba f + return ba + +bytesConcat :: [Bytes] -> IO Bytes +bytesConcat l = bytesAlloc retLen (copy l) + where + !retLen = sum $ map bytesLength l + + copy [] _ = return () + copy (x:xs) dst = do + withPtr x $ \src -> memCopy dst src chunkLen + copy xs (dst `plusPtr` chunkLen) + where + !chunkLen = bytesLength x + +bytesAppend :: Bytes -> Bytes -> IO Bytes +bytesAppend b1 b2 = bytesAlloc retLen $ \dst -> do + withPtr b1 $ \s1 -> memCopy dst s1 len1 + withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2 + where + !len1 = bytesLength b1 + !len2 = bytesLength b2 + !retLen = len1 + len2 + +bytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, Bytes) +bytesAllocRet sz f = do + ba <- newBytes sz + r <- withPtr ba f + return (r, ba) + +bytesLength :: Bytes -> Int +bytesLength = sizeofBytes +{-# LANGUAGE bytesLength #-} + +withBytes :: Bytes -> (Ptr p -> IO a) -> IO a +withBytes = withPtr + +bytesEq :: Bytes -> Bytes -> Bool +bytesEq b1@(Bytes m1) b2@(Bytes m2) + | l1 /= l2 = False + | otherwise = unsafeDoIO $ IO $ \s -> loop 0# s + where + !l1@(I# len) = bytesLength b1 + !l2 = bytesLength b2 + + loop i s + | booleanPrim (i ==# len) = (# s, True #) + | otherwise = + case readWord8Array# m1 i s of + (# s', e1 #) -> case readWord8Array# m2 i s' of + (# s'', e2 #) -> + if (W8# e1) == (W8# e2) + then loop (i +# 1#) s'' + else (# s'', False #) + {-# INLINE loop #-} + +bytesCompare :: Bytes -> Bytes -> Ordering +bytesCompare b1@(Bytes m1) b2@(Bytes m2) = unsafeDoIO $ loop 0 + where + !l1 = bytesLength b1 + !l2 = bytesLength b2 + !len = min l1 l2 + + loop !i + | i == len = + if l1 == l2 + then pure EQ + else if l1 > l2 then pure GT + else pure LT + | otherwise = do + e1 <- read8 m1 i + e2 <- read8 m2 i + if e1 == e2 + then loop (i+1) + else if e1 < e2 then pure LT + else pure GT + + read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of + (# s2, e #) -> (# s2, W8# e #) + +bytesUnpackChars :: Bytes -> String -> String +bytesUnpackChars (Bytes mba) xs = chunkLoop 0# + where + !len = sizeofMutableByteArray# mba + -- chunk 64 bytes at a time + chunkLoop :: Int# -> [Char] + chunkLoop idx + | booleanPrim (len ==# idx) = [] + | booleanPrim ((len -# idx) ># 63#) = + bytesLoop idx 64# (chunkLoop (idx +# 64#)) + | otherwise = + bytesLoop idx (len -# idx) xs + + bytesLoop idx chunkLenM1 paramAcc = unsafeDoIO $ + loop (idx +# chunkLenM1 -# 1#) paramAcc + where loop i acc + | booleanPrim (i ==# idx) = do + c <- rChar i + return (c : acc) + | otherwise = do + c <- rChar i + loop (i -# 1#) (c : acc) + + rChar :: Int# -> IO Char + rChar idx = IO $ \s -> + case readWord8Array# mba idx s of + (# s2, w #) -> (# s2, chr (fromIntegral (W8# w)) #) + +{- +bytesShowHex :: Bytes -> String +bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b) +{-# NOINLINE bytesShowHex #-} +-} diff --git a/Data/ByteArray/Encoding.hs b/Data/ByteArray/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Encoding.hs @@ -0,0 +1,162 @@ +-- | +-- Module : Data.ByteArray.Encoding +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Base conversions for 'ByteArray'. +-- +module Data.ByteArray.Encoding + ( convertToBase + , convertFromBase + , Base(..) + ) where + +import Data.ByteArray.Types +import qualified Data.ByteArray.Types as B +import qualified Data.ByteArray.Methods as B +import Data.Memory.Internal.Compat +import Data.Memory.Encoding.Base16 +import Data.Memory.Encoding.Base32 +import Data.Memory.Encoding.Base64 + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.ByteString + +-- | The different bases that can be used. +-- +-- See for details. +-- In particular, Base64 can be standard or +-- . URL-safe +-- encoding is often used in other specifications without +-- characters. +-- +-- +-- defines a separate Base64 encoding, which is not supported. This format +-- requires a newline at least every 76 encoded characters, which works around +-- limitations of older email programs that could not handle long lines. +-- Be aware that other languages, such as Ruby, encode the RFC 2045 version +-- by default. To decode their output, remove all newlines before decoding. +-- +-- ==== Examples +-- +-- A quick example to show the differences: +-- +-- >>> let input = "Is 3 > 2?" :: ByteString +-- >>> let convertedTo base = convertToBase base input :: ByteString +-- >>> convertedTo Base16 +-- "49732033203e20323f" +-- >>> convertedTo Base32 +-- "JFZSAMZAHYQDEPY=" +-- >>> convertedTo Base64 +-- "SXMgMyA+IDI/" +-- >>> convertedTo Base64URLUnpadded +-- "SXMgMyA-IDI_" +-- >>> convertedTo Base64OpenBSD +-- "QVKeKw.8GBG9" +-- +data Base = Base16 -- ^ similar to hexadecimal + | Base32 + | Base64 -- ^ standard Base64 + | Base64URLUnpadded -- ^ unpadded URL-safe Base64 + | Base64OpenBSD -- ^ Base64 as used in OpenBSD password encoding (such as bcrypt) + deriving (Show,Eq) + +-- | Encode some bytes to the equivalent representation in a specific 'Base'. +-- +-- ==== Examples +-- +-- Convert a 'ByteString' to base-64: +-- +-- >>> convertToBase Base64 ("foobar" :: ByteString) :: ByteString +-- "Zm9vYmFy" +-- +convertToBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> bout +convertToBase base b = case base of + Base16 -> doConvert (binLength * 2) toHexadecimal + Base32 -> let (q,r) = binLength `divMod` 5 + outLen = 8 * (if r == 0 then q else q + 1) + in doConvert outLen toBase32 + Base64 -> doConvert base64Length toBase64 + -- Base64URL -> doConvert base64Length (toBase64URL True) + Base64URLUnpadded -> doConvert base64UnpaddedLength (toBase64URL False) + Base64OpenBSD -> doConvert base64UnpaddedLength toBase64OpenBSD + where + binLength = B.length b + + base64Length = let (q,r) = binLength `divMod` 3 + in 4 * (if r == 0 then q else q+1) + + base64UnpaddedLength = let (q,r) = binLength `divMod` 3 + in 4 * q + (if r == 0 then 0 else r+1) + doConvert l f = + B.unsafeCreate l $ \bout -> + B.withByteArray b $ \bin -> + f bout bin binLength + +-- | Try to decode some bytes from the equivalent representation in a specific 'Base'. +-- +-- ==== Examples +-- +-- Successfully convert from base-64 to a 'ByteString': +-- +-- >>> convertFromBase Base64 ("Zm9vYmFy" :: ByteString) :: Either String ByteString +-- Right "foobar" +-- +-- Trying to decode invalid data will return an error string: +-- +-- >>> convertFromBase Base64 ("!!!" :: ByteString) :: Either String ByteString +-- Left "base64: input: invalid length" +-- +convertFromBase :: (ByteArrayAccess bin, ByteArray bout) => Base -> bin -> Either String bout +convertFromBase Base16 b + | odd (B.length b) = Left "base16: input: invalid length" + | otherwise = unsafeDoIO $ do + (ret, out) <- + B.allocRet (B.length b `div` 2) $ \bout -> + B.withByteArray b $ \bin -> + fromHexadecimal bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base16: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base32 b = unsafeDoIO $ + withByteArray b $ \bin -> do + mDstLen <- unBase32Length bin (B.length b) + case mDstLen of + Nothing -> return $ Left "base32: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase32 bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base32: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64 b = unsafeDoIO $ + withByteArray b $ \bin -> do + mDstLen <- unBase64Length bin (B.length b) + case mDstLen of + Nothing -> return $ Left "base64: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64 bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64URLUnpadded b = unsafeDoIO $ + withByteArray b $ \bin -> + case unBase64LengthUnpadded (B.length b) of + Nothing -> return $ Left "base64URL unpadded: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64URLUnpadded bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64URL unpadded: input: invalid encoding at offset: " ++ show ofs) +convertFromBase Base64OpenBSD b = unsafeDoIO $ + withByteArray b $ \bin -> + case unBase64LengthUnpadded (B.length b) of + Nothing -> return $ Left "base64 unpadded: input: invalid length" + Just dstLen -> do + (ret, out) <- B.allocRet dstLen $ \bout -> fromBase64OpenBSD bout bin (B.length b) + case ret of + Nothing -> return $ Right out + Just ofs -> return $ Left ("base64 unpadded: input: invalid encoding at offset: " ++ show ofs) + diff --git a/Data/ByteArray/Hash.hs b/Data/ByteArray/Hash.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Hash.hs @@ -0,0 +1,78 @@ +-- | +-- Module : Data.ByteArray.Hash +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteArray.Hash + ( + -- * SipHash + SipKey(..) + , SipHash(..) + , sipHash + , sipHashWith + -- * FNV1 and FNV1a (32 and 64 bits) + , FnvHash32(..) + , FnvHash64(..) + , fnv1Hash + , fnv1aHash + , fnv1_64Hash + , fnv1a_64Hash + ) where + +import Data.Memory.Internal.Compat +import Data.Memory.Hash.SipHash +import Data.Memory.Hash.FNV +import qualified Data.ByteArray.Types as B + +-- | Compute the SipHash tag of a byte array for a given key. +-- +-- 'sipHash` is equivalent to 'sipHashWith 2 4' +sipHash :: B.ByteArrayAccess ba + => SipKey + -> ba + -> SipHash +sipHash key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hash key p (B.length ba) + +-- | Compute the SipHash tag of a byte array for a given key. +-- +-- The user can choose the C and D numbers of rounds. +-- +-- calling 'sipHash` is equivalent to 'sipHashWith 2 4' +sipHashWith :: B.ByteArrayAccess ba + => Int -- ^ c rounds + -> Int -- ^ d rounds + -> SipKey -- ^ key + -> ba -- ^ data to hash + -> SipHash +sipHashWith c d key ba = unsafeDoIO $ B.withByteArray ba $ \p -> hashWith c d key p (B.length ba) + + +-- | Compute the FNV1 32 bit hash value of a byte array +fnv1Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash32 +fnv1Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1 p (B.length ba) + +-- | Compute the FNV1a 32 bit hash value of a byte array +fnv1aHash :: B.ByteArrayAccess ba + => ba + -> FnvHash32 +fnv1aHash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a p (B.length ba) + +-- | Compute the FNV1 64 bit hash value of a byte array +fnv1_64Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash64 +fnv1_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1_64 p (B.length ba) + +-- | Compute the FNV1a 64 bit hash value of a byte array +fnv1a_64Hash :: B.ByteArrayAccess ba + => ba + -> FnvHash64 +fnv1a_64Hash ba = unsafeDoIO $ B.withByteArray ba $ \p -> fnv1a_64 p (B.length ba) diff --git a/Data/ByteArray/Mapping.hs b/Data/ByteArray/Mapping.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Mapping.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Data.ByteArray.Mapping +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +module Data.ByteArray.Mapping + ( toW64BE + , toW64LE + , fromW64BE + , mapAsWord64 + , mapAsWord128 + ) where + +import Data.ByteArray.Types +import Data.ByteArray.Methods +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports hiding (empty) +import Data.Memory.Endian +import Data.Memory.ExtendedWords +import Foreign.Storable +import Foreign.Ptr + +import Prelude hiding (length, take, drop, span, concat, replicate, splitAt, null, pred) + +-- | Transform a bytearray at a specific offset into +-- a Word64 tagged as BE (Big Endian) +-- +-- no bounds checking. unsafe +toW64BE :: ByteArrayAccess bs => bs -> Int -> BE Word64 +toW64BE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs) + +-- | Transform a bytearray at a specific offset into +-- a Word64 tagged as LE (Little Endian) +-- +-- no bounds checking. unsafe +toW64LE :: ByteArrayAccess bs => bs -> Int -> LE Word64 +toW64LE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs) + +-- | Serialize a @Word64@ to a @ByteArray@ in big endian format +fromW64BE :: (ByteArray ba) => Word64 -> ba +fromW64BE n = allocAndFreeze 8 $ \p -> poke p (toBE n) + +-- | map blocks of 128 bits of a bytearray, creating a new bytestring +-- of equivalent size where each blocks has been mapped through @f@ +-- +-- no length checking is done. unsafe +mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs +mapAsWord128 f bs = + unsafeCreate len $ \dst -> + withByteArray bs $ \src -> + loop (len `div` 16) dst src + where + len = length bs + loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO () + loop 0 _ _ = return () + loop i d s = do + w1 <- peek s + w2 <- peek (s `plusPtr` 8) + let (Word128 r1 r2) = f (Word128 (fromBE w1) (fromBE w2)) + poke d (toBE r1) + poke (d `plusPtr` 8) (toBE r2) + loop (i-1) (d `plusPtr` 16) (s `plusPtr` 16) + +-- | map blocks of 64 bits of a bytearray, creating a new bytestring +-- of equivalent size where each blocks has been mapped through @f@ +-- +-- no length checking is done. unsafe +mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs +mapAsWord64 f bs = + unsafeCreate len $ \dst -> + withByteArray bs $ \src -> + loop (len `div` 8) dst src + where + len = length bs + + loop :: Int -> Ptr (BE Word64) -> Ptr (BE Word64) -> IO () + loop 0 _ _ = return () + loop i d s = do + w <- peek s + let r = f (fromBE w) + poke d (toBE r) + loop (i-1) (d `plusPtr` 8) (s `plusPtr` 8) diff --git a/Data/ByteArray/MemView.hs b/Data/ByteArray/MemView.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/MemView.hs @@ -0,0 +1,38 @@ +-- | +-- Module : Data.ByteArray.MemView +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +module Data.ByteArray.MemView + ( MemView(..) + , memViewPlus + ) where + +import Foreign.Ptr +import Data.ByteArray.Types +import Data.Memory.Internal.Imports + +-- | A simple abstraction to a piece of memory. +-- +-- Do beware that garbage collection related to +-- piece of memory could be triggered before this +-- is used. +-- +-- Only use with the appropriate handler has been +-- used (e.g. withForeignPtr on ForeignPtr) +-- +data MemView = MemView {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !Int + deriving (Show,Eq) + +instance ByteArrayAccess MemView where + length (MemView _ l) = l + withByteArray (MemView p _) f = f (castPtr p) + +-- | Increase the memory view while reducing the size of the window +-- +-- this is useful as an abstraction to represent the current offset +-- in a buffer, and the remaining bytes left. +memViewPlus :: MemView -> Int -> MemView +memViewPlus (MemView p len) n = MemView (p `plusPtr` n) (len - n) diff --git a/Data/ByteArray/Methods.hs b/Data/ByteArray/Methods.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Methods.hs @@ -0,0 +1,301 @@ +-- | +-- Module : Data.ByteArray.Methods +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Data.ByteArray.Methods + ( alloc + , allocAndFreeze + , create + , unsafeCreate + , pack + , unpack + , uncons + , empty + , singleton + , cons + , snoc + , null + , replicate + , zero + , copy + , take + , drop + , span + , reverse + , convert + , copyRet + , copyAndFreeze + , splitAt + , xor + , index + , eq + , constEq + , any + , all + , append + , concat + ) where + +import Data.ByteArray.Types +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports hiding (empty) +import Data.Memory.PtrMethods +import Data.Monoid +import Foreign.Storable +import Foreign.Ptr + +import Prelude hiding (length, take, drop, span, reverse, concat, replicate, splitAt, null, pred, last, any, all) +import qualified Prelude + + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +alloc :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba +alloc n f + | n < 0 = alloc 0 f + | otherwise = snd `fmap` allocRet n f +{-# INLINE alloc #-} + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +create :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba +create n f = alloc n f + +-- | similar to 'alloc' but hide the allocation and initializer in a pure context +allocAndFreeze :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +allocAndFreeze sz f = unsafeDoIO (alloc sz f) +{-# NOINLINE allocAndFreeze #-} + +-- | similar to 'create' but hide the allocation and initializer in a pure context +unsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +unsafeCreate sz f = unsafeDoIO (alloc sz f) +{-# NOINLINE unsafeCreate #-} + +inlineUnsafeCreate :: ByteArray a => Int -> (Ptr p -> IO ()) -> a +inlineUnsafeCreate !sz f = unsafeDoIO (alloc sz f) +{-# INLINE inlineUnsafeCreate #-} + +-- | Create an empty byte array +empty :: ByteArray a => a +empty = unsafeDoIO (alloc 0 $ \_ -> return ()) + +-- | Check if a byte array is empty +null :: ByteArrayAccess a => a -> Bool +null b = length b == 0 + +-- | Pack a list of bytes into a bytearray +pack :: ByteArray a => [Word8] -> a +pack l = inlineUnsafeCreate (Prelude.length l) (fill l) + where fill [] _ = return () + fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1) + {-# INLINE fill #-} +{-# NOINLINE pack #-} + +-- | Un-pack a bytearray into a list of bytes +unpack :: ByteArrayAccess a => a -> [Word8] +unpack bs = loop 0 + where !len = length bs + loop i + | i == len = [] + | otherwise = + let !v = unsafeDoIO $ withByteArray bs (\p -> peekByteOff p i) + in v : loop (i+1) + +-- | returns the first byte, and the remaining bytearray if the bytearray is not null +uncons :: ByteArray a => a -> Maybe (Word8, a) +uncons a + | null a = Nothing + | otherwise = Just (index a 0, drop 1 a) + +-- | Create a byte array from a single byte +singleton :: ByteArray a => Word8 -> a +singleton b = unsafeCreate 1 (\p -> pokeByteOff p 0 b) + +-- | prepend a single byte to a byte array +cons :: ByteArray a => Word8 -> a -> a +cons b ba = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do + pokeByteOff d 0 b + memCopy (d `plusPtr` 1) s len + where len = length ba + +-- | append a single byte to a byte array +snoc :: ByteArray a => a -> Word8 -> a +snoc ba b = unsafeCreate (len + 1) $ \d -> withByteArray ba $ \s -> do + memCopy d s len + pokeByteOff d len b + where len = length ba + +-- | Create a xor of bytes between a and b. +-- +-- the returns byte array is the size of the smallest input. +xor :: (ByteArrayAccess a, ByteArrayAccess b, ByteArray c) => a -> b -> c +xor a b = + unsafeCreate n $ \pc -> + withByteArray a $ \pa -> + withByteArray b $ \pb -> + memXor pc pa pb n + where + n = min la lb + la = length a + lb = length b + +-- | return a specific byte indexed by a number from 0 in a bytearray +-- +-- unsafe, no bound checking are done +index :: ByteArrayAccess a => a -> Int -> Word8 +index b i = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i) + +-- | Split a bytearray at a specific length in two bytearray +splitAt :: ByteArray bs => Int -> bs -> (bs, bs) +splitAt n bs + | n <= 0 = (empty, bs) + | n >= len = (bs, empty) + | otherwise = unsafeDoIO $ do + withByteArray bs $ \p -> do + b1 <- alloc n $ \r -> memCopy r p n + b2 <- alloc (len - n) $ \r -> memCopy r (p `plusPtr` n) (len - n) + return (b1, b2) + where len = length bs + +-- | Take the first @n@ byte of a bytearray +take :: ByteArray bs => Int -> bs -> bs +take n bs + | n <= 0 = empty + | otherwise = unsafeCreate m $ \d -> withByteArray bs $ \s -> memCopy d s m + where + !m = min len n + !len = length bs + +-- | drop the first @n@ byte of a bytearray +drop :: ByteArray bs => Int -> bs -> bs +drop n bs + | n <= 0 = bs + | nb == 0 = empty + | otherwise = unsafeCreate nb $ \d -> withByteArray bs $ \s -> memCopy d (s `plusPtr` ofs) nb + where + ofs = min len n + nb = len - ofs + len = length bs + +-- | Split a bytearray at the point where @pred@ becomes invalid +span :: ByteArray bs => (Word8 -> Bool) -> bs -> (bs, bs) +span pred bs + | null bs = (bs, bs) + | otherwise = let n = loop 0 in (take n bs, drop n bs) + where loop !i + | i >= len = len + | pred (index bs i) = loop (i+1) + | otherwise = i + len = length bs + +-- | Reverse a bytearray +reverse :: ByteArray bs => bs -> bs +reverse bs = unsafeCreate n $ \d -> withByteArray bs $ \s -> memReverse d s n + where n = length bs + +-- | Concatenate bytearray into a larger bytearray +concat :: (ByteArrayAccess bin, ByteArray bout) => [bin] -> bout +concat l = unsafeCreate retLen (loopCopy l) + where + retLen = sum $ map length l + + loopCopy [] _ = return () + loopCopy (x:xs) dst = do + copyByteArrayToPtr x dst + loopCopy xs (dst `plusPtr` chunkLen) + where + !chunkLen = length x + +-- | append one bytearray to the other +append :: ByteArray bs => bs -> bs -> bs +append = mappend + +-- | Duplicate a bytearray into another bytearray, and run an initializer on it +copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2 +copy bs f = + alloc (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) + +-- | Similar to 'copy' but also provide a way to return a value from the initializer +copyRet :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2) +copyRet bs f = + allocRet (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) + +-- | Similiar to 'copy' but expect the resulting bytearray in a pure context +copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2 +copyAndFreeze bs f = + inlineUnsafeCreate (length bs) $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) +{-# NOINLINE copyAndFreeze #-} + +-- | Create a bytearray of a specific size containing a repeated byte value +replicate :: ByteArray ba => Int -> Word8 -> ba +replicate 0 _ = empty +replicate n b + | n < 0 = empty + | otherwise = inlineUnsafeCreate n $ \ptr -> memSet ptr b n +{-# NOINLINE replicate #-} + +-- | Create a bytearray of a specific size initialized to 0 +zero :: ByteArray ba => Int -> ba +zero 0 = empty +zero n + | n < 0 = empty + | otherwise = unsafeCreate n $ \ptr -> memSet ptr 0 n +{-# NOINLINE zero #-} + +-- | Check if two bytearray are equals +-- +-- This is not constant time, as soon some byte differs the function will +-- returns. use 'constEq' in sensitive context where timing matters. +eq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool +eq b1 b2 + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memEqual p1 p2 l1 + where + l1 = length b1 + l2 = length b2 + +-- | A constant time equality test for 2 ByteArrayAccess values. +-- +-- If values are of 2 different sizes, the function will abort early +-- without comparing any bytes. +-- +-- compared to == , this function will go over all the bytes +-- present before yielding a result even when knowing the +-- overall result early in the processing. +constEq :: (ByteArrayAccess bs1, ByteArrayAccess bs2) => bs1 -> bs2 -> Bool +constEq b1 b2 + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withByteArray b1 $ \p1 -> withByteArray b2 $ \p2 -> memConstEqual p1 p2 l1 + where + !l1 = length b1 + !l2 = length b2 + +-- | Check if any element of a byte array satisfies a predicate +any :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool +any f b + | null b = False + | otherwise = unsafeDoIO $ withByteArray b $ \p -> loop p 0 + where + len = length b + loop p i + | i == len = return False + | otherwise = do + w <- peekByteOff p i + if f w then return True else loop p (i+1) + +-- | Check if all elements of a byte array satisfy a predicate +all :: (ByteArrayAccess ba) => (Word8 -> Bool) -> ba -> Bool +all f b = not (any (not . f) b) + +-- | Convert a bytearray to another type of bytearray +convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout +convert bs = inlineUnsafeCreate (length bs) (copyByteArrayToPtr bs) diff --git a/Data/ByteArray/Pack.hs b/Data/ByteArray/Pack.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Pack.hs @@ -0,0 +1,145 @@ +-- | +-- Module : Data.ByteArray.Pack +-- License : BSD-Style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple Byte Array packer +-- +-- Simple example: +-- +-- > > flip pack 20 $ putWord8 0x41 >> putByteString "BCD" >> putWord8 0x20 >> putStorable (42 :: Word32) +-- > Right (ABCD *\NUL\NUL\NUL") +-- +-- Original code from +-- generalized and adapted to run on 'memory', and spellchecked / tweaked. (2015-05) +-- Copyright (c) 2014 Nicolas DI PRIMA +-- +module Data.ByteArray.Pack + ( Packer + , Result(..) + , fill + , pack + -- * Operations + -- ** put + , putWord8 + , putWord16 + , putWord32 + , putStorable + , putBytes + , fillList + , fillUpWith + -- ** skip + , skip + , skipStorable + ) where + +import Data.Word +import Foreign.Ptr +import Foreign.Storable +import Data.Memory.Internal.Imports () +import Data.Memory.Internal.Compat +import Data.Memory.PtrMethods +import Data.ByteArray.Pack.Internal +import Data.ByteArray (ByteArray, ByteArrayAccess, MemView(..)) +import qualified Data.ByteArray as B + +-- | Fill a given sized buffer with the result of the Packer action +fill :: ByteArray byteArray => Int -> Packer a -> Either String byteArray +fill len packing = unsafeDoIO $ do + (val, out) <- B.allocRet len $ \ptr -> runPacker_ packing (MemView ptr len) + case val of + PackerMore _ (MemView _ r) + | r == 0 -> return $ Right out + | otherwise -> return $ Left ("remaining unpacked bytes " ++ show r ++ " at the end of buffer") + PackerFail err -> return $ Left err + +-- | Pack the given packer into the given bytestring +pack :: ByteArray byteArray => Packer a -> Int -> Either String byteArray +pack packing len = fill len packing +{-# DEPRECATED pack "use fill instead" #-} + +fillUpWithWord8' :: Word8 -> Packer () +fillUpWithWord8' w = Packer $ \(MemView ptr size) -> do + memSet ptr w size + return $ PackerMore () (MemView (ptr `plusPtr` size) 0) + +-- | Put a storable from the current position in the stream +putStorable :: Storable storable => storable -> Packer () +putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s) + +-- | Put a Byte Array from the current position in the stream +-- +-- If the ByteArray is null, then do nothing +putBytes :: ByteArrayAccess ba => ba -> Packer () +putBytes bs + | neededLength == 0 = return () + | otherwise = + actionPacker neededLength $ \dstPtr -> B.withByteArray bs $ \srcPtr -> + memCopy dstPtr srcPtr neededLength + where + neededLength = B.length bs + +-- | Skip some bytes from the current position in the stream +skip :: Int -> Packer () +skip n = actionPacker n (\_ -> return ()) + +-- | Skip the size of a storable from the current position in the stream +skipStorable :: Storable storable => storable -> Packer () +skipStorable = skip . sizeOf + +-- | Fill up from the current position in the stream to the end +-- +-- It is equivalent to: +-- +-- > fillUpWith s == fillList (repeat s) +-- +fillUpWith :: Storable storable => storable -> Packer () +fillUpWith s = fillList $ repeat s +{-# RULES "fillUpWithWord8" forall s . fillUpWith s = fillUpWithWord8' s #-} +{-# NOINLINE fillUpWith #-} + +-- | Will put the given storable list from the current position in the stream +-- to the end. +-- +-- This function will fail with not enough storage if the given storable can't +-- be written (not enough space) +-- +-- Example: +-- +-- > > pack (fillList $ [1..] :: Word8) 9 +-- > "\1\2\3\4\5\6\7\8\9" +-- > > pack (fillList $ [1..] :: Word32) 4 +-- > "\1\0\0\0" +-- > > pack (fillList $ [1..] :: Word32) 64 +-- > .. <..succesful..> +-- > > pack (fillList $ [1..] :: Word32) 1 +-- > .. <.. not enough space ..> +-- > > pack (fillList $ [1..] :: Word32) 131 +-- > .. <.. not enough space ..> +-- +fillList :: Storable storable => [storable] -> Packer () +fillList [] = return () +fillList (x:xs) = putStorable x >> fillList xs + +------------------------------------------------------------------------------ +-- Common packer -- +------------------------------------------------------------------------------ + +-- | put Word8 in the current position in the stream +putWord8 :: Word8 -> Packer () +putWord8 = putStorable +{-# INLINE putWord8 #-} + +-- | put Word16 in the current position in the stream +-- /!\ use Host Endianness +putWord16 :: Word16 -> Packer () +putWord16 = putStorable +{-# INLINE putWord16 #-} + +-- | put Word32 in the current position in the stream +-- /!\ use Host Endianness +putWord32 :: Word32 -> Packer () +putWord32 = putStorable +{-# INLINE putWord32 #-} diff --git a/Data/ByteArray/Pack/Internal.hs b/Data/ByteArray/Pack/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Pack/Internal.hs @@ -0,0 +1,88 @@ +-- | +-- Module : Data.ByteArray.Pack.Internal +-- License : BSD-Style +-- Copyright : Copyright © 2014 Nicolas DI PRIMA +-- +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +module Data.ByteArray.Pack.Internal + ( Result(..) + , Packer(..) + , actionPacker + , actionPackerWithRemain + ) where + +import Foreign.Ptr (Ptr) +import Data.ByteArray.MemView +import Data.Memory.Internal.Imports + +-- | Packing result: +-- +-- * PackerMore: the next state of Packing with an arbitrary value +-- * PackerFail: an error happened +data Result a = + PackerMore a MemView + | PackerFail String + deriving (Show) + +-- | Simple ByteArray Packer +newtype Packer a = Packer { runPacker_ :: MemView -> IO (Result a) } + +instance Functor Packer where + fmap = fmapPacker + +instance Applicative Packer where + pure = returnPacker + (<*>) = appendPacker + +instance Monad Packer where + return = pure + (>>=) = bindPacker + +fmapPacker :: (a -> b) -> Packer a -> Packer b +fmapPacker f p = Packer $ \cache -> do + rv <- runPacker_ p cache + return $ case rv of + PackerMore v cache' -> PackerMore (f v) cache' + PackerFail err -> PackerFail err +{-# INLINE fmapPacker #-} + +returnPacker :: a -> Packer a +returnPacker v = Packer $ \cache -> return $ PackerMore v cache +{-# INLINE returnPacker #-} + +bindPacker :: Packer a -> (a -> Packer b) -> Packer b +bindPacker p fp = Packer $ \cache -> do + rv <- runPacker_ p cache + case rv of + PackerMore v cache' -> runPacker_ (fp v) cache' + PackerFail err -> return $ PackerFail err +{-# INLINE bindPacker #-} + +appendPacker :: Packer (a -> b) -> Packer a -> Packer b +appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v) +{-# INLINE appendPacker #-} + +-- | run a sized action +actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a +actionPacker s action = Packer $ \m@(MemView ptr size) -> + case compare size s of + LT -> return $ PackerFail "Not enough space in destination" + _ -> do + v <- action ptr + return $ PackerMore v (m `memViewPlus` s) +{-# INLINE actionPacker #-} + +-- | run a sized action +actionPackerWithRemain :: Int -> (Ptr Word8 -> Int -> IO (Int, a)) -> Packer a +actionPackerWithRemain s action = Packer $ \m@(MemView ptr size) -> + case compare size s of + LT -> return $ PackerFail "Not enough space in destination" + _ -> do + (remain, v) <- action ptr size + return $ if remain > s + then PackerFail "remaining bytes higher than the destination's size" + else PackerMore v (m `memViewPlus` (s+remain)) +{-# INLINE actionPackerWithRemain #-} diff --git a/Data/ByteArray/Parse.hs b/Data/ByteArray/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Parse.hs @@ -0,0 +1,258 @@ +-- | +-- Module : Data.ByteArray.Parse +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- A very simple bytearray parser related to Parsec and Attoparsec +-- +-- Simple example: +-- +-- > > parse ((,,) <$> take 2 <*> byte 0x20 <*> (bytes "abc" *> anyByte)) "xx abctest" +-- > ParseOK "est" ("xx", 116) +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE OverloadedStrings #-} +module Data.ByteArray.Parse + ( Parser + , Result(..) + -- * run the Parser + , parse + , parseFeed + -- * Parser methods + , hasMore + , byte + , anyByte + , bytes + , take + , takeWhile + , takeAll + , skip + , skipWhile + , skipAll + , takeStorable + ) where + +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Foreign.Storable (Storable, peek, sizeOf) +import Data.Word + +import Data.Memory.Internal.Imports +import Data.Memory.Internal.Compat +import Data.ByteArray.Types (ByteArrayAccess, ByteArray) +import qualified Data.ByteArray.Types as B +import qualified Data.ByteArray.Methods as B + +import Prelude hiding (take, takeWhile) + +-- | Simple parsing result, that represent respectively: +-- +-- * failure: with the error message +-- +-- * continuation: that need for more input data +-- +-- * success: the remaining unparsed data and the parser value +data Result byteArray a = + ParseFail String + | ParseMore (Maybe byteArray -> Result byteArray a) + | ParseOK byteArray a + +instance (Show ba, Show a) => Show (Result ba a) where + show (ParseFail err) = "ParseFailure: " ++ err + show (ParseMore _) = "ParseMore _" + show (ParseOK b a) = "ParseOK " ++ show a ++ " " ++ show b + +-- | The continuation of the current buffer, and the error string +type Failure byteArray r = byteArray -> String -> Result byteArray r + +-- | The continuation of the next buffer value, and the parsed value +type Success byteArray a r = byteArray -> a -> Result byteArray r + +-- | Simple ByteString parser structure +newtype Parser byteArray a = Parser + { runParser :: forall r . byteArray + -> Failure byteArray r + -> Success byteArray a r + -> Result byteArray r } + +instance Functor (Parser byteArray) where + fmap f p = Parser $ \buf err ok -> + runParser p buf err (\b a -> ok b (f a)) +instance Applicative (Parser byteArray) where + pure v = Parser $ \buf _ ok -> ok buf v + (<*>) d e = d >>= \b -> e >>= \a -> return (b a) +instance Monad (Parser byteArray) where +#if !(MIN_VERSION_base(4,13,0)) + fail = Fail.fail +#endif + return = pure + m >>= k = Parser $ \buf err ok -> + runParser m buf err (\buf' a -> runParser (k a) buf' err ok) +instance Fail.MonadFail (Parser byteArray) where + fail errorMsg = Parser $ \buf err _ -> err buf ("Parser failed: " ++ errorMsg) +instance MonadPlus (Parser byteArray) where + mzero = fail "MonadPlus.mzero" + mplus f g = Parser $ \buf err ok -> + -- rewrite the err callback of @f to call @g + runParser f buf (\_ _ -> runParser g buf err ok) ok +instance Alternative (Parser byteArray) where + empty = fail "Alternative.empty" + (<|>) = mplus + +-- | Run a parser on an @initial byteArray. +-- +-- If the Parser need more data than available, the @feeder function +-- is automatically called and fed to the More continuation. +parseFeed :: (ByteArrayAccess byteArray, Monad m) + => m (Maybe byteArray) + -> Parser byteArray a + -> byteArray + -> m (Result byteArray a) +parseFeed feeder p initial = loop $ parse p initial + where loop (ParseMore k) = feeder >>= (loop . k) + loop r = return r + +-- | Run a Parser on a ByteString and return a 'Result' +parse :: ByteArrayAccess byteArray + => Parser byteArray a -> byteArray -> Result byteArray a +parse p s = runParser p s (\_ msg -> ParseFail msg) (\b a -> ParseOK b a) + +------------------------------------------------------------ + +-- When needing more data, getMore append the next data +-- to the current buffer. if no further data, then +-- the err callback is called. +getMore :: ByteArray byteArray => Parser byteArray () +getMore = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> err buf "EOL: need more data" + Just nc + | B.null nc -> runParser getMore buf err ok + | otherwise -> ok (B.append buf nc) () + +-- Only used by takeAll, which accumulate all the remaining data +-- until ParseMore is fed a Nothing value. +-- +-- getAll cannot fail. +getAll :: ByteArray byteArray => Parser byteArray () +getAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf () + Just nc -> runParser getAll (B.append buf nc) err ok + +-- Only used by skipAll, which flush all the remaining data +-- until ParseMore is fed a Nothing value. +-- +-- flushAll cannot fail. +flushAll :: ByteArray byteArray => Parser byteArray () +flushAll = Parser $ \buf err ok -> ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf () + Just _ -> runParser flushAll B.empty err ok + +------------------------------------------------------------ +hasMore :: ByteArray byteArray => Parser byteArray Bool +hasMore = Parser $ \buf err ok -> + if B.null buf + then ParseMore $ \nextChunk -> + case nextChunk of + Nothing -> ok buf False + Just nc -> runParser hasMore nc err ok + else ok buf True + +-- | Get the next byte from the parser +anyByte :: ByteArray byteArray => Parser byteArray Word8 +anyByte = Parser $ \buf err ok -> + case B.uncons buf of + Nothing -> runParser (getMore >> anyByte) buf err ok + Just (c1,b2) -> ok b2 c1 + +-- | Parse a specific byte at current position +-- +-- if the byte is different than the expected on, +-- this parser will raise a failure. +byte :: ByteArray byteArray => Word8 -> Parser byteArray () +byte w = Parser $ \buf err ok -> + case B.uncons buf of + Nothing -> runParser (getMore >> byte w) buf err ok + Just (c1,b2) | c1 == w -> ok b2 () + | otherwise -> err buf ("byte " ++ show w ++ " : failed : got " ++ show c1) + +-- | Parse a sequence of bytes from current position +-- +-- if the following bytes don't match the expected +-- bytestring completely, the parser will raise a failure +bytes :: (Show ba, Eq ba, ByteArray ba) => ba -> Parser ba () +bytes allExpected = consumeEq allExpected + where errMsg = "bytes " ++ show allExpected ++ " : failed" + + -- partially consume as much as possible or raise an error. + consumeEq expected = Parser $ \actual err ok -> + let eLen = B.length expected in + if B.length actual >= eLen + then -- enough data for doing a full match + let (aMatch,aRem) = B.splitAt eLen actual + in if aMatch == expected + then ok aRem () + else err actual errMsg + else -- not enough data, match as much as we have, and then recurse. + let (eMatch, eRem) = B.splitAt (B.length actual) expected + in if actual == eMatch + then runParser (getMore >> consumeEq eRem) B.empty err ok + else err actual errMsg + +------------------------------------------------------------ + +-- | Take a storable from the current position in the stream +takeStorable :: (ByteArray byteArray, Storable d) + => Parser byteArray d +takeStorable = anyStorable undefined + where + anyStorable :: ByteArray byteArray => Storable d => d -> Parser byteArray d + anyStorable a = do + buf <- take (sizeOf a) + return $ unsafeDoIO $ B.withByteArray buf $ \ptr -> peek ptr + +-- | Take @n bytes from the current position in the stream +take :: ByteArray byteArray => Int -> Parser byteArray byteArray +take n = Parser $ \buf err ok -> + if B.length buf >= n + then let (b1,b2) = B.splitAt n buf in ok b2 b1 + else runParser (getMore >> take n) buf err ok + +-- | Take bytes while the @predicate hold from the current position in the stream +takeWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray byteArray +takeWhile predicate = Parser $ \buf err ok -> + let (b1, b2) = B.span predicate buf + in if B.null b2 + then runParser (getMore >> takeWhile predicate) buf err ok + else ok b2 b1 + +-- | Take the remaining bytes from the current position in the stream +takeAll :: ByteArray byteArray => Parser byteArray byteArray +takeAll = Parser $ \buf err ok -> + runParser (getAll >> returnBuffer) buf err ok + where + returnBuffer = Parser $ \buf _ ok -> ok B.empty buf + +-- | Skip @n bytes from the current position in the stream +skip :: ByteArray byteArray => Int -> Parser byteArray () +skip n = Parser $ \buf err ok -> + if B.length buf >= n + then ok (B.drop n buf) () + else runParser (getMore >> skip (n - B.length buf)) B.empty err ok + +-- | Skip bytes while the @predicate hold from the current position in the stream +skipWhile :: ByteArray byteArray => (Word8 -> Bool) -> Parser byteArray () +skipWhile p = Parser $ \buf err ok -> + let (_, b2) = B.span p buf + in if B.null b2 + then runParser (getMore >> skipWhile p) B.empty err ok + else ok b2 () + +-- | Skip all the remaining bytes from the current position in the stream +skipAll :: ByteArray byteArray => Parser byteArray () +skipAll = Parser $ \buf err ok -> runParser flushAll buf err ok diff --git a/Data/ByteArray/ScrubbedBytes.hs b/Data/ByteArray/ScrubbedBytes.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/ScrubbedBytes.hs @@ -0,0 +1,198 @@ +-- | +-- Module : Data.ByteArray.ScrubbedBytes +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : Stable +-- Portability : GHC +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.ByteArray.ScrubbedBytes + ( ScrubbedBytes + ) where + +import GHC.Types +import GHC.Prim +import GHC.Ptr +import GHC.Word +#if MIN_VERSION_base(4,15,0) +import GHC.Exts (unsafeCoerce#) +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup +import Data.Foldable (toList) +#else +import Data.Monoid +#endif +import Data.String (IsString(..)) +import Data.Typeable +import Data.Memory.PtrMethods +import Data.Memory.Internal.CompatPrim +import Data.Memory.Internal.Compat (unsafeDoIO) +import Data.Memory.Internal.Imports +import Data.ByteArray.Types +import Foreign.Storable + +-- | ScrubbedBytes is a memory chunk which have the properties of: +-- +-- * Being scrubbed after its goes out of scope. +-- +-- * A Show instance that doesn't actually show any content +-- +-- * A Eq instance that is constant time +-- +data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld) + deriving (Typeable) + +instance Show ScrubbedBytes where + show _ = "" + +instance Eq ScrubbedBytes where + (==) = scrubbedBytesEq +instance Ord ScrubbedBytes where + compare = scrubbedBytesCompare +#if MIN_VERSION_base(4,9,0) +instance Semigroup ScrubbedBytes where + b1 <> b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 + sconcat = unsafeDoIO . scrubbedBytesConcat . toList +#endif +instance Monoid ScrubbedBytes where + mempty = unsafeDoIO (newScrubbedBytes 0) +#if !(MIN_VERSION_base(4,11,0)) + mappend b1 b2 = unsafeDoIO $ scrubbedBytesAppend b1 b2 + mconcat = unsafeDoIO . scrubbedBytesConcat +#endif +instance NFData ScrubbedBytes where + rnf b = b `seq` () +instance IsString ScrubbedBytes where + fromString = scrubbedFromChar8 + +instance ByteArrayAccess ScrubbedBytes where + length = sizeofScrubbedBytes + withByteArray = withPtr + +instance ByteArray ScrubbedBytes where + allocRet = scrubbedBytesAllocRet + +newScrubbedBytes :: Int -> IO ScrubbedBytes +newScrubbedBytes (I# sz) + | booleanPrim (sz <# 0#) = error "ScrubbedBytes: size must be >= 0" + | booleanPrim (sz ==# 0#) = IO $ \s -> + case newAlignedPinnedByteArray# 0# 8# s of + (# s2, mba #) -> (# s2, ScrubbedBytes mba #) + | otherwise = IO $ \s -> + case newAlignedPinnedByteArray# sz 8# s of + (# s1, mbarr #) -> + let !scrubber = getScrubber (byteArrayContents# (unsafeCoerce# mbarr)) + !mba = ScrubbedBytes mbarr + in case mkWeak# mbarr () (finalize scrubber mba) s1 of + (# s2, _ #) -> (# s2, mba #) + where + getScrubber :: Addr# -> State# RealWorld -> State# RealWorld + getScrubber addr s = + let IO scrubBytes = memSet (Ptr addr) 0 (I# sz) + in case scrubBytes s of + (# s', _ #) -> s' + +#if __GLASGOW_HASKELL__ >= 800 + finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> State# RealWorld -> (# State# RealWorld, () #) + finalize scrubber mba@(ScrubbedBytes _) = \s1 -> + case scrubber s1 of + s2 -> case touch# mba s2 of + s3 -> (# s3, () #) +#else + finalize :: (State# RealWorld -> State# RealWorld) -> ScrubbedBytes -> IO () + finalize scrubber mba@(ScrubbedBytes _) = IO $ \s1 -> do + case scrubber s1 of + s2 -> case touch# mba s2 of + s3 -> (# s3, () #) +#endif + +scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes) +scrubbedBytesAllocRet sz f = do + ba <- newScrubbedBytes sz + r <- withPtr ba f + return (r, ba) + +scrubbedBytesAlloc :: Int -> (Ptr p -> IO ()) -> IO ScrubbedBytes +scrubbedBytesAlloc sz f = do + ba <- newScrubbedBytes sz + withPtr ba f + return ba + +scrubbedBytesConcat :: [ScrubbedBytes] -> IO ScrubbedBytes +scrubbedBytesConcat l = scrubbedBytesAlloc retLen (copy l) + where + retLen = sum $ map sizeofScrubbedBytes l + + copy [] _ = return () + copy (x:xs) dst = do + withPtr x $ \src -> memCopy dst src chunkLen + copy xs (dst `plusPtr` chunkLen) + where + chunkLen = sizeofScrubbedBytes x + +scrubbedBytesAppend :: ScrubbedBytes -> ScrubbedBytes -> IO ScrubbedBytes +scrubbedBytesAppend b1 b2 = scrubbedBytesAlloc retLen $ \dst -> do + withPtr b1 $ \s1 -> memCopy dst s1 len1 + withPtr b2 $ \s2 -> memCopy (dst `plusPtr` len1) s2 len2 + where + len1 = sizeofScrubbedBytes b1 + len2 = sizeofScrubbedBytes b2 + retLen = len1 + len2 + + +sizeofScrubbedBytes :: ScrubbedBytes -> Int +sizeofScrubbedBytes (ScrubbedBytes mba) = I# (sizeofMutableByteArray# mba) + +withPtr :: ScrubbedBytes -> (Ptr p -> IO a) -> IO a +withPtr b@(ScrubbedBytes mba) f = do + a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba))) + touchScrubbedBytes b + return a + +touchScrubbedBytes :: ScrubbedBytes -> IO () +touchScrubbedBytes (ScrubbedBytes mba) = IO $ \s -> case touch# mba s of s' -> (# s', () #) + +scrubbedBytesEq :: ScrubbedBytes -> ScrubbedBytes -> Bool +scrubbedBytesEq a b + | l1 /= l2 = False + | otherwise = unsafeDoIO $ withPtr a $ \p1 -> withPtr b $ \p2 -> memConstEqual p1 p2 l1 + where + l1 = sizeofScrubbedBytes a + l2 = sizeofScrubbedBytes b + +scrubbedBytesCompare :: ScrubbedBytes -> ScrubbedBytes -> Ordering +scrubbedBytesCompare b1@(ScrubbedBytes m1) b2@(ScrubbedBytes m2) = unsafeDoIO $ loop 0 + where + !l1 = sizeofScrubbedBytes b1 + !l2 = sizeofScrubbedBytes b2 + !len = min l1 l2 + + loop !i + | i == len = + if l1 == l2 + then pure EQ + else if l1 > l2 then pure GT + else pure LT + | otherwise = do + e1 <- read8 m1 i + e2 <- read8 m2 i + if e1 == e2 + then loop (i+1) + else if e1 < e2 then pure LT + else pure GT + + read8 m (I# i) = IO $ \s -> case readWord8Array# m i s of + (# s2, e #) -> (# s2, W8# e #) + +scrubbedFromChar8 :: [Char] -> ScrubbedBytes +scrubbedFromChar8 l = unsafeDoIO $ scrubbedBytesAlloc len (fill l) + where + len = Prelude.length l + fill :: [Char] -> Ptr Word8 -> IO () + fill [] _ = return () + fill (x:xs) !p = poke p (fromIntegral $ fromEnum x) >> fill xs (p `plusPtr` 1) diff --git a/Data/ByteArray/Sized.hs b/Data/ByteArray/Sized.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Sized.hs @@ -0,0 +1,383 @@ +-- | +-- Module : Data.ByteArray.Sized +-- License : BSD-style +-- Maintainer : Nicolas Di Prima +-- Stability : stable +-- Portability : Good +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoStarIsType #-} + +module Data.ByteArray.Sized + ( ByteArrayN(..) + , SizedByteArray + , unSizedByteArray + , sizedByteArray + , unsafeSizedByteArray + + , -- * ByteArrayN operators + alloc + , create + , allocAndFreeze + , unsafeCreate + , inlineUnsafeCreate + , empty + , pack + , unpack + , cons + , snoc + , xor + , index + , splitAt + , take + , drop + , append + , copy + , copyRet + , copyAndFreeze + , replicate + , zero + , convert + , fromByteArrayAccess + , unsafeFromByteArrayAccess + ) where + +import Prelude hiding (length, splitAt, take, drop, replicate) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Data.Proxy (Proxy(..)) +import Data.Maybe (fromMaybe) +import GHC.TypeLits (KnownNat, Nat, natVal, type (+), type (<=)) +import Data.Memory.Internal.DeepSeq (NFData) +import Foreign.Storable +import Foreign.Ptr + +import Data.Memory.Internal.Compat +import Data.Memory.PtrMethods + +import Data.ByteArray.Types (ByteArrayAccess(..), ByteArray) +import qualified Data.ByteArray.Types as ByteArray (allocRet) + +-- | A list with a type-level length. +newtype ListN (n :: Nat) a = ListN [a] + +-- | Extract the underlying list from a 'ListN'. +unListN :: ListN n a -> [a] +unListN (ListN l) = l + +-- | Wrap a list in 'ListN' if its length matches the type-level @n@. +toListN :: forall n a . KnownNat n => [a] -> Maybe (ListN n a) +toListN l = go l (fromIntegral (natVal (Proxy @n)) :: Int) + where + go [] 0 = Just (ListN l) + go [] _ = Nothing + go _ 0 = Nothing + go (_:xs) k = go xs (k - 1) + +-- | Type class to emulate exactly the behaviour of 'ByteArray' but with +-- a known length at compile time +-- +class (ByteArrayAccess c, KnownNat n) => ByteArrayN (n :: Nat) c | c -> n where + -- | just like 'allocRet' but with the size at the type level + allocRet :: forall p a + . Proxy n + -> (Ptr p -> IO a) + -> IO (a, c) + +-- | Wrapper around any collection type with the size as type parameter +-- +newtype SizedByteArray (n :: Nat) ba = SizedByteArray { unSizedByteArray :: ba } + deriving (Eq, Show, Typeable, Ord, NFData) + +-- | create a 'SizedByteArray' from the given 'ByteArrayAccess' if the +-- size is the same as the target size. +-- +sizedByteArray :: forall n ba . (KnownNat n, ByteArrayAccess ba) + => ba + -> Maybe (SizedByteArray n ba) +sizedByteArray ba + | length ba == n = Just $ SizedByteArray ba + | otherwise = Nothing + where + n = fromInteger $ natVal (Proxy @n) + +-- | just like the 'sizedByteArray' function but throw an exception if +-- the size is invalid. +unsafeSizedByteArray :: forall n ba . (ByteArrayAccess ba, KnownNat n) => ba -> SizedByteArray n ba +unsafeSizedByteArray = fromMaybe (error "The size is invalid") . sizedByteArray + +instance (ByteArrayAccess ba, KnownNat n) => ByteArrayAccess (SizedByteArray n ba) where + length _ = fromInteger $ natVal (Proxy @n) + withByteArray (SizedByteArray ba) = withByteArray ba + +instance (KnownNat n, ByteArray ba) => ByteArrayN n (SizedByteArray n ba) where + allocRet p f = do + (a, ba) <- ByteArray.allocRet n f + pure (a, SizedByteArray ba) + where + n = fromInteger $ natVal p + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +alloc :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) + -> IO ba +alloc f = snd <$> allocRet (Proxy @n) f + +-- | Allocate a new bytearray of specific size, and run the initializer on this memory +create :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) + -> IO ba +create = alloc @n +{-# NOINLINE create #-} + +-- | similar to 'allocN' but hide the allocation and initializer in a pure context +allocAndFreeze :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +allocAndFreeze f = unsafeDoIO (alloc @n f) +{-# NOINLINE allocAndFreeze #-} + +-- | similar to 'createN' but hide the allocation and initializer in a pure context +unsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +unsafeCreate f = unsafeDoIO (alloc @n f) +{-# NOINLINE unsafeCreate #-} + +inlineUnsafeCreate :: forall n ba p . (ByteArrayN n ba, KnownNat n) + => (Ptr p -> IO ()) -> ba +inlineUnsafeCreate f = unsafeDoIO (alloc @n f) +{-# INLINE inlineUnsafeCreate #-} + +-- | Create an empty byte array +empty :: forall ba . ByteArrayN 0 ba => ba +empty = unsafeDoIO (alloc @0 $ \_ -> return ()) + +-- | Pack a list of bytes into a bytearray +pack :: forall n ba . (ByteArrayN n ba, KnownNat n) => ListN n Word8 -> ba +pack l = inlineUnsafeCreate @n (fill $ unListN l) + where fill [] _ = return () + fill (x:xs) !p = poke p x >> fill xs (p `plusPtr` 1) + {-# INLINE fill #-} +{-# NOINLINE pack #-} + +-- | Un-pack a bytearray into a list of bytes +unpack :: forall n ba + . (ByteArrayN n ba, KnownNat n, ByteArrayAccess ba) + => ba -> ListN n Word8 +unpack bs = fromMaybe (error "the impossible appened") $ toListN @n $ loop 0 + where !len = length bs + loop i + | i == len = [] + | otherwise = + let !v = unsafeDoIO $ withByteArray bs (`peekByteOff` i) + in v : loop (i+1) + +-- | prepend a single byte to a byte array +cons :: forall ni no bi bo + . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi + , KnownNat ni, KnownNat no + , (ni + 1) ~ no + ) + => Word8 -> bi -> bo +cons b ba = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do + pokeByteOff d 0 b + memCopy (d `plusPtr` 1) s len + where + !len = fromInteger $ natVal (Proxy @ni) + +-- | append a single byte to a byte array +snoc :: forall bi bo ni no + . ( ByteArrayN ni bi, ByteArrayN no bo, ByteArrayAccess bi + , KnownNat ni, KnownNat no + , (ni + 1) ~ no + ) + => bi -> Word8 -> bo +snoc ba b = unsafeCreate @no $ \d -> withByteArray ba $ \s -> do + memCopy d s len + pokeByteOff d len b + where + !len = fromInteger $ natVal (Proxy @ni) + +-- | Create a xor of bytes between a and b. +-- +-- the returns byte array is the size of the smallest input. +xor :: forall n a b c + . ( ByteArrayN n a, ByteArrayN n b, ByteArrayN n c + , ByteArrayAccess a, ByteArrayAccess b + , KnownNat n + ) + => a -> b -> c +xor a b = + unsafeCreate @n $ \pc -> + withByteArray a $ \pa -> + withByteArray b $ \pb -> + memXor pc pa pb n + where + n = fromInteger (natVal (Proxy @n)) + +-- | return a specific byte indexed by a number from 0 in a bytearray +-- +-- unsafe, no bound checking are done +index :: forall n na ba + . ( ByteArrayN na ba, ByteArrayAccess ba + , KnownNat na, KnownNat n + , n <= na + ) + => ba -> Proxy n -> Word8 +index b pi = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i) + where + i = fromInteger $ natVal pi + +-- | Split a bytearray at a specific length in two bytearray +splitAt :: forall nblhs nbi nbrhs bi blhs brhs + . ( ByteArrayN nbi bi, ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs + , ByteArrayAccess bi + , KnownNat nbi, KnownNat nblhs, KnownNat nbrhs + , nblhs <= nbi, (nbrhs + nblhs) ~ nbi + ) + => bi -> (blhs, brhs) +splitAt bs = unsafeDoIO $ + withByteArray bs $ \p -> do + b1 <- alloc @nblhs $ \r -> memCopy r p n + b2 <- alloc @nbrhs $ \r -> memCopy r (p `plusPtr` n) (len - n) + return (b1, b2) + where + n = fromInteger $ natVal (Proxy @nblhs) + len = length bs + +-- | Take the first @n@ byte of a bytearray +take :: forall nbo nbi bi bo + . ( ByteArrayN nbi bi, ByteArrayN nbo bo + , ByteArrayAccess bi + , KnownNat nbi, KnownNat nbo + , nbo <= nbi + ) + => bi -> bo +take bs = unsafeCreate @nbo $ \d -> withByteArray bs $ \s -> memCopy d s m + where + !m = min len n + !len = length bs + !n = fromInteger $ natVal (Proxy @nbo) + +-- | drop the first @n@ byte of a bytearray +drop :: forall n nbi nbo bi bo + . ( ByteArrayN nbi bi, ByteArrayN nbo bo + , ByteArrayAccess bi + , KnownNat n, KnownNat nbi, KnownNat nbo + , (nbo + n) ~ nbi + ) + => Proxy n -> bi -> bo +drop pn bs = unsafeCreate @nbo $ \d -> + withByteArray bs $ \s -> + memCopy d (s `plusPtr` ofs) nb + where + ofs = min len n + nb = len - ofs + len = length bs + n = fromInteger $ natVal pn + +-- | append one bytearray to the other +append :: forall nblhs nbrhs nbout blhs brhs bout + . ( ByteArrayN nblhs blhs, ByteArrayN nbrhs brhs, ByteArrayN nbout bout + , ByteArrayAccess blhs, ByteArrayAccess brhs + , KnownNat nblhs, KnownNat nbrhs, KnownNat nbout + , (nbrhs + nblhs) ~ nbout + ) + => blhs -> brhs -> bout +append blhs brhs = unsafeCreate @nbout $ \p -> + withByteArray blhs $ \plhs -> + withByteArray brhs $ \prhs -> do + memCopy p plhs (length blhs) + memCopy (p `plusPtr` length blhs) prhs (length brhs) + +-- | Duplicate a bytearray into another bytearray, and run an initializer on it +copy :: forall n bs1 bs2 p + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO ()) -> IO bs2 +copy bs f = alloc @n $ \d -> do + withByteArray bs $ \s -> memCopy d s (length bs) + f (castPtr d) + +-- | Similar to 'copy' but also provide a way to return a value from the initializer +copyRet :: forall n bs1 bs2 p a + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO a) -> IO (a, bs2) +copyRet bs f = + allocRet (Proxy @n) $ \d -> do + withByteArray bs $ \s -> memCopy d s (length bs) + f (castPtr d) + +-- | Similiar to 'copy' but expect the resulting bytearray in a pure context +copyAndFreeze :: forall n bs1 bs2 p + . ( ByteArrayN n bs1, ByteArrayN n bs2 + , ByteArrayAccess bs1 + , KnownNat n + ) + => bs1 -> (Ptr p -> IO ()) -> bs2 +copyAndFreeze bs f = + inlineUnsafeCreate @n $ \d -> do + copyByteArrayToPtr bs d + f (castPtr d) +{-# NOINLINE copyAndFreeze #-} + +-- | Create a bytearray of a specific size containing a repeated byte value +replicate :: forall n ba . (ByteArrayN n ba, KnownNat n) + => Word8 -> ba +replicate b = inlineUnsafeCreate @n $ \ptr -> memSet ptr b (fromInteger $ natVal $ Proxy @n) +{-# NOINLINE replicate #-} + +-- | Create a bytearray of a specific size initialized to 0 +zero :: forall n ba . (ByteArrayN n ba, KnownNat n) => ba +zero = unsafeCreate @n $ \ptr -> memSet ptr 0 (fromInteger $ natVal $ Proxy @n) +{-# NOINLINE zero #-} + +-- | Convert a bytearray to another type of bytearray +convert :: forall n bin bout + . ( ByteArrayN n bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> bout +convert bs = inlineUnsafeCreate @n (copyByteArrayToPtr bs) + +-- | Convert a ByteArrayAccess to another type of bytearray +-- +-- This function returns nothing if the size is not compatible +fromByteArrayAccess :: forall n bin bout + . ( ByteArrayAccess bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> Maybe bout +fromByteArrayAccess bs + | l == n = Just $ inlineUnsafeCreate @n (copyByteArrayToPtr bs) + | otherwise = Nothing + where + l = length bs + n = fromInteger $ natVal (Proxy @n) + +-- | Convert a ByteArrayAccess to another type of bytearray +unsafeFromByteArrayAccess :: forall n bin bout + . ( ByteArrayAccess bin, ByteArrayN n bout + , KnownNat n + ) + => bin -> bout +unsafeFromByteArrayAccess bs = case fromByteArrayAccess @n @bin @bout bs of + Nothing -> error "Invalid Size" + Just v -> v diff --git a/Data/ByteArray/Types.hs b/Data/ByteArray/Types.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/Types.hs @@ -0,0 +1,66 @@ +-- | +-- Module : Data.ByteArray.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.ByteArray.Types + ( ByteArrayAccess(..) + , ByteArray(..) + ) where + +import Foreign.Ptr +import Data.Monoid + +#ifdef WITH_BYTESTRING_SUPPORT +import qualified Data.ByteString as Bytestring (length) +import qualified Data.ByteString.Internal as Bytestring +import Foreign.ForeignPtr (withForeignPtr) +#endif + +import Data.Memory.PtrMethods (memCopy) + + +import Data.Proxy (Proxy(..)) +import Data.Word (Word8) + +import Prelude hiding (length) + +-- | Class to Access size properties and data of a ByteArray +class ByteArrayAccess ba where + -- | Return the length in bytes of a bytearray + length :: ba -> Int + -- | Allow to use using a pointer + withByteArray :: ba -> (Ptr p -> IO a) -> IO a + -- | Copy the data of a bytearray to a ptr + copyByteArrayToPtr :: ba -> Ptr p -> IO () + copyByteArrayToPtr a dst = withByteArray a $ \src -> memCopy (castPtr dst) src (length a) + +-- | Class to allocate new ByteArray of specific size +class (Eq ba, Ord ba, Monoid ba, ByteArrayAccess ba) => ByteArray ba where + -- | allocate `n` bytes and perform the given operation + allocRet :: Int + -- ^ number of bytes to allocate. i.e. might not match the + -- size of the given type `ba`. + -> (Ptr p -> IO a) + -> IO (a, ba) + +#ifdef WITH_BYTESTRING_SUPPORT +instance ByteArrayAccess Bytestring.ByteString where + length = Bytestring.length + withByteArray (Bytestring.PS fptr off _) f = withForeignPtr fptr $ \ptr -> f $! (ptr `plusPtr` off) + +instance ByteArray Bytestring.ByteString where + allocRet sz f = do + fptr <- Bytestring.mallocByteString sz + r <- withForeignPtr fptr (f . castPtr) + return (r, Bytestring.PS fptr 0 sz) +#endif + diff --git a/Data/ByteArray/View.hs b/Data/ByteArray/View.hs new file mode 100644 --- /dev/null +++ b/Data/ByteArray/View.hs @@ -0,0 +1,128 @@ +-- | +-- Module : Data.ByteArray.View +-- License : BSD-style +-- Maintainer : Nicolas DI PRIMA +-- Stability : stable +-- Portability : Good +-- +-- a View on a given ByteArrayAccess +-- + +module Data.ByteArray.View + ( View + , view + , takeView + , dropView + ) where + +import Data.ByteArray.Methods +import Data.ByteArray.Types +import Data.Memory.PtrMethods +import Data.Memory.Internal.Compat +import Foreign.Ptr (plusPtr) + +import Prelude hiding (length, take, drop) + +-- | a view on a given bytes +-- +-- Equality test in constant time +data View bytes = View + { viewOffset :: !Int + , viewSize :: !Int + , unView :: !bytes + } + +instance ByteArrayAccess bytes => Eq (View bytes) where + (==) = constEq + +instance ByteArrayAccess bytes => Ord (View bytes) where + compare v1 v2 = unsafeDoIO $ + withByteArray v1 $ \ptr1 -> + withByteArray v2 $ \ptr2 -> do + ret <- memCompare ptr1 ptr2 (min (viewSize v1) (viewSize v2)) + return $ case ret of + EQ | length v1 > length v2 -> GT + | length v1 < length v2 -> LT + | length v1 == length v2 -> EQ + _ -> ret + +instance ByteArrayAccess bytes => Show (View bytes) where + showsPrec p v r = showsPrec p (viewUnpackChars v []) r + +instance ByteArrayAccess bytes => ByteArrayAccess (View bytes) where + length = viewSize + withByteArray v f = withByteArray (unView v) $ \ptr -> f (ptr `plusPtr` (viewOffset v)) + +viewUnpackChars :: ByteArrayAccess bytes + => View bytes + -> String + -> String +viewUnpackChars v xs = chunkLoop 0 + where + len = length v + + chunkLoop :: Int -> [Char] + chunkLoop idx + | len == idx = [] + | (len - idx) > 63 = + bytesLoop idx (idx + 64) (chunkLoop (idx + 64)) + | otherwise = + bytesLoop idx (len - idx) xs + + bytesLoop :: Int -> Int -> [Char] -> [Char] + bytesLoop idx chunkLenM1 paramAcc = + loop (idx + chunkLenM1 - 1) paramAcc + where + loop i acc + | i == idx = (rChar i : acc) + | otherwise = loop (i - 1) (rChar i : acc) + + rChar :: Int -> Char + rChar idx = toEnum $ fromIntegral $ index v idx + +-- | create a view on a given bytearray +-- +-- This function update the offset and the size in order to guarantee: +-- +-- * offset >= 0 +-- * size >= 0 +-- * offset < length +-- * size =< length - offset +-- +view :: ByteArrayAccess bytes + => bytes -- ^ the byte array we put a view on + -> Int -- ^ the offset to start the byte array on + -> Int -- ^ the size of the view + -> View bytes +view b offset'' size'' = View offset size b + where + -- make sure offset is not negative + offset' :: Int + offset' = max offset'' 0 + + -- make sure the offset is not out of bound + offset :: Int + offset = min offset' (length b - 1) + + -- make sure length is not negative + size' :: Int + size' = max size'' 0 + + -- make sure the length is not out of the bound + size :: Int + size = min size' (length b - offset) + +-- | create a view from the given bytearray +takeView :: ByteArrayAccess bytes + => bytes -- ^ byte aray + -> Int -- ^ size of the view + -> View bytes +takeView b size = view b 0 size + +-- | create a view from the given byte array +-- starting after having dropped the fist n bytes +dropView :: ByteArrayAccess bytes + => bytes -- ^ byte array + -> Int -- ^ the number of bytes do dropped before creating the view + -> View bytes +dropView b offset = view b offset (length b - offset) diff --git a/Data/Memory/Encoding/Base16.hs b/Data/Memory/Encoding/Base16.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Encoding/Base16.hs @@ -0,0 +1,175 @@ +-- | +-- Module : Data.Memory.Encoding.Base16 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base16 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base16 + ( showHexadecimal + , toHexadecimal + , fromHexadecimal + ) where + +import Data.Memory.Internal.Compat +import Data.Word +import Data.Bits ((.|.)) +import GHC.Prim +import GHC.Types +import GHC.Word +import GHC.Char (chr) +import Control.Monad +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a raw memory to an hexadecimal 'String' +-- +-- user beware, no checks are made +showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object + -> Int -- ^ length in bytes + -> String +showHexadecimal withPtr = doChunks 0 + where + doChunks ofs len + | len < 4 = doUnique ofs len + | otherwise = do + let !(a, b, c, d) = unsafeDoIO $ withPtr (read4 ofs) + !(# w1, w2 #) = convertByte a + !(# w3, w4 #) = convertByte b + !(# w5, w6 #) = convertByte c + !(# w7, w8 #) = convertByte d + in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4 + : wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8 + : doChunks (ofs + 4) (len - 4) + + doUnique ofs len + | len == 0 = [] + | otherwise = + let !b = unsafeDoIO $ withPtr (byteIndex ofs) + !(# w1, w2 #) = convertByte b + in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1) + + read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8) + read4 ofs p = + liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p) + (byteIndex (ofs+2) p) (byteIndex (ofs+3) p) + + wToChar :: Word8 -> Char + wToChar w = chr (fromIntegral w) + + byteIndex :: Int -> Ptr Word8 -> IO Word8 + byteIndex i p = peekByteOff p i + +-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst +-- +-- destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toHexadecimal :: Ptr Word8 -- ^ destination memory + -> Ptr Word8 -- ^ source memory + -> Int -- ^ number of bytes + -> IO () +toHexadecimal bout bin n = loop 0 + where loop i + | i == n = return () + | otherwise = do + !w <- peekByteOff bin i + let !(# !w1, !w2 #) = convertByte w + pokeByteOff bout (i * 2) w1 + pokeByteOff bout (i * 2 + 1) w2 + loop (i+1) + +-- | Convert a value Word# to two Word#s containing +-- the hexadecimal representation of the Word# +convertByte :: Word8 -> (# Word8, Word8 #) +convertByte bwrap = (# r tableHi b, r tableLo b #) + where + !(W# b) = fromIntegral bwrap + r :: Addr# -> Word# -> Word8 + r table index = W8# (indexWord8OffAddr# table (word2Int# index)) + + !tableLo = + "0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef\ + \0123456789abcdef0123456789abcdef"# + !tableHi = + "00000000000000001111111111111111\ + \22222222222222223333333333333333\ + \44444444444444445555555555555555\ + \66666666666666667777777777777777\ + \88888888888888889999999999999999\ + \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\ + \ccccccccccccccccdddddddddddddddd\ + \eeeeeeeeeeeeeeeeffffffffffffffff"# +{-# INLINE convertByte #-} + +-- | convert a base16 @src in @dst. +-- +-- n need to even +fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromHexadecimal dst src n + | odd n = error "fromHexadecimal: invalid odd length." + | otherwise = loop 0 0 + where loop di i + | i == n = return Nothing + | otherwise = do + a <- rHi `fmap` peekByteOff src i + b <- rLo `fmap` peekByteOff src (i+1) + if a == 0xff || b == 0xff + then return $ Just i + else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2) + + rLo, rHi :: Word8 -> Word8 + rLo index = W8# (indexWord8OffAddr# tableLo (word2Int# widx)) + where !(W# widx) = fromIntegral index + rHi index = W8# (indexWord8OffAddr# tableHi (word2Int# widx)) + where !(W# widx) = fromIntegral index + + !tableLo = + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\ + \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + !tableHi = + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\ + \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# diff --git a/Data/Memory/Encoding/Base32.hs b/Data/Memory/Encoding/Base32.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Encoding/Base32.hs @@ -0,0 +1,255 @@ +-- | +-- Module : Data.Memory.Encoding.Base32 +-- License : BSD-style +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base32 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base32 + ( toBase32 + , unBase32Length + , fromBase32 + ) where + +import Data.Memory.Internal.Compat +import Data.Word +import Data.Bits ((.&.), (.|.)) +import GHC.Prim +import GHC.Word +import Control.Monad +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a number of bytes pointed by.@src in the base32 binary representation in @dst +-- +-- destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase32 :: Ptr Word8 -- ^ input + -> Ptr Word8 -- ^ output + -> Int -- ^ input len + -> IO () +toBase32 dst src len = loop 0 0 + where + eqChar :: Word8 + eqChar = 0x3d + + peekOrZero :: Int -> IO Word8 + peekOrZero i + | i >= len = return 0 + | otherwise = peekByteOff src i + + pokeOrPadding :: Int -- for the test + -> Int -- src index + -> Word8 -- the value + -> IO () + pokeOrPadding i di v + | i < len = pokeByteOff dst di v + | otherwise = pokeByteOff dst di eqChar + + loop :: Int -- index input + -> Int -- index output + -> IO () + loop i di + | i >= len = return () + | otherwise = do + i1 <- peekByteOff src i + i2 <- peekOrZero (i + 1) + i3 <- peekOrZero (i + 2) + i4 <- peekOrZero (i + 3) + i5 <- peekOrZero (i + 4) + + let (o1,o2,o3,o4,o5,o6,o7,o8) = toBase32Per5Bytes (i1, i2, i3, i4, i5) + + pokeByteOff dst di o1 + pokeByteOff dst (di + 1) o2 + pokeOrPadding (i + 1) (di + 2) o3 + pokeOrPadding (i + 1) (di + 3) o4 + pokeOrPadding (i + 2) (di + 4) o5 + pokeOrPadding (i + 3) (di + 5) o6 + pokeOrPadding (i + 3) (di + 6) o7 + pokeOrPadding (i + 4) (di + 7) o8 + + loop (i+5) (di+8) + +toBase32Per5Bytes :: (Word8, Word8, Word8, Word8, Word8) + -> (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) +toBase32Per5Bytes (!i1, !i2, !i3, !i4, !i5) = + (index o1, index o2, index o3, index o4, index o5, index o6, index o7, index o8) + where + -- 1111 1000 >> 3 + !o1 = (i1 .&. 0xF8) `unsafeShiftR` 3 + -- 0000 0111 << 2 | 1100 0000 >> 6 + !o2 = ((i1 .&. 0x07) `unsafeShiftL` 2) .|. ((i2 .&. 0xC0) `unsafeShiftR` 6) + -- 0011 1110 >> 1 + !o3 = ((i2 .&. 0x3E) `unsafeShiftR` 1) + -- 0000 0001 << 4 | 1111 0000 >> 4 + !o4 = ((i2 .&. 0x01) `unsafeShiftL` 4) .|. ((i3 .&. 0xF0) `unsafeShiftR` 4) + -- 0000 1111 << 1 | 1000 0000 >> 7 + !o5 = ((i3 .&. 0x0F) `unsafeShiftL` 1) .|. ((i4 .&. 0x80) `unsafeShiftR` 7) + -- 0111 1100 >> 2 + !o6 = (i4 .&. 0x7C) `unsafeShiftR` 2 + -- 0000 0011 << 3 | 1110 0000 >> 5 + !o7 = ((i4 .&. 0x03) `unsafeShiftL` 3) .|. ((i5 .&. 0xE0) `unsafeShiftR` 5) + -- 0001 1111 + !o8 = i5 .&. 0x1F + + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# + + index :: Word8 -> Word8 + index idx = W8# (indexWord8OffAddr# set (word2Int# widx)) + where !(W# widx) = fromIntegral idx + +-- | Get the length needed for the destination buffer for a base32 decoding. +-- +-- if the length is not a multiple of 8, Nothing is returned +unBase32Length :: Ptr Word8 -> Int -> IO (Maybe Int) +unBase32Length src len + | len < 1 = return $ Just 0 + | (len `mod` 8) /= 0 = return Nothing + | otherwise = do + last1Byte <- peekByteOff src (len - 1) + last2Byte <- peekByteOff src (len - 2) + last3Byte <- peekByteOff src (len - 3) + last4Byte <- peekByteOff src (len - 4) + last5Byte <- peekByteOff src (len - 5) + last6Byte <- peekByteOff src (len - 6) + + let dstLen = caseByte last1Byte last2Byte last3Byte last4Byte last5Byte last6Byte + return $ Just $ (len `div` 8) * 5 - dstLen + where + caseByte :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Int + caseByte last1 last2 last3 last4 last5 last6 + | last6 == eqAscii = 4 + | last5 == eqAscii = 3 -- error this padding is not expected (error will be detected in fromBase32) + | last4 == eqAscii = 3 + | last3 == eqAscii = 2 + | last2 == eqAscii = 1 -- error this padding is not expected (error will be detected in fromBase32) + | last1 == eqAscii = 1 + | otherwise = 0 + + eqAscii :: Word8 + eqAscii = 0x3D + +-- | convert from base32 in @src to binary in @dst, using the number of bytes specified +-- +-- the user should use unBase32Length to compute the correct length, or check that +-- the length specification is proper. no check is done here. +fromBase32 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase32 dst src len + | len == 0 = return Nothing + | otherwise = loop 0 0 + where + loop :: Int -- the index dst + -> Int -- the index src + -> IO (Maybe Int) + loop di i + | i == (len - 8) = do + i1 <- peekByteOff src i + i2 <- peekByteOff src (i + 1) + i3 <- peekByteOff src (i + 2) + i4 <- peekByteOff src (i + 3) + i5 <- peekByteOff src (i + 4) + i6 <- peekByteOff src (i + 5) + i7 <- peekByteOff src (i + 6) + i8 <- peekByteOff src (i + 7) + + let (nbBytes, i3', i4', i5', i6', i7', i8') = + case (i3, i4, i5, i6, i7, i8) of + (0x3D, 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (6, 0x41, 0x41, 0x41, 0x41, 0x41, 0x41) + (0x3D, _ , _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , 0x3D, 0x3D, 0x3D, 0x3D, 0x3D) -> (5, i3 , 0x41, 0x41, 0x41, 0x41, 0x41) + (_ , 0x3D, _ , _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , 0x3D, 0x3D, 0x3D, 0x3D) -> (4, i3 , i4 , 0x41, 0x41, 0x41, 0x41) + (_ , _ , 0x3D, _ , _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , 0x3D, 0x3D, 0x3D) -> (3, i3 , i4 , i5 , 0x41, 0x41, 0x41) + (_ , _ , _ , 0x3D, _ , _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , _ , 0x3D, 0x3D) -> (2, i3 , i4 , i5 , i6 , 0x41, 0x41) + (_ , _ , _ , _ , 0x3D, _ ) -> (0, i3, i4, i5, i6, i7, i8) -- invalid + (_ , _ , _ , _ , _ , 0x3D) -> (1, i3 , i4 , i5 , i6 , i7 , 0x41) + (_ , _ , _ , _ , _ , _ ) -> (0 :: Int, i3, i4, i5, i6, i7, i8) + + case fromBase32Per8Bytes (i1, i2, i3', i4', i5', i6', i7', i8') of + Left ofs -> return $ Just (i + ofs) + Right (o1, o2, o3, o4, o5) -> do + pokeByteOff dst di o1 + pokeByteOff dst (di+1) o2 + when (nbBytes < 5) $ pokeByteOff dst (di+2) o3 + when (nbBytes < 4) $ pokeByteOff dst (di+3) o4 + when (nbBytes < 2) $ pokeByteOff dst (di+4) o5 + return Nothing + + | otherwise = do + i1 <- peekByteOff src i + i2 <- peekByteOff src (i + 1) + i3 <- peekByteOff src (i + 2) + i4 <- peekByteOff src (i + 3) + i5 <- peekByteOff src (i + 4) + i6 <- peekByteOff src (i + 5) + i7 <- peekByteOff src (i + 6) + i8 <- peekByteOff src (i + 7) + + case fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) of + Left ofs -> return $ Just (i + ofs) + Right (o1, o2, o3, o4, o5) -> do + pokeByteOff dst di o1 + pokeByteOff dst (di+1) o2 + pokeByteOff dst (di+2) o3 + pokeByteOff dst (di+3) o4 + pokeByteOff dst (di+4) o5 + loop (di+5) (i+8) + +fromBase32Per8Bytes :: (Word8, Word8, Word8, Word8, Word8, Word8, Word8, Word8) + -> Either Int (Word8, Word8, Word8, Word8, Word8) +fromBase32Per8Bytes (i1, i2, i3, i4, i5, i6, i7, i8) = + case (rset i1, rset i2, rset i3, rset i4, rset i5, rset i6, rset i7, rset i8) of + (0xFF, _ , _ , _ , _ , _ , _ , _ ) -> Left 0 + (_ , 0xFF, _ , _ , _ , _ , _ , _ ) -> Left 1 + (_ , _ , 0xFF, _ , _ , _ , _ , _ ) -> Left 2 + (_ , _ , _ , 0xFF, _ , _ , _ , _ ) -> Left 3 + (_ , _ , _ , _ , 0xFF, _ , _ , _ ) -> Left 4 + (_ , _ , _ , _ , _ , 0xFF, _ , _ ) -> Left 5 + (_ , _ , _ , _ , _ , _ , 0xFF, _ ) -> Left 6 + (_ , _ , _ , _ , _ , _ , _ , 0xFF) -> Left 7 + (ri1 , ri2 , ri3 , ri4 , ri5 , ri6 , ri7 , ri8 ) -> + -- 0001 1111 << 3 | 0001 11xx >> 2 + let o1 = (ri1 `unsafeShiftL` 3) .|. (ri2 `unsafeShiftR` 2) + -- 000x xx11 << 6 | 0001 1111 << 1 | 0001 xxxx >> 4 + o2 = (ri2 `unsafeShiftL` 6) .|. (ri3 `unsafeShiftL` 1) .|. (ri4 `unsafeShiftR` 4) + -- 000x 1111 << 4 | 0001 111x >> 1 + o3 = (ri4 `unsafeShiftL` 4) .|. (ri5 `unsafeShiftR` 1) + -- 000x xxx1 << 7 | 0001 1111 << 2 | 0001 1xxx >> 3 + o4 = (ri5 `unsafeShiftL` 7) .|. (ri6 `unsafeShiftL` 2) .|. (ri7 `unsafeShiftR` 3) + -- 000x x111 << 5 | 0001 1111 + o5 = (ri7 `unsafeShiftL` 5) .|. ri8 + in Right (o1, o2, o3, o4, o5) + where + rset :: Word8 -> Word8 + rset w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = fromIntegral w + + !rsetTable = "\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\x1A\x1B\x1C\x1D\x1E\x1F\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\ + \\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\ + \\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"# diff --git a/Data/Memory/Encoding/Base64.hs b/Data/Memory/Encoding/Base64.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Encoding/Base64.hs @@ -0,0 +1,327 @@ +-- | +-- Module : Data.Memory.Encoding.Base64 +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Low-level Base64 encoding and decoding. +-- +-- If you just want to encode or decode some bytes, you probably want to use +-- the "Data.ByteArray.Encoding" module. +-- +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Data.Memory.Encoding.Base64 + ( toBase64 + , toBase64URL + , toBase64OpenBSD + , unBase64Length + , unBase64LengthUnpadded + , fromBase64 + , fromBase64URLUnpadded + , fromBase64OpenBSD + ) where + +import Data.Memory.Internal.Compat +import Data.Memory.Internal.Imports +import Data.Bits ((.&.), (.|.)) +import GHC.Prim +import GHC.Word +import Foreign.Storable +import Foreign.Ptr (Ptr) + +-- | Transform a number of bytes pointed by @src@ to base64 binary representation in @dst@ +-- +-- The destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64 dst src len = toBase64Internal set dst src len True + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# + +-- | Transform a number of bytes pointed by @src@ to, URL-safe base64 binary +-- representation in @dst@. The result will be either padded or unpadded, +-- depending on the boolean @padded@ argument. +-- +-- The destination memory need to be of correct size, otherwise it will lead +-- to really bad things. +toBase64URL :: Bool -> Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64URL padded dst src len = toBase64Internal set dst src len padded + where + !set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# + +toBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +toBase64OpenBSD dst src len = toBase64Internal set dst src len False + where + !set = "./ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"# + +toBase64Internal :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> Bool -> IO () +toBase64Internal table dst src len padded = loop 0 0 + where + eqChar = 0x3d :: Word8 + + loop i di + | i >= len = return () + | otherwise = do + a <- peekByteOff src i + b <- if i + 1 >= len then return 0 else peekByteOff src (i+1) + c <- if i + 2 >= len then return 0 else peekByteOff src (i+2) + + let (w,x,y,z) = convert3 table a b c + + pokeByteOff dst di w + pokeByteOff dst (di+1) x + + if i + 1 < len + then + pokeByteOff dst (di+2) y + else + when padded (pokeByteOff dst (di+2) eqChar) + if i + 2 < len + then + pokeByteOff dst (di+3) z + else + when padded (pokeByteOff dst (di+3) eqChar) + + loop (i+3) (di+4) + +convert3 :: Addr# -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8) +convert3 table !a !b !c = + let !w = a `unsafeShiftR` 2 + !x = ((a `unsafeShiftL` 4) .&. 0x30) .|. (b `unsafeShiftR` 4) + !y = ((b `unsafeShiftL` 2) .&. 0x3c) .|. (c `unsafeShiftR` 6) + !z = c .&. 0x3f + in (index w, index x, index y, index z) + where + index :: Word8 -> Word8 + index !idxb = W8# (indexWord8OffAddr# table (word2Int# idx)) + where !(W# idx) = fromIntegral idxb + +-- | Get the length needed for the destination buffer for a base64 decoding. +-- +-- if the length is not a multiple of 4, Nothing is returned +unBase64Length :: Ptr Word8 -> Int -> IO (Maybe Int) +unBase64Length src len + | len < 1 = return $ Just 0 + | (len `mod` 4) /= 0 = return Nothing + | otherwise = do + last1Byte <- peekByteOff src (len - 1) + last2Byte <- peekByteOff src (len - 2) + let dstLen = if last1Byte == eqAscii + then if last2Byte == eqAscii then 2 else 1 + else 0 + return $ Just $ (len `div` 4) * 3 - dstLen + where + eqAscii :: Word8 + eqAscii = fromIntegral (fromEnum '=') + +-- | Get the length needed for the destination buffer for an +-- base64 decoding. +-- +-- If the length of the encoded string is a multiple of 4, plus one, Nothing is +-- returned. Any other value can be valid without padding. +unBase64LengthUnpadded :: Int -> Maybe Int +unBase64LengthUnpadded len = case r of + 0 -> Just (3*q) + 2 -> Just (3*q + 1) + 3 -> Just (3*q + 2) + _ -> Nothing + where (q, r) = len `divMod` 4 + +fromBase64OpenBSD :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64OpenBSD dst src len = fromBase64Unpadded rsetOpenBSD dst src len + +fromBase64URLUnpadded :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64URLUnpadded dst src len = fromBase64Unpadded rsetURL dst src len + +fromBase64Unpadded :: (Word8 -> Word8) -> Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64Unpadded rset dst src len = loop 0 0 + where loop di i + | i == len = return Nothing + | i == len - 1 = return Nothing -- Shouldn't happen if len is valid + | i == len - 2 = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + + case decode2 a b of + Left ofs -> return $ Just (i + ofs) + Right x -> do + pokeByteOff dst di x + return Nothing + | i == len - 3 = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + + case decode3 a b c of + Left ofs -> return $ Just (i + ofs) + Right (x,y) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + return Nothing + | otherwise = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + case decode4 a b c d of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + pokeByteOff dst (di+2) z + loop (di + 3) (i + 4) + + decode2 :: Word8 -> Word8 -> Either Int Word8 + decode2 a b = + case (rset a, rset b) of + (0xff, _ ) -> Left 0 + (_ , 0xff) -> Left 1 + (ra , rb ) -> Right ((ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4)) + + decode3 :: Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8) + decode3 a b c = + case (rset a, rset b, rset c) of + (0xff, _ , _ ) -> Left 0 + (_ , 0xff, _ ) -> Left 1 + (_ , _ , 0xff) -> Left 2 + (ra , rb , rc ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + in Right (x,y) + + + decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8) + decode4 a b c d = + case (rset a, rset b, rset c, rset d) of + (0xff, _ , _ , _ ) -> Left 0 + (_ , 0xff, _ , _ ) -> Left 1 + (_ , _ , 0xff, _ ) -> Left 2 + (_ , _ , _ , 0xff) -> Left 3 + (ra , rb , rc , rd ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + z = (rc `unsafeShiftL` 6) .|. rd + in Right (x,y,z) + +rsetURL :: Word8 -> Word8 +rsetURL !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = fromIntegral w + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\ + \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\ + \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\ + \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\x3f\ + \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\ + \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +rsetOpenBSD :: Word8 -> Word8 +rsetOpenBSD !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = fromIntegral w + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\ + \\x36\x37\x38\x39\x3a\x3b\x3c\x3d\x3e\x3f\xff\xff\xff\xff\xff\xff\ + \\xff\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\ + \\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\xff\xff\xff\xff\xff\ + \\xff\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\ + \\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\x34\x35\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + + +-- | convert from base64 in @src@ to binary in @dst@, using the number of bytes specified +-- +-- the user should use unBase64Length to compute the correct length, or check that +-- the length specification is proper. no check is done here. +fromBase64 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int) +fromBase64 dst src len + | len == 0 = return Nothing + | otherwise = loop 0 0 + where loop di i + | i == (len-4) = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + let (nbBytes, c',d') = + case (c,d) of + (0x3d, 0x3d) -> (2, 0x30, 0x30) + (0x3d, _ ) -> (0, c, d) -- invalid: automatically 'c' will make it error out + (_ , 0x3d) -> (1, c, 0x30) + (_ , _ ) -> (0 :: Int, c, d) + case decode4 a b c' d' of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + when (nbBytes < 2) $ pokeByteOff dst (di+1) y + when (nbBytes < 1) $ pokeByteOff dst (di+2) z + return Nothing + | otherwise = do + a <- peekByteOff src i + b <- peekByteOff src (i+1) + c <- peekByteOff src (i+2) + d <- peekByteOff src (i+3) + + case decode4 a b c d of + Left ofs -> return $ Just (i + ofs) + Right (x,y,z) -> do + pokeByteOff dst di x + pokeByteOff dst (di+1) y + pokeByteOff dst (di+2) z + loop (di + 3) (i + 4) + + decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Int (Word8, Word8, Word8) + decode4 a b c d = + case (rset a, rset b, rset c, rset d) of + (0xff, _ , _ , _ ) -> Left 0 + (_ , 0xff, _ , _ ) -> Left 1 + (_ , _ , 0xff, _ ) -> Left 2 + (_ , _ , _ , 0xff) -> Left 3 + (ra , rb , rc , rd ) -> + let x = (ra `unsafeShiftL` 2) .|. (rb `unsafeShiftR` 4) + y = (rb `unsafeShiftL` 4) .|. (rc `unsafeShiftR` 2) + z = (rc `unsafeShiftL` 6) .|. rd + in Right (x,y,z) + + rset :: Word8 -> Word8 + rset !w = W8# (indexWord8OffAddr# rsetTable (word2Int# widx)) + where !(W# widx) = fromIntegral w + + !rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\xff\x3f\ + \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\ + \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\ + \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\xff\ + \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\ + \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\ + \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# diff --git a/Data/Memory/Endian.hs b/Data/Memory/Endian.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Endian.hs @@ -0,0 +1,121 @@ +-- | +-- Module : Data.Memory.Endian +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : good +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Memory.Endian + ( Endianness(..) + , getSystemEndianness + , BE(..), LE(..) + , fromBE, toBE + , fromLE, toLE + , ByteSwap + ) where + +import Data.Word (Word16, Word32, Word64) +import Foreign.Storable +#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN) +import Data.Word (Word8) +import Data.Memory.Internal.Compat (unsafeDoIO) +import Foreign.Marshal.Alloc +import Foreign.Ptr +#endif + +import Data.Memory.Internal.Compat (byteSwap64, byteSwap32, byteSwap16) + +-- | represent the CPU endianness +-- +-- Big endian system stores bytes with the MSB as the first byte. +-- Little endian system stores bytes with the LSB as the first byte. +-- +-- middle endian is purposely avoided. +data Endianness = LittleEndian + | BigEndian + deriving (Show,Eq) + +-- | Return the system endianness +getSystemEndianness :: Endianness +#ifdef ARCH_IS_LITTLE_ENDIAN +getSystemEndianness = LittleEndian +#elif ARCH_IS_BIG_ENDIAN +getSystemEndianness = BigEndian +#else +getSystemEndianness + | isLittleEndian = LittleEndian + | isBigEndian = BigEndian + | otherwise = error "cannot determine endianness" + where + isLittleEndian = endianCheck == 2 + isBigEndian = endianCheck == 1 + endianCheck = unsafeDoIO $ alloca $ \p -> do + poke p (0x01000002 :: Word32) + peek (castPtr p :: Ptr Word8) +#endif + +-- | Little Endian value +newtype LE a = LE { unLE :: a } + deriving (Show,Eq,Storable) + +-- | Big Endian value +newtype BE a = BE { unBE :: a } + deriving (Show,Eq,Storable) + +-- | Convert a value in cpu endianess to big endian +toBE :: ByteSwap a => a -> BE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toBE = BE . byteSwap +#elif ARCH_IS_BIG_ENDIAN +toBE = BE +#else +toBE = BE . (if getSystemEndianness == LittleEndian then byteSwap else id) +#endif +{-# INLINE toBE #-} + +-- | Convert from a big endian value to the cpu endianness +fromBE :: ByteSwap a => BE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromBE (BE a) = byteSwap a +#elif ARCH_IS_BIG_ENDIAN +fromBE (BE a) = a +#else +fromBE (BE a) = if getSystemEndianness == LittleEndian then byteSwap a else a +#endif +{-# INLINE fromBE #-} + +-- | Convert a value in cpu endianess to little endian +toLE :: ByteSwap a => a -> LE a +#ifdef ARCH_IS_LITTLE_ENDIAN +toLE = LE +#elif ARCH_IS_BIG_ENDIAN +toLE = LE . byteSwap +#else +toLE = LE . (if getSystemEndianness == LittleEndian then id else byteSwap) +#endif +{-# INLINE toLE #-} + +-- | Convert from a little endian value to the cpu endianness +fromLE :: ByteSwap a => LE a -> a +#ifdef ARCH_IS_LITTLE_ENDIAN +fromLE (LE a) = a +#elif ARCH_IS_BIG_ENDIAN +fromLE (LE a) = byteSwap a +#else +fromLE (LE a) = if getSystemEndianness == LittleEndian then a else byteSwap a +#endif +{-# INLINE fromLE #-} + +-- | Class of types that can be byte-swapped. +-- +-- e.g. Word16, Word32, Word64 +class Storable a => ByteSwap a where + byteSwap :: a -> a +instance ByteSwap Word16 where + byteSwap = byteSwap16 +instance ByteSwap Word32 where + byteSwap = byteSwap32 +instance ByteSwap Word64 where + byteSwap = byteSwap64 diff --git a/Data/Memory/ExtendedWords.hs b/Data/Memory/ExtendedWords.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/ExtendedWords.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Data.Memory.ExtendedWords +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Extra Word size +-- +module Data.Memory.ExtendedWords + ( Word128(..) + ) where + +import Data.Word (Word64) + +-- | A simple Extended Word128 composed of 2 Word64 +data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq) diff --git a/Data/Memory/Hash/FNV.hs b/Data/Memory/Hash/FNV.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Hash/FNV.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Data.Memory.Hash.FNV +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- Fowler Noll Vo Hash (1 and 1a / 32 / 64 bits versions) +-- +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +module Data.Memory.Hash.FNV + ( + -- * types + FnvHash32(..) + , FnvHash64(..) + -- * methods + , fnv1 + , fnv1a + , fnv1_64 + , fnv1a_64 + ) where + +import Data.Bits (xor) +import Data.Memory.Internal.Compat () +import Data.Memory.Internal.Imports +import GHC.Word +import GHC.Prim hiding (Word64#, Int64#) +import GHC.Types +import GHC.Ptr + +-- | FNV1(a) hash (32 bit variants) +newtype FnvHash32 = FnvHash32 Word32 + deriving (Show,Eq,Ord,NFData) + +-- | FNV1(a) hash (64 bit variants) +newtype FnvHash64 = FnvHash64 Word64 + deriving (Show,Eq,Ord,NFData) + +fnv1_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 +fnv1_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (xor (0x01000193 * acc) (fromIntegral w)) +{-# INLINE fnv1_32_Mix8 #-} + +fnv1a_32_Mix8 :: Word8 -> FnvHash32 -> FnvHash32 +fnv1a_32_Mix8 !w (FnvHash32 acc) = FnvHash32 (0x01000193 * xor acc (fromIntegral w)) +{-# INLINE fnv1a_32_Mix8 #-} + +fnv1_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 +fnv1_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (xor (0x100000001b3 * acc) (fromIntegral w)) +{-# INLINE fnv1_64_Mix8 #-} + +fnv1a_64_Mix8 :: Word8 -> FnvHash64 -> FnvHash64 +fnv1a_64_Mix8 !w (FnvHash64 acc) = FnvHash64 (0x100000001b3 * xor acc (fromIntegral w)) +{-# INLINE fnv1a_64_Mix8 #-} + +-- | compute FNV1 (32 bit variant) of a raw piece of memory +fnv1 :: Ptr Word8 -> Int -> IO FnvHash32 +fnv1 (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 + where + loop :: FnvHash32 -> Int -> IO FnvHash32 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1_32_Mix8 v acc) (i + 1) + +-- | compute FNV1a (32 bit variant) of a raw piece of memory +fnv1a :: Ptr Word8 -> Int -> IO FnvHash32 +fnv1a (Ptr addr) n = loop (FnvHash32 0x811c9dc5) 0 + where + loop :: FnvHash32 -> Int -> IO FnvHash32 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1a_32_Mix8 v acc) (i + 1) + +-- | compute FNV1 (64 bit variant) of a raw piece of memory +fnv1_64 :: Ptr Word8 -> Int -> IO FnvHash64 +fnv1_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 + where + loop :: FnvHash64 -> Int -> IO FnvHash64 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1_64_Mix8 v acc) (i + 1) + +-- | compute FNV1a (64 bit variant) of a raw piece of memory +fnv1a_64 :: Ptr Word8 -> Int -> IO FnvHash64 +fnv1a_64 (Ptr addr) n = loop (FnvHash64 0xcbf29ce484222325) 0 + where + loop :: FnvHash64 -> Int -> IO FnvHash64 + loop !acc !i + | i == n = pure $ acc + | otherwise = do + v <- read8 addr i + loop (fnv1a_64_Mix8 v acc) (i + 1) + +read8 :: Addr# -> Int -> IO Word8 +read8 addr (I# i) = IO $ \s -> case readWord8OffAddr# addr i s of + (# s2, e #) -> (# s2, W8# e #) diff --git a/Data/Memory/Hash/SipHash.hs b/Data/Memory/Hash/SipHash.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Hash/SipHash.hs @@ -0,0 +1,163 @@ +-- | +-- Module : Data.Memory.Hash.SipHash +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : good +-- +-- provide the SipHash algorithm. +-- reference: +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.Memory.Hash.SipHash + ( SipKey(..) + , SipHash(..) + , hash + , hashWith + ) where + +import Data.Memory.Endian +import Data.Memory.Internal.Compat +import Data.Word +import Data.Bits +import Data.Typeable (Typeable) +import Control.Monad +import Foreign.Ptr +import Foreign.Storable + +-- | SigHash Key +data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | Siphash tag value +newtype SipHash = SipHash Word64 + deriving (Show,Eq,Ord,Typeable) + +data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + +-- | produce a siphash with a key and a memory pointer + length. +hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash +hash = hashWith 2 4 + +-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest. +hashWith :: Int -- ^ siphash C + -> Int -- ^ siphash D + -> SipKey -- ^ key for the hash + -> Ptr Word8 -- ^ memory pointer + -> Int -- ^ length of the data + -> IO SipHash +hashWith c d key startPtr totalLen = runHash (initSip key) startPtr totalLen + where runHash !st !ptr l + | l > 7 = peek (castPtr ptr) >>= \v -> runHash (process st (fromLE v)) (ptr `plusPtr` 8) (l-8) + | otherwise = do + let !lengthBlock = (fromIntegral totalLen `mod` 256) `unsafeShiftL` 56 + (finish . process st) `fmap` case l of + 0 -> do return lengthBlock + 1 -> do v0 <- peekByteOff ptr 0 + return (lengthBlock .|. to64 v0) + 2 -> do (v0,v1) <- liftM2 (,) (peekByteOff ptr 0) (peekByteOff ptr 1) + return (lengthBlock + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 3 -> do (v0,v1,v2) <- liftM3 (,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + return ( lengthBlock + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 4 -> do (v0,v1,v2,v3) <- liftM4 (,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) + return ( lengthBlock + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 5 -> do (v0,v1,v2,v3,v4) <- liftM5 (,,,,) (peekByteOff ptr 0) (peekByteOff ptr 1) (peekByteOff ptr 2) + (peekByteOff ptr 3) (peekByteOff ptr 4) + return ( lengthBlock + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 6 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + return ( lengthBlock + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + 7 -> do v0 <- peekByteOff ptr 0 + v1 <- peekByteOff ptr 1 + v2 <- peekByteOff ptr 2 + v3 <- peekByteOff ptr 3 + v4 <- peekByteOff ptr 4 + v5 <- peekByteOff ptr 5 + v6 <- peekByteOff ptr 6 + return ( lengthBlock + .|. (to64 v6 `unsafeShiftL` 48) + .|. (to64 v5 `unsafeShiftL` 40) + .|. (to64 v4 `unsafeShiftL` 32) + .|. (to64 v3 `unsafeShiftL` 24) + .|. (to64 v2 `unsafeShiftL` 16) + .|. (to64 v1 `unsafeShiftL` 8) + .|. to64 v0) + _ -> error "siphash: internal error: cannot happens" + + {-# INLINE to64 #-} + to64 :: Word8 -> Word64 + to64 = fromIntegral + + {-# INLINE process #-} + process istate m = newState + where newState = postInject $! runRoundsCompression $! preInject istate + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 v2 (v3 `xor` m) + postInject (InternalState v0 v1 v2 v3) = InternalState (v0 `xor` m) v1 v2 v3 + + {-# INLINE finish #-} + finish istate = getDigest $! runRoundsDigest $! preInject istate + where getDigest (InternalState v0 v1 v2 v3) = SipHash (v0 `xor` v1 `xor` v2 `xor` v3) + preInject (InternalState v0 v1 v2 v3) = InternalState v0 v1 (v2 `xor` 0xff) v3 + + {-# INLINE doRound #-} + doRound (InternalState v0 v1 v2 v3) = + let !v0' = v0 + v1 + !v2' = v2 + v3 + !v1' = v1 `rotateL` 13 + !v3' = v3 `rotateL` 16 + !v1'' = v1' `xor` v0' + !v3'' = v3' `xor` v2' + !v0'' = v0' `rotateL` 32 + !v2'' = v2' + v1'' + !v0''' = v0'' + v3'' + !v1''' = v1'' `rotateL` 17 + !v3''' = v3'' `rotateL` 21 + !v1'''' = v1''' `xor` v2'' + !v3'''' = v3''' `xor` v0''' + !v2''' = v2'' `rotateL` 32 + in InternalState v0''' v1'''' v2''' v3'''' + + {-# INLINE runRoundsCompression #-} + runRoundsCompression st + | c == 2 = doRound $! doRound st + | otherwise = loopRounds c st + + {-# INLINE runRoundsDigest #-} + runRoundsDigest st + | d == 4 = doRound $! doRound $! doRound $! doRound st + | otherwise = loopRounds d st + + {-# INLINE loopRounds #-} + loopRounds 1 !v = doRound v + loopRounds n !v = loopRounds (n-1) (doRound v) + + {-# INLINE initSip #-} + initSip (SipKey k0 k1) = InternalState (k0 `xor` 0x736f6d6570736575) + (k1 `xor` 0x646f72616e646f6d) + (k0 `xor` 0x6c7967656e657261) + (k1 `xor` 0x7465646279746573) diff --git a/Data/Memory/Internal/Compat.hs b/Data/Memory/Internal/Compat.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Internal/Compat.hs @@ -0,0 +1,76 @@ +-- | +-- Module : Data.Memory.Internal.Compat +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Good +-- +-- This module try to keep all the difference between versions of base +-- or other needed packages, so that modules don't need to use CPP +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.Compat + ( unsafeDoIO + , popCount + , unsafeShiftL + , unsafeShiftR + , byteSwap64 + , byteSwap32 + , byteSwap16 + ) where + +import System.IO.Unsafe +import Data.Word +import Data.Bits + +-- | perform io for hashes that do allocation and ffi. +-- unsafeDupablePerformIO is used when possible as the +-- computation is pure and the output is directly linked +-- to the input. we also do not modify anything after it has +-- been returned to the user. +unsafeDoIO :: IO a -> a +#if __GLASGOW_HASKELL__ > 704 +unsafeDoIO = unsafeDupablePerformIO +#else +unsafeDoIO = unsafePerformIO +#endif + +#if !(MIN_VERSION_base(4,5,0)) +popCount :: Word64 -> Int +popCount n = loop 0 n + where loop c 0 = c + loop c i = loop (c + if testBit c 0 then 1 else 0) (i `shiftR` 1) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap64 :: Word64 -> Word64 +byteSwap64 w = + (w `shiftR` 56) .|. (w `shiftL` 56) + .|. ((w `shiftR` 40) .&. 0xff00) .|. ((w .&. 0xff00) `shiftL` 40) + .|. ((w `shiftR` 24) .&. 0xff0000) .|. ((w .&. 0xff0000) `shiftL` 24) + .|. ((w `shiftR` 8) .&. 0xff000000) .|. ((w .&. 0xff000000) `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap32 :: Word32 -> Word32 +byteSwap32 w = + (w `shiftR` 24) + .|. (w `shiftL` 24) + .|. ((w `shiftR` 8) .&. 0xff00) + .|. ((w .&. 0xff00) `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,7,0)) +byteSwap16 :: Word16 -> Word16 +byteSwap16 w = + (w `shiftR` 8) .|. (w `shiftL` 8) +#endif + +#if !(MIN_VERSION_base(4,5,0)) +unsafeShiftL :: Bits a => a -> Int -> a +unsafeShiftL = shiftL + +unsafeShiftR :: Bits a => a -> Int -> a +unsafeShiftR = shiftR +#endif + diff --git a/Data/Memory/Internal/CompatPrim.hs b/Data/Memory/Internal/CompatPrim.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Internal/CompatPrim.hs @@ -0,0 +1,70 @@ +-- | +-- Module : Data.Memory.Internal.CompatPrim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Compat +-- +-- This module try to keep all the difference between versions of ghc primitive +-- or other needed packages, so that modules don't need to use CPP. +-- +-- Note that MagicHash and CPP conflicts in places, making it "more interesting" +-- to write compat code for primitives +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +module Data.Memory.Internal.CompatPrim + ( be32Prim + , le32Prim + , byteswap32Prim + , booleanPrim + ) where + +import GHC.Prim + +-- | byteswap Word# to or from Big Endian +-- +-- on a big endian machine, this function is a nop. +be32Prim :: Word# -> Word# +#ifdef ARCH_IS_LITTLE_ENDIAN +be32Prim = byteswap32Prim +#else +be32Prim w = w +#endif + +-- | byteswap Word# to or from Little Endian +-- +-- on a little endian machine, this function is a nop. +le32Prim :: Word# -> Word# +#ifdef ARCH_IS_LITTLE_ENDIAN +le32Prim w = w +#else +le32Prim = byteswap32Prim +#endif + +-- | Simple compatibility for byteswap the lower 32 bits of a Word# +-- at the primitive level +byteswap32Prim :: Word# -> Word# +#if __GLASGOW_HASKELL__ >= 708 +byteswap32Prim w = byteSwap32# w +#else +byteswap32Prim w = + let !a = uncheckedShiftL# w 24# + !b = and# (uncheckedShiftL# w 8#) 0x00ff0000## + !c = and# (uncheckedShiftRL# w 8#) 0x0000ff00## + !d = and# (uncheckedShiftRL# w 24#) 0x000000ff## + in or# a (or# b (or# c d)) +#endif + +-- | Simple wrapper to handle pre 7.8 and future, where +-- most comparaison functions don't returns a boolean +-- anymore. +#if __GLASGOW_HASKELL__ >= 708 +booleanPrim :: Int# -> Bool +booleanPrim v = tagToEnum# v +#else +booleanPrim :: Bool -> Bool +booleanPrim b = b +#endif +{-# INLINE booleanPrim #-} diff --git a/Data/Memory/Internal/CompatPrim64.hs b/Data/Memory/Internal/CompatPrim64.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Internal/CompatPrim64.hs @@ -0,0 +1,169 @@ +-- | +-- Module : Data.Memory.Internal.CompatPrim +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : stable +-- Portability : Compat +-- +-- This module try to keep all the difference between versions of ghc primitive +-- or other needed packages, so that modules don't need to use CPP. +-- +-- Note that MagicHash and CPP conflicts in places, making it "more interesting" +-- to write compat code for primitives +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +#include "MachDeps.h" +module Data.Memory.Internal.CompatPrim64 + ( Word64# + , Int64# + , eqInt64# + , neInt64# + , ltInt64# + , leInt64# + , gtInt64# + , geInt64# + , quotInt64# + , remInt64# + , eqWord64# + , neWord64# + , ltWord64# + , leWord64# + , gtWord64# + , geWord64# + , and64# + , or64# + , xor64# + , not64# + , timesWord64# + , uncheckedShiftL64# + , uncheckedShiftRL64# + + , int64ToWord64# + , word64ToInt64# + , intToInt64# + , int64ToInt# + , wordToWord64# + , word64ToWord# + , w64# + ) where + + +#if WORD_SIZE_IN_BITS == 64 +import GHC.Prim hiding (Word64#, Int64#) + +#if __GLASGOW_HASKELL__ >= 708 +type OutBool = Int# +#else +type OutBool = Bool +#endif + +type Word64# = Word# +type Int64# = Int# + +#if __GLASGOW_HASKELL__ < 904 +eqWord64# :: Word64# -> Word64# -> OutBool +eqWord64# = eqWord# + +neWord64# :: Word64# -> Word64# -> OutBool +neWord64# = neWord# + +ltWord64# :: Word64# -> Word64# -> OutBool +ltWord64# = ltWord# + +leWord64# :: Word64# -> Word64# -> OutBool +leWord64# = leWord# + +gtWord64# :: Word64# -> Word64# -> OutBool +gtWord64# = gtWord# + +geWord64# :: Word64# -> Word64# -> OutBool +geWord64# = geWord# + +eqInt64# :: Int64# -> Int64# -> OutBool +eqInt64# = (==#) + +neInt64# :: Int64# -> Int64# -> OutBool +neInt64# = (/=#) + +ltInt64# :: Int64# -> Int64# -> OutBool +ltInt64# = (<#) + +leInt64# :: Int64# -> Int64# -> OutBool +leInt64# = (<=#) + +gtInt64# :: Int64# -> Int64# -> OutBool +gtInt64# = (>#) + +geInt64# :: Int64# -> Int64# -> OutBool +geInt64# = (<=#) + +quotInt64# :: Int64# -> Int64# -> Int64# +quotInt64# = quotInt# + +remInt64# :: Int64# -> Int64# -> Int64# +remInt64# = remInt# + +and64# :: Word64# -> Word64# -> Word64# +and64# = and# + +or64# :: Word64# -> Word64# -> Word64# +or64# = or# + +xor64# :: Word64# -> Word64# -> Word64# +xor64# = xor# + +not64# :: Word64# -> Word64# +not64# = not# + +uncheckedShiftL64# :: Word64# -> Int# -> Word64# +uncheckedShiftL64# = uncheckedShiftL# + +uncheckedShiftRL64# :: Word64# -> Int# -> Word64# +uncheckedShiftRL64# = uncheckedShiftL# + +int64ToWord64# :: Int64# -> Word64# +int64ToWord64# = int2Word# + +word64ToInt64# :: Word64# -> Int64# +word64ToInt64# = word2Int# + +intToInt64# :: Int# -> Int64# +intToInt64# w = w + +int64ToInt# :: Int64# -> Int# +int64ToInt# w = w + +wordToWord64# :: Word# -> Word64# +wordToWord64# w = w + +word64ToWord# :: Word64# -> Word# +word64ToWord# w = w + +timesWord64# :: Word64# -> Word64# -> Word64# +timesWord64# = timesWord# +#endif + +w64# :: Word# -> Word# -> Word# -> Word64# +w64# w _ _ = w + +#elif WORD_SIZE_IN_BITS == 32 +import GHC.IntWord64 +import GHC.Prim (Word#) + +timesWord64# :: Word64# -> Word64# -> Word64# +timesWord64# a b = + let !ai = word64ToInt64# a + !bi = word64ToInt64# b + in int64ToWord64# (timesInt64# ai bi) + +w64# :: Word# -> Word# -> Word# -> Word64# +w64# _ hw lw = + let !h = wordToWord64# hw + !l = wordToWord64# lw + in or64# (uncheckedShiftL64# h 32#) l +#else +#error "not a supported architecture. supported WORD_SIZE_IN_BITS is 32 bits or 64 bits" +#endif diff --git a/Data/Memory/Internal/DeepSeq.hs b/Data/Memory/Internal/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Internal/DeepSeq.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Data.Memory.Internal.DeepSeq +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- Simple abstraction module to allow compilation without deepseq +-- by defining our own NFData class if not compiling with deepseq +-- support. +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.DeepSeq + ( NFData(..) + ) where + +#ifdef WITH_DEEPSEQ_SUPPORT +import Control.DeepSeq +#else +import Data.Word + +class NFData a where rnf :: a -> () + +instance NFData Word8 where rnf w = w `seq` () +instance NFData Word16 where rnf w = w `seq` () +instance NFData Word32 where rnf w = w `seq` () +instance NFData Word64 where rnf w = w `seq` () +#endif diff --git a/Data/Memory/Internal/Imports.hs b/Data/Memory/Internal/Imports.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/Internal/Imports.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Data.Memory.Internal.Imports +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +{-# LANGUAGE CPP #-} +module Data.Memory.Internal.Imports + ( module X + ) where + +import Data.Word as X +import Control.Applicative as X +import Control.Monad as X (forM, forM_, void, when) +import Control.Arrow as X (first, second) +import Data.Memory.Internal.DeepSeq as X diff --git a/Data/Memory/MemMap/Posix.hsc b/Data/Memory/MemMap/Posix.hsc new file mode 100644 --- /dev/null +++ b/Data/Memory/MemMap/Posix.hsc @@ -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 +#include + +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} +module Data.Memory.MemMap.Posix + ( memoryMap + , memoryUnmap + , memoryAdvise + , memoryLock + , memoryUnlock + , memoryProtect + , memorySync + -- * Flags types + , MemoryMapFlag(..) + , MemoryProtection(..) + , MemoryAdvice(..) + , MemorySyncFlag(..) + -- * system page size + , sysconfPageSize + ) where + +import System.Posix.Types +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.Error +import Data.Bits + +foreign import ccall unsafe "mmap" + c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a) + +foreign import ccall unsafe "munmap" + c_munmap :: Ptr a -> CSize -> IO CInt + +#if defined(POSIX_MADV_NORMAL) +foreign import ccall unsafe "posix_madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#else +foreign import ccall unsafe "madvise" + c_madvise :: Ptr a -> CSize -> CInt -> IO CInt +#endif + +foreign import ccall unsafe "msync" + c_msync :: Ptr a -> CSize -> CInt -> IO CInt + +foreign import ccall unsafe "mprotect" + c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt + +#ifndef __HAIKU__ +foreign import ccall unsafe "mlock" + c_mlock :: Ptr a -> CSize -> IO CInt +#else +c_mlock :: Ptr a -> CSize -> IO CInt +c_mlock _ _ = return (-1) +#endif + +#ifndef __HAIKU__ +foreign import ccall unsafe "munlock" + c_munlock :: Ptr a -> CSize -> IO CInt +#else +c_munlock :: Ptr a -> CSize -> IO CInt +c_munlock _ _ = return (-1) +#endif + +foreign import ccall unsafe "sysconf" + c_sysconf :: CInt -> CLong + +-- | Mapping flag +data MemoryMapFlag = + MemoryMapShared -- ^ memory changes are shared between process + | MemoryMapPrivate -- ^ memory changes are private to process + deriving (Show,Read,Eq) + +-- | Memory protection +data MemoryProtection = + MemoryProtectionNone + | MemoryProtectionRead + | MemoryProtectionWrite + | MemoryProtectionExecute + deriving (Show,Read,Eq) + +-- | Advice to put on memory. +-- +-- only define the posix one. +data MemoryAdvice = + MemoryAdviceNormal -- ^ no specific advice, the default. + | MemoryAdviceRandom -- ^ Expect page references in random order. No readahead should occur. + | MemoryAdviceSequential -- ^ Expect page references in sequential order. Page should be readahead aggressively. + | MemoryAdviceWillNeed -- ^ Expect access in the near future. Probably a good idea to readahead early + | MemoryAdviceDontNeed -- ^ Do not expect access in the near future. + deriving (Show,Read,Eq) + +-- | Memory synchronization flags +data MemorySyncFlag = + MemorySyncAsync -- ^ perform asynchronous write. + | MemorySyncSync -- ^ perform synchronous write. + | MemorySyncInvalidate -- ^ invalidate cache data. + deriving (Show,Read,Eq) + +cvalueOfMemoryProts :: [MemoryProtection] -> CInt +cvalueOfMemoryProts = foldl (.|.) 0 . map toProt + where toProt :: MemoryProtection -> CInt + toProt MemoryProtectionNone = (#const PROT_NONE) + toProt MemoryProtectionRead = (#const PROT_READ) + toProt MemoryProtectionWrite = (#const PROT_WRITE) + toProt MemoryProtectionExecute = (#const PROT_EXEC) + +cvalueOfMemorySync :: [MemorySyncFlag] -> CInt +cvalueOfMemorySync = foldl (.|.) 0 . map toSync + where toSync MemorySyncAsync = (#const MS_ASYNC) + toSync MemorySyncSync = (#const MS_SYNC) + toSync MemorySyncInvalidate = (#const MS_INVALIDATE) + +-- | Map pages of memory. +-- +-- If fd is present, this memory will represent the file associated. +-- Otherwise, the memory will be an anonymous mapping. +-- +-- use 'mmap' +memoryMap :: Maybe (Ptr a) -- ^ The address to map to if MapFixed is used. + -> CSize -- ^ The length of the mapping + -> [MemoryProtection] -- ^ the memory protection associated with the mapping + -> MemoryMapFlag -- ^ + -> Maybe Fd + -> COff + -> IO (Ptr a) +memoryMap initPtr sz prots flag mfd off = + throwErrnoIf (== m1ptr) "mmap" (c_mmap (maybe nullPtr id initPtr) sz cprot cflags fd off) + where m1ptr = nullPtr `plusPtr` (-1) + fd = maybe (-1) (\(Fd v) -> v) mfd + cprot = cvalueOfMemoryProts prots + cflags = maybe cMapAnon (const 0) mfd + .|. maybe 0 (const cMapFixed) initPtr + .|. toMapFlag flag + +#ifdef __APPLE__ + cMapAnon = (#const MAP_ANON) +#else + cMapAnon = (#const MAP_ANONYMOUS) +#endif + cMapFixed = (#const MAP_FIXED) + + toMapFlag MemoryMapShared = (#const MAP_SHARED) + toMapFlag MemoryMapPrivate = (#const MAP_PRIVATE) + +-- | Unmap pages of memory +-- +-- use 'munmap' +memoryUnmap :: Ptr a -> CSize -> IO () +memoryUnmap ptr sz = throwErrnoIfMinus1_ "munmap" (c_munmap ptr sz) + +-- | give advice to the operating system about use of memory +-- +-- call 'madvise' +memoryAdvise :: Ptr a -> CSize -> MemoryAdvice -> IO () +memoryAdvise ptr sz adv = throwErrnoIfMinus1_ "madvise" (c_madvise ptr sz cadv) + where cadv = toAdvice adv +#if defined(POSIX_MADV_NORMAL) + toAdvice MemoryAdviceNormal = (#const POSIX_MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const POSIX_MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const POSIX_MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const POSIX_MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const POSIX_MADV_DONTNEED) +#else + toAdvice MemoryAdviceNormal = (#const MADV_NORMAL) + toAdvice MemoryAdviceRandom = (#const MADV_RANDOM) + toAdvice MemoryAdviceSequential = (#const MADV_SEQUENTIAL) + toAdvice MemoryAdviceWillNeed = (#const MADV_WILLNEED) + toAdvice MemoryAdviceDontNeed = (#const MADV_DONTNEED) +#endif + +-- | lock a range of process address space +-- +-- call 'mlock' +memoryLock :: Ptr a -> CSize -> IO () +memoryLock ptr sz = throwErrnoIfMinus1_ "mlock" (c_mlock ptr sz) + +-- | unlock a range of process address space +-- +-- call 'munlock' +memoryUnlock :: Ptr a -> CSize -> IO () +memoryUnlock ptr sz = throwErrnoIfMinus1_ "munlock" (c_munlock ptr sz) + +-- | set protection of memory mapping +-- +-- call 'mprotect' +memoryProtect :: Ptr a -> CSize -> [MemoryProtection] -> IO () +memoryProtect ptr sz prots = throwErrnoIfMinus1_ "mprotect" (c_mprotect ptr sz cprot) + where cprot = cvalueOfMemoryProts prots + +-- | memorySync synchronize memory with physical storage. +-- +-- On an anonymous mapping this function doesn't have any effect. +-- call 'msync' +memorySync :: Ptr a -> CSize -> [MemorySyncFlag] -> IO () +memorySync ptr sz flags = throwErrnoIfMinus1_ "msync" (c_msync ptr sz cflags) + where cflags = cvalueOfMemorySync flags + +-- | Return the operating system page size. +-- +-- call 'sysconf' +sysconfPageSize :: Int +sysconfPageSize = fromIntegral $ c_sysconf (#const _SC_PAGESIZE) diff --git a/Data/Memory/MemMap/Windows.hs b/Data/Memory/MemMap/Windows.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/MemMap/Windows.hs @@ -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 diff --git a/Data/Memory/PtrMethods.hs b/Data/Memory/PtrMethods.hs new file mode 100644 --- /dev/null +++ b/Data/Memory/PtrMethods.hs @@ -0,0 +1,120 @@ +-- | +-- Module : Data.Memory.PtrMethods +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- +-- methods to manipulate raw memory representation +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Data.Memory.PtrMethods + ( memCreateTemporary + , memXor + , memXorWith + , memCopy + , memSet + , memReverse + , memEqual + , memConstEqual + , memCompare + ) where + +import Data.Memory.Internal.Imports +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek, poke, peekByteOff) +import Foreign.C.Types +import Foreign.Marshal.Alloc (allocaBytesAligned) +import Data.Bits ((.|.), xor) + +-- | Create a new temporary buffer +memCreateTemporary :: Int -> (Ptr Word8 -> IO a) -> IO a +memCreateTemporary size f = allocaBytesAligned size 8 f + +-- | xor bytes from source1 and source2 to destination +-- +-- d = s1 xor s2 +-- +-- s1, nor s2 are modified unless d point to s1 or s2 +memXor :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO () +memXor _ _ _ 0 = return () +memXor d s1 s2 n = do + (xor <$> peek s1 <*> peek s2) >>= poke d + memXor (d `plusPtr` 1) (s1 `plusPtr` 1) (s2 `plusPtr` 1) (n-1) + +-- | xor bytes from source with a specific value to destination +-- +-- d = replicate (sizeof s) v `xor` s +memXorWith :: Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO () +memXorWith destination !v source bytes + | destination == source = loopInplace source bytes + | otherwise = loop destination source bytes + where + loop !d !s n = when (n > 0) $ do + peek s >>= poke d . xor v + loop (d `plusPtr` 1) (s `plusPtr` 1) (n-1) + + loopInplace !s n = when (n > 0) $ do + peek s >>= poke s . xor v + loopInplace (s `plusPtr` 1) (n-1) + +-- | Copy a set number of bytes from @src to @dst +memCopy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memCopy dst src n = c_memcpy dst src (fromIntegral n) +{-# INLINE memCopy #-} + +-- | Set @n number of bytes to the same value @v +memSet :: Ptr Word8 -> Word8 -> Int -> IO () +memSet start v n = c_memset start v (fromIntegral n) >>= \_ -> return () +{-# INLINE memSet #-} + +-- | Reverse a set number of bytes from @src@ to @dst@. Memory +-- locations should not overlap. +memReverse :: Ptr Word8 -> Ptr Word8 -> Int -> IO () +memReverse d s n + | n > 0 = do peekByteOff s (n - 1) >>= poke d + memReverse (d `plusPtr` 1) s (n - 1) + | otherwise = return () + +-- | Check if two piece of memory are equals +memEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +memEqual p1 p2 n = loop 0 + where + loop i + | i == n = return True + | otherwise = do + e <- (==) <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + if e then loop (i+1) else return False + +-- | Compare two piece of memory and returns how they compare +memCompare :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering +memCompare p1 p2 n = loop 0 + where + loop i + | i == n = return EQ + | otherwise = do + e <- compare <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + if e == EQ then loop (i+1) else return e + +-- | A constant time equality test for 2 Memory buffers +-- +-- compared to normal equality function, this function will go +-- over all the bytes present before yielding a result even when +-- knowing the overall result early in the processing. +memConstEqual :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +memConstEqual p1 p2 n = loop 0 0 + where + loop i !acc + | i == n = return $! acc == 0 + | otherwise = do + e <- xor <$> peekByteOff p1 i <*> (peekByteOff p2 i :: IO Word8) + loop (i+1) (acc .|. e) + +foreign import ccall unsafe "memset" + c_memset :: Ptr Word8 -> Word8 -> CSize -> IO () + +foreign import ccall unsafe "memcpy" + c_memcpy :: Ptr Word8 -> Ptr Word8 -> CSize -> IO () diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2015-2018 Vincent Hanquez +Copyright (c) 2017-2018 Nicolas Di Prima + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ram.cabal b/ram.cabal new file mode 100644 --- /dev/null +++ b/ram.cabal @@ -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 +author: Vincent Hanquez +maintainer: hi@jappie.me +category: memory +stability: experimental +build-type: Simple +homepage: https://github.com/jappeace/ram +bug-reports: https://github.com/jappeace/ram/issues +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/jappeace/ram + +library + exposed-modules: + Data.ByteArray + Data.ByteArray.Encoding + Data.ByteArray.Hash + Data.ByteArray.Mapping + Data.ByteArray.Pack + Data.ByteArray.Parse + Data.Memory.Encoding.Base16 + Data.Memory.Encoding.Base32 + Data.Memory.Encoding.Base64 + Data.Memory.Endian + Data.Memory.ExtendedWords + Data.Memory.PtrMethods + + other-modules: + Data.ByteArray.Bytes + Data.ByteArray.MemView + Data.ByteArray.Methods + Data.ByteArray.Pack.Internal + Data.ByteArray.ScrubbedBytes + Data.ByteArray.Types + Data.ByteArray.View + Data.Memory.Hash.FNV + Data.Memory.Hash.SipHash + Data.Memory.Internal.Compat + Data.Memory.Internal.CompatPrim + Data.Memory.Internal.CompatPrim64 + Data.Memory.Internal.DeepSeq + Data.Memory.Internal.Imports + + exposed-modules: Data.ByteArray.Sized + build-depends: + , base <4.23 + , bytestring <0.13 + , deepseq >=1.1 && <1.17 + , ghc-prim <0.14 + + -- FIXME armel or mispel is also little endian. + -- might be a good idea to also add a runtime autodetect mode. + -- ARCH_ENDIAN_UNKNOWN + if (arch(i386) || arch(x86_64)) + cpp-options: -DARCH_IS_LITTLE_ENDIAN + + if os(windows) + other-modules: Data.Memory.MemMap.Windows + + else + other-modules: Data.Memory.MemMap.Posix + + ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 + +test-suite test-memory + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + other-modules: + Imports + SipHash + Utils + + build-depends: + , base <5 + , bytestring + , memory + , QuickCheck + , tasty + + ghc-options: + -Wall -fno-warn-orphans -fno-warn-missing-signatures -threaded + + default-language: Haskell2010 diff --git a/tests/Imports.hs b/tests/Imports.hs new file mode 100644 --- /dev/null +++ b/tests/Imports.hs @@ -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) diff --git a/tests/SipHash.hs b/tests/SipHash.hs new file mode 100644 --- /dev/null +++ b/tests/SipHash.hs @@ -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 + ] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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) + ] diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -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..]