{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash                #-}
{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE UnboxedTuples            #-}
{-# LANGUAGE UnliftedFFITypes         #-}
{-# OPTIONS_GHC -fobject-code #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Crypto.Hash.XKCP
-- Copyright   : [2016..2022] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Crypto.Hash.XKCP (

  SHA3_256,
  hash, hashlazy,

) where

import Control.Monad
import Data.Word
import Foreign.C.Types
import Foreign.Ptr
import Language.Haskell.TH.Syntax
import System.IO.Unsafe

import qualified Data.ByteString                                    as S
import qualified Data.ByteString.Lazy                               as L
import qualified Data.ByteString.Lazy.Internal                      as L
import qualified Data.ByteString.Unsafe                             as B

import GHC.Exts
import GHC.Base
import GHC.Word
import GHC.Show


-- | SHA3 (256 bits) cryptographic hash digest
--
data SHA3_256 = SHA3_256 ByteArray#

instance Show SHA3_256 where
  show :: SHA3_256 -> String
show (SHA3_256 ByteArray#
ba#) =
    let go :: Int# -> String
go !Int#
i# =
          case Int#
i# Int# -> Int# -> Int#
<# Int#
32# of
            Int#
0# -> []
            Int#
_  -> let w8# :: Word8#
w8# = ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba# Int#
i#
                      w# :: Word#
w#  = Word8# -> Word#
word8ToWord# Word8#
w8#
                      n# :: Word#
n#  = Word# -> Word# -> Word#
quotWord# Word#
w# Word#
16##
                      d# :: Word#
d#  = Word# -> Word# -> Word#
remWord# Word#
w# Word#
16##
                      x :: Char
x   = Int -> Char
intToDigit (Int# -> Int
I# (Word# -> Int#
word2Int# Word#
n#))
                      y :: Char
y   = Int -> Char
intToDigit (Int# -> Int
I# (Word# -> Int#
word2Int# Word#
d#))
                  in
                  Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: Char
y Char -> ShowS
forall a. a -> [a] -> [a]
: Int# -> String
go (Int#
i# Int# -> Int# -> Int#
+# Int#
1#)
    in
    Int# -> String
go Int#
0#

instance Eq SHA3_256 where
  SHA3_256 ByteArray#
ba1# == :: SHA3_256 -> SHA3_256 -> Bool
== SHA3_256 ByteArray#
ba2# =
    case Any -> Any -> Int#
forall a b. a -> b -> Int#
reallyUnsafePtrEquality# (ByteArray# -> Any
forall a b. a -> b
unsafeCoerce# ByteArray#
ba1#) (ByteArray# -> Any
forall a b. a -> b
unsafeCoerce# ByteArray#
ba2#) of
      Int#
1# -> Bool
True
      Int#
_  -> case (ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#
compareByteArrays# ByteArray#
ba1# Int#
0# ByteArray#
ba2# Int#
0# Int#
32#) of
              Int#
0# -> Bool
True
              Int#
_  -> Bool
False

instance Ord SHA3_256 where
  compare :: SHA3_256 -> SHA3_256 -> Ordering
compare (SHA3_256 ByteArray#
ba1#) (SHA3_256 ByteArray#
ba2#) =
    let go :: Int# -> Ordering
go !Int#
i# =
          case Int#
i# Int# -> Int# -> Int#
<# Int#
32# of
            Int#
0# -> Ordering
EQ
            Int#
_  -> case Word8# -> Word8
W8# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba1# Int#
i#) Word8 -> Word8 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Word8# -> Word8
W8# (ByteArray# -> Int# -> Word8#
indexWord8Array# ByteArray#
ba2# Int#
i#) of
                    Ordering
EQ -> Int# -> Ordering
go (Int#
i# Int# -> Int# -> Int#
+# Int#
1#)
                    Ordering
r  -> Ordering
r
    in
    Int# -> Ordering
go Int#
0#

#if !MIN_VERSION_base(4,16,0)
{-# INLINE word8ToWord# #-}
word8ToWord# :: Word# -> Word#
word8ToWord# w# = w#
#endif

-- | Hash a strict 'S.ByteString' into a digest
--
hash :: S.ByteString -> SHA3_256
hash :: ByteString -> SHA3_256
hash ByteString
bs = IO SHA3_256 -> SHA3_256
forall a. IO a -> a
unsafePerformIO (IO SHA3_256 -> SHA3_256) -> IO SHA3_256 -> SHA3_256
forall a b. (a -> b) -> a -> b
$!
  ByteString -> (CStringLen -> IO SHA3_256) -> IO SHA3_256
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO SHA3_256) -> IO SHA3_256)
-> (CStringLen -> IO SHA3_256) -> IO SHA3_256
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
p, Int
n) -> Ptr Word8 -> Int -> IO SHA3_256
keccak_Hash_SHA3_256 (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
p) Int
n


-- | Hash a lazy 'L.ByteString' into a digest
--
hashlazy :: L.ByteString -> SHA3_256
hashlazy :: ByteString -> SHA3_256
hashlazy ByteString
lbs = IO SHA3_256 -> SHA3_256
forall a. IO a -> a
unsafePerformIO (IO SHA3_256 -> SHA3_256) -> IO SHA3_256 -> SHA3_256
forall a b. (a -> b) -> a -> b
$! do
  Keccak_HashInstance
s <- IO Keccak_HashInstance
keccak_HashInitialize_SHA3_256
  let go :: ByteString -> IO SHA3_256
go ByteString
L.Empty        = Keccak_HashInstance -> IO SHA3_256
keccak_HashFinal_SHA3_256 Keccak_HashInstance
s
      go (L.Chunk ByteString
c ByteString
cs) = do
        ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
c ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
p, Int
n) -> Keccak_HashInstance -> Ptr Word8 -> Int -> IO ()
keccak_HashUpdate_SHA3_256 Keccak_HashInstance
s (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
p) Int
n
        ByteString -> IO SHA3_256
go ByteString
cs
  ByteString -> IO SHA3_256
go ByteString
lbs


-- Internals
-- -----------------------------------------------------------------------------

keccak_Hash_SHA3_256 :: Ptr Word8 -> Int -> IO SHA3_256
keccak_Hash_SHA3_256 :: Ptr Word8 -> Int -> IO SHA3_256
keccak_Hash_SHA3_256 Ptr Word8
ptr Int
len =
  (State# RealWorld -> (# State# RealWorld, SHA3_256 #))
-> IO SHA3_256
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, SHA3_256 #))
 -> IO SHA3_256)
-> (State# RealWorld -> (# State# RealWorld, SHA3_256 #))
-> IO SHA3_256
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
32# State# RealWorld
s0                   of { (# State# RealWorld
s1, MutableByteArray# RealWorld
mba# #) ->
    case MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO CInt
c_sha3_256 MutableByteArray# RealWorld
mba# Ptr Word8
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) of { IO State# RealWorld -> (# State# RealWorld, CInt #)
c_sha3_256# ->
    case State# RealWorld -> (# State# RealWorld, CInt #)
c_sha3_256# State# RealWorld
s1                         of { (# State# RealWorld
s2, CInt
_ #) ->
    case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba# State# RealWorld
s2         of { (# State# RealWorld
s3, ByteArray#
hash_val# #) ->
      (# State# RealWorld
s3, ByteArray# -> SHA3_256
SHA3_256 ByteArray#
hash_val# #)
    }}}}


data Keccak_HashInstance = Keccak_HashInstance (MutableByteArray# RealWorld)

-- See: KeccakHash.h for magic numbers
--
keccak_HashInitialize_SHA3_256 :: IO Keccak_HashInstance
keccak_HashInitialize_SHA3_256 :: IO Keccak_HashInstance
keccak_HashInitialize_SHA3_256 =
  (State# RealWorld -> (# State# RealWorld, Keccak_HashInstance #))
-> IO Keccak_HashInstance
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Keccak_HashInstance #))
 -> IO Keccak_HashInstance)
-> (State# RealWorld
    -> (# State# RealWorld, Keccak_HashInstance #))
-> IO Keccak_HashInstance
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
224# State# RealWorld
s0                                      of { (# State# RealWorld
s1, MutableByteArray# RealWorld
hash_instance# #) ->
    case MutableByteArray# RealWorld
-> CUInt -> CUInt -> CUInt -> CUChar -> IO CInt
c_keccak_hash_initialise MutableByteArray# RealWorld
hash_instance# CUInt
1088 CUInt
512 CUInt
256 CUChar
0x06  of { IO State# RealWorld -> (# State# RealWorld, CInt #)
c_keccak_hash_initialise# ->
    case State# RealWorld -> (# State# RealWorld, CInt #)
c_keccak_hash_initialise# State# RealWorld
s1                               of { (# State# RealWorld
s2, CInt
_ #) ->
      (# State# RealWorld
s2, MutableByteArray# RealWorld -> Keccak_HashInstance
Keccak_HashInstance MutableByteArray# RealWorld
hash_instance# #)
  }}}

keccak_HashUpdate_SHA3_256 :: Keccak_HashInstance -> Ptr Word8 -> Int -> IO ()
keccak_HashUpdate_SHA3_256 :: Keccak_HashInstance -> Ptr Word8 -> Int -> IO ()
keccak_HashUpdate_SHA3_256 (Keccak_HashInstance MutableByteArray# RealWorld
hash_instance#) Ptr Word8
ptr Int
len =
  IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO CInt
c_keccak_hash_update MutableByteArray# RealWorld
hash_instance# Ptr Word8
ptr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len CSize -> CSize -> CSize
forall a. Num a => a -> a -> a
* CSize
8)

keccak_HashFinal_SHA3_256 :: Keccak_HashInstance -> IO SHA3_256
keccak_HashFinal_SHA3_256 :: Keccak_HashInstance -> IO SHA3_256
keccak_HashFinal_SHA3_256 (Keccak_HashInstance MutableByteArray# RealWorld
hash_instance#) =
  (State# RealWorld -> (# State# RealWorld, SHA3_256 #))
-> IO SHA3_256
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, SHA3_256 #))
 -> IO SHA3_256)
-> (State# RealWorld -> (# State# RealWorld, SHA3_256 #))
-> IO SHA3_256
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
32# State# RealWorld
s0                    of { (# State# RealWorld
s1, MutableByteArray# RealWorld
mba# #) ->
    case MutableByteArray# RealWorld
-> MutableByteArray# RealWorld -> IO CInt
c_keccak_hash_final MutableByteArray# RealWorld
hash_instance# MutableByteArray# RealWorld
mba# of { IO State# RealWorld -> (# State# RealWorld, CInt #)
c_keccak_hash_final# ->
    case State# RealWorld -> (# State# RealWorld, CInt #)
c_keccak_hash_final# State# RealWorld
s1                 of { (# State# RealWorld
s2, CInt
_ #) ->
    case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba# State# RealWorld
s2          of { (# State# RealWorld
s3, ByteArray#
hash_val# #) ->
      (# State# RealWorld
s3, ByteArray# -> SHA3_256
SHA3_256 ByteArray#
hash_val# #)
    }}}}

-- SEE: [HLS and GHC IDE]
--
#ifndef __GHCIDE__

foreign import ccall unsafe "SHA3_256" c_sha3_256 :: MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO CInt
foreign import ccall unsafe "Keccak_HashInitialize" c_keccak_hash_initialise :: MutableByteArray# RealWorld -> CUInt -> CUInt -> CUInt -> CUChar -> IO CInt
foreign import ccall unsafe "Keccak_HashUpdate" c_keccak_hash_update :: MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO CInt
foreign import ccall unsafe "Keccak_HashFinal" c_keccak_hash_final :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CInt

#else

c_sha3_256 :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt
c_sha3_256 = undefined

c_keccak_hash_initialise :: MutableByteArray# RealWorld -> CUInt -> CUInt -> CUInt -> CUChar -> IO CInt
c_keccak_hash_initialise = undefined

c_keccak_hash_update :: MutableByteArray# RealWorld -> Ptr Word8 -> CSize -> IO CInt
c_keccak_hash_update = undefined

c_keccak_hash_final :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CInt
c_keccak_hash_final = undefined

#endif


-- SEE: [linking to .c files]
--
runQ $ do
  addForeignFilePath LangC "cbits/xkcp/KeccakHash.c"
  addForeignFilePath LangC "cbits/xkcp/KeccakSponge.c"
  addForeignFilePath LangC "cbits/xkcp/SimpleFIPS202.c"
  addForeignFilePath LangC "cbits/xkcp/KeccakP-1600-opt64.c"
  return []