initial commit (adapt from hackage)

Dockerfile

@@ -0,0 +1,17 @@
+FROM haskell:9.8.4
+
+WORKDIR /opt/cryptoids
+
+RUN cabal update
+
+# Add just the .cabal file to capture dependencies
+COPY ./cryptoids.cabal /opt/cryptoids/cryptoids.cabal
+
+# Docker will cache this command as a layer, freeing us up to
+# modify source code without re-installing dependencies
+# (unless the .cabal file changes!)
+RUN cabal build --only-dependencies -j4
+
+# Add and Install Application Code
+COPY . /opt/cryptoids
+RUN cabal build

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.

Setup.hs

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

changes.md

@@ -0,0 +1,37 @@
+# 0.5.1.0
+
+    - Add 'CiphertextIsWrongLength'
+    - Bump version bound on 'cryptonite'
+
+# 0.5.0.0
+
+    - Add support for 'cryptoids-class'
+
+# 0.4.0.0
+
+    - Expose 'cipherBlockSize'
+    - Adjust 'Data.CryptoID.Poly' to allow for more dynamic padding
+
+# 0.3.0.0
+
+    - Better exception type (does no longer leak private information)
+    - 'Data.CryptoID.Poly' now supports padding the plaintext to a certain length before encryption
+
+# 0.2.0.0
+
+    - Rename 'Data.CryptoID.Poly' to 'Data.CryptoID.ByteString'
+    - Introduce 'Data.CryptoID.Poly' doing actual serialization
+
+# 0.1.0.1
+
+    - Correct mistakes in the documentation
+
+# 0.1.0
+
+    - Switch to using 'MonadThrow' instead of 'MonadError'
+    - Introduce 'readKeyFile'
+
+# 0.0.0
+
+First published version
+

cryptoids.cabal

@@ -0,0 +1,39 @@
+name:           cryptoids
+version:        0.6.0.0
+synopsis:       Reversable and secure encoding of object ids as a bytestring
+category:       cryptography
+author:         Gregor Kleen <aethoago@141.li>
+maintainer:     Gregor Kleen <aethoago@141.li>
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+cabal-version:  >= 1.10
+extra-source-files:
+    changes.md
+
+source-repository head
+  type: git
+  location: https://gitea.uniworx.systems/haskell/cryptoids
+
+library
+  exposed-modules:
+      Data.CryptoID.Poly
+      Data.CryptoID.Poly.ImplicitNamespace
+      Data.CryptoID.ByteString
+      Data.CryptoID.ByteString.ImplicitNamespace
+  other-modules:
+      Paths_cryptoids
+  hs-source-dirs:
+      src
+  default-extensions: RankNTypes DataKinds GeneralizedNewtypeDeriving ViewPatterns RecordWildCards FlexibleContexts FlexibleInstances MultiParamTypeClasses TypeFamilies ConstraintKinds
+  ghc-options: -Wall
+  build-depends:
+      base >=4.19 && <5
+    , binary >=0.8.9 && <0.9
+    , bytestring >=0.12 && <1
+    , crypton >=1.0.4 && <2
+    , directory >=1.3.8.5 && <2
+    , exceptions >=0.10.7 && <0.11
+    , filepath >=1.4.301 && <1.5
+    , memory >=0.18 && <0.19
+  default-language: Haskell2010

src/Data/CryptoID/ByteString.hs

