cryptostore 0.5.0.0 → 0.6.0.0

raw patch · 29 files changed

+444/−270 lines, 29 filesdep +ramdep −basementdep ~cryptondep ~crypton-x509dep ~crypton-x509-validationPVP ok

version bump matches the API change (PVP)

Dependencies added: ram

Dependencies removed: basement

Dependency ranges changed: crypton, crypton-x509, crypton-x509-validation

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−0
• README.md +3/−186
• cryptostore.cabal +12/−9
• src/Crypto/Store/ASN1/Parse.hs +0/−1
• src/Crypto/Store/Block.hs +137/−0
• src/Crypto/Store/CMS.hs +1/−0
• src/Crypto/Store/CMS/Algorithms.hs +20/−5
• src/Crypto/Store/CMS/OriginatorInfo.hs +0/−1
• src/Crypto/Store/Cipher/RC2/Primitive.hs +33/−27
• src/Crypto/Store/KeyWrap/AES.hs +1/−0
• src/Crypto/Store/KeyWrap/RC2.hs +1/−0
• src/Crypto/Store/KeyWrap/TripleDES.hs +1/−0
• src/Crypto/Store/PKCS12.hs +3/−3
• src/Crypto/Store/PKCS5.hs +9/−0
• src/Crypto/Store/PKCS5/PBES1.hs +36/−27
• src/Crypto/Store/PKCS8.hs +1/−0
• src/Crypto/Store/PKCS8/EC.hs +8/−0
• src/Crypto/Store/Utf8.hs +104/−0
• src/Crypto/Store/Util.hs +3/−1
• tests/CMS/Instances.hs +1/−1
• tests/CMS/Tests.hs +1/−1
• tests/KeyWrap/AES.hs +1/−0
• tests/KeyWrap/RC2.hs +1/−0
• tests/KeyWrap/TripleDES.hs +1/−0
• tests/Main.hs +2/−0
• tests/PKCS12/Instances.hs +0/−1
• tests/PKCS8/Instances.hs +0/−1
• tests/Password.hs +39/−0
• tests/Util.hs +1/−6

@@ -1,5 +1,29 @@ # Revision history for cryptostore +## 0.6.0.0 - 2026-09-27++* _DEPRECATED:_  modules `Crypto.Store.CMS` and `Crypto.Store.KeyWrap.*` will+  be removed in the next major release in 2027.  Goal is to reduce cryptography+  in cryptostore, still retaining password-based encryption of private keys.++* Raise minimum bounds to crypton >= 1.1.0 when flag `use_crypton` is enabled,+  and replace memory with ram as dependency++* Key agreement with `StdDH` is now stricter and verifies that the peer public+  key is in a proper subgroup++* Password-based encryption/decryption is now more strict as it rejects invalid+  Unicode passwords when the algorithm requires code points in the UCS-2 set.+  Previously the high surrogate bits were silently ignored.++* Function `passwordToString` is added to modules `PKCS5`, `PKCS8`, `PKCS12`.+  This is the opposite of `fromString` for type `ProtectionPassword`.++* Module `Crypto.Store.PKCS5` re-exports more types and functions from+  `Crypto.Store.CMS`, to prepare removal of CMS++* Dependency to basement is removed and replaced by local implementations+ ## 0.5.0.0 - 2026-02-08  * Add support for key encapsulation to CMS, aka KEMRecipientInfo.  The only

