{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|
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 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
  ( CryptoUUID
  , HasCryptoUUID
  , encrypt
  , decrypt
  , module Data.CryptoID.Poly
  ) where

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

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

import qualified Data.ByteString.Lazy as Lazy.ByteString

import Control.Monad.Catch

import GHC.TypeLits


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


-- | 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 128 bits (the length of an 'UUID').
encrypt :: forall a m namespace.
           ( KnownSymbol namespace
           , Binary a
           , MonadThrow m
           ) => CryptoIDKey -> a -> m (CryptoUUID namespace)
encrypt = Poly.encrypt (const . return $ Just 16) $ \str -> maybe (throwM $ CiphertextConversionFailed str) return . fromByteString $ Lazy.ByteString.fromStrict str


-- | 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
           , MonadThrow m
           ) => CryptoIDKey -> CryptoUUID namespace -> m a
decrypt = Poly.decrypt $ return . Lazy.ByteString.toStrict . toByteString

instance ( MonadCrypto m
         , MonadCryptoKey m ~ CryptoIDKey
         , KnownSymbol namespace
         , Binary a
         ) => HasCryptoID namespace UUID a m where
  encrypt = cryptoIDKey . flip encrypt
  decrypt = cryptoIDKey . flip decrypt