{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}

module Cardano.Crypto.Util
  ( Empty
  , SignableRepresentation(..)
  , getRandomWord64

    -- * Simple serialisation used in mock instances
  , readBinaryWord64
  , writeBinaryWord64
  , readBinaryNatural
  , writeBinaryNatural
  , splitsAt

  -- * Low level conversions
  , bytesToNatural
  , naturalToBytes

  -- * ByteString manipulation
  , slice
  )
where

import           Data.Word
import           Numeric.Natural
import           Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import           Data.ByteString (ByteString)

import qualified GHC.Exts    as GHC
import qualified GHC.IO      as GHC (unsafeDupablePerformIO)
import qualified GHC.Natural as GHC
import qualified GHC.Integer.GMP.Internals as GMP
import           Foreign.ForeignPtr (withForeignPtr)

import           Crypto.Random (MonadRandom (..))


class Empty a
instance Empty a



--
-- Signable
--

-- | A class of types that have a representation in bytes that can be used
-- for signing and verifying.
--
class SignableRepresentation a where
    getSignableRepresentation :: a -> ByteString

instance SignableRepresentation ByteString where
    getSignableRepresentation :: ByteString -> ByteString
getSignableRepresentation = ByteString -> ByteString
forall a. a -> a
id


--
-- Random source used in some mock instances
--

getRandomWord64 :: MonadRandom m => m Word64
getRandomWord64 :: m Word64
getRandomWord64 = ByteString -> Word64
readBinaryWord64 (ByteString -> Word64) -> m ByteString -> m Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m ByteString
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
8


--
-- Really simple serialisation used in some mock instances
--

readBinaryWord64 :: ByteString -> Word64
readBinaryWord64 :: ByteString -> Word64
readBinaryWord64 =
  (Word64 -> Word8 -> Word64) -> Word64 -> ByteString -> Word64
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Word64
acc Word8
w8 -> Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftL Word64
acc Int
8 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8) Word64
0


readBinaryNatural :: ByteString -> Natural
readBinaryNatural :: ByteString -> Natural
readBinaryNatural =
  (Natural -> Word8 -> Natural) -> Natural -> ByteString -> Natural
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' (\Natural
acc Word8
w8 -> Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
unsafeShiftL Natural
acc Int
8 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Word8 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8) Natural
0


writeBinaryWord64 :: Word64 -> ByteString
writeBinaryWord64 :: Word64 -> ByteString
writeBinaryWord64 =
    ByteString -> ByteString
BS.reverse (ByteString -> ByteString)
-> (Word64 -> ByteString) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe Word64) -> ByteString
forall a b. (a, b) -> a
fst
  ((ByteString, Maybe Word64) -> ByteString)
-> (Word64 -> (ByteString, Maybe Word64)) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (Word64 -> Maybe (Word8, Word64))
-> Word64
-> (ByteString, Maybe Word64)
forall a.
Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
BS.unfoldrN Int
8 (\Word64
w -> (Word8, Word64) -> Maybe (Word8, Word64)
forall a. a -> Maybe a
Just (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w, Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftR Word64
w Int
8))

writeBinaryNatural :: Int -> Natural -> ByteString
writeBinaryNatural :: Int -> Natural -> ByteString
writeBinaryNatural Int
bytes =
    ByteString -> ByteString
BS.reverse (ByteString -> ByteString)
-> (Natural -> ByteString) -> Natural -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe Natural) -> ByteString
forall a b. (a, b) -> a
fst
  ((ByteString, Maybe Natural) -> ByteString)
-> (Natural -> (ByteString, Maybe Natural))
-> Natural
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (Natural -> Maybe (Word8, Natural))
-> Natural
-> (ByteString, Maybe Natural)
forall a.
Int -> (a -> Maybe (Word8, a)) -> a -> (ByteString, Maybe a)
BS.unfoldrN Int
bytes (\Natural
w -> (Word8, Natural) -> Maybe (Word8, Natural)
forall a. a -> Maybe a
Just (Natural -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
w, Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
unsafeShiftR Natural
w Int
8))

splitsAt :: [Int] -> ByteString -> [ByteString]
splitsAt :: [Int] -> ByteString -> [ByteString]
splitsAt = Int -> [Int] -> ByteString -> [ByteString]
go Int
0
  where
    go :: Int -> [Int] -> ByteString -> [ByteString]
go !Int
_   [] ByteString
bs
      | ByteString -> Bool
BS.null ByteString
bs         = []
      | Bool
otherwise          = [ByteString
bs]

    go !Int
off (Int
sz:[Int]
szs) ByteString
bs
      | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz = Int -> ByteString -> ByteString
BS.take Int
sz ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> [Int] -> ByteString -> [ByteString]
go (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
sz) [Int]
szs (Int -> ByteString -> ByteString
BS.drop Int
sz ByteString
bs)
      | Bool
otherwise          = []

-- | Create a 'Natural' out of a 'ByteString', in big endian.
--
-- This is fast enough to use in production.
--
bytesToNatural :: ByteString -> Natural
bytesToNatural :: ByteString -> Natural
bytesToNatural = Integer -> Natural
GHC.naturalFromInteger (Integer -> Natural)
-> (ByteString -> Integer) -> ByteString -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Integer
bytesToInteger

-- | The inverse of 'bytesToNatural'. Note that this is a naive implementation
-- and only suitable for tests.
--
naturalToBytes :: Int -> Natural -> ByteString
naturalToBytes :: Int -> Natural -> ByteString
naturalToBytes = Int -> Natural -> ByteString
writeBinaryNatural

bytesToInteger :: ByteString -> Integer
bytesToInteger :: ByteString -> Integer
bytesToInteger (BS.PS ForeignPtr Word8
fp (GHC.I# Int#
off#) (GHC.I# Int#
len#)) =
    -- This should be safe since we're simply reading from ByteString (which is
    -- immutable) and GMP allocates a new memory for the Integer, i.e., there is
    -- no mutation involved.
    IO Integer -> Integer
forall a. IO a -> a
GHC.unsafeDupablePerformIO (IO Integer -> Integer) -> IO Integer -> Integer
forall a b. (a -> b) -> a -> b
$
      ForeignPtr Word8 -> (Ptr Word8 -> IO Integer) -> IO Integer
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Integer) -> IO Integer)
-> (Ptr Word8 -> IO Integer) -> IO Integer
forall a b. (a -> b) -> a -> b
$ \(GHC.Ptr Addr#
addr#) ->
        let addrOff# :: Addr#
addrOff# = Addr#
addr# Addr# -> Int# -> Addr#
`GHC.plusAddr#` Int#
off#
        -- The last parmaeter (`1#`) tells the import function to use big
        -- endian encoding.
        in Addr# -> Word# -> Int# -> IO Integer
GMP.importIntegerFromAddr Addr#
addrOff# (Int# -> Word#
GHC.int2Word# Int#
len#) Int#
1#

slice :: Word -> Word -> ByteString -> ByteString
slice :: Word -> Word -> ByteString -> ByteString
slice Word
offset Word
size = Int -> ByteString -> ByteString
BS.take (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size)
                  (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
offset)