@@ -15,8 +15,6 @@  * PKCS #12 container format (password-based only) -* Many parts of Cryptographic Message Syntax- Please have a look at the examples below as well as some warnings about cryptographic algorithms. @@ -133,7 +131,7 @@ > privKey <- PrivKeyRSA . snd <$> generate (2048 `div` 8) 0x10001  -- Put the key inside a bag-> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5 Crypto.Store.CMS+> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5 > let keyPair = keyPairFromPrivKey privKey > let attrs = setFriendlyName "Some Key" [] >     keyBag = Bag (KeyBag $ FormattedKey PKCS8Format keyPair) attrs@@ -158,7 +156,7 @@  ```haskell > :set -XOverloadedStrings-> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5 Crypto.Store.CMS+> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5  -- Read PKCS #12 content as credential > Right p12 <- readP12File "/path/to/other.p12"@@ -201,7 +199,7 @@ > privKey <- PrivKeyRSA . snd <$> generate (2048 `div` 8) 0x10001  -- Put the key inside a bag-> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5 Crypto.Store.CMS+> :m Crypto.Store.PKCS12 Crypto.Store.PKCS8 Crypto.Store.PKCS5 > let keyPair = keyPairFromPrivKey privKey > let attrs = setFriendlyName "Some Key" [] >     keyBag = Bag (KeyBag $ FormattedKey PKCS8Format keyPair) attrs@@ -221,187 +219,6 @@ > let iParams = AuthSchemeIntegrity authScheme > writeP12File "/path/to/newkey.p12" iParams "mypassword" pkcs12 Right ()-```--## Cryptographic Message Syntax--The API to read and write CMS content is available in `Crypto.Store.CMS`.  The-main data type `ContentInfo` represents a CMS structure.--Implemented content types are:--* data-* signed data-* enveloped data-* digested data-* encrypted data-* authenticated data-* and authenticated-enveloped data--Notable omissions:--* streaming-* compressed data-* and S/MIME external format (only PEM is supported, i.e. the textual encoding-  of [RFC 7468](https://tools.ietf.org/html/rfc7468))--### Enveloped data--The following examples generate a CMS structure enveloping some data to a-password recipient, then decrypt the data to recover the content.--#### Generating enveloped data--```haskell-> :set -XOverloadedStrings-> :m Crypto.Store.CMS---- Input content info-> let info = DataCI "Hi, what will you need from the cryptostore?"---- Content encryption will use AES-128-CBC-> ceParams <- generateCBCParams AES128-> ceKey <- generateKey ceParams :: IO ContentEncryptionKey---- Encrypt the Content Encryption Key with a Password Recipient Info,--- i.e. a KDF will derive the Key Encryption Key from a password--- that the recipient will need to know-> salt <- generateSalt 16-> let kdf = PBKDF2 salt 200000 Nothing PBKDF2_SHA256-> keParams <- generateCBCParams AES128-> let pri = forPasswordRecipient "mypassword" kdf (PWRIKEK keParams)---- Generate the enveloped structure for this single recipient.  Encrypted--- content is kept attached in the structure.-> Right envelopedData <- envelopData mempty ceKey ceParams [pri] [] info-> let envelopedCI = toAttachedCI envelopedData-> writeCMSFile "/path/to/enveloped.pem" [envelopedCI]-```--#### Opening the enveloped data--```haskell-> :set -XOverloadedStrings-> :m Crypto.Store.CMS---- Then this recipient just has to read the file and recover enveloped--- content using the password-> [EnvelopedDataCI envelopedEncapData] <- readCMSFile "/path/to/enveloped.pem"-> envelopedData <- fromAttached envelopedEncapData-> openEnvelopedData (withRecipientPassword "mypassword") envelopedData-Right (DataCI "Hi, what will you need from the cryptostore?")-```--### Signed data--The following examples generate a CMS structure signing data with an RSA key-and certificate, then verify the signature and recover the content.--#### Signing data--```haskell-> :set -XOverloadedStrings-> :m Crypto.Store.CMS Data.X509 Crypto.Store.X509 Crypto.Store.PKCS8---- Input content info-> let info = DataCI "Some trustworthy content"---- Read signer certificate and private key-> (key : _) <- readKeyFile "/path/to/privkey.pem" -- assuming single key-> let Right pair = recover "mypassword" key-> chain <- readSignedObject "/path/to/cert.pem" :: IO [SignedCertificate]-> let cert = CertificateChain chain---- Signature will use RSASSA-PSS and SHA-256-> let sha256 = DigestAlgorithm SHA256-> let params = PSSParams sha256 (MGF1 sha256) 16---- Generate the signed structure with a single signer.  Signed content is--- kept attached in the structure.-> let signer = certSigner (RSAPSS params) pair cert (Just []) []-> Right signedData <- signData [signer] info-> let signedCI = toAttachedCI signedData-> writeCMSFile "/path/to/signed.pem" [signedCI]-```--#### Verifying signed data--```haskell--- Read certificate authorities to be trusted for validation-> :m Crypto.Store.X509 Data.X509.CertificateStore-> store <- makeCertificateStore <$> readSignedObject "/path/to/cacert.pem"---- Assume we will not verify the signer FQHN.  Instead the certificate could be--- related to an identity from which we received the signed data.-> :m Data.Default.Class Data.X509 Data.X509.Validation-> let validateNoFQHN = validate HashSHA256 def def { checkFQHN = False }-> let noServiceID = (undefined, undefined)---- Read the signed data and validate it to recover the content-> :m Crypto.Store.CMS Data.Default.Class-> [SignedDataCI signedEncapData] <- readCMSFile "/path/to/signed.pem"-> signedData <- fromAttached signedEncapData-> let doValidation _ chain = null <$> validateNoFQHN store def noServiceID chain-> verifySignedData (withSignerCertificate doValidation) signedData-Right (DataCI "Some trustworthy content")-```--### Authenticated-enveloped data--The following examples generate a CMS structure auth-enveloping some data to a-KEM recipient, then decrypt the data to recover the content.--#### Generating authenticated-enveloped data--```haskell-> :set -XOverloadedStrings-> :m Crypto.Store.CMS Data.X509 Crypto.Store.X509---- Input content info-> let info = DataCI "Powered by Haskell"---- Read receipient certificate-> [cert] <- readSignedObject "/path/to/cert.pem" :: IO [SignedCertificate]---- Content encryption will use AES-128-GCM, and we protect against manipulation--- of algorithm identifiers as defined in RFC 9709-> aceParams' <- generateGCMParams AES128 16-> let aceParams = authDeriveEncryptionKey aceParams'-> aceKey <- generateKey aceParams :: IO ContentEncryptionKey---- Encrypt the Content Encryption Key with a KEM Recipient Info,--- i.e. a KDF will derive the Key Encryption Key from a shared secret produced--- by a Key Encapsulation Mechanism.  We are using RSA-KEM based on KDF3 with--- SHA-256 to produce a 16-byte shared secret.  Further derivation of the KEK--- uses HKDF with SHA-256.  The CEK is finally wrapped with AES-Wrap-128.-> let kem = KeyEncapsulationRSA (KDF3 (DigestAlgorithm SHA256)) 16-> let kdf = HKDF (DigestAlgorithm SHA256)-> let kri = forKeyEncapRecipient cert kdf AES128_WRAP kem---- Generate the auth-enveloped structure for this single recipient.  Encrypted--- content is kept attached in the structure.-> Right authEnvData <- authEnvelopData mempty aceKey aceParams [kri] [] [] info-> let authEnvCI = toAttachedCI authEnvData-> writeCMSFile "/path/to/authEnveloped.pem" [authEnvCI]-```--#### Opening the authenticated-enveloped data--```haskell-> :set -XOverloadedStrings-> :m Crypto.Store.CMS Data.X509 Crypto.Store.X509 Crypto.Store.PKCS8---- Read receipient certificate and private key-> (key : _) <- readKeyFile "/path/to/privkey.pem" -- assuming single key-> let Right pair = recover "mypassword" key-> [cert] <- readSignedObject "/path/to/cert.pem" :: IO [SignedCertificate]---- Then this recipient just has to read the file and recover enveloped--- content using the private key and certificate-> [AuthEnvelopedDataCI authEnvEncapData] <- readCMSFile "/path/to/authEnveloped.pem"-> authEnvData <- fromAttached authEnvEncapData-> openAuthEnvelopedData (withRecipientKeyEncap pair cert) authEnvData-Right (DataCI "Powered by Haskell") ```  ## Algorithms and security

