diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 0000000..c02ab49 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..4522849 --- /dev/null +++ b/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/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changes.md b/changes.md new file mode 100644 index 0000000..304b948 --- /dev/null +++ b/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 + diff --git a/cryptoids.cabal b/cryptoids.cabal new file mode 100644 index 0000000..6653797 --- /dev/null +++ b/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 +maintainer: Gregor Kleen +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 diff --git a/src/Data/CryptoID/ByteString.hs b/src/Data/CryptoID/ByteString.hs new file mode 100644 index 0000000..4252353 --- /dev/null +++ b/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 diff --git a/src/Data/CryptoID/ByteString/ImplicitNamespace.hs b/src/Data/CryptoID/ByteString/ImplicitNamespace.hs new file mode 100644 index 0000000..139d177 --- /dev/null +++ b/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 diff --git a/src/Data/CryptoID/Poly.hs b/src/Data/CryptoID/Poly.hs new file mode 100644 index 0000000..f9799f1 --- /dev/null +++ b/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) diff --git a/src/Data/CryptoID/Poly/ImplicitNamespace.hs b/src/Data/CryptoID/Poly/ImplicitNamespace.hs new file mode 100644 index 0000000..7427f63 --- /dev/null +++ b/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)