Move from git.rhepire.org/rheperire

.gitignore

@@ -0,0 +1,5 @@
+**/.gup
+**/result*
+**/.stack-work
+uuid-crypto.nix
+**/dist

uuid-crypto/LICENSE

@@ -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.

uuid-crypto/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

uuid-crypto/src/Data/UUID/Cryptographic.hs

@@ -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

uuid-crypto/uuid-crypto.cabal

@@ -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