@@ -1,8 +1,7 @@ name:                cryptostore-version:             0.5.0.0+version:             0.6.0.0 synopsis:            Serialization of cryptographic data types-description:         Haskell implementation of PKCS \#8, PKCS \#12 and CMS-                     (Cryptographic Message Syntax).+description:         Haskell implementation of PKCS \#8 and PKCS \#12. license:             BSD3 license-file:        LICENSE author:              Olivier Chéron@@ -38,6 +37,7 @@                      , Crypto.Store.X509   other-modules:       Crypto.Store.ASN1.Generate                      , Crypto.Store.ASN1.Parse+                     , Crypto.Store.Block                      , Crypto.Store.CMS.Algorithms                      , Crypto.Store.CMS.Attribute                      , Crypto.Store.CMS.Authenticated@@ -57,19 +57,19 @@                      , Crypto.Store.PKCS5.PBES1                      , Crypto.Store.PKCS8.EC                      , Crypto.Store.PubKey.RSA.KEM+                     , Crypto.Store.Utf8                      , Crypto.Store.Util   -- other-extensions:   build-depends:       base >= 4.9 && < 5                      , bytestring-                     , basement-                     , memory   if flag(use_crypton)-    build-depends:     crypton+    build-depends:     crypton >= 1.1.0                      , crypton-asn1-encoding >= 0.10.0 && < 0.11                      , crypton-asn1-types >= 0.4.1 && < 0.5                      , crypton-pem >= 0.2.4 && <0.4-                     , crypton-x509 >= 1.8.0-                     , crypton-x509-validation >= 1.8.0+                     , crypton-x509 >= 1.9.0+                     , crypton-x509-validation >= 1.9.0+                     , ram                      , time-hourglass   else     build-depends:     cryptonite >=0.26@@ -79,6 +79,7 @@                      , asn1-types >= 0.3.1 && < 0.4                      , asn1-encoding >= 0.9.6 && < 0.10                      , hourglass >= 0.2.10+                     , memory   default-language:    Haskell2010   ghc-options:         -Wall @@ -92,6 +93,7 @@                      , CMS.Instances                      , CMS.Tests                      , Cipher.RC2+                     , Password                      , PKCS12.Instances                      , PKCS12.Tests                      , PKCS8.Instances@@ -101,7 +103,6 @@                      , X509.Tests   build-depends:       base >= 4.9 && < 5                      , bytestring-                     , memory                      , tasty                      , tasty-hunit                      , tasty-quickcheck@@ -111,12 +112,14 @@                      , crypton-asn1-types >= 0.4.1 && < 0.5                      , crypton-pem >= 0.2.4 && <0.4                      , crypton-x509+                     , ram                      , time-hourglass   else     build-depends:     cryptonite >=0.25                      , x509                      , asn1-types >= 0.3.1 && < 0.4                      , hourglass+                     , memory                      , pem   default-language:    Haskell2010   ghc-options:         -Wall

@@ -70,7 +70,6 @@     empty = throwParseError "empty"     (<|>) = mplus instance Monad (ParseASN1 e) where-    return      = pure     (>>=) m1 m2 = P $ \s ->         case runP m1 s of             Left err      -> Left err

@@ -0,0 +1,137 @@+-- |+-- Module      : Crypto.Store.Block+-- License     : BSD-style+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability   : experimental+-- Portability : unknown+--+-- Minimal port of basement @Block@ data type.  Provides a typed interface on+-- top of @ByteArray#@.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+module Crypto.Store.Block+    ( Block, Offset(..), CountOf(..), PrimType(..)+    , createWithPtr, Crypto.Store.Block.map, unsafeCast, unsafeIndex+    ) where++import Data.Memory.Endian++import Data.Proxy+import Data.Word++import Foreign.Ptr (castPtr)++import GHC.Exts+import GHC.IO (IO(..))+import GHC.Word++import System.IO.Unsafe++data Block a = Block ByteArray#+data MutableBlock a = MutableBlock (MutableByteArray# RealWorld)++newtype CountOf a = CountOf Int deriving (Show, Eq, Ord)+newtype Offset a = Offset Int deriving (Show, Eq, Ord, Num)++class PrimType a where+    primSizeInBytes :: Proxy a -> CountOf Word8+    primBaIndex :: ByteArray# -> Offset a -> a+    primMbaWrite :: MutableByteArray# RealWorld -> Offset a -> a -> IO ()++instance PrimType Word8 where+    primSizeInBytes _ = CountOf 1+    {-# INLINE primSizeInBytes #-}+    primBaIndex ba (Offset (I# n)) = W8# (indexWord8Array# ba n)+    {-# INLINE primBaIndex #-}+    primMbaWrite mba (Offset (I# n)) (W8# w) = IO $ \s -> (# writeWord8Array# mba n w s, () #)+    {-# INLINE primMbaWrite #-}++instance PrimType Word16 where+    primSizeInBytes _ = CountOf 2+    {-# INLINE primSizeInBytes #-}+    primBaIndex ba (Offset (I# n)) = W16# (indexWord16Array# ba n)+    {-# INLINE primBaIndex #-}+    primMbaWrite mba (Offset (I# n)) (W16# w) = IO $ \s -> (# writeWord16Array# mba n w s, () #)+    {-# INLINE primMbaWrite #-}++instance PrimType a => PrimType (LE a) where+    primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy a)+    {-# INLINE primSizeInBytes #-}+    primBaIndex ba (Offset i) = LE $ primBaIndex ba (Offset i)+    {-# INLINE primBaIndex #-}+    primMbaWrite mba (Offset i) (LE x) = primMbaWrite mba (Offset i) x+    {-# INLINE primMbaWrite #-}++create :: PrimType a => CountOf a -> (Offset a -> a) -> Block a+create n@(CountOf !sz) f = unsafeDupablePerformIO $ do+    mb <- new n+    loop mb 0+    unsafeFreeze mb+  where+    loop !mb i+        | i == sz = pure ()+        | otherwise =+            let off = Offset i+             in unsafeWrite mb off (f off) >> loop mb (i + 1)+{-# INLINE create #-}++createWithPtr :: CountOf Word8 -> (Ptr p -> IO a) -> Block Word8+createWithPtr n f = unsafeDupablePerformIO $ do+    b <- unsafeNewPinned n >>= unsafeFreeze+    f (castPtr $ unsafeBlockPtr b) *> touch b+    return b+{-# INLINE createWithPtr #-}++length :: forall a. PrimType a => Block a -> CountOf a+length (Block ba) = CountOf (I# (sizeofByteArray# ba) `quot` sz)+  where CountOf sz = primSizeInBytes (Proxy :: Proxy a)+{-# INLINE length #-}++map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b+map f b = create (CountOf len) $ \(Offset i) -> f (unsafeIndex b (Offset i))+  where CountOf len = Crypto.Store.Block.length b+{-# INLINE map #-}++new :: forall a. PrimType a => CountOf a -> IO (MutableBlock a)+new (CountOf n) = IO $ \s1 ->+    case newByteArray# bytes s1 of+        (# s2, mba #) -> (# s2, MutableBlock mba #)+  where+    !(I# bytes) = n * sz+    CountOf sz = primSizeInBytes (Proxy :: Proxy a)+{-# INLINE new #-}++touch :: Block a -> IO ()+touch (Block ba) = IO $ \s1 -> case touch# ba s1 of { s2 -> (# s2, () #) }++unsafeBlockPtr :: Block a -> Ptr a+unsafeBlockPtr (Block ba) = Ptr (byteArrayContents# ba)+{-# INLINE unsafeBlockPtr #-}++unsafeCast :: Block a -> Block b+unsafeCast (Block ba) = Block ba+{-# INLINE unsafeCast #-}++unsafeFreeze :: MutableBlock a -> IO (Block a)+unsafeFreeze (MutableBlock mba) = IO $ \s1 ->+    case unsafeFreezeByteArray# mba s1 of+        (# s2, ba #) -> (# s2, Block ba #)+{-# INLINE unsafeFreeze #-}++unsafeIndex :: PrimType a => Block a -> Offset a -> a+unsafeIndex (Block ba) = primBaIndex ba+{-# INLINE unsafeIndex #-}++unsafeNewPinned :: CountOf Word8 -> IO (MutableBlock a)+unsafeNewPinned (CountOf (I# bytes)) = IO $ \s1 ->+    case newAlignedPinnedByteArray# bytes 8# s1 of+        (# s2, mba #) -> (# s2, MutableBlock mba #)+{-# INLINE unsafeNewPinned #-}++unsafeWrite :: PrimType a => MutableBlock a -> Offset a -> a -> IO ()+unsafeWrite (MutableBlock mba) = primMbaWrite mba+{-# INLINE unsafeWrite #-}

