Pure.hs

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

-- |
-- Module: Crypto.Hash.SHA512.Pure
-- Copyright: (c) 2024 Jared Tobin
-- License: MIT
-- Maintainer: Jared Tobin <jared@ppad.tech>
--
-- Pure Haskell SHA-512 and HMAC-SHA512 implementations for strict
-- ByteStrings, used when the ARM cryptographic extensions are
-- unavailable.

module Crypto.Hash.SHA512.Pure (
    hash
  , hmac
  , _hmac_rr
  , _hmac_rsb
  ) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
import Data.Word (Word8, Word64)
import Foreign.Ptr (Ptr)
import qualified GHC.Exts as Exts
import Crypto.Hash.SHA512.Internal

-- utilities ------------------------------------------------------------------

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral
{-# INLINE fi #-}

-- hash -----------------------------------------------------------------------

-- | Compute a condensed representation of a strict bytestring via
--   SHA-512, using the pure Haskell implementation.
hash :: BS.ByteString -> BS.ByteString
hash m = cat (_hash 0 (iv ()) m)
{-# INLINABLE hash #-}

_hash
  :: Word64        -- ^ extra prefix length for padding calculations
  -> Registers     -- ^ register state
  -> BS.ByteString -- ^ input
  -> Registers
_hash el rs m@(BI.PS _ _ l) = do
  let !state = _hash_blocks rs m
      !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 128) m
      !total = el + fi l
  if   ll < 112
  then
    let !ult = parse_pad1 fin total
    in  update state ult
  else
    let !(# pen, ult #) = parse_pad2 fin total
    in  update (update state pen) ult
{-# INLINABLE _hash #-}

_hash_blocks
  :: Registers     -- ^ state
  -> BS.ByteString -- ^ input
  -> Registers
_hash_blocks rs m@(BI.PS _ _ l) = loop rs 0 where
  loop !acc !j
    | j + 128 > l = acc
    | otherwise   =
        let !nacc = update acc (parse m j)
        in  loop nacc (j + 128)
{-# INLINABLE _hash_blocks #-}

-- hmac ----------------------------------------------------------------------

-- | Produce a message authentication code for a strict bytestring,
--   based on the provided (strict, bytestring) key, via HMAC-SHA512,
--   using the pure Haskell implementation.
hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString
hmac k m = cat (_hmac (prep_key k) m)
{-# INLINABLE hmac #-}

prep_key :: BS.ByteString -> Block
prep_key k@(BI.PS _ _ l)
    | l > 128   = parse_key (hash k)
    | otherwise = parse_key k
{-# INLINABLE prep_key #-}

_hmac
  :: Block          -- ^ padded key
  -> BS.ByteString  -- ^ message
  -> Registers
_hmac k m =
  let !rs0   = update (iv ()) (xor k (Exts.wordToWord64# 0x3636363636363636##))
      !block = pad_registers_with_length (_hash 128 rs0 m)
      !rs1   = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##))
  in  update rs1 block
{-# INLINABLE _hmac #-}

-- the following functions are useful when we want to avoid allocating certain
-- components of the HMAC key and message on the heap.

-- Computes hmac(k, v) when k and v are Registers.
--
-- The 64-byte result is written to the destination pointer.
_hmac_rr
  :: Ptr Word64    -- ^ destination (8 Word64s)
  -> Ptr Word64    -- ^ scratch block buffer (unused)
  -> Registers     -- ^ key
  -> Registers     -- ^ message
  -> IO ()
_hmac_rr rp _ k m = do
  let !key   = pad_registers k
      !block = pad_registers_with_length m
      !rs    = _hmac_bb key block
  poke_registers rp rs
{-# INLINABLE _hmac_rr #-}

_hmac_bb
  :: Block     -- ^ key
  -> Block     -- ^ message
  -> Registers
_hmac_bb k m =
  let !rs0   = update (iv ()) (xor k (Exts.wordToWord64# 0x3636363636363636##))
      !rs1   = update rs0 m
      !inner = pad_registers_with_length rs1
      !rs2   = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##))
  in  update rs2 inner
{-# INLINABLE _hmac_bb #-}

-- Calculate hmac(k, m) where m is the concatenation of v (registers), a
-- separator byte, and a ByteString. This avoids allocating 'v' on the
-- heap.
--
-- The 64-byte result is written to the destination pointer.
_hmac_rsb
  :: Ptr Word64    -- ^ destination pointer (8 x Word64)
  -> Ptr Word64    -- ^ scratch block pointer (unused)
  -> Registers     -- ^ k
  -> Registers     -- ^ v
  -> Word8         -- ^ separator byte
  -> BS.ByteString -- ^ data
  -> IO ()
_hmac_rsb rp _ k v sep dat = do
  let !key   = pad_registers k
      !rs0   = update (iv ())
                 (xor key (Exts.wordToWord64# 0x3636363636363636##))
      !inner = _hash_vsb 128 rs0 v sep dat
      !block = pad_registers_with_length inner
      !rs1   = update (iv ())
                 (xor key (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##))
      !rs    = update rs1 block
  poke_registers rp rs
{-# INLINABLE _hmac_rsb #-}

-- hash(v || sep || dat) with a custom initial state and extra
-- prefix length. used for producing a more specialized hmac.
_hash_vsb
  :: Word64        -- ^ extra prefix length
  -> Registers     -- ^ initial state
  -> Registers     -- ^ v
  -> Word8         -- ^ sep
  -> BS.ByteString -- ^ dat
  -> Registers
_hash_vsb el rs0 v sep dat@(BI.PS _ _ l)
  | l >= 63 =
      -- first block is complete
      let !b0    = parse_vsb v sep dat
          !rs1   = update rs0 b0
          !rest  = BU.unsafeDrop 63 dat
          !rlen  = l - 63
          !rs2   = _hash_blocks rs1 rest
          !flen  = rlen `rem` 128
          !fin   = BU.unsafeDrop (rlen - flen) rest
          !total = el + 65 + fi l
      in  if   flen < 112
          then update rs2 (parse_pad1 fin total)
          else let !(# pen, ult #) = parse_pad2 fin total
               in  update (update rs2 pen) ult
  | otherwise =
      -- message < 128 bytes, goes straight to padding
      let !total = el + 65 + fi l
      in  if   65 + l < 112
          then update rs0 (parse_pad1_vsb v sep dat total)
          else let !(# pen, ult #) = parse_pad2_vsb v sep dat total
               in  update (update rs0 pen) ult
{-# INLINABLE _hash_vsb #-}