mirror of https://github.com/voidlizard/hbs2
117 lines
4.2 KiB
Haskell
117 lines
4.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module SecretBoxProperties (
|
|
testSecretBox
|
|
) where
|
|
|
|
import Util
|
|
import Crypto.Saltine.Core.SecretBox
|
|
import Crypto.Saltine.Class
|
|
import Crypto.Saltine.Internal.SecretBox as Internal
|
|
|
|
import qualified Data.ByteString as S
|
|
import Data.Maybe (fromJust)
|
|
import Test.Framework.Providers.QuickCheck2
|
|
import Test.Framework
|
|
import Test.QuickCheck (Property, (==>))
|
|
import Test.QuickCheck.Arbitrary
|
|
|
|
instance Arbitrary Nonce where
|
|
arbitrary =
|
|
do bs <- S.pack <$> vector Internal.secretbox_noncebytes
|
|
pure $ fromJust (decode bs)
|
|
|
|
instance Arbitrary Key where
|
|
arbitrary =
|
|
do bs <- S.pack <$> vector Internal.secretbox_keybytes
|
|
pure $ fromJust (decode bs)
|
|
|
|
-- | Ciphertext can be decrypted
|
|
rightInverseProp :: Key -> Nonce -> Message -> Bool
|
|
rightInverseProp k n (Message bs) =
|
|
Just bs == secretboxOpen k n (secretbox k n bs)
|
|
|
|
-- | Detached ciphertext/tag can be decrypted
|
|
rightInverseDetachedProp :: Key -> Nonce -> Message -> Bool
|
|
rightInverseDetachedProp k n (Message bs) =
|
|
Just bs == uncurry (secretboxOpenDetached k n) (secretboxDetached k n bs)
|
|
|
|
-- | Ciphertext cannot be decrypted if the ciphertext is perturbed
|
|
rightInverseFailureProp :: Key -> Nonce -> Message -> Perturb -> Property
|
|
rightInverseFailureProp k n (Message bs) p =
|
|
let ct = secretbox k n bs
|
|
fakeCT = perturb ct p
|
|
in ct /= fakeCT ==> Nothing == secretboxOpen k n fakeCT
|
|
|
|
-- | Ciphertext cannot be decrypted if the tag is perturbed
|
|
rightInverseTagFailureProp :: Key -> Nonce -> Message -> Message -> Property
|
|
rightInverseTagFailureProp k n (Message bs) (Message fakeTagBs) =
|
|
let (realTag, ct) = secretboxDetached k n bs
|
|
fakeTag = Internal.Au fakeTagBs
|
|
in realTag /= fakeTag ==> Nothing == secretboxOpenDetached k n fakeTag ct
|
|
|
|
-- | Ciphertext cannot be decrypted if the ciphertext is perturbed
|
|
rightInverseFailureDetachedProp :: Key -> Nonce -> Message -> Perturb -> Property
|
|
rightInverseFailureDetachedProp k n (Message bs) p =
|
|
let (tag,ct) = secretboxDetached k n bs
|
|
fakeCT = perturb ct p
|
|
in fakeCT /= ct ==> Nothing == secretboxOpenDetached k n tag fakeCT
|
|
|
|
-- | Ciphertext cannot be decrypted with a different key
|
|
cannotDecryptKeyProp :: Key -> Key -> Nonce -> Message -> Property
|
|
cannotDecryptKeyProp k1 k2 n (Message bs) =
|
|
k1 /= k2 ==> Nothing == secretboxOpen k2 n (secretbox k1 n bs)
|
|
|
|
-- | Ciphertext cannot be decrypted with a different key
|
|
cannotDecryptKeyDetachedProp :: Key -> Key -> Nonce -> Message -> Property
|
|
cannotDecryptKeyDetachedProp k1 k2 n (Message bs) =
|
|
k1 /= k2 ==> Nothing == uncurry (secretboxOpenDetached k2 n) (secretboxDetached k1 n bs)
|
|
|
|
-- | Ciphertext cannot be decrypted with a different nonce
|
|
cannotDecryptNonceProp :: Key -> Nonce -> Nonce -> Message -> Property
|
|
cannotDecryptNonceProp k n1 n2 (Message bs) =
|
|
n1 /= n2 ==> Nothing == secretboxOpen k n2 (secretbox k n1 bs)
|
|
|
|
-- | Ciphertext cannot be decrypted with a different nonce
|
|
cannotDecryptNonceDetachedProp :: Key -> Nonce -> Nonce -> Message -> Property
|
|
cannotDecryptNonceDetachedProp k n1 n2 (Message bs) =
|
|
n1 /= n2 ==> Nothing == uncurry (secretboxOpenDetached k n2) (secretboxDetached k n1 bs)
|
|
|
|
testSecretBox :: Test
|
|
testSecretBox = buildTest $ do
|
|
|
|
return $ testGroup "...Internal.SecretBox" [
|
|
|
|
testProperty "Can decrypt ciphertext"
|
|
$ rightInverseProp,
|
|
|
|
testProperty "Can decrypt ciphertext (detached)"
|
|
$ rightInverseDetachedProp,
|
|
|
|
testGroup "Cannot decrypt ciphertext when..." [
|
|
|
|
testProperty "... ciphertext is perturbed"
|
|
$ rightInverseFailureProp,
|
|
|
|
testProperty "... ciphertext is perturbed (detached)"
|
|
$ rightInverseFailureDetachedProp,
|
|
|
|
testProperty "... tag is perturbed (detached)"
|
|
$ rightInverseTagFailureProp,
|
|
|
|
testProperty "... using the wrong key"
|
|
$ cannotDecryptKeyProp,
|
|
|
|
testProperty "... using the wrong key (detached)"
|
|
$ cannotDecryptKeyDetachedProp,
|
|
|
|
testProperty "... using the wrong nonce"
|
|
$ cannotDecryptNonceProp,
|
|
|
|
testProperty "... using the wrong nonce (detached"
|
|
$ cannotDecryptNonceDetachedProp
|
|
|
|
]
|
|
]
|