@@ -28,6 +28,7 @@ -- * <https://tools.ietf.org/html/rfc9709 RFC 9709>: Encryption Key Derivation in the Cryptographic Message Syntax (CMS) Using HKDF with SHA-256 {-# LANGUAGE RecordWildCards #-} module Crypto.Store.CMS+    {-# DEPRECATED "Will be removed in the next major release" #-}     ( ContentType(..)     , ContentInfo(..)     , getContentType

@@ -94,7 +94,7 @@     ) where  import Control.Applicative-import Control.Monad (guard, when)+import Control.Monad (guard, unless, when)  import           Data.ASN1.BinaryEncoding import           Data.ASN1.OID@@ -2010,6 +2010,17 @@     | PairX25519 X25519.SecretKey X25519.PublicKey     | PairX448 X448.SecretKey X448.PublicKey +-- EC points are validated by function 'unserializePoint'.  When using standard+-- D-H, we also need to make sure that points are in the expected subgroup.+--+-- Note: elliptic curves are assumed to be valid.  We trust curve parameters+-- obtained from the private key.  When parameters come from a public key, only+-- named curves are accepted.+ecdhStdCheck :: ECC.Curve -> ECC.Point -> Either StoreError ()+ecdhStdCheck curve pt =+    unless (isBasePointMultiple curve pt) $+        Left (InvalidInput "Serialized point is not a generator multiple")+ -- | Generate an ephemeral ECDH key. ecdhGenerate :: MonadRandom m => X509.PubKey -> m (Either StoreError ECDHPair) ecdhGenerate (X509.PubKeyEC pub) =@@ -2040,10 +2051,13 @@ -- algorithm. ecdhEncrypt :: (MonadRandom m, ByteArray ba)             => KeyAgreementParams -> Maybe ByteString -> ECDHPair -> ba -> m (Either StoreError ba)-ecdhEncrypt (StdDH dig kep) ukm (PairEC curve d pub) bs = do-    let s = ECDH.getShared curve d pub-        k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes-    keyEncrypt k kep bs+ecdhEncrypt (StdDH dig kep) ukm (PairEC curve d pub) bs =+    case ecdhStdCheck curve pub of+        Left e  -> return (Left e)+        Right _ -> do+            let s = ECDH.getShared curve d pub+                k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes+            keyEncrypt k kep bs ecdhEncrypt (StdDH dig kep) ukm (PairX25519 priv pub) bs =     case fromCryptoFailable (ecdh x25519 priv pub) of         Left e  -> return (Left e)@@ -2077,6 +2091,7 @@             case unserializePoint curve (X509.SerializedPoint pt) of                 Nothing  -> Left (InvalidInput "Invalid serialized point")                 Just pub -> do+                    ecdhStdCheck curve pub                     let d = X509.privkeyEC_priv priv                         s = ECDH.getShared curve d pub                         k = ecdhKeyMaterial dig kep ukm s :: B.ScrubbedBytes

@@ -57,7 +57,6 @@  instance Monoid OriginatorInfo where     mempty = OriginatorInfo [] []-    mappend = (<>)  instance HasChoiceOther OriginatorInfo where     hasChoiceOther OriginatorInfo{..} =

