Types.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Crypto.Hash.Types
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Crypto hash types definitions
module Crypto.Hash.Types (
    HashAlgorithm (..),
    HashAlgorithmPrefix (..),
    Context (..),
    Digest (..),
) where

import Control.DeepSeq (deepseq)
import Control.Monad.Primitive (PrimMonad (..))
import Control.Monad.ST
import Crypto.Internal.ByteArray (ByteArrayAccess (..), Bytes)
import qualified Crypto.Internal.ByteArray as B
import Crypto.Internal.Imports
import Data.Base16.Types (extractBase16)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 (encodeBase16)
import Data.Char (digitToInt, isHexDigit)
import Data.Data (Data)
import Data.Primitive.ByteArray (
    ByteArray,
    MutableByteArray,
    newPinnedByteArray,
    sizeofByteArray,
    unsafeFreezeByteArray,
    withByteArrayContents,
    writeByteArray,
 )
import qualified Data.Text as Text
import Foreign.Ptr (Ptr, castPtr)
import GHC.TypeLits (Nat)

-- | Class representing hashing algorithms.
--
-- The interface presented here is update in place
-- and lowlevel. the Hash module takes care of
-- hidding the mutable interface properly.
class HashAlgorithm a where
    -- | Associated type for the block size of the hash algorithm
    type HashBlockSize a :: Nat

    -- | Associated type for the digest size of the hash algorithm
    type HashDigestSize a :: Nat

    -- | Associated type for the internal context size of the hash algorithm
    type HashInternalContextSize a :: Nat

    -- | Get the block size of a hash algorithm
    hashBlockSize :: a -> Int

    -- | Get the digest size of a hash algorithm
    hashDigestSize :: a -> Int

    -- | Get the size of the context used for a hash algorithm
    hashInternalContextSize :: a -> Int

    -- hashAlgorithmFromProxy  :: Proxy a -> a

    -- | Initialize a context pointer to the initial state of a hash algorithm
    hashInternalInit :: Ptr (Context a) -> IO ()

    -- | Update the context with some raw data
    hashInternalUpdate :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()

    -- | Finalize the context and set the digest raw memory to the right value
    hashInternalFinalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()

-- | Hashing algorithms with a constant-time implementation.
class HashAlgorithm a => HashAlgorithmPrefix a where
    -- | Update the context with the first N bytes of a buffer and finalize this
    -- context.  The code path executed is independent from N and depends only
    -- on the complete buffer length.
    hashInternalFinalizePrefix
        :: Ptr (Context a)
        -> Ptr Word8
        -> Word32
        -> Word32
        -> Ptr (Digest a)
        -> IO ()

{-
hashContextGetAlgorithm :: HashAlgorithm a => Context a -> a
hashContextGetAlgorithm = undefined
-}

-- | Represent a context for a given hash algorithm.
--
-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal
-- layout is architecture dependent, may contain uninitialized data fragments,
-- and change in future versions.  The bytearray should not be used as input to
-- cryptographic algorithms.
newtype Context a = Context Bytes
    deriving (ByteArrayAccess, NFData)

-- | Represent a digest for a given hash algorithm.
--
-- This type is an instance of 'ByteArrayAccess' from package
-- <https://hackage.haskell.org/package/ram ram>.
-- Module "Data.ByteArray" provides many primitives to work with those values
-- including conversion to other types.
--
-- Creating a digest from a bytearray is also possible with function
-- 'Crypto.Hash.digestFromByteString'.
newtype Digest a = Digest ByteArray
    deriving (Eq, Ord, Data)

type role Digest nominal

instance NFData (Digest a) where
    rnf (Digest u) = u `deepseq` ()

instance ByteArrayAccess (Digest a) where
    length (Digest ba) = sizeofByteArray ba
    withByteArray (Digest ba) f = withByteArrayContents ba (f . castPtr)

instance Show (Digest a) where
    show d =
        Text.unpack (extractBase16 $ encodeBase16 (B.convert d :: ByteString))

instance HashAlgorithm a => Read (Digest a) where
    readsPrec _ str = runST $ do
        mut <- newPinnedByteArray len
        loop len mut len str
      where
        len = hashDigestSize (undefined :: a)

loop
    :: Int
    -> MutableByteArray (PrimState (ST s))
    -> Int
    -> String
    -> ST s [(Digest a, String)]
loop _ mut 0 cs = (\b -> [(Digest b, cs)]) <$> unsafeFreezeByteArray mut
loop _ _ _ [] = return []
loop _ _ _ [_] = return []
loop len mut n (c : (d : ds))
    | not (isHexDigit c) = return []
    | not (isHexDigit d) = return []
    | otherwise = do
        let w8 :: Word8
            w8 = fromIntegral $ digitToInt c * 16 + digitToInt d
        writeByteArray mut (len - n) w8
        loop len mut (n - 1) ds