Move from git.rhepire.org/rheperire
This commit is contained in:
Gregor Kleen
commit
51c9a1fd01
5
.gitignore
vendored
Normal file
5
.gitignore
vendored
Normal file
@ -0,0 +1,5 @@
|
||||
**/.gup
|
||||
**/result*
|
||||
**/.stack-work
|
||||
uuid-crypto.nix
|
||||
**/dist
|
||||
30
uuid-crypto/LICENSE
Normal file
30
uuid-crypto/LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright (c) 2017, Gregor Kleen
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Gregor Kleen nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
2
uuid-crypto/Setup.hs
Normal file
2
uuid-crypto/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
235
uuid-crypto/src/Data/UUID/Cryptographic.hs
Normal file
235
uuid-crypto/src/Data/UUID/Cryptographic.hs
Normal file
@ -0,0 +1,235 @@
|
||||
{-# 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 exactly the length of a single cipher
|
||||
block 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(..)
|
||||
, CryptoIDKey
|
||||
, genKey
|
||||
, CryptoIDError(..)
|
||||
, encrypt
|
||||
, decrypt
|
||||
, CryptoCipher, CryptoHash
|
||||
) where
|
||||
|
||||
import Data.UUID (UUID, toByteString, fromByteString)
|
||||
import Data.Binary
|
||||
import Data.Binary.Put
|
||||
import Data.Binary.Get
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString.Char8 as ByteString.Char
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
|
||||
import Data.List (sortOn)
|
||||
import Data.Ord (Down(..))
|
||||
|
||||
import Data.ByteArray (ByteArrayAccess)
|
||||
import qualified Data.ByteArray as ByteArray
|
||||
|
||||
import Data.Foldable (asum)
|
||||
import Control.Monad.Except
|
||||
import Control.Exception
|
||||
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits
|
||||
|
||||
import Crypto.Cipher.Types
|
||||
import Crypto.Cipher.AES (AES256)
|
||||
import Crypto.Hash (hash, Digest)
|
||||
import Crypto.Hash.Algorithms (SHAKE128)
|
||||
import Crypto.Error
|
||||
|
||||
import Crypto.Random.Entropy
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Data (Data)
|
||||
import Foreign.Storable (Storable)
|
||||
|
||||
|
||||
-- | The symmetric cipher 'BlockCipher' this module uses
|
||||
type CryptoCipher = AES256
|
||||
-- | The cryptographic 'HashAlgorithm' this module uses
|
||||
--
|
||||
-- We expect the block size of 'CryptoCipher' to be exactly the size of the
|
||||
-- 'Digest' generated by 'CryptoHash'.
|
||||
--
|
||||
-- Violation of this expectation causes runtime errors.
|
||||
type CryptoHash = SHAKE128 128
|
||||
|
||||
|
||||
-- | This newtype ensures only keys of the correct length can be created
|
||||
--
|
||||
-- Use 'genKey' to securely generate keys.
|
||||
--
|
||||
-- Use the 'Binary' instance to save and restore values of 'CryptoIDKey' across
|
||||
-- executions.
|
||||
newtype CryptoIDKey = CryptoIDKey { keyMaterial :: ByteString }
|
||||
deriving (Typeable, ByteArrayAccess)
|
||||
|
||||
-- | Does not actually show any key material
|
||||
instance Show CryptoIDKey where
|
||||
show = show . typeOf
|
||||
|
||||
instance Binary CryptoIDKey where
|
||||
put = putByteString . keyMaterial
|
||||
get = CryptoIDKey <$> getKey (cipherKeySize cipher)
|
||||
where
|
||||
cipher :: CryptoCipher
|
||||
cipher = undefined
|
||||
|
||||
-- Try key sizes from large to small ('Get' commits to the first branch
|
||||
-- that parses)
|
||||
getKey (KeySizeFixed n) = getByteString n
|
||||
getKey (KeySizeEnum ns) = asum [ getKey $ KeySizeFixed n | n <- sortOn Down ns ]
|
||||
getKey (KeySizeRange min max) = getKey $ KeySizeEnum [max .. min]
|
||||
|
||||
|
||||
-- | A thin wrapper around 'UUID' to carry the type information from which we
|
||||
-- infer what payload we expect the 'UUID' to contain.
|
||||
newtype CryptoID (namespace :: Symbol) = CryptoID { ciphertext :: UUID }
|
||||
deriving (Eq, Data, Ord, Read, Show, Binary, Typeable, Storable, Generic)
|
||||
|
||||
-- | Error cases that can be encountered during 'encrypt' and 'decrypt'
|
||||
data CryptoIDError = AlgorithmError CryptoError
|
||||
-- ^ One of the underlying cryptographic algorithms
|
||||
-- ('CryptoHash' or 'CryptoCipher') failed.
|
||||
| NamespaceHashIsWrongLength ByteString
|
||||
-- ^ The length of the digest produced by 'CryptoHash' does
|
||||
-- not match the block size of 'CryptoCipher'.
|
||||
--
|
||||
-- The offending digest is included.
|
||||
--
|
||||
-- This error should not occur and is included primarily
|
||||
-- for sake of totality.
|
||||
| PlaintextTooLong ByteString
|
||||
-- ^ The serialized representation of the payload exceeds
|
||||
-- the block size of 'CryptoCipher'.
|
||||
--
|
||||
-- The offending serialization is included.
|
||||
| UUIDConversionFailed
|
||||
-- ^ The length of the produced ciphertext (which is
|
||||
-- expected to be exactly one block size of
|
||||
-- 'CryptoCipher') does not match the size expected for a
|
||||
-- 'UUID' (128 bits).
|
||||
--
|
||||
-- This error should not occur and is included primarily
|
||||
-- for sake of totality.
|
||||
| DeserializationError (Lazy.ByteString, ByteOffset, String)
|
||||
-- ^ The plaintext obtained by decrypting a 'UUID' with the
|
||||
-- given 'CryptoIDKey' in the context of the @namespace@
|
||||
-- could not be deserialized into a value of the expected
|
||||
-- @payload@-type.
|
||||
--
|
||||
-- This is expected behaviour if the @namespace@ or
|
||||
-- @payload@-type does not match the ones used during
|
||||
-- 'encrypt'ion or if the 'ciphertext' was tempered with.
|
||||
| InvalidNamespaceDetected
|
||||
-- ^ We have determined that, allthough deserializion
|
||||
-- succeded, the 'UUID' was likely modified during
|
||||
-- transit or created using a different namespace.
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Exception CryptoIDError
|
||||
|
||||
-- | Securely generate a new key using system entropy
|
||||
--
|
||||
-- When 'CryptoCipher' accepts keys of varying lengths this function generates a
|
||||
-- key of the largest accepted size.
|
||||
genKey :: MonadIO m => m CryptoIDKey
|
||||
genKey = CryptoIDKey <$> liftIO (getEntropy keySize)
|
||||
where
|
||||
keySize' = cipherKeySize (undefined :: CryptoCipher)
|
||||
|
||||
keySize
|
||||
| KeySizeFixed n <- keySize' = n
|
||||
| KeySizeEnum ns <- keySize' = maximum ns
|
||||
| KeySizeRange _ max <- keySize' = max
|
||||
|
||||
|
||||
-- | @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 e m, ByteArrayAccess a) => (ByteString -> e) -> Int -> a -> m ByteString
|
||||
pad err n (ByteArray.unpack -> src)
|
||||
| l > n = throwError . err $ ByteString.pack src
|
||||
| otherwise = return . ByteString.pack $ src ++ replicate (n - l) 0
|
||||
where
|
||||
l = length src
|
||||
|
||||
-- | Use 'CryptoHash' to generate a 'Digest' of the Symbol passed as proxy type
|
||||
namespace' :: forall proxy namespace m.
|
||||
( KnownSymbol namespace, MonadError CryptoIDError m
|
||||
) => proxy namespace -> m (IV CryptoCipher)
|
||||
namespace' p = case makeIV namespaceHash of
|
||||
Nothing -> throwError . NamespaceHashIsWrongLength $ ByteArray.convert namespaceHash
|
||||
Just iv -> return iv
|
||||
where
|
||||
namespaceHash = hash . ByteString.Char.pack $ symbolVal p :: Digest CryptoHash
|
||||
|
||||
-- | Wrap failure of one of the cryptographic algorithms as a 'CryptoIDError'
|
||||
cryptoFailable :: MonadError CryptoIDError m => CryptoFailable a -> m a
|
||||
cryptoFailable = either (throwError . AlgorithmError) return . eitherCryptoError
|
||||
|
||||
-- | 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 (CryptoID namespace)
|
||||
encrypt (keyMaterial -> key) val = do
|
||||
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
|
||||
|
||||
namespace <- namespace' (Proxy :: Proxy namespace)
|
||||
plaintext <- pad PlaintextTooLong (blockSize cipher) . Lazy.ByteString.toStrict $ encode val
|
||||
|
||||
CryptoID <$> uuidConversion (cbcEncrypt cipher namespace plaintext)
|
||||
where
|
||||
uuidConversion = maybe (throwError UUIDConversionFailed) 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 -> CryptoID namespace -> m a
|
||||
decrypt (keyMaterial -> key) CryptoID{..} = do
|
||||
cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
|
||||
|
||||
namespace <- namespace' (Proxy :: Proxy namespace)
|
||||
let ciphertext' = Lazy.ByteString.toStrict $ toByteString ciphertext
|
||||
plaintext = Lazy.ByteString.fromStrict (cbcDecrypt cipher namespace ciphertext')
|
||||
|
||||
case decodeOrFail plaintext of
|
||||
Left err -> throwError $ DeserializationError err
|
||||
Right (rem, _, res)
|
||||
| Lazy.ByteString.all (== 0) rem -> return res
|
||||
| otherwise -> throwError InvalidNamespaceDetected
|
||||
39
uuid-crypto/uuid-crypto.cabal
Normal file
39
uuid-crypto/uuid-crypto.cabal
Normal file
@ -0,0 +1,39 @@
|
||||
-- Initial uuid-crypto.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: uuid-crypto
|
||||
version: 0.1.0
|
||||
synopsis: Reversable and secure encoding of object ids as uuids
|
||||
-- description:
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Gregor Kleen
|
||||
maintainer: aethoago@141.li
|
||||
-- copyright:
|
||||
category: cryptography
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
exposed-modules: Data.UUID.Cryptographic
|
||||
-- other-modules:
|
||||
default-extensions: KindSignatures
|
||||
, ViewPatterns
|
||||
, FlexibleContexts
|
||||
, GeneralizedNewtypeDeriving
|
||||
, PatternGuards
|
||||
, RecordWildCards
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
other-extensions: ScopedTypeVariables
|
||||
build-depends: base >=4.9 && <4.11
|
||||
, uuid
|
||||
, cryptonite
|
||||
, binary
|
||||
, memory
|
||||
, bytestring
|
||||
, mtl
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fno-warn-name-shadowing
|
||||
Loading…
Reference in New Issue
Block a user