@@ -0,0 +1,245 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-|
+Description: Encryption of bytestrings using a type level nonce for determinism
+License: BSD3
+
+Given a strict 'ByteString' we compute a cryptographic hash of the associated
+namespace (carried as a phantom type of kind 'Symbol').
+The payload is then encrypted using the symmetric cipher in CBC mode using the
+hashed namespace as an initialization vector (IV).
+
+The probability of detecting a namespace mismatch is thus the density of valid
+payloads within all 'ByteString's of the correct length.
+-}
+module Data.CryptoID.ByteString
+  ( CryptoByteString
+  , HasCryptoByteString
+  , CryptoIDKey
+  , genKey, readKeyFile
+  , encrypt
+  , decrypt
+  , CryptoIDError(..)
+  , CryptoCipher, CryptoHash
+  , cipherBlockSize
+  , module Data.CryptoID
+  , module Data.CryptoID.Class
+  ) where
+
+import Data.CryptoID
+import Data.CryptoID.Class hiding (encrypt, decrypt)
+import qualified Data.CryptoID.Class as Class (encrypt, decrypt)
+
+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 Data.List (sortOn)
+import Data.Ord (Down(..))
+
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as ByteArray
+
+import Data.Foldable (asum)
+import Control.Monad.Catch (MonadThrow(..))
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Exception
+import System.IO.Error
+
+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
+
+import System.Directory
+import System.FilePath
+
+
+-- | 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
+
+
+cipherBlockSize :: Int
+cipherBlockSize = blockSize (undefined :: CryptoCipher)
+  
+
+-- | 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 [min .. max]
+
+
+-- | Error cases that can be encountered during 'encrypt' and 'decrypt'
+--
+-- Care has been taken to ensure that presenting values of 'CryptoIDError' to an
+-- attacker leaks no plaintext (it does leak information about the length of the
+-- plaintext).
+data CryptoIDError
+  = AlgorithmError CryptoError
+    -- ^ One of the underlying cryptographic algorithms
+    --   ('CryptoHash' or 'CryptoCipher') failed.
+  | PlaintextIsWrongLength Int
+    -- ^ The length of the plaintext is not a multiple of the block size of
+    --   'CryptoCipher'
+    --
+    -- The length of the offending plaintext is included.
+  | CiphertextIsWrongLength ByteString
+    -- ^ The length of the ciphertext is not a multiple of the block size of
+    --   'CryptoCipher'
+    --
+    -- The offending ciphertext is included.
+  | 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 ByteString
+    -- ^ The produced 'ByteString' is the wrong length for deserialization into
+    --   a ciphertext.
+    --
+    -- The offending 'ByteString' is included.
+  | DeserializationError
+    -- ^ 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
+
+-- | Try to read a 'CryptoIDKey' from a file.
+--   If the file does not exist, securely generate a key (using 'genKey') and
+--   save it to the file. 
+readKeyFile :: MonadIO m => FilePath -> m CryptoIDKey
+readKeyFile keyFile = liftIO $ decodeFile keyFile `catch` generateInstead
+  where
+    generateInstead e
+      | isDoesNotExistError e = do
+          createDirectoryIfMissing True $ takeDirectory keyFile
+          key <- genKey
+          encodeFile keyFile key
+          return key
+      | otherwise = throw e
+
+
+type CryptoByteString (namespace :: Symbol) = CryptoID namespace ByteString
+
+type HasCryptoByteString (namespace :: Symbol) = HasCryptoID namespace ByteString
+  
+
+-- | Use 'CryptoHash' to generate a 'Digest' of the Symbol passed as proxy type
+namespace' :: forall proxy namespace m.
+              ( KnownSymbol namespace, MonadThrow m
+              ) => proxy namespace -> m (IV CryptoCipher)
+namespace' p = case makeIV namespaceHash of
+                 Nothing -> throwM . 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 :: MonadThrow m => CryptoFailable a -> m a
+cryptoFailable = either (throwM . AlgorithmError) return . eitherCryptoError
+
+-- | Encrypt a serialized value
+encrypt :: forall m namespace.
+             ( KnownSymbol namespace
+             , MonadThrow m
+             ) => CryptoIDKey -> ByteString -> m (CryptoID namespace ByteString)
+encrypt (keyMaterial -> key) plaintext = do
+  cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
+  namespace <- namespace' (Proxy :: Proxy namespace)
+  when (ByteString.length plaintext `mod` blockSize cipher /= 0) $
+    throwM . PlaintextIsWrongLength $ ByteString.length plaintext
+  return . CryptoID $ cbcEncrypt cipher namespace plaintext
+
+
+-- | Decrypt a serialized value
+decrypt :: forall m namespace.
+             ( KnownSymbol namespace
+             , MonadThrow m
+             ) => CryptoIDKey -> CryptoID namespace ByteString -> m ByteString
+decrypt (keyMaterial -> key) CryptoID{..} = do
+  cipher <- cryptoFailable (cipherInit key :: CryptoFailable CryptoCipher)
+  namespace <- namespace' (Proxy :: Proxy namespace)
+  when (ByteString.length ciphertext `mod` blockSize cipher /= 0) $
+    throwM $ CiphertextIsWrongLength ciphertext
+  return $ cbcDecrypt cipher namespace ciphertext
+
+-- | This instance is somewhat improper in that it works only for plain- and
+--   ciphertexts whose length is a multiple of 'cipherBlockSize'
+--
+-- Improper plaintext lengths throw 'PlaintextIsWrongLength'
+--
+-- Improper ciphertext lengths throw 'CiphertextIsWrongLength'
+instance ( MonadCrypto m
+         , MonadCryptoKey m ~ CryptoIDKey
+         , KnownSymbol namespace
+         ) => HasCryptoID namespace ByteString ByteString m where
+  encrypt = cryptoIDKey . flip encrypt
+  decrypt = cryptoIDKey . flip decrypt

src/Data/CryptoID/ByteString/ImplicitNamespace.hs

