{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_HADDOCK hide #-}

-- |
-- Module      : Crypto.Internal.ByteArray
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : stable
-- Portability : Good
--
-- Simple and efficient byte array types
module Crypto.Internal.ByteArray (
    module Data.ByteArray,
    module Data.ByteArray.Mapping,
    module Data.ByteArray.Encoding,
    constAllZero,
    overCLength,
    inCLengths,
    allocAndFreezePrimIO,
    allocAndFreezePrim,
    bxor,
) where

import Data.ByteArray
import Data.ByteArray.Encoding
import Data.ByteArray.Mapping

import Data.Bits ((.|.))
import qualified Data.Primitive.ByteArray as Prim
import Data.Word (Word32, Word8)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (peekByteOff)

import Crypto.Internal.Compat (unsafeDoIO)

-- | Whether a length is too large to reach the C, which takes its lengths as
-- @uint32_t@.
--
-- From 2^32 up the value is truncated on the way down, and the C then works
-- on the low bits of it and leaves the rest of the buffer as it found it --
-- which for a fresh allocation is zeros.  What comes back is as long as the
-- caller asked for, with nothing to say that most of it was never written:
-- a 4 GiB message through Crypto.Cipher.ChaCha.combine came back with 2^32
-- bytes of zeros where the ciphertext should have been.
--
-- Every place that hands a caller's length to the C either turns it away
-- with this or cuts the work into pieces small enough to pass.
--
-- The round trip through 'Word32' rather than a comparison against 2^32,
-- which a 32-bit 'Int' cannot hold.  There every non-negative 'Int' passes,
-- which is the right answer: there is no such buffer to be had.
overCLength :: Int -> Bool
overCLength :: Int -> Bool
overCLength Int
n = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word32) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n

-- | Walk a length in pieces small enough to reach the C, calling the action
-- with the offset and the size of each.
--
-- The same 2 GiB step "Crypto.Hash" has always taken, and for the same
-- reason: the C takes its lengths as @uint32_t@, and a 32-bit 'Int' cannot
-- hold a whole one either.  This is for the C that keeps its state in a
-- context and can simply be called again -- the stream ciphers, the MACs --
-- where a long message can be enciphered in pieces rather than refused.
inCLengths :: Int -> (Int -> Int -> IO ()) -> IO ()
inCLengths :: Int -> (Int -> Int -> IO ()) -> IO ()
inCLengths Int
total Int -> Int -> IO ()
f = Int -> IO ()
go Int
0
  where
    go :: Int -> IO ()
go !Int
off
        | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
total = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = Int -> Int -> IO ()
f Int
off Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
go (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
      where
        !n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
off) Int
cChunk

-- | The step 'inCLengths' takes: the largest multiple of 64 that a signed
-- 32-bit integer holds.
--
-- Under 2^31 because a 32-bit 'Int' cannot hold more, and a
-- multiple of 64 because some of the C this feeds -- the AEAD modes -- will
-- take a piece that is not a whole number of blocks only as the last one.
cChunk :: Int
cChunk :: Int
cChunk = Int
0x7fffffc0

-- | Allocate a pinned 'Prim.ByteArray' of the given size, populate it via a
-- 'Ptr', then freeze and return it.  The pointer must not be retained after
-- the action returns.
allocAndFreezePrimIO :: Int -> (Ptr p -> IO ()) -> IO Prim.ByteArray
allocAndFreezePrimIO :: forall p. Int -> (Ptr p -> IO ()) -> IO ByteArray
allocAndFreezePrimIO Int
n Ptr p -> IO ()
f = do
    MutableByteArray RealWorld
mba <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
Prim.newPinnedByteArray Int
n
    Ptr p -> IO ()
f (Ptr Word8 -> Ptr p
forall a b. Ptr a -> Ptr b
castPtr (MutableByteArray RealWorld -> Ptr Word8
forall s. MutableByteArray s -> Ptr Word8
Prim.mutableByteArrayContents MutableByteArray RealWorld
mba))
    MutableByteArray (PrimState IO) -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