@@ -5,7 +5,8 @@ -- Stability   : stable -- Portability : good ---{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} module Crypto.Store.Cipher.RC2.Primitive     ( Key     , buildKey@@ -13,21 +14,22 @@     , decrypt     ) where -import Basement.Block-import Basement.Compat.IsList-import Basement.Endianness-import Basement.Types.OffsetSize- import Control.Monad (forM_)  import           Data.Bits import           Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as B+import           Data.Memory.Endian (fromLE) import           Data.Word +import Foreign.Marshal.Utils (copyBytes) import Foreign.Storable +import GHC.Ptr (Ptr(..)) +import Crypto.Store.Block++ -- | Expanded RC2 key newtype Key = Key (Block Word16) -- [ K[0], K[1], ..., K[63] ] @@ -187,7 +189,7 @@          => Int    -- ^ Effective key length in bits          -> key    -- ^ Input key between 1 and 128 bytes          -> Key    -- ^ Expanded key-buildKey t1 key = Key $ doCast $ B.allocAndFreeze 128 $ \p -> do+buildKey !t1 key = Key $ doCast $ createWithPtr (CountOf 128) $ \p -> do     B.copyByteArrayToPtr key p      forM_ [t .. 127] $ \i -> do@@ -199,7 +201,7 @@     let b' = unsafeIndex piTable (fromIntegral pos')     pokeElemOff p (128 - t8) b' -    forM_ (Prelude.reverse [0 .. 127 - t8]) $ \i -> do+    forM_ [127 - t8, 126 - t8 .. 0] $ \i -> do         pos <- xor <$> peekElemOff p (i + 1) <*> peekElemOff p (i + t8)         let b = unsafeIndex piTable (fromIntegral pos)         pokeElemOff p i b@@ -210,27 +212,31 @@            | otherwise    = 255 `mod` shiftL 1 (8 + t1 - 8 * t8)          doCast :: Block Word8 -> Block Word16-        doCast = Basement.Block.map fromLE . cast+        doCast = Crypto.Store.Block.map fromLE . unsafeCast+{-# NOINLINE buildKey #-}   -- PITABLE  piTable :: Block Word8-piTable = fromList-    [ 0xd9, 0x78, 0xf9, 0xc4, 0x19, 0xdd, 0xb5, 0xed, 0x28, 0xe9, 0xfd, 0x79, 0x4a, 0xa0, 0xd8, 0x9d-    , 0xc6, 0x7e, 0x37, 0x83, 0x2b, 0x76, 0x53, 0x8e, 0x62, 0x4c, 0x64, 0x88, 0x44, 0x8b, 0xfb, 0xa2-    , 0x17, 0x9a, 0x59, 0xf5, 0x87, 0xb3, 0x4f, 0x13, 0x61, 0x45, 0x6d, 0x8d, 0x09, 0x81, 0x7d, 0x32-    , 0xbd, 0x8f, 0x40, 0xeb, 0x86, 0xb7, 0x7b, 0x0b, 0xf0, 0x95, 0x21, 0x22, 0x5c, 0x6b, 0x4e, 0x82-    , 0x54, 0xd6, 0x65, 0x93, 0xce, 0x60, 0xb2, 0x1c, 0x73, 0x56, 0xc0, 0x14, 0xa7, 0x8c, 0xf1, 0xdc-    , 0x12, 0x75, 0xca, 0x1f, 0x3b, 0xbe, 0xe4, 0xd1, 0x42, 0x3d, 0xd4, 0x30, 0xa3, 0x3c, 0xb6, 0x26-    , 0x6f, 0xbf, 0x0e, 0xda, 0x46, 0x69, 0x07, 0x57, 0x27, 0xf2, 0x1d, 0x9b, 0xbc, 0x94, 0x43, 0x03-    , 0xf8, 0x11, 0xc7, 0xf6, 0x90, 0xef, 0x3e, 0xe7, 0x06, 0xc3, 0xd5, 0x2f, 0xc8, 0x66, 0x1e, 0xd7-    , 0x08, 0xe8, 0xea, 0xde, 0x80, 0x52, 0xee, 0xf7, 0x84, 0xaa, 0x72, 0xac, 0x35, 0x4d, 0x6a, 0x2a-    , 0x96, 0x1a, 0xd2, 0x71, 0x5a, 0x15, 0x49, 0x74, 0x4b, 0x9f, 0xd0, 0x5e, 0x04, 0x18, 0xa4, 0xec-    , 0xc2, 0xe0, 0x41, 0x6e, 0x0f, 0x51, 0xcb, 0xcc, 0x24, 0x91, 0xaf, 0x50, 0xa1, 0xf4, 0x70, 0x39-    , 0x99, 0x7c, 0x3a, 0x85, 0x23, 0xb8, 0xb4, 0x7a, 0xfc, 0x02, 0x36, 0x5b, 0x25, 0x55, 0x97, 0x31-    , 0x2d, 0x5d, 0xfa, 0x98, 0xe3, 0x8a, 0x92, 0xae, 0x05, 0xdf, 0x29, 0x10, 0x67, 0x6c, 0xba, 0xc9-    , 0xd3, 0x00, 0xe6, 0xcf, 0xe1, 0x9e, 0xa8, 0x2c, 0x63, 0x16, 0x01, 0x3f, 0x58, 0xe2, 0x89, 0xa9-    , 0x0d, 0x38, 0x34, 0x1b, 0xab, 0x33, 0xff, 0xb0, 0xbb, 0x48, 0x0c, 0x5f, 0xb9, 0xb1, 0xcd, 0x2e-    , 0xc5, 0xf3, 0xdb, 0x47, 0xe5, 0xa5, 0x9c, 0x77, 0x0a, 0xa6, 0x20, 0x68, 0xfe, 0x7f, 0xc1, 0xad-    ]+piTable = createWithPtr (CountOf bytes) $ \p -> copyBytes p (Ptr addr#) bytes+  where+    bytes = 256+    addr# =+        "\xd9\x78\xf9\xc4\x19\xdd\xb5\xed\x28\xe9\xfd\x79\x4a\xa0\xd8\x9d\+        \\xc6\x7e\x37\x83\x2b\x76\x53\x8e\x62\x4c\x64\x88\x44\x8b\xfb\xa2\+        \\x17\x9a\x59\xf5\x87\xb3\x4f\x13\x61\x45\x6d\x8d\x09\x81\x7d\x32\+        \\xbd\x8f\x40\xeb\x86\xb7\x7b\x0b\xf0\x95\x21\x22\x5c\x6b\x4e\x82\+        \\x54\xd6\x65\x93\xce\x60\xb2\x1c\x73\x56\xc0\x14\xa7\x8c\xf1\xdc\+        \\x12\x75\xca\x1f\x3b\xbe\xe4\xd1\x42\x3d\xd4\x30\xa3\x3c\xb6\x26\+        \\x6f\xbf\x0e\xda\x46\x69\x07\x57\x27\xf2\x1d\x9b\xbc\x94\x43\x03\+        \\xf8\x11\xc7\xf6\x90\xef\x3e\xe7\x06\xc3\xd5\x2f\xc8\x66\x1e\xd7\+        \\x08\xe8\xea\xde\x80\x52\xee\xf7\x84\xaa\x72\xac\x35\x4d\x6a\x2a\+        \\x96\x1a\xd2\x71\x5a\x15\x49\x74\x4b\x9f\xd0\x5e\x04\x18\xa4\xec\+        \\xc2\xe0\x41\x6e\x0f\x51\xcb\xcc\x24\x91\xaf\x50\xa1\xf4\x70\x39\+        \\x99\x7c\x3a\x85\x23\xb8\xb4\x7a\xfc\x02\x36\x5b\x25\x55\x97\x31\+        \\x2d\x5d\xfa\x98\xe3\x8a\x92\xae\x05\xdf\x29\x10\x67\x6c\xba\xc9\+        \\xd3\x00\xe6\xcf\xe1\x9e\xa8\x2c\x63\x16\x01\x3f\x58\xe2\x89\xa9\+        \\x0d\x38\x34\x1b\xab\x33\xff\xb0\xbb\x48\x0c\x5f\xb9\xb1\xcd\x2e\+        \\xc5\xf3\xdb\x47\xe5\xa5\x9c\x77\x0a\xa6\x20\x68\xfe\x7f\xc1\xad"#+{-# NOINLINE piTable #-}

