103 lines
3.5 KiB
Haskell
103 lines
3.5 KiB
Haskell
{-# 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
|
|
|
|
|
|
mapCiphertext :: Functor m => (a -> m b) -> CryptoID n a -> m (CryptoID n b)
|
|
mapCiphertext 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
|
|
|
|
mapCiphertext 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 id = do
|
|
id' <- (return . Lazy.ByteString.toStrict . toByteString) `mapCiphertext` id
|
|
plaintext <- Lazy.ByteString.fromStrict <$> Poly.decrypt key id'
|
|
|
|
case decodeOrFail plaintext of
|
|
Left err -> throwError $ DeserializationError err
|
|
Right (rem, _, res)
|
|
| Lazy.ByteString.all (== 0) rem -> return res
|
|
| otherwise -> throwError InvalidNamespaceDetected
|