@@ -0,0 +1,19 @@
+{-|
+Description: Encryption of bytestrings with implicit type level nonces
+License: BSD3
+-}
+module Data.CryptoID.ByteString.ImplicitNamespace
+  ( CryptoByteString
+  , HasCryptoByteString
+  , module Data.CryptoID.ByteString
+  , module Data.CryptoID.Class.ImplicitNamespace
+  ) where
+
+import Data.CryptoID.Class.ImplicitNamespace
+
+import Data.CryptoID.ByteString hiding (encrypt, decrypt, CryptoID, HasCryptoID, CryptoByteString, HasCryptoByteString)
+
+import Data.ByteString (ByteString)
+
+type CryptoByteString plaintext = CryptoID ByteString plaintext
+type HasCryptoByteString plaintext = HasCryptoID ByteString plaintext

src/Data/CryptoID/Poly.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-|
+Description: Encryption of serializable values using a type level nonce for determinism
+License: BSD3
+
+Given a value of an arbitrary 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 serializedpayload is then encrypted using the symmetric cipher in CBC mode
+using the hashed namespace as an initialization vector (IV).
+
+Since the serialized payload is padded such that its length is an integer
+multiple of the block size 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^{l \
+\text{mod} \ 64}\) where \(l\) is the length of the serialized payload in bits.
+-}
+module Data.CryptoID.Poly
+  ( encrypt
+  , decrypt
+  , module Data.CryptoID.ByteString
+  ) where
+
+import Data.CryptoID.ByteString hiding (encrypt, decrypt)
+import qualified Data.CryptoID.ByteString as ByteString (encrypt, decrypt)
+import Data.CryptoID.Class (HasCryptoID)
+import qualified Data.CryptoID.Class as Class (HasCryptoID(..))
+
+import Data.Binary
+
+import Data.Monoid
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as Lazy.ByteString
+
+import GHC.TypeLits
+
+import Control.Monad
+import Control.Monad.Catch (MonadThrow(..))
+  
+
+_ciphertext :: Functor m => (a -> m b) -> CryptoID n a -> m (CryptoID n b)
+_ciphertext f (CryptoID x) = CryptoID <$> f x
+
+  
+-- | Encrypt a serialized value
+encrypt :: forall a m c namespace.
+           ( KnownSymbol namespace
+           , MonadThrow m
+           , Binary a
+           ) => (ByteString -> m (Maybe Int)) -- ^ Ensure the resulting ciphertext is of the provided length (needs to be a multiple of the block size of 'CryptoCipher' in bytes, otherwise an exception will be thrown at runtime). The computation has access to the serialized plaintext
+        -> (ByteString -> m c)
+        -> CryptoIDKey
+        -> a
+        -> m (CryptoID namespace c)
+encrypt pLength' encode' key plaintext = do
+  cID <- ByteString.encrypt key <=< (\str -> pad str =<< pLength' str) . Lazy.ByteString.toStrict $ encode plaintext
+  _ciphertext encode' cID
+  where
+    pad str pLength
+      | Just l <- pLength
+      , l' <= l           = return $ str <> ByteString.replicate (l - l') 0
+      | Just _ <- pLength = throwM $ CiphertextConversionFailed str
+      | otherwise         = return str
+      where
+        l' = ByteString.length str
+
+
+-- | Decrypt a serialized value
+decrypt :: forall a m c namespace.
+           ( KnownSymbol namespace
+           , MonadThrow m
+           , Binary a
+           ) => (c -> m ByteString) -> CryptoIDKey -> CryptoID namespace c -> m a
+decrypt decode key cID = do
+  cID' <- _ciphertext decode cID
+  plaintext <- Lazy.ByteString.fromStrict <$> ByteString.decrypt key cID'
+
+  case decodeOrFail plaintext of
+    Left _ -> throwM DeserializationError
+    Right (rem, _, res)
+      | Lazy.ByteString.all (== 0) rem -> return res
+      | otherwise -> throwM InvalidNamespaceDetected
+
+instance ( MonadCrypto m
+         , MonadCryptoKey m ~ CryptoIDKey
+         , KnownSymbol namespace
+         , Binary a
+         ) => HasCryptoID namespace ByteString a m where
+  encrypt = cryptoIDKey . flip (encrypt (const $ return Nothing) return)
+  decrypt = cryptoIDKey . flip (decrypt return)

src/Data/CryptoID/Poly/ImplicitNamespace.hs

@@ -0,0 +1,12 @@
+{-|
+Description: Encryption of serializable values with implicit type level nonces
+License: BSD3
+-}
+module Data.CryptoID.Poly.ImplicitNamespace
+  ( module Data.CryptoID.Poly
+  , module Data.CryptoID.Class.ImplicitNamespace
+  ) where
+
+import Data.CryptoID.Class.ImplicitNamespace
+
+import Data.CryptoID.Poly hiding (encrypt, decrypt, CryptoID, HasCryptoID)