{-# LANGUAGE CPP                       #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE ConstraintKinds           #-}

-- | This module exposes the low-level internal details of
-- cryptographic hashes. Do not import this module unless you want to
-- implement a new hash or give a new implementation of an existing
-- hash.
module Raaz.Hash.Internal
       ( -- * Cryptographic hashes and their implementations.
         -- $hashdoc$
         Hash(..)
       , hash, hashFile, hashSource
         -- ** Computing hashes using non-standard implementations.
       , hash', hashFile', hashSource'
         -- * Hash implementations.
       , HashI(..), SomeHashI(..), HashM
         -- ** Implementation of truncated hashes.
       , truncatedI
         -- * Memory used by most hashes.
       , HashMemory(..), extractLength, updateLength
       -- * Some low level functions.
       , completeHashing
       ) where


#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative
#endif

import qualified Data.ByteString      as B
import qualified Data.ByteString.Lazy as L
import           Data.Monoid
import           Data.Word
import           Foreign.Storable
import           System.IO
import           System.IO.Unsafe     (unsafePerformIO)

import Raaz.Core

-- $hashdoc$
--
-- Each cryptographic hash is a distinct type and are instances of a
-- the type class `Hash`. The standard idiom that we follow for hash
-- implementations are the following:
--
-- [`HashI`:] This type captures implementations of a the hash. This
-- type is parameterised over the memory element used by the
-- implementation.
--
-- [`SomeHashI`:] This type is the existentially quantified version of
-- `HashI` over its memory element. Thus it exposes only the interface
-- and not the internals of the implementation. The `Implementation`
-- associated type of a hash is the type `SomeHashI`
--
-- To support a new hash, a developer needs to:
--
-- 1. Define a new type which captures the result of hashing. This
--    type should be an instance of the class `Hash`.
--
-- 2. Define an implementation, i.e. a value of the type `SomeHashI`.
--
-- 3. Define a recommended implementation, i.e. an instance of the
--    type class `Raaz.Core.Primitives.Recommendation`

-------------------- Hash Implementations --------------------------

-- | The Hash implementation. Implementations should ensure the
-- following.
--
-- 1. The action @compress impl ptr blks@ should only read till the
-- @blks@ offset starting at ptr and never write any data.
--
-- 2. The action @padFinal impl ptr byts@ should touch at most
-- @⌈byts/blocksize⌉ + padBlocks@ blocks starting at ptr. It should
-- not write anything till the @byts@ offset but may write stuff
-- beyond that.
--
-- An easy to remember this rule is to remember that computing hash of
-- a payload should not modify the payload.
--
data HashI h m = HashI
  { hashIName           :: String
  , hashIDescription    :: String
  , compress       :: Pointer -> BLOCKS h  -> MT m ()
                      -- ^ compress the blocks,
  , compressFinal  :: Pointer -> BYTES Int -> MT m ()
                      -- ^ pad and process the final bytes,
  , compressStartAlignment :: Alignment
  }

instance BlockAlgorithm (HashI h m) where
  bufferStartAlignment = compressStartAlignment

-- | The constraints that a memory used by a hash implementation
-- should satisfy.
type HashM h m = (Initialisable m (), Extractable m h, Primitive h)

-- | Some implementation of a given hash. The existentially
-- quantification allows us freedom to choose the best memory type
-- suitable for each implementations.
data SomeHashI h = forall m . HashM h m =>
     SomeHashI (HashI h m)

instance Describable (HashI h m) where
  name        = hashIName
  description = hashIDescription


instance Describable (SomeHashI h) where
  name         (SomeHashI hI) = name hI
  description  (SomeHashI hI) = description hI

instance BlockAlgorithm (SomeHashI h) where
  bufferStartAlignment (SomeHashI imp) = bufferStartAlignment imp

-- | Certain hashes are essentially bit-truncated versions of other
-- hashes. For example, SHA224 is obtained from SHA256 by dropping the
-- last 32-bits. This combinator can be used build an implementation
-- of truncated hash from the implementation of its parent hash.
truncatedI :: (BLOCKS htrunc -> BLOCKS h)
           -> (mtrunc        -> m)
           -> HashI h m -> HashI htrunc mtrunc
truncatedI coerce unMtrunc (HashI{..})
  = HashI { hashIName        = hashIName
          , hashIDescription = hashIDescription
          , compress         = comp
          , compressFinal    = compF
          , compressStartAlignment = compressStartAlignment
          }
  where comp  ptr = onSubMemory unMtrunc . compress ptr . coerce
        compF ptr = onSubMemory unMtrunc . compressFinal ptr

---------------------- The Hash class ---------------------------------

-- | Type class capturing a cryptographic hash.
class ( Primitive h
      , EndianStore h
      , Encodable h
      , Eq h
      , Implementation h ~ SomeHashI h
      ) => Hash h where
  -- | Cryptographic hashes can be computed for messages that are not
  -- a multiple of the block size. This combinator computes the
  -- maximum size of padding that can be attached to a message.
  additionalPadBlocks :: h -> BLOCKS h

---------------------- Helper combinators --------------------------

-- | Compute the hash of a pure byte source like, `B.ByteString`.
hash :: ( Hash h, Recommendation h, PureByteSource src )
     => src  -- ^ Message
     -> h
hash = unsafePerformIO . hashSource
{-# INLINEABLE hash #-}
{-# SPECIALIZE hash :: (Hash h, Recommendation h) => B.ByteString -> h #-}
{-# SPECIALIZE hash :: (Hash h, Recommendation h) => L.ByteString -> h #-}

-- | Compute the hash of file.
hashFile :: ( Hash h, Recommendation h)
         => FilePath  -- ^ File to be hashed
         -> IO h
hashFile fileName = withBinaryFile fileName ReadMode hashSource
{-# INLINEABLE hashFile #-}


-- | Compute the hash of a generic byte source.
hashSource :: ( Hash h, Recommendation h, ByteSource src )
           => src  -- ^ Message
           -> IO h
hashSource = go undefined
  where go :: (Hash h, Recommendation h, ByteSource src) => h -> src -> IO h
        go h = hashSource' $ recommended h

{-# INLINEABLE hashSource #-}
{-# SPECIALIZE hashSource :: (Hash h, Recommendation h) => Handle -> IO h #-}


-- | Similar to `hash` but the user can specify the implementation to
-- use.
hash' :: ( PureByteSource src
         , Hash h
         )
      => Implementation h -- ^ Implementation
      -> src              -- ^ the message as a byte source.
      -> h
hash' imp = unsafePerformIO . hashSource' imp
{-# INLINEABLE hash' #-}

-- TODO: For bytestrings (strict and lazy) we can do better. We can
-- avoid copying as the bytestring exposes the underlying
-- pointer. However, there is a huge cost if the underlying pointer
-- does not start at the machine alignment boundary. The idea
-- therefore is to process strict bytestring is multiples of blocks
-- directly if the starting pointer is aligned.
--
-- More details in the bug report #256.
--
-- https://github.com/raaz-crypto/raaz/issues/256
--

-- | Similar to hashFile' but the user can specify the implementation
-- to use.
hashFile' :: Hash h
          => Implementation h  -- ^ Implementation
          -> FilePath          -- ^ File to be hashed
          -> IO h
hashFile' imp fileName = withBinaryFile fileName ReadMode $ hashSource' imp
{-# INLINEABLE hashFile' #-}


-- | Similar to @hashSource@ but the user can specify the
-- implementation to use.
hashSource' :: (Hash h, ByteSource src)
            => Implementation h
            -> src
            -> IO h
hashSource' (SomeHashI impl) src =
  insecurely $ initialise () >> completeHashing impl src


-- | Gives a memory action that completes the hashing procedure with
-- the rest of the source. Useful to compute the hash of a source with
-- some prefix (like in the HMAC procedure).
completeHashing :: (Hash h, ByteSource src, HashM h m)
                => HashI h m
                -> src
                -> MT m h
completeHashing imp@(HashI{..}) src =
  allocate $ \ ptr -> let
    comp                = compress ptr bufSize
    finish bytes        = compressFinal ptr bytes >> extract
    in processChunks comp finish src bufSize ptr
  where bufSize             = atLeast l1Cache <> toEnum 1
        totalSize           = bufSize <> additionalPadBlocks undefined
        allocate            = liftPointerAction $ allocBufferFor (SomeHashI imp) totalSize

----------------------- Hash memory ----------------------------------

-- | Computing cryptographic hashes usually involves chunking the
-- message into blocks and compressing one block at a time. Usually
-- this compression makes use of the hash of the previous block and
-- the length of the message seen so far to compressing the current
-- block. Most implementations therefore need to keep track of only
-- hash and the length of the message seen so. This memory can be used
-- in such situations.
data HashMemory h =
  HashMemory
  { hashCell          :: MemoryCell h
                         -- ^ Cell to store the hash
  , messageLengthCell :: MemoryCell (BITS Word64)
                         -- ^ Cell to store the length
  }

instance Storable h => Memory (HashMemory h) where

  memoryAlloc     = HashMemory <$> memoryAlloc <*> memoryAlloc

  unsafeToPointer = unsafeToPointer . hashCell

instance Storable h => Initialisable (HashMemory h) h where
  initialise h = do
    onSubMemory hashCell          $ initialise h
    onSubMemory messageLengthCell $ initialise (0 :: BITS Word64)

instance Storable h => Extractable (HashMemory h) h where
  extract = onSubMemory hashCell extract

-- | Extract the length of the message hashed so far.
extractLength :: MT (HashMemory h) (BITS Word64)
extractLength = onSubMemory messageLengthCell extract
{-# INLINE extractLength #-}


-- | Update the message length by a given amount.
updateLength :: LengthUnit u => u -> MT (HashMemory h) ()
{-# INLINE updateLength #-}
updateLength u = onSubMemory messageLengthCell $ modify (nBits +)
  where nBits :: BITS Word64
        nBits =  inBits u