haskell/cryptoids
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refactor & generalize

Browse Source
This commit is contained in:
Gregor Kleen 2017-10-10 03:40:23 +02:00
parent 51c9a1fd01
commit 78a4b91032
19 changed files with 503 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
cryptoids-types/LICENSE Normal file
View 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
cryptoids-types/Setup.hs Normal file
View File

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

24
cryptoids-types/cryptoids-types.cabal Normal file
View File

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

8
cryptoids-types/cryptoids-types.nix Normal file
View File

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

22
cryptoids-types/src/Data/CryptoID.hs Normal file
View File

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

7
cryptoids.nix Normal file
View File

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

30
cryptoids/LICENSE Normal file
View 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
cryptoids/Setup.hs Normal file
View File

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

34
cryptoids/cryptoids.cabal Normal file
View File

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

13
cryptoids/cryptoids.nix Normal file
View File

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

181
cryptoids/src/Data/CryptoID/Poly.hs Normal file
View File

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

6
default.nix Normal file
View File

@ -0,0 +1,6 @@
argumentPackages@{ ... }:
let
defaultPackages = (import <nixpkgs> {}).haskellPackages;
haskellPackages = defaultPackages // argumentPackages;
in import ./cryptoids.nix { inherit (haskellPackages) callPackage; }

2
gup/Gupfile Normal file
View File

@ -0,0 +1,2 @@
cabal2nix.gup:
**/*.nix

8
gup/cabal2nix.gup Executable file
View File

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

20
shell.nix Normal file
View File

@ -0,0 +1,20 @@
{ nixpkgs ? import <nixpkgs> {}, 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

13
stack.nix Normal file
View File

@ -0,0 +1,13 @@
{ ghc, nixpkgs ? (import <nixpkgs> {}) }:
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
];
}

72
stack.yaml Normal file
View File

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

181
uuid-crypto/src/Data/UUID/Cryptographic.hs
View File

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

4
uuid-crypto/uuid-crypto.cabal
View File

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