diff --git a/cryptoids-types/LICENSE b/cryptoids-types/LICENSE new file mode 100644 index 0000000..4522849 --- /dev/null +++ b/cryptoids-types/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. diff --git a/cryptoids-types/Setup.hs b/cryptoids-types/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/cryptoids-types/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cryptoids-types/cryptoids-types.cabal b/cryptoids-types/cryptoids-types.cabal new file mode 100644 index 0000000..276f59b --- /dev/null +++ b/cryptoids-types/cryptoids-types.cabal @@ -0,0 +1,24 @@ +name: cryptoids-types +description: Shared types for encrypting internal object identifiers before exposing them in public facing apis +version: 0.0.0 +license: BSD3 +license-file: LICENSE +author: Gregor Kleen +maintainer: aethoago@141.li +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Data.CryptoID + default-extensions: KindSignatures + , DataKinds + , GeneralizedNewtypeDeriving + , DeriveGeneric + , DeriveDataTypeable + build-depends: base >=4.9 && <4.10 + , binary + , path-pieces + , http-api-data + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cryptoids-types/cryptoids-types.nix b/cryptoids-types/cryptoids-types.nix new file mode 100644 index 0000000..488252f --- /dev/null +++ b/cryptoids-types/cryptoids-types.nix @@ -0,0 +1,8 @@ +{ mkDerivation, base, binary, http-api-data, path-pieces, stdenv }: +mkDerivation { + pname = "cryptoids-types"; + version = "0.0.0"; + src = ./.; + libraryHaskellDepends = [ base binary http-api-data path-pieces ]; + license = stdenv.lib.licenses.bsd3; +} diff --git a/cryptoids-types/src/Data/CryptoID.hs b/cryptoids-types/src/Data/CryptoID.hs new file mode 100644 index 0000000..2d51294 --- /dev/null +++ b/cryptoids-types/src/Data/CryptoID.hs @@ -0,0 +1,22 @@ +module Data.CryptoID + ( CryptoID(..) + ) where + +import GHC.Generics (Generic) +import Data.Typeable (Typeable) +import Data.Data (Data) +import GHC.TypeLits (Symbol) + +import Data.Binary (Binary) +import Foreign.Storable (Storable) + +import Web.PathPieces (PathPiece) +import Web.HttpApiData (ToHttpApiData, FromHttpApiData) + +newtype CryptoID (namespace :: Symbol) a = CryptoID { ciphertext :: a } + deriving ( Eq, Ord + , Read, Show + , Binary, Storable + , Data, Typeable, Generic + , PathPiece, ToHttpApiData, FromHttpApiData + ) diff --git a/cryptoids.nix b/cryptoids.nix new file mode 100644 index 0000000..b842ca0 --- /dev/null +++ b/cryptoids.nix @@ -0,0 +1,7 @@ +{ callPackage }: + +rec { + cryptoids-types = callPackage ./cryptoids-types/cryptoids-types.nix {}; + uuid-crypto = callPackage ./uuid-crypto/uuid-crypto.nix {}; + cryptoids = callPackage ./cryptoids/cryptoids.nix { inherit cryptoids-types; }; +} diff --git a/cryptoids/LICENSE b/cryptoids/LICENSE new file mode 100644 index 0000000..4522849 --- /dev/null +++ b/cryptoids/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. diff --git a/cryptoids/Setup.hs b/cryptoids/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/cryptoids/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cryptoids/cryptoids.cabal b/cryptoids/cryptoids.cabal new file mode 100644 index 0000000..eec4506 --- /dev/null +++ b/cryptoids/cryptoids.cabal @@ -0,0 +1,34 @@ +-- Initial cryptoids.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: cryptoids +version: 0.0.0 +synopsis: Reversable and secure encoding of object ids as a bytestring +-- 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.CryptoID.Poly + -- other-modules: + default-extensions: RankNTypes + , DataKinds + , GeneralizedNewtypeDeriving + , ViewPatterns + , RecordWildCards + , FlexibleContexts + build-depends: base >=4.9 && <4.10 + , cryptoids-types + , cryptonite + , bytestring + , binary + , memory + , mtl + hs-source-dirs: src + default-language: Haskell2010 diff --git a/cryptoids/cryptoids.nix b/cryptoids/cryptoids.nix new file mode 100644 index 0000000..8ed59e5 --- /dev/null +++ b/cryptoids/cryptoids.nix @@ -0,0 +1,13 @@ +{ mkDerivation, base, binary, bytestring, cryptoids-types +, cryptonite, memory, stdenv +}: +mkDerivation { + pname = "cryptoids"; + version = "0.0.0"; + src = ./.; + libraryHaskellDepends = [ + base binary bytestring cryptoids-types cryptonite memory + ]; + description = "Reversable and secure encoding of object ids as a bytestring"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/cryptoids/src/Data/CryptoID/Poly.hs b/cryptoids/src/Data/CryptoID/Poly.hs new file mode 100644 index 0000000..5ce359f --- /dev/null +++ b/cryptoids/src/Data/CryptoID/Poly.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{-| +Description: Reversably generate variable length bytestrings 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). + +The probability of detecting a namespace mismatch is thus \(1 - 2^{128-l}\) +where \(l\) is the length of the serialized payload. +-} +module Data.CryptoID.Poly + ( CryptoID(..) + , CryptoIDKey + , genKey + , encrypt + , decrypt + , CryptoIDError(..) + , CryptoCipher, CryptoHash + ) where + +import Data.CryptoID + +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.Blowfish (Blowfish) +import Crypto.Hash (hash, Digest) +import Crypto.Hash.Algorithms (SHAKE128) +import Crypto.Error + +import Crypto.Random.Entropy + + +-- | The symmetric cipher 'BlockCipher' this module uses +type CryptoCipher = Blowfish +-- | The cryptographic 'HashAlgorithm' this module uses +-- +-- We expect the block size of 'CryptoCipher' to be exactly the size of the +-- 'Digest' generated by 'CryptoHash' (since a 'Digest' is used as an 'IV'). +-- +-- Violation of this expectation causes runtime errors. +type CryptoHash = SHAKE128 64 + + +-- | 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] + + +-- | 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. + | CiphertextConversionFailed + -- ^ The produced 'ByteString' is the wrong length for conversion into a + -- ciphertext. + | DeserializationError (Lazy.ByteString, ByteOffset, String) + -- ^ The plaintext obtained by decrypting a ciphertext 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 + -- ciphertext 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 + + +-- | 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 :: Digest CryptoHash + namespaceHash = hash . ByteString.Char.pack $ symbolVal p + +-- | 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 +encrypt :: forall a m namespace. + ( KnownSymbol namespace + , MonadError CryptoIDError m + ) => CryptoIDKey -> ByteString -> m (CryptoID namespace ByteString) +encrypt (keyMaterial -> key) plaintext = do + cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher) + namespace <- namespace' (Proxy :: Proxy namespace) + return . CryptoID $ cbcEncrypt cipher namespace plaintext + + +-- | Decrypt an arbitrary serializable value +decrypt :: forall a m namespace. + ( KnownSymbol namespace + , MonadError CryptoIDError m + ) => CryptoIDKey -> CryptoID namespace ByteString -> m ByteString +decrypt (keyMaterial -> key) CryptoID{..} = do + cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher) + namespace <- namespace' (Proxy :: Proxy namespace) + return $ cbcDecrypt cipher namespace ciphertext + diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..35fe5b5 --- /dev/null +++ b/default.nix @@ -0,0 +1,6 @@ +argumentPackages@{ ... }: + +let + defaultPackages = (import {}).haskellPackages; + haskellPackages = defaultPackages // argumentPackages; +in import ./cryptoids.nix { inherit (haskellPackages) callPackage; } diff --git a/gup/Gupfile b/gup/Gupfile new file mode 100644 index 0000000..67efea3 --- /dev/null +++ b/gup/Gupfile @@ -0,0 +1,2 @@ +cabal2nix.gup: + **/*.nix \ No newline at end of file diff --git a/gup/cabal2nix.gup b/gup/cabal2nix.gup new file mode 100755 index 0000000..9854cec --- /dev/null +++ b/gup/cabal2nix.gup @@ -0,0 +1,8 @@ +#! /usr/bin/env nix-shell +#! nix-shell -i zsh -p zsh haskellPackages.cabal2nix + +gup -u ${2:r}.cabal + +cd ${2:h} + +cabal2nix . > $1 diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..f48aa4a --- /dev/null +++ b/shell.nix @@ -0,0 +1,20 @@ +{ nixpkgs ? import {}, compiler ? null }: + +let + inherit (nixpkgs) pkgs; + + haskellPackages = if isNull compiler + then pkgs.haskellPackages + else pkgs.haskell.packages.${compiler}; + + drvs = import ./. { inherit (haskellPackages) callPackage; }; + + override = oldAttrs: { + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ cabal2nix gup ]) ++ (with haskellPackages; [ hlint stack cabal-install ]); + shellHook = '' + ${oldAttrs.shellHook} + export PROMPT_INFO="${oldAttrs.name}" + ''; + }; +in + pkgs.lib.mapAttrs (name: drv: pkgs.stdenv.lib.overrideDerivation drv.env override) drvs diff --git a/stack.nix b/stack.nix new file mode 100644 index 0000000..5f26b5e --- /dev/null +++ b/stack.nix @@ -0,0 +1,13 @@ +{ ghc, nixpkgs ? (import {}) }: + +let + inherit (nixpkgs) haskell pkgs; +in haskell.lib.buildStackProject { + inherit ghc; + name = ''stackenv-uuid-crypto''; + buildInputs = with pkgs; + [ postgresql zlib.dev ncurses.dev + haskellPackages.yesod-bin haskellPackages.happy + haskellPackages.alex + ]; +} diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..8f9c280 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,72 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-9.3 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: + - cryptoids-types + - cryptoids + - uuid-crypto +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.4" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor +nix: + packages: [] + shell-file: ./stack.nix diff --git a/uuid-crypto/src/Data/UUID/Cryptographic.hs b/uuid-crypto/src/Data/UUID/Cryptographic.hs index 577fe66..b31d0f8 100644 --- a/uuid-crypto/src/Data/UUID/Cryptographic.hs +++ b/uuid-crypto/src/Data/UUID/Cryptographic.hs @@ -10,184 +10,59 @@ 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. +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(..) - , CryptoIDKey - , genKey - , CryptoIDError(..) + , CryptoUUID , encrypt , decrypt - , CryptoCipher, CryptoHash + , 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.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] +type CryptoUUID (namespace :: Symbol) = CryptoID namespace UUID --- | 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) +mapCiphertext :: Functor m => (a -> m b) -> CryptoID n a -> m (CryptoID n b) +mapCiphertext f (CryptoID x) = CryptoID <$> f x --- | 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 +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 --- | 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 @@ -199,16 +74,15 @@ 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) + ) => CryptoIDKey -> a -> m (CryptoUUID namespace) +encrypt key val = do + plaintext <- pad (blockSize cipher) . Lazy.ByteString.toStrict $ encode val - namespace <- namespace' (Proxy :: Proxy namespace) - plaintext <- pad PlaintextTooLong (blockSize cipher) . Lazy.ByteString.toStrict $ encode val - - CryptoID <$> uuidConversion (cbcEncrypt cipher namespace plaintext) + mapCiphertext uuidConversion =<< Poly.encrypt key plaintext where - uuidConversion = maybe (throwError UUIDConversionFailed) return . fromByteString . Lazy.ByteString.fromStrict + uuidConversion = maybe (throwError CiphertextConversionFailed) return . fromByteString . Lazy.ByteString.fromStrict + cipher :: CryptoCipher + cipher = undefined -- | Decrypt an arbitrary serializable value @@ -220,13 +94,10 @@ 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') + ) => 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 diff --git a/uuid-crypto/uuid-crypto.cabal b/uuid-crypto/uuid-crypto.cabal index 298b92c..317b570 100644 --- a/uuid-crypto/uuid-crypto.cabal +++ b/uuid-crypto/uuid-crypto.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: uuid-crypto -version: 0.1.0 +version: 1.0.0 synopsis: Reversable and secure encoding of object ids as uuids -- description: license: BSD3 @@ -28,6 +28,8 @@ library , DeriveGeneric other-extensions: ScopedTypeVariables build-depends: base >=4.9 && <4.11 + , cryptoids-types + , cryptoids , uuid , cryptonite , binary