Prim.unsafeFreezeByteArray MutableByteArray RealWorld
MutableByteArray (PrimState IO)
mba

-- | The allocation is strictly local,
-- the computation is deterministic, and no IO effects escape.
allocAndFreezePrim :: Int -> (Ptr p -> IO ()) -> Prim.ByteArray
allocAndFreezePrim :: forall p. Int -> (Ptr p -> IO ()) -> ByteArray
allocAndFreezePrim Int
n = IO ByteArray -> ByteArray
forall a. IO a -> a
unsafeDoIO (IO ByteArray -> ByteArray)
-> ((Ptr p -> IO ()) -> IO ByteArray)
-> (Ptr p -> IO ())
-> ByteArray
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Ptr p -> IO ()) -> IO ByteArray
forall p. Int -> (Ptr p -> IO ()) -> IO ByteArray
allocAndFreezePrimIO Int
n

constAllZero :: ByteArrayAccess ba => ba -> Bool
constAllZero :: forall ba. ByteArrayAccess ba => ba -> Bool
constAllZero ba
b = IO Bool -> Bool
forall a. IO a -> a
unsafeDoIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ba -> (Ptr Any -> IO Bool) -> IO Bool
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. ba -> (Ptr p -> IO a) -> IO a
withByteArray ba
b ((Ptr Any -> IO Bool) -> IO Bool)
-> (Ptr Any -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr Any
p -> Ptr Any -> Int -> Word8 -> IO Bool
forall b. Ptr b -> Int -> Word8 -> IO Bool
loop Ptr Any
p Int
0 Word8
0
  where
    loop :: Ptr b -> Int -> Word8 -> IO Bool
    loop :: forall b. Ptr b -> Int -> Word8 -> IO Bool
loop Ptr b
p Int
i !Word8
acc
        | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Word8
acc Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
        | Bool
otherwise = do
            Word8
e <- Ptr b -> Int -> IO Word8
forall b. Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
p Int
i
            Ptr b -> Int -> Word8 -> IO Bool
forall b. Ptr b -> Int -> Word8 -> IO Bool
loop Ptr b
p (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Word8
acc Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
e)
    len :: Int
len = ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
Data.ByteArray.length ba
b

-- | @a@ exclusive-ored with @b@, as long as the shorter of the two.
--
-- 'Data.ByteArray.xor' does this a byte at a time through an IO applicative,
-- which allocates about fifty bytes of heap for every byte it produces.  That
-- is more than a block cipher costs: it was four fifths of the time counter
-- mode spent on anything but AES, whose modes are in C and do not come this
-- way.
bxor :: (ByteArrayAccess a, ByteArrayAccess b, ByteArray c) => a -> b -> c
bxor :: forall a b c.
(ByteArrayAccess a, ByteArrayAccess b, ByteArray c) =>
a -> b -> c
bxor a
a b
b = IO c -> c
forall a. IO a -> a
unsafeDoIO (IO c -> c) -> IO c -> c
forall a b. (a -> b) -> a -> b
$
    Int -> (Ptr Word8 -> IO ()) -> IO c
forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
alloc Int
n ((Ptr Word8 -> IO ()) -> IO c) -> (Ptr Word8 -> IO ()) -> IO c
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pd ->
        a -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. a -> (Ptr p -> IO a) -> IO a
withByteArray a
a ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pa ->
            b -> (Ptr Word8 -> IO ()) -> IO ()
forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
forall p a. b -> (Ptr p -> IO a) -> IO a
withByteArray b
b ((Ptr Word8 -> IO ()) -> IO ()) -> (Ptr Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
pb ->
                Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Word32 -> IO ()
c_memxor Ptr Word8
pd Ptr Word8
pa Ptr Word8
pb (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  where
    n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (a -> Int
forall ba. ByteArrayAccess ba => ba -> Int
Data.ByteArray.length a
a) (b -> Int
forall ba. ByteArrayAccess ba => ba -> Int
Data.ByteArray.length b
b)

foreign import ccall unsafe "crypton_memxor.h crypton_memxor"
    c_memxor :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Word32 -> IO ()