{-# LANGUAGE ScopedTypeVariables #-}

{-|
Description: Reversably generate UUIDs from arbitrary serializable types in a secure fashion
License: BSD3

Given a value of a serializable type (like 'Int') we perform serialization and
compute a cryptographic hash of the associated namespace (carried as a phantom
type of kind 'Symbol').
The serialized payload is then encrypted using the a symmetric cipher in CBC
mode using the hashed namespace as an initialization vector (IV).

Since the serialized payload is padded to the length of an UUID we can detect
namespace mismatches by checking that all bytes expected to have been inserted
during padding are nil.
The probability of detecting a namespace mismatch is thus \(1 - 2^{128-l}\)
where \(l\) is the length of the serialized payload.
-}
module Data.UUID.Cryptographic
  ( CryptoID(..)
  , CryptoUUID
  , encrypt
  , decrypt
  , CryptoIDError(..)
  ) where

import Data.CryptoID
import Data.CryptoID.Poly hiding (encrypt, decrypt)
import qualified Data.CryptoID.Poly as Poly (encrypt, decrypt)

import Data.UUID (UUID, toByteString, fromByteString)
import Data.Binary

import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString

import qualified Data.ByteString.Lazy as Lazy.ByteString

import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as ByteArray

import Control.Monad.Except

import GHC.TypeLits


type CryptoUUID (namespace :: Symbol) = CryptoID namespace UUID


_ciphertext :: Functor m => (a -> m b) -> CryptoID n a -> m (CryptoID n b)
_ciphertext f (CryptoID x) = CryptoID <$> f x


-- | @pad err size src@ appends null bytes to @src@ until it has length @size@.
--
-- If @src@ is already longer than @size@ @err@ is thrown instead.
pad :: (MonadError CryptoIDError m, ByteArrayAccess a) => Int -> a -> m ByteString
pad n (ByteArray.unpack -> src)
  | l > n     = throwError CiphertextConversionFailed
  | otherwise = return . ByteString.pack $ src ++ replicate (n - l) 0
  where
    l = length src

-- | Encrypt an arbitrary serializable value
--
-- We only expect to fail if the given value is not serialized in such a fashion
-- that it fits within one 'CryptoCipher'-block.
--
-- Larger values could likely not be contained wholly within 128 bits (the size
-- of an 'UUID') in any case.
encrypt :: forall a m namespace.
           ( KnownSymbol namespace
           , Binary a
           , MonadError CryptoIDError m
           ) => CryptoIDKey -> a -> m (CryptoUUID namespace)
encrypt key val = do
  plaintext <- pad 16 . Lazy.ByteString.toStrict $ encode val
  
  _ciphertext uuidConversion =<< Poly.encrypt key plaintext
    where
      uuidConversion = maybe (throwError CiphertextConversionFailed) return . fromByteString . Lazy.ByteString.fromStrict


-- | Decrypt an arbitrary serializable value
--
-- Since no integrity guarantees can be made (we do not sign the values we
-- 'encrypt') it is likely that deserialization will fail emitting
-- 'DeserializationError' or 'InvalidNamespaceDetected'.
decrypt :: forall a m namespace.
           ( KnownSymbol namespace
           , Binary a
           , MonadError CryptoIDError m
           ) => CryptoIDKey -> CryptoUUID namespace -> m a
decrypt key cId = do
  cId' <- _ciphertext (return . Lazy.ByteString.toStrict . toByteString) cId
  plaintext <- Lazy.ByteString.fromStrict <$> Poly.decrypt key cId'

  case decodeOrFail plaintext of
    Left err -> throwError $ DeserializationError err
    Right (rem, _, res)
      | Lazy.ByteString.all (== 0) rem -> return res
      | otherwise -> throwError InvalidNamespaceDetected