{-# LANGUAGE CPP, MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Crypto.Nettle.UMAC
-- Copyright   :  (c) 2013 Stefan Bühler
-- License     :  MIT-style (see the file COPYING)
-- 
-- Maintainer  :  stbuehler@web.de
-- Stability   :  experimental
-- Portability :  portable
--
-- This module exports the UMAC algorithms supported by nettle:
--   <http://www.lysator.liu.se/~nisse/nettle/>
--
-----------------------------------------------------------------------------

module Crypto.Nettle.UMAC (
	  UMAC(..)
	, UMAC32
	, UMAC64
	, UMAC96
	, UMAC128

	, umacInitKeyedHash
	) where

import Data.SecureMem
import Data.Tagged
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy as L
import Control.Applicative ((<$>))
import Data.List (foldl')

import Nettle.Utils
import Crypto.Nettle.KeyedHash
import Crypto.Nettle.Hash.ForeignImports

-- internal functions are not camelCase on purpose
{-# ANN module "HLint: ignore Use camelCase" #-}

{-|
'UMAC' is a class of keyed hash algorithms that take an additional nonce.

Keys for 'UMAC' are always 16 bytes; there are different digest sizes: 4, 8, 12 and 16 bytes (32, 64, 96 and 128 bits),
and the variants are named after the digest length in bits.

On initialization the nonce is set to 0; each finalize returns a new state with an incremented nonce.
The nonce is interpreted as 16-byte (128-bit) big-endian integer (and for string shorter than 16 bytes padded with zeroes /on the left/; setting empty nonces is not allowed).
-}
class UMAC u where
	-- | digest size in bytes
	umacDigestSize :: Tagged u Int
	-- | umac name ("UMAC" ++ digest size in bits)
	umacName :: Tagged u String
	umacName = (("UMAC" ++) . show . (8*)) <$> umacDigestSize
	-- | initialize a new context from a @key@ with a zero @nonce@
	umacInit :: B.ByteString {- ^ @key@ argument -} -> u
	-- | set a @nonce@; can be called anytime before producing the digest
	umacSetNonce :: u -> B.ByteString {- ^ @nonce@ argument -} -> u
	-- | append @message@ data to be hashed
	umacUpdate :: u -> B.ByteString {- ^ @message@ argument -} -> u
	-- | append lazy @message@ data to be hashed
	umacUpdateLazy :: u -> L.ByteString {- ^ @message@ argument -} -> u
	umacUpdateLazy u = foldl' umacUpdate u . L.toChunks
	-- | produce a digest, and return a new state with incremented nonce
	umacFinalize :: u -> (B.ByteString, u)

-- make all (UMAC u) a (KeyedHashAlgorithm u u)
umacKHDigestSize :: UMAC u => Tagged u Int
umacKHDigestSize = umacDigestSize
umacKHName :: UMAC u => Tagged u String
umacKHName = umacName
umacKHInit :: UMAC u => B.ByteString -> u
umacKHInit = umacInit
umacKHUpdate :: UMAC u => u -> B.ByteString -> u
umacKHUpdate = umacUpdate
umacKHFinalize :: UMAC u => u -> B.ByteString
umacKHFinalize = fst . umacFinalize

{-|
The default 'KeyedHash' generated for UMAC 'KeyedHashAlgorithm' instances use a zero nonce; to set a different nonce you need to use this initialization function (or use the 'UMAC' interface).

Once the UMAC lives as 'KeyedHash' the nonce cannot be changed anymore, as 'KeyedHash' hides all internal state.
-}
umacInitKeyedHash :: (UMAC u, KeyedHashAlgorithm u) => B.ByteString {- ^ @key@ argument -} -> B.ByteString {- ^ @nonce@ argument -} -> Tagged u KeyedHash
umacInitKeyedHash key nonce = KeyedHash <$> flip umacSetNonce nonce <$> tagSelf (umacInit key)

class NettleUMAC u where
	nu_ctx_size :: Tagged u Int
	nu_digest_size :: Tagged u Int
	nu_set_key :: Tagged u (Ptr Word8 -> Ptr Word8 -> IO ())
	nu_set_nonce :: Tagged u (Ptr Word8 -> Word -> Ptr Word8 -> IO ())
	nu_update :: Tagged u (Ptr Word8 -> Word -> Ptr Word8 -> IO ())
	nu_digest :: Tagged u (Ptr Word8 -> Word -> Ptr Word8 -> IO ())
	nu_ctx :: u -> SecureMem
	nu_Ctx :: SecureMem -> u

nettleUmacDigestSize :: NettleUMAC u => Tagged u Int
nettleUmacDigestSize = nu_digest_size
nettleUmacInit :: NettleUMAC u => B.ByteString -> u
nettleUmacInit key = if B.length key /= 16 then error "wrong key length" else untag go where
	go :: NettleUMAC u => Tagged u u
	go = do
		size <- nu_ctx_size
		set_key <- nu_set_key
		return $ nu_Ctx $ unsafeCreateSecureMem size $ \ctxptr ->
			withByteStringPtr key $ \_ keyptr ->
			set_key ctxptr keyptr
nettleUmacSetNonce :: NettleUMAC u => u -> B.ByteString -> u
nettleUmacSetNonce c nonce = if B.length nonce < 1 || B.length nonce > 16 then error "invalid nonce length" else untag $ go c where
	go :: NettleUMAC u => u -> Tagged u u
	go ctx = do
		set_nonce <- nu_set_nonce
		return $ nu_Ctx $ unsafeDupablePerformIO $
			withSecureMemCopy (nu_ctx ctx) $ \ctxptr ->
			withByteStringPtr nonce $ \noncelen nonceptr ->
				set_nonce ctxptr noncelen nonceptr
nettleUmacUpdate :: NettleUMAC u => u -> B.ByteString -> u
nettleUmacUpdate c msg = untag $ go c where
	go :: NettleUMAC u => u -> Tagged u u
	go ctx = do
		update <- nu_update
		return $ nu_Ctx $ unsafeDupablePerformIO $
			withSecureMemCopy (nu_ctx ctx) $ \ctxptr ->
			withByteStringPtr msg $ \msglen msgptr ->
				update ctxptr msglen msgptr
nettleUmacUpdateLazy :: NettleUMAC u => u -> L.ByteString -> u
nettleUmacUpdateLazy c msg = untag $ go c where
	go :: NettleUMAC u => u -> Tagged u u
	go ctx = do
		update <- nu_update
		return $ nu_Ctx $ unsafeDupablePerformIO $
			withSecureMemCopy (nu_ctx ctx) $ \ctxptr ->
			forM_ (L.toChunks msg) $ \chunk ->
			withByteStringPtr chunk $ \chunklen chunkptr ->
				update ctxptr chunklen chunkptr
nettleUmacFinalize :: NettleUMAC u => u -> (B.ByteString, u)
nettleUmacFinalize c = untag $ go c where
	go :: NettleUMAC u => u -> Tagged u (B.ByteString, u)
	go ctx = do
		digestSize <- nu_digest_size
		digest <- nu_digest
		return $ unsafeDupablePerformIO $ do
			ctx' <- secureMemCopy (nu_ctx ctx)
			dig <- withSecureMemPtr ctx' $ \ctxptr ->
				B.create digestSize $ \digestptr ->
				digest ctxptr (fromIntegral digestSize) digestptr
			return (dig, nu_Ctx ctx')

#define INSTANCE_UMAC(Typ) \
instance UMAC Typ where \
	{ umacDigestSize = nettleUmacDigestSize \
	; umacInit       = nettleUmacInit \
	; umacSetNonce   = nettleUmacSetNonce \
	; umacUpdate     = nettleUmacUpdate \
	; umacUpdateLazy = nettleUmacUpdateLazy \
	; umacFinalize   = nettleUmacFinalize \
	} ; \
instance KeyedHashAlgorithm Typ where \
	{ implKeyedHashDigestSize = umacKHDigestSize \
	; implKeyedHashName       = umacKHName \
	; implKeyedHashInit       = umacKHInit \
	; implKeyedHashUpdate     = umacKHUpdate \
	; implKeyedHashFinalize   = umacKHFinalize \
	}


{-|
'UMAC32' is the 32-bit (4 byte) digest variant. See 'umacInitKeyedHash' for the 'KeyedHashAlgorithm' instance.
-}
newtype UMAC32 = UMAC32 { umac32_ctx :: SecureMem }
instance NettleUMAC UMAC32 where
	nu_ctx_size    = Tagged c_umac32_ctx_size
	nu_digest_size = Tagged c_umac32_digest_size
	nu_set_key     = Tagged c_umac32_set_key
	nu_set_nonce   = Tagged c_umac32_set_nonce
	nu_update      = Tagged c_umac32_update
	nu_digest      = Tagged c_umac32_digest
	nu_ctx         = umac32_ctx
	nu_Ctx         = UMAC32
INSTANCE_UMAC(UMAC32)

{-|
'UMAC64' is the 32-bit (4 byte) digest variant. See 'umacInitKeyedHash' for the 'KeyedHashAlgorithm' instance.
-}
newtype UMAC64 = UMAC64 { umac64_ctx :: SecureMem }
instance NettleUMAC UMAC64 where
	nu_ctx_size    = Tagged c_umac64_ctx_size
	nu_digest_size = Tagged c_umac64_digest_size
	nu_set_key     = Tagged c_umac64_set_key
	nu_set_nonce   = Tagged c_umac64_set_nonce
	nu_update      = Tagged c_umac64_update
	nu_digest      = Tagged c_umac64_digest
	nu_ctx         = umac64_ctx
	nu_Ctx         = UMAC64
INSTANCE_UMAC(UMAC64)

{-|
'UMAC96' is the 32-bit (4 byte) digest variant. See 'umacInitKeyedHash' for the 'KeyedHashAlgorithm' instance.
-}
newtype UMAC96 = UMAC96 { umac96_ctx :: SecureMem }
instance NettleUMAC UMAC96 where
	nu_ctx_size    = Tagged c_umac96_ctx_size
	nu_digest_size = Tagged c_umac96_digest_size
	nu_set_key     = Tagged c_umac96_set_key
	nu_set_nonce   = Tagged c_umac96_set_nonce
	nu_update      = Tagged c_umac96_update
	nu_digest      = Tagged c_umac96_digest
	nu_ctx         = umac96_ctx
	nu_Ctx         = UMAC96
INSTANCE_UMAC(UMAC96)

{-|
'UMAC128' is the 32-bit (4 byte) digest variant. See 'umacInitKeyedHash' for the 'KeyedHashAlgorithm' instance.
-}
newtype UMAC128 = UMAC128 { umac128_ctx :: SecureMem }
instance NettleUMAC UMAC128 where
	nu_ctx_size    = Tagged c_umac128_ctx_size
	nu_digest_size = Tagged c_umac128_digest_size
	nu_set_key     = Tagged c_umac128_set_key
	nu_set_nonce   = Tagged c_umac128_set_nonce
	nu_update      = Tagged c_umac128_update
	nu_digest      = Tagged c_umac128_digest
	nu_ctx         = umac128_ctx
	nu_Ctx         = UMAC128
INSTANCE_UMAC(UMAC128)