@@ -12,6 +12,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} module Crypto.Store.KeyWrap.AES+    {-# DEPRECATED "Will be removed in the next major release" #-}     ( wrap     , unwrap     , wrapPad

@@ -9,6 +9,7 @@ -- -- Should be used with a cipher from module "Crypto.Store.Cipher.RC2". module Crypto.Store.KeyWrap.RC2+    {-# DEPRECATED "Will be removed in the next major release" #-}     ( wrap     , wrap'     , unwrap

@@ -9,6 +9,7 @@ -- -- Should be used with a cipher from module "Crypto.Cipher.TripleDES". module Crypto.Store.KeyWrap.TripleDES+    {-# DEPRECATED "Will be removed in the next major release" #-}     ( wrap     , unwrap     ) where

@@ -66,6 +66,7 @@     , emptyNotTerminated     , fromProtectionPassword     , toProtectionPassword+    , passwordToString     , OptProtected(..)     , recover     , recoverA@@ -90,11 +91,12 @@  import Crypto.Store.ASN1.Generate import Crypto.Store.ASN1.Parse-import Crypto.Store.CMS import Crypto.Store.CMS.Algorithms import Crypto.Store.CMS.Attribute import Crypto.Store.CMS.Encrypted import Crypto.Store.CMS.Enveloped+import Crypto.Store.CMS.Info+import Crypto.Store.CMS.Type import Crypto.Store.CMS.Util import Crypto.Store.Error import Crypto.Store.Keys@@ -811,8 +813,6 @@         SamePassword $ Protected (\pwd -> f pwd <*> x pwd)  instance Monad SamePassword where-    return = pure-     SamePassword (Unprotected x)   >>= f = f x     SamePassword (Protected inner) >>= f =         SamePassword . Protected $ \pwd ->

@@ -15,6 +15,7 @@     , emptyNotTerminated     , fromProtectionPassword     , toProtectionPassword+    , passwordToString     , EncryptedContent     -- * High-level API     , PKCS5(..)@@ -27,11 +28,18 @@     -- * Message authentication schemes     , AuthenticationScheme(..)     , PBMAC1Parameter(..)+    -- * Hash functions+    , DigestProxy(..)+    , DigestAlgorithm(..)     -- * Key derivation     , KeyDerivationFunc(..)     , PBKDF2_PRF(..)     , Salt     , generateSalt+    -- * Content authentication+    , EncapsulatedContent+    , MessageAuthenticationCode+    , MACAlgorithm(..)     -- * Content encryption     , ContentEncryptionParams     , ContentEncryptionAlg(..)@@ -41,6 +49,7 @@     , generateRC2EncryptionParams     , generateCFBParams     , generateCTRParams+    , deriveEncryptionKey     , getContentEncryptionAlg     -- * Low-level API     , pbEncrypt

@@ -19,6 +19,7 @@     , fromProtectionPassword     , toProtectionPassword     , toProtectionPasswords+    , passwordToString     , pkcs5     , pkcs12     , pkcs12rc2@@ -27,11 +28,6 @@     , rc4Combine     ) where -import           Basement.Block (Block)-import           Basement.Compat.IsList-import           Basement.Endianness-import qualified Basement.String as S- import           Crypto.Cipher.Types import qualified Crypto.Cipher.RC4 as RC4 import qualified Crypto.Hash as Hash@@ -41,6 +37,8 @@ import           Data.ByteArray (ByteArray, ByteArrayAccess) import qualified Data.ByteArray as B import           Data.ByteString (ByteString)+import           Data.ByteString.Builder (Builder, toLazyByteString, word16BE)+import           Data.ByteString.Lazy (toStrict) import           Data.Maybe (fromMaybe) import           Data.Memory.PtrMethods import           Data.String (IsString(..))@@ -54,6 +52,7 @@ import Crypto.Store.CMS.Algorithms import Crypto.Store.CMS.Util import Crypto.Store.Error+import Crypto.Store.Utf8  -- | A password stored as a sequence of UTF-8 bytes. --@@ -78,7 +77,7 @@         showString "toProtectionPassword " . showsPrec 11 b  instance IsString ProtectionPassword where-    fromString = PasswordUTF8 . B.convert . S.toBytes S.UTF8 . fromString+    fromString = PasswordUTF8 . stringToUTF8  instance ByteArrayAccess ProtectionPassword where     length = applyPP 0 B.length@@ -113,6 +112,15 @@     | B.null bs = [PasswordUTF8 B.empty, NullPassword]     | otherwise = [PasswordUTF8 bs] +-- | Convert a password value to a Haskell string, or return 'Nothing' if the+-- input was not proper UTF-8.+passwordToString :: ProtectionPassword -> Maybe String+passwordToString NullPassword = Just ""+passwordToString (PasswordUTF8 bs)+    | B.null r  = Just p+    | otherwise = Nothing+  where (p, r) = stringFromUTF8 bs+ -- | Secret key. type Key = B.ScrubbedBytes @@ -151,21 +159,25 @@ rc4Combine :: (ByteArrayAccess key, ByteArray ba) => key -> ba -> Either StoreError ba rc4Combine key = Right . snd . RC4.combine (RC4.initialize key) --- | Conversion to UCS2 from UTF-8, ignoring non-BMP bits.-toUCS2 :: ByteArray bucs2 => ProtectionPassword -> Maybe bucs2-toUCS2 NullPassword = Just B.empty+-- | Conversion to UCS2 from UTF-8, failing for malformed input or code points+-- found outside the Basic Multilingual Plane.+toUCS2 :: ProtectionPassword -> Either String ByteString+toUCS2 NullPassword = Right B.empty toUCS2 (PasswordUTF8 pwdUTF8)-    | B.null r  = Just pwdUCS2-    | otherwise = Nothing+    | not (B.null r) = Left "Provided password is not valid UTF-8"+    | not (all bmp p) = Left "Password is not compatible with UCS-2"+    | otherwise = Right pwdUCS2   where-    (p, _, r) = S.fromBytes S.UTF8 $ B.snoc (B.convert pwdUTF8) 0-    pwdBlock  = fromList $ map ucs2 $ toList p :: Block (BE Word16)-    pwdUCS2   = B.convert pwdBlock+    (p, r)    = stringFromUTF8 (B.snoc pwdUTF8 0)+    pwdUCS2   = toStrict $ toLazyByteString (foldMap ucs2 p) -    ucs2 :: Char -> BE Word16-    ucs2 = toBE . toEnum . fromEnum+    bmp :: Char -> Bool+    bmp c = c < '\x10000' +    ucs2 :: Char -> Builder+    ucs2 = word16BE . toEnum . fromEnum + -- PBES1, RFC 8018 section 6.1.2  -- | Apply PBKDF1 on the specified password and run an encryption or decryption@@ -221,8 +233,8 @@        -> result pkcs12 failure encdec hashAlg cec pbeParam bs pwdUTF8 =     case toUCS2 pwdUTF8 of-        Nothing      -> failure passwordNotUTF8-        Just pwdUCS2 ->+        Left msg      -> failure (InvalidPassword msg)+        Right pwdUCS2 ->             let ivLen   = proxyBlockSize cec                 iv      = pkcs12Derive hashAlg pbeParam 2 pwdUCS2 ivLen :: B.Bytes                 eScheme = cbcWith cec iv@@ -244,8 +256,8 @@           -> result pkcs12rc2 failure encdec hashAlg len pbeParam bs pwdUTF8 =     case toUCS2 pwdUTF8 of-        Nothing      -> failure passwordNotUTF8-        Just pwdUCS2 ->+        Left msg      -> failure (InvalidPassword msg)+        Right pwdUCS2 ->             let ivLen   = 8                 iv      = pkcs12Derive hashAlg pbeParam 2 pwdUCS2 ivLen :: B.Bytes                 eScheme = rc2cbcWith len iv@@ -267,8 +279,8 @@              -> result pkcs12stream failure encdec hashAlg keyLen pbeParam bs pwdUTF8 =     case toUCS2 pwdUTF8 of-        Nothing      -> failure passwordNotUTF8-        Just pwdUCS2 ->+        Left msg      -> failure (InvalidPassword msg)+        Right pwdUCS2 ->             let key = pkcs12Derive hashAlg pbeParam 1 pwdUCS2 keyLen :: Key              in encdec key bs @@ -284,15 +296,12 @@           -> result pkcs12mac failure macFn hashAlg pbeParam bs pwdUTF8 =     case toUCS2 pwdUTF8 of-        Nothing      -> failure passwordNotUTF8-        Just pwdUCS2 ->+        Left msg      -> failure (InvalidPassword msg)+        Right pwdUCS2 ->             let macAlg = HMAC hashAlg                 keyLen = getMaximumKeySize macAlg                 key    = pkcs12Derive hashAlg pbeParam 3 pwdUCS2 keyLen :: Key             in macFn key macAlg bs--passwordNotUTF8 :: StoreError-passwordNotUTF8 = InvalidPassword "Provided password is not valid UTF-8"  pkcs12Derive :: (Hash.HashAlgorithm hash, ByteArray bout)              => DigestProxy hash

@@ -49,6 +49,7 @@     , emptyNotTerminated     , fromProtectionPassword     , toProtectionPassword+    , passwordToString     , OptProtected(..)     , recover     , recoverA

@@ -12,6 +12,7 @@     , curveOrderBytes     , curveNameOID     , getSerializedPoint+    , isBasePointMultiple     , module Data.X509.EC     ) where @@ -50,6 +51,13 @@      serializePoint PointO      = B.singleton 0     serializePoint (Point x y) = B.cons 4 (B.append (bs x) (bs y))++-- | Return 'True' when a curve point is in the subgroup generated by the base+-- point.  The input must have been validated first with 'isPointValid'.+isBasePointMultiple :: Curve -> Point -> Bool+isBasePointMultiple curve pt =+    let cc = common_curve curve+     in ecc_h cc == 1 || isPointAtInfinity (pointMul curve (ecc_n cc) pt)  -- | Return the OID associated to a curve name. curveNameOID :: CurveName -> OID

@@ -0,0 +1,104 @@+-- |+-- Module      : Crypto.Store.Utf8+-- License     : BSD-style+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>+-- Stability   : experimental+-- Portability : unknown+--+-- UTF-8 encoding and decoding.  This implementation preserves surrogates and+-- does not use the replacement character.+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+module Crypto.Store.Utf8+    ( stringFromUTF8, stringToUTF8+    ) where++import           Data.Bits+import           Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import           Data.Char (chr, ord)+import           Data.Word++-- | Convert a string to UTF-8 encoding.+stringToUTF8 :: String -> ByteString+stringToUTF8 = B.pack . foldr charToUtf8 []++charToUtf8 :: Char -> [Word8] -> [Word8]+charToUtf8 c list+    | x < 0x80     = encode1+    | x < 0x800    = encode2+    | x < 0x10000  = encode3+    | x < 0x110000 = encode4+    | otherwise    = error ("charToUtf8: invalid code point: " ++ show x)+  where+    !x = fromIntegral (ord c) :: Word++    encode1 = fromIntegral x : list+    encode2 =+        let !x1 = fromIntegral (unsafeShiftR x 6 .|. 0xc0)+            !x2 = toC x+         in x1 : x2 : list+    encode3 =+        let !x1 = fromIntegral (unsafeShiftR x 12 .|. 0xe0)+            !x2 = toC (unsafeShiftR x 6)+            !x3 = toC x+         in x1 : x2 : x3 : list+    encode4 =+        let !x1 = fromIntegral (unsafeShiftR x 18 .|. 0xf0)+            !x2 = toC (unsafeShiftR x 12)+            !x3 = toC (unsafeShiftR x 6)+            !x4 = toC x+         in x1 : x2 : x3 : x4 : list++    toC :: Word -> Word8+    toC w = fromIntegral ((w .&. 0x3f) .|. 0x80)++-- | Convert a string from UTF-8 encoding.  When not fully valid, also return+-- the bytes that have not been converted.+stringFromUTF8 :: ByteString -> (String, ByteString)+stringFromUTF8 bs = go id 0+  where+    len = B.length bs++    go :: (String -> String) -> Int -> (String, ByteString)+    go f i+        | remaining < 1 = (f "", B.empty)+        | x1 < 0x80 =+            let w = fromIntegral x1+             in next w f (i + 1)+        | remaining < 2 || invalid x2 = end f i+        | x1 >= 0xc0 && x1 < 0xe0 =+            let w = unsafeShiftL (fromIntegral x1 .&. 0x1f) 6 .|.+                    (fromIntegral x2 .&. 0x3f)+             in next w f (i + 2)+        | remaining < 3 || invalid x3 = end f i+        | x1 >= 0xe0 && x1 < 0xf0 =+            let w = unsafeShiftL (fromIntegral x1 .&. 0x0f) 12 .|.+                    unsafeShiftL (fromIntegral x2 .&. 0x3f)  6 .|.+                    (fromIntegral x3 .&. 0x3f)+             in next w f (i + 3)+        | remaining < 4 || invalid x4 = end f i+        | x1 >= 0xf0 && x1 < 0xf8 =+            let w = unsafeShiftL (fromIntegral x1 .&. 0x07) 18 .|.+                    unsafeShiftL (fromIntegral x2 .&. 0x3f) 12 .|.+                    unsafeShiftL (fromIntegral x3 .&. 0x3f)  6 .|.+                    (fromIntegral x4 .&. 0x3f)+             in next w f (i + 4)+        | otherwise = end f i++      where+        remaining = len - i+        x1 = B.unsafeIndex bs i+        x2 = B.unsafeIndex bs (i + 1)+        x3 = B.unsafeIndex bs (i + 2)+        x4 = B.unsafeIndex bs (i + 3)++    end :: (String -> String) -> Int -> (String, ByteString)+    end f !i = (f "", B.drop i bs)++    next :: Word -> (String -> String) -> Int -> (String, ByteString)+    next w f i = let !c = chr (fromIntegral w) in go (f . (c :)) i++    invalid :: Word8 -> Bool+    invalid x = x < 0x80 || x >= 0xc0

@@ -39,7 +39,9 @@  -- | Reverse a bytearray. reverseBytes :: ByteArray ba => ba -> ba-#if MIN_VERSION_memory(0,14,18)+#ifdef VERSION_ram+reverseBytes = B.reverse+#elif MIN_VERSION_memory(0,14,18) reverseBytes = B.reverse #else reverseBytes = B.pack . reverse . B.unpack

@@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-orphans -Wno-deprecations #-} -- | Orphan instances. module CMS.Instances     ( arbitraryPassword

@@ -1,5 +1,5 @@ -- | CMS tests.-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-deprecations #-} module CMS.Tests (cmsTests) where  import Control.Monad

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | Test vectors from RFC 3394 and RFC 5649. module KeyWrap.AES (aeskwTests) where 

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | Test vectors from RFC 3217. module KeyWrap.RC2 (rc2kwTests) where 

@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-deprecations #-} -- | Test vectors from RFC 3217. module KeyWrap.TripleDES (tripledeskwTests) where 

@@ -7,6 +7,7 @@ import KeyWrap.TripleDES import KeyWrap.RC2 import Cipher.RC2+import Password import CMS.Tests import PKCS12.Tests import PKCS8.Tests@@ -21,6 +22,7 @@     , rc2Tests     , cmsTests     , x509Tests+    , pwdTests     , pkcs8Tests     , pkcs12Tests     ]

@@ -17,7 +17,6 @@  import Test.Tasty.QuickCheck -import Crypto.Store.CMS import Crypto.Store.PKCS12 import Crypto.Store.PKCS5 

@@ -9,7 +9,6 @@  import Test.Tasty.QuickCheck -import Crypto.Store.CMS import Crypto.Store.PKCS5 import Crypto.Store.PKCS8 

@@ -0,0 +1,39 @@+-- | Password tests.+module Password (pwdTests) where++import qualified Data.ByteString as B+import           Data.String (fromString)++import Crypto.Store.PKCS5++import Test.Tasty+import Test.Tasty.QuickCheck++arbitraryUnicode :: Gen String+arbitraryUnicode = listOf $ oneof+    [ choose ('\x0', '\x7f')+    , choose ('\x80', '\x7ff')+    , choose ('\x800', '\xffff')+    , choose ('\x10000', '\x10ffff')+    ]++pwdTests :: TestTree+pwdTests = testGroup "PKCS5.properties"+    [ testProperty "converting unicode passwords" $ do+        chars <- arbitraryUnicode+        return $ Just chars === passwordToString (fromString chars)+    , testProperty "detecting invalid sequences" $ do+        prefix <- fromProtectionPassword . fromString <$> arbitraryUnicode+        suffix <- fromProtectionPassword . fromString <$> arbitraryUnicode+        bad <- elements [ B.pack [ 0x82 ]+                        , B.pack [ 0xc2, 0x0c ]+                        , B.pack [ 0xe2, 0x0c, 0x82 ]+                        , B.pack [ 0xe2, 0x82, 0x0c ]+                        , B.pack [ 0xf2, 0x0c, 0x82, 0x82 ]+                        , B.pack [ 0xf2, 0x82, 0x0c, 0x82 ]+                        , B.pack [ 0xf2, 0x82, 0x82, 0x0c ]+                        , B.pack [ 0xfa, 0x82, 0x82, 0x82 ]+                        ]+        let invalid = toProtectionPassword $ B.concat [prefix, bad, suffix]+        return $ Nothing === passwordToString invalid+    ]

@@ -1,8 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Test utilities. module Util-    ( assertJust-    , assertLeft+    ( assertLeft     , assertRight     , getAttached     , getDetached@@ -21,10 +20,6 @@  import Test.Tasty.HUnit import Test.Tasty.QuickCheck--assertJust :: Maybe a -> (a -> Assertion) -> Assertion-assertJust (Just a) f = f a-assertJust Nothing  _ = assertFailure "expecting Just but got Nothing"  assertLeft :: Show b => Either a b -> (a -> Assertion) -> Assertion assertLeft (Left a)  f = f a