haskell/cryptonite
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

import memory as builtin

Browse Source
This commit is contained in:
Vincent Hanquez 2015-05-09 14:23:10 +01:00
parent ac16029f07
commit 68e3a58be7
14 changed files with 1027 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Data/Memory/ByteArray.hs Normal file
View File

@ -0,0 +1,22 @@
-- |
-- Module : Data.Memory.ByteArray
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
-- Simple and efficient byte array types
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Memory.ByteArray
( module X
) where
import Data.Memory.ByteArray.Types as X
import Data.Memory.ByteArray.Methods as X
import Data.Memory.ByteArray.ScrubbedBytes as X (ScrubbedBytes)
import Data.Memory.ByteArray.Bytes as X (Bytes)
import Data.Memory.ByteArray.MemView as X (MemView(..))

123
Data/Memory/ByteArray/Bytes.hs Normal file
View File

@ -0,0 +1,123 @@
-- |
-- Module : Data.Memory.ByteArray.Bytes
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
-- Simple and efficient byte array types
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Data.Memory.ByteArray.Bytes
( Bytes
) where
import GHC.Types
import GHC.Prim
import GHC.Ptr
import Data.Memory.Internal.CompatPrim
import Data.Memory.Internal.Compat (unsafeDoIO)
import Data.Memory.ByteArray.Types
import Data.Memory.Encoding.Base16 (showHexadecimal)
data Bytes = Bytes (MutableByteArray# RealWorld)
instance Show Bytes where
show = bytesShowHex
instance Eq Bytes where
(==) = bytesEq
instance ByteArrayAccess Bytes where
length = bytesLength
withByteArray = withBytes
instance ByteArray Bytes where
allocRet = bytesAllocRet
------------------------------------------------------------------------
newBytes :: Int -> IO Bytes
newBytes (I# sz) = 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', () #)
sizeofBytes :: Bytes -> Int
sizeofBytes (Bytes mba) = I# (sizeofMutableByteArray# mba)
withPtr :: Bytes -> (Ptr p -> IO a) -> IO a
withPtr b@(Bytes mba) f = do
a <- f (Ptr (byteArrayContents# (unsafeCoerce# mba)))
touchBytes b
return a
------------------------------------------------------------------------
{-
bytesCopyAndModify :: Bytes -> (Ptr a -> IO ()) -> IO Bytes
bytesCopyAndModify src f = do
dst <- newBytes sz
withPtr dst $ \d -> do
withPtr src $ \s -> copyBytes (castPtr d) s sz
f d
return dst
where sz = sizeofBytes src
bytesTemporary :: Int -> (Ptr p -> IO a) -> IO a
bytesTemporary sz f = newBytes sz >>= \ba -> withPtr ba f
bytesCopyTemporary :: Bytes -> (Ptr p -> IO a) -> IO a
bytesCopyTemporary src f = do
dst <- newBytes (sizeofBytes src)
withPtr dst $ \d -> do
withPtr src $ \s -> copyBytes (castPtr d) s (sizeofBytes src)
f d
bytesAlloc :: Int -> (Ptr p -> IO ()) -> IO Bytes
bytesAlloc sz f = do
ba <- newBytes sz
withPtr ba f
return ba
-}
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
withBytes :: Bytes -> (Ptr p -> IO a) -> IO a
withBytes = withPtr
bytesEq :: Bytes -> Bytes -> Bool
bytesEq b1@(Bytes m1) b2@(Bytes m2)
| l1 /= l2 = False
| otherwise = unsafeDoIO $ IO $ \s -> loop 0# s
where
!l1@(I# len) = bytesLength b1
!l2 = bytesLength b2
loop i s
| booleanPrim (i ==# len) = (# s, True #)
| otherwise =
case readWord8Array# m1 i s of
(# s', e1 #) -> case readWord8Array# m2 i s' of
(# s'', e2 #) ->
if booleanPrim (eqWord# e1 e2)
then loop (i +# 1#) s''
else (# s', False #)
{-
bytesIndex :: Bytes -> Int -> Word8
bytesIndex (Bytes m) (I# i) = unsafeDoIO $ IO $ \s ->
case readWord8Array# m i s of
(# s', e #) -> (# s', W8# e #)
{-# NOINLINE bytesIndex #-}
-}
bytesShowHex :: Bytes -> String
bytesShowHex b = showHexadecimal (withPtr b) (bytesLength b)
{-# NOINLINE bytesShowHex #-}

21
Data/Memory/ByteArray/MemView.hs Normal file
View File

@ -0,0 +1,21 @@
-- |
-- Module : Data.Memory.ByteArray.MemView
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
module Data.Memory.ByteArray.MemView
( MemView(..)
) where
import Foreign.Ptr
import Data.Memory.ByteArray.Types
import Data.Memory.Internal.Imports
data MemView = MemView !(Ptr Word8) !Int
instance ByteArrayAccess MemView where
length (MemView _ l) = l
withByteArray (MemView p _) f = f (castPtr p)

191
Data/Memory/ByteArray/Methods.hs Normal file
View File

@ -0,0 +1,191 @@
-- |
-- Module : Data.Memory.ByteArray.Methods
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
{-# LANGUAGE BangPatterns #-}
module Data.Memory.ByteArray.Methods
( alloc
, allocAndFreeze
, empty
, zero
, copy
, take
, convert
, convertHex
, copyRet
, copyAndFreeze
, split
, xor
, eq
, index
, constEq
, concat
, toW64BE
, toW64LE
, mapAsWord64
, mapAsWord128
) where
import Data.Memory.Internal.Compat
import Data.Memory.Internal.Imports hiding (empty)
import Data.Memory.ByteArray.Types
import Data.Memory.Endian
import Data.Memory.PtrMethods
import Data.Memory.ExtendedWords
import Data.Memory.Encoding.Base16
import Foreign.Storable
import Foreign.Ptr
import Prelude hiding (length, take, concat)
alloc :: ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
alloc n f = snd `fmap` allocRet n f
allocAndFreeze :: ByteArray a => Int -> (Ptr p -> IO ()) -> a
allocAndFreeze sz f = unsafeDoIO (alloc sz f)
empty :: ByteArray a => a
empty = unsafeDoIO (alloc 0 $ \_ -> return ())
-- | 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 =
allocAndFreeze n $ \pc ->
withByteArray a $ \pa ->
withByteArray b $ \pb ->
memXor pc pa pb n
where
n = min la lb
la = length a
lb = length b
index :: ByteArrayAccess a => a -> Int -> Word8
index b i = unsafeDoIO $ withByteArray b $ \p -> peek (p `plusPtr` i)
split :: ByteArray bs => Int -> bs -> (bs, bs)
split 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 :: ByteArray bs => Int -> bs -> bs
take n bs =
allocAndFreeze m $ \d -> withByteArray bs $ \s -> memCopy d s m
where
m = min len n
len = length bs
concat :: ByteArray bs => [bs] -> bs
concat [] = empty
concat allBs = allocAndFreeze total (loop allBs)
where
total = sum $ map length allBs
loop [] _ = return ()
loop (b:bs) dst = do
let sz = length b
withByteArray b $ \p -> memCopy dst p sz
loop bs (dst `plusPtr` sz)
copy :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> IO bs2
copy bs f =
alloc (length bs) $ \d -> do
withByteArray bs $ \s -> memCopy d s (length bs)
f (castPtr d)
copyRet :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO a) -> IO (a, bs2)
copyRet bs f =
allocRet (length bs) $ \d -> do
withByteArray bs $ \s -> memCopy d s (length bs)
f (castPtr d)
copyAndFreeze :: (ByteArrayAccess bs1, ByteArray bs2) => bs1 -> (Ptr p -> IO ()) -> bs2
copyAndFreeze bs f =
allocAndFreeze (length bs) $ \d -> do
withByteArray bs $ \s -> memCopy d s (length bs)
f (castPtr d)
zero :: ByteArray ba => Int -> ba
zero n = allocAndFreeze n $ \ptr -> memSet ptr 0 n
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
toW64BE :: ByteArrayAccess bs => bs -> Int -> BE Word64
toW64BE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)
toW64LE :: ByteArrayAccess bs => bs -> Int -> LE Word64
toW64LE bs ofs = unsafeDoIO $ withByteArray bs $ \p -> peek (p `plusPtr` ofs)
mapAsWord128 :: ByteArray bs => (Word128 -> Word128) -> bs -> bs
mapAsWord128 f bs =
allocAndFreeze 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)
mapAsWord64 :: ByteArray bs => (Word64 -> Word64) -> bs -> bs
mapAsWord64 f bs =
allocAndFreeze 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)
convert :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout
convert = flip copyAndFreeze (\_ -> return ())
convertHex :: (ByteArrayAccess bin, ByteArray bout) => bin -> bout
convertHex b =
allocAndFreeze (length b * 2) $ \bout ->
withByteArray b $ \bin ->
toHexadecimal bout bin (length b)

103
Data/Memory/ByteArray/ScrubbedBytes.hs Normal file
View File

@ -0,0 +1,103 @@
-- |
-- Module : Data.Memory.ByteArray.ScrubbedBytes
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : Stable
-- Portability : GHC
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE CPP #-}
module Data.Memory.ByteArray.ScrubbedBytes
( ScrubbedBytes
) where
import GHC.Types
import GHC.Prim
import GHC.Ptr
import Data.Memory.Internal.CompatPrim
import Data.Memory.Internal.Compat (unsafeDoIO)
import Data.Memory.PtrMethods (memConstEqual)
import Data.Memory.ByteArray.Types
-- | ScrubbedBytes is a memory chunk which have the properties of:
--
-- * Being scrubbed after its goes out of scope.
--
-- * A Show instance that doesn't actually show any content
--
-- * A Eq instance that is constant time
--
data ScrubbedBytes = ScrubbedBytes (MutableByteArray# RealWorld)
instance Show ScrubbedBytes where
show _ = "<scrubbed-bytes>"
instance Eq ScrubbedBytes where
(==) = scrubbedBytesEq
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 "negative or null size for scrubbed array" -- TODO raise a proper exception
| otherwise = IO $ \s ->
case newAlignedPinnedByteArray# sz 8# s of
(# s1, mbarr #) ->
let !scrubber = getScrubber
!mba = ScrubbedBytes mbarr
in case mkWeak# mbarr () (scrubber (byteArrayContents# (unsafeCoerce# mbarr)) >> touchScrubbedBytes mba) s1 of
(# s2, _ #) -> (# s2, mba #)
where
getScrubber :: Addr# -> IO ()
getScrubber = eitherDivideBy8# sz scrubber64 scrubber8
scrubber64 :: Int# -> Addr# -> IO ()
scrubber64 sz64 addr = IO $ \s -> (# loop sz64 addr s, () #)
where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld
loop n a s
| booleanPrim (n ==# 0#) = s
| otherwise =
case writeWord64OffAddr# a 0# 0## s of
s' -> loop (n -# 1#) (plusAddr# a 8#) s'
scrubber8 :: Int# -> Addr# -> IO ()
scrubber8 sz8 addr = IO $ \s -> (# loop sz8 addr s, () #)
where loop :: Int# -> Addr# -> State# RealWorld -> State# RealWorld
loop n a s
| booleanPrim (n ==# 0#) = s
| otherwise =
case writeWord8OffAddr# a 0# 0## s of
s' -> loop (n -# 1#) (plusAddr# a 1#) s'
scrubbedBytesAllocRet :: Int -> (Ptr p -> IO a) -> IO (a, ScrubbedBytes)
scrubbedBytesAllocRet sz f = do
ba <- newScrubbedBytes sz
r <- withPtr ba f
return (r, ba)
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

41
Data/Memory/ByteArray/Types.hs Normal file
View File

@ -0,0 +1,41 @@
-- |
-- Module : Data.Memory.ByteArray.Types
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
{-# LANGUAGE CPP #-}
module Data.Memory.ByteArray.Types
( ByteArrayAccess(..)
, ByteArray(..)
) where
import Foreign.Ptr
#ifdef WITH_BYTESTRING_SUPPORT
import qualified Data.ByteString as B (length)
import qualified Data.ByteString.Internal as B
import Foreign.ForeignPtr (withForeignPtr)
#endif
class ByteArrayAccess ba where
length :: ba -> Int
withByteArray :: ba -> (Ptr p -> IO a) -> IO a
class ByteArrayAccess ba => ByteArray ba where
allocRet :: Int -> (Ptr p -> IO a) -> IO (a, ba)
#ifdef WITH_BYTESTRING_SUPPORT
instance ByteArrayAccess B.ByteString where
length = B.length
withByteArray b f = withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)
where (fptr, off, _) = B.toForeignPtr b
instance ByteArray B.ByteString where
allocRet sz f = do
fptr <- B.mallocByteString sz
r <- withForeignPtr fptr (f . castPtr)
return (r, B.PS fptr 0 sz)
#endif

99
Data/Memory/Encoding/Base16.hs Normal file
View File

@ -0,0 +1,99 @@
-- |
-- Module : Data.Memory.Encoding.Base16
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Hexadecimal escaper
--
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Data.Memory.Encoding.Base16
( showHexadecimal
, toHexadecimal
) where
import Data.Memory.Internal.Compat
import Data.Word
import GHC.Prim
import GHC.Types
import GHC.Word
import Control.Monad
import Foreign.Storable
import Foreign.Ptr (Ptr)
showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a)
-> Int
-> String
showHexadecimal withPtr = doChunks 0
where
doChunks ofs len
| len < 4 = doUnique ofs len
| otherwise = do
let !(W8# a, W8# b, W8# c, W8# d) = unsafeDoIO $ withPtr (read4 ofs)
!(# w1, w2 #) = convertByte a
!(# w3, w4 #) = convertByte b
!(# w5, w6 #) = convertByte c
!(# w7, w8 #) = convertByte d
in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4
: wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8
: doChunks (ofs + 4) (len - 4)
doUnique ofs len
| len == 0 = []
| otherwise =
let !(W8# b) = unsafeDoIO $ withPtr (byteIndex ofs)
!(# w1, w2 #) = convertByte b
in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1)
read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
read4 ofs p =
liftM4 (,,,) (byteIndex ofs p) (byteIndex (ofs+1) p)
(byteIndex (ofs+2) p) (byteIndex (ofs+3) p)
wToChar :: Word# -> Char
wToChar w = toEnum (I# (word2Int# w))
byteIndex :: Int -> Ptr Word8 -> IO Word8
byteIndex i p = peekByteOff p i
toHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
toHexadecimal bout bin n = loop 0
where loop i
| i == n = return ()
| otherwise = do
(W8# w) <- peekByteOff bin i
let !(# w1, w2 #) = convertByte w
pokeByteOff bout (i * 2) (W8# w1)
pokeByteOff bout (i * 2 + 1) (W8# w2)
loop (i+1)
convertByte :: Word# -> (# Word#, Word# #)
convertByte b = (# r tableHi b, r tableLo b #)
where
r :: Addr# -> Word# -> Word#
r table index = indexWord8OffAddr# table (word2Int# index)
!tableLo =
"0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef\
\0123456789abcdef0123456789abcdef"#
!tableHi =
"00000000000000001111111111111111\
\22222222222222223333333333333333\
\44444444444444445555555555555555\
\66666666666666667777777777777777\
\88888888888888889999999999999999\
\aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\
\ccccccccccccccccdddddddddddddddd\
\eeeeeeeeeeeeeeeeffffffffffffffff"#
{-# INLINE convertByte #-}

114
Data/Memory/Endian.hs Normal file
View File

@ -0,0 +1,114 @@
-- |
-- Module : Data.Memory.Endian
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : good
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Memory.Endian
( Endianness(..)
, getSystemEndianness
, BE(..), LE(..)
, fromBE, toBE
, fromLE, toLE
) where
import Data.Word (Word16, Word32, Word64)
import Foreign.Storable
#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
import Data.Memory.Internal.Compat (unsafeDoIO)
#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 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

16
Data/Memory/ExtendedWords.hs Normal file
View File

@ -0,0 +1,16 @@
-- |
-- Module : Data.Memory.ExtendedWords
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- Extra Word size
--
module Data.Memory.ExtendedWords
( Word128(..)
) where
import Data.Word (Word64)
data Word128 = Word128 !Word64 !Word64 deriving (Show, Eq)

65
Data/Memory/Internal/Compat.hs Normal file
View File

@ -0,0 +1,65 @@
-- |
-- Module : Data.Memory.Internal.Compat
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Good
--
-- This module try to keep all the difference between versions of base
-- or other needed packages, so that modules don't need to use CPP
--
{-# LANGUAGE CPP #-}
module Data.Memory.Internal.Compat
( unsafeDoIO
, popCount
, 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

84
Data/Memory/Internal/CompatPrim.hs Normal file
View File

@ -0,0 +1,84 @@
-- |
-- Module : Data.Memory.Internal.CompatPrim
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : stable
-- Portability : Compat
--
-- This module try to keep all the difference between versions of ghc primitive
-- or other needed packages, so that modules don't need to use CPP.
--
-- Note that MagicHash and CPP conflicts in places, making it "more interesting"
-- to write compat code for primitives
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Data.Memory.Internal.CompatPrim
( be32Prim
, le32Prim
, byteswap32Prim
, booleanPrim
, eitherDivideBy8#
) where
import GHC.Prim
-- | byteswap Word# to or from Big Endian
--
-- on a big endian machine, this function is a nop.
be32Prim :: Word# -> Word#
#ifdef ARCH_IS_LITTLE_ENDIAN
be32Prim = byteswap32Prim
#else
be32Prim w = w
#endif
-- | byteswap Word# to or from Little Endian
--
-- on a little endian machine, this function is a nop.
le32Prim :: Word# -> Word#
#ifdef ARCH_IS_LITTLE_ENDIAN
le32Prim w = w
#else
le32Prim = byteswap32Prim
#endif
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
#if __GLASGOW_HASKELL__ >= 708
booleanPrim :: Int# -> Bool
booleanPrim v = tagToEnum# v
#else
booleanPrim :: Bool -> Bool
booleanPrim b = b
#endif
-- | Apply or or another function if 8 divides the number of bytes
eitherDivideBy8# :: Int# -- ^ number of bytes
-> (Int# -> a) -- ^ if it divided by 8, the argument is the number of 8 bytes words
-> (Int# -> a) -- ^ if it doesn't, just the number of bytes
-> a
#if __GLASGOW_HASKELL__ >= 740
eitherDivideBy8# v f8 f1 =
let !(# q, r #) = quotRemInt v 8#
in if booleanPrim (r ==# 0)
then f8 q
else f1 v
#else
eitherDivideBy8# v f8 f1 =
if booleanPrim ((remInt# v 8#) ==# 0#)
then f8 (quotInt# v 8#)
else f1 v
#endif

15
Data/Memory/Internal/Imports.hs Normal file
View File

@ -0,0 +1,15 @@
-- |
-- Module : Data.Memory.Internal.Imports
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
module Data.Memory.Internal.Imports
( module X
) where
import Data.Word as X
import Control.Applicative as X
import Control.Monad as X (forM, forM_, void)
import Control.Arrow as X (first, second)

110
Data/Memory/PtrMethods.hs Normal file
View File

@ -0,0 +1,110 @@
-- |
-- Module : Data.Memory.PtrMethods
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- methods to manipulate raw memory representation
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Data.Memory.PtrMethods
( memCreateTemporary
, memXor
, memXorWith
, memCopy
, memSet
, memEqual
, memConstEqual
, memCompare
) where
import Data.Memory.Internal.Imports
import Foreign.Ptr (Ptr, plusPtr)
import Foreign.Storable (peek, poke, pokeByteOff, 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 d v s n = loop 0
where
loop i
| i == n = return ()
| otherwise = do
(xor v <$> peekByteOff s i) >>= pokeByteOff d i
loop (i+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)
-- | Set @n number of bytes to the same value @v
memSet :: Ptr Word8 -> Word8 -> Int -> IO ()
memSet start v n = c_memset start (fromIntegral v) (fromIntegral n) >>= \_ -> return ()
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
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 True
where
loop i !ret
| i == n = return ret
| otherwise = do
e <- (==) <$> peek p1 <*> peek p2
loop (i+1) (ret &&! e)
-- Bool == Bool
(&&!) :: Bool -> Bool -> Bool
True &&! True = True
True &&! False = False
False &&! True = False
False &&! False = False
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 ()

23
cryptonite.cabal
View File

@ -35,6 +35,11 @@ Flag support_pclmuldq
Default: False Default: False
Manual: True Manual: True
Flag builtin_memory
Description: Build with a local snapshot of the memory package
Default: True
Manual: True
Library Library
Exposed-modules: Crypto.Cipher.AES Exposed-modules: Crypto.Cipher.AES
Crypto.Cipher.Blowfish Crypto.Cipher.Blowfish
@ -164,6 +169,24 @@ Library
, cbits/cryptonite_scrypt.c , cbits/cryptonite_scrypt.c
include-dirs: cbits cbits/ed25519 include-dirs: cbits cbits/ed25519
if flag(builtin_memory)
Exposed-modules: Data.Memory.ByteArray
Data.Memory.Endian
Data.Memory.PtrMethods
Data.Memory.ExtendedWords
Data.Memory.Encoding.Base16
Other-modules: Data.Memory.Internal.Compat
Data.Memory.Internal.CompatPrim
Data.Memory.Internal.Imports
Data.Memory.ByteArray.Types
Data.Memory.ByteArray.Bytes
Data.Memory.ByteArray.ScrubbedBytes
Data.Memory.ByteArray.Methods
Data.Memory.ByteArray.MemView
CPP-options: -DWITH_BYTESTRING_SUPPORT
else
build-depends: memory
-- FIXME armel or mispel is also little endian. -- FIXME armel or mispel is also little endian.
-- might be a good idea to also add a runtime autodetect mode. -- might be a good idea to also add a runtime autodetect mode.
-- ARCH_ENDIAN_UNKNOWN -- ARCH_ENDIAN_UNKNOWN