78 lines
2.7 KiB
Haskell
78 lines
2.7 KiB
Haskell
{-# 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
|