File: Test.hs

package info (click to toggle)
haskell-rsa 1.2.2.0-3
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 88 kB
  • sloc: haskell: 638; makefile: 2
file content (229 lines) | stat: -rw-r--r-- 8,029 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
{-# LANGUAGE FlexibleInstances #-}
import Codec.Crypto.RSA
import Control.Monad
import Data.ByteString(pack)
import Data.ByteString.Lazy(ByteString)
import qualified Data.ByteString.Lazy as BS
import Data.Digest.Pure.SHA
import Data.Tagged
import Test.QuickCheck
import Crypto.Random
import Crypto.Random.DRBG
import Crypto.Types
import Crypto.Types.PubKey.RSA

import Test.Framework (defaultMain, testGroup, Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)

-- --------------------------------------------------------------------------

buildGen :: Gen (GenAutoReseed HashDRBG HashDRBG)
buildGen = do
  let len = genSeedLength :: Tagged (GenAutoReseed HashDRBG HashDRBG) ByteLength
  bytes <- pack `fmap` replicateM (unTagged len) arbitrary
  let Right seed = newGen bytes
  return seed

instance Show (GenAutoReseed HashDRBG HashDRBG) where
  show _ = "<randomGen>"

instance Arbitrary (GenAutoReseed HashDRBG HashDRBG) where
  arbitrary = buildGen

-- --------------------------------------------------------------------------

data KeyPair     = KP1K PublicKey PrivateKey
 deriving (Show)

data KeyPair2048 = KP2K PublicKey PrivateKey
 deriving (Show)

instance Arbitrary KeyPair where
  arbitrary   = do g <- buildGen
                   let (pub, priv, _) = generateKeyPair g 1024
                   return $ KP1K pub priv

instance Arbitrary KeyPair2048 where
  arbitrary   = do g <- buildGen
                   let (pub, priv, _) = generateKeyPair g 2048
                   return $ KP2K pub priv

-- --------------------------------------------------------------------------

newtype LargePrime = LP Integer

instance Show LargePrime where
  show (LP x) = show x

instance Arbitrary LargePrime where
  arbitrary   = do g <- buildGen
                   let (res, _) = large_random_prime g 64
                   return (LP res)

-- --------------------------------------------------------------------------

newtype PositiveInteger = PI Integer

instance Show PositiveInteger where
  show (PI x) = show x

instance Arbitrary PositiveInteger where
  arbitrary   = (PI . (+1) . abs) `fmap` arbitrary

-- --------------------------------------------------------------------------

newtype NonEmptyByteString = NEBS ByteString

instance Show NonEmptyByteString where
  show (NEBS x) = show x

instance Arbitrary ByteString where
  arbitrary   = BS.pack `fmap` arbitrary

instance Arbitrary NonEmptyByteString where
  arbitrary   = (NEBS . BS.pack) `fmap` (return(:)`ap`arbitrary`ap`arbitrary)

-- --------------------------------------------------------------------------

instance Arbitrary EncryptionOptions where
  arbitrary   = arbitrary >>= \ lbl -> elements [
                  UsePKCS1_v1_5
                , UseOAEP sha1'   (generate_MGF1 sha1') lbl
                , UseOAEP sha256' (generate_MGF1 sha256') lbl
                , UseOAEP sha384' (generate_MGF1 sha384') lbl
                , UseOAEP sha512' (generate_MGF1 sha512') lbl
                ]
   where
    sha1'   = bytestringDigest . sha1
    sha256' = bytestringDigest . sha256
    sha384' = bytestringDigest . sha384
    sha512' = bytestringDigest . sha512

instance Show HashInfo where
  show h = "<hash: len=" ++ (show $ BS.length $ hashFunction h BS.empty) ++ ">"

instance Arbitrary HashInfo where
  arbitrary   = elements [ha_SHA1, ha_SHA256, ha_SHA384, ha_SHA512]

-- --------------------------------------------------------------------------

prop_chunkify_works :: NonEmptyByteString -> PositiveInteger -> Bool
prop_chunkify_works (NEBS x) (PI l) =
  all (\ bs -> BS.length bs <= (fromIntegral l)) (chunkify (fromIntegral l) x)

prop_mod_exp_works :: PositiveInteger -> PositiveInteger -> PositiveInteger ->
                      Bool
prop_mod_exp_works (PI b) (PI e) (PI m) =
  ((b ^ e) `mod` m) == (modular_exponentiation b e m)

prop_mod_inv_works :: LargePrime -> LargePrime -> Bool
prop_mod_inv_works (LP p) (LP q) = (e * d) `mod` phi == 1
 where 
  e   = 65537
  phi = (p - 1) * (q - 1)
  d   = modular_inverse e phi

-- --------------------------------------------------------------------------

prop_i2o2i_identity :: PositiveInteger -> Bool
prop_i2o2i_identity (PI x) = x == (os2ip $ i2osp x 16)

prop_o2i2o_identity :: NonEmptyByteString -> Bool
prop_o2i2o_identity (NEBS x) = x == (i2osp (os2ip x) (fromIntegral $ BS.length x))

prop_ep_dp_identity :: KeyPair -> PositiveInteger -> Bool
prop_ep_dp_identity (KP1K pub priv) (PI x) = m == m'
 where
  n  = public_n pub
  e  = public_e pub
  d  = private_d priv
  m  = x `mod` n
  m' = rsa_dp n d $ rsa_ep n e m

prop_sp_vp_identity :: KeyPair -> PositiveInteger -> Bool
prop_sp_vp_identity (KP1K pub priv) (PI x) = m == m'
 where
  n  = public_n pub
  e  = public_e pub
  d  = private_d priv
  m  = x `mod` n
  m' = rsa_vp1 n e $ rsa_sp1 n d m

-- --------------------------------------------------------------------------

prop_oaep_inverts :: GenAutoReseed HashDRBG HashDRBG ->
                     HashInfo -> KeyPair2048 -> PositiveInteger ->
                     ByteString -> NonEmptyByteString -> 
                     Bool
prop_oaep_inverts g hi (KP2K pub priv) (PI seed) l (NEBS x) = m == m'
 where
  hash  = hashFunction hi
  kLen  = public_size pub
  hLen  = BS.length $ hash BS.empty
  mgf   = generate_MGF1 hash
  m     = BS.take (fromIntegral kLen - (2 * hLen) - 2) x
  (c,_) = rsaes_oaep_encrypt g hash mgf pub  l m
  m'    = rsaes_oaep_decrypt   hash mgf priv l c

prop_pkcs_inverts :: CryptoRandomGen g => g -> KeyPair -> NonEmptyByteString -> Bool
prop_pkcs_inverts g (KP1K pub priv) (NEBS x) = m == m'
 where
  kLen  = fromIntegral $ public_size pub
  m     = BS.take (kLen - 11) x
  (c,_) = rsaes_pkcs1_v1_5_encrypt g pub  m
  m'    = rsaes_pkcs1_v1_5_decrypt   priv c

prop_sign_works :: HashInfo -> KeyPair -> NonEmptyByteString -> Bool
prop_sign_works hi (KP1K pub priv) (NEBS m) = 
  rsassa_pkcs1_v1_5_verify hi pub m $ rsassa_pkcs1_v1_5_sign hi priv m

-- --------------------------------------------------------------------------

prop_encrypt_inverts :: CryptoRandomGen g => 
                        g -> KeyPair2048 -> NonEmptyByteString -> 
                        Bool
prop_encrypt_inverts g (KP2K pub priv) (NEBS m) =
  m == decrypt priv (fst $ encrypt g pub m)

prop_encrypt_plus_inverts :: CryptoRandomGen g =>
                             g -> EncryptionOptions -> KeyPair2048 -> 
                             NonEmptyByteString ->
                             Bool
prop_encrypt_plus_inverts g opts (KP2K pub priv) (NEBS m) =
  m == decrypt' opts priv (fst $ encrypt' opts g pub m)

-- --------------------------------------------------------------------------

main :: IO ()
main = do
  putStrLn "\nWARNING WARNING WARNING"
  putStrLn "This test suite takes a very long time to run. If you're in a "
  putStrLn "hurry, Control-C is your friend."
  putStrLn "WARNING WARNING WARNING\n"

  g <- newGenIO :: IO SystemRandom
  defaultMain $ tests g

tests :: SystemRandom -> [Test]
tests g = [
  testGroup "Testing basic helper functions" [
     testProperty "prop_chunkify_works"         prop_chunkify_works,
     testProperty "prop_mod_exp_works"          prop_mod_exp_works,
     testProperty "prop_mod_inv_works"          prop_mod_inv_works
     ],
  testGroup "Testing RSA core functions" [
    testProperty "prop_i2o2i_identity"         prop_i2o2i_identity,
    testProperty "prop_o2i2o_identity"         prop_o2i2o_identity,
    testProperty "prop_ep_dp_identity"         prop_ep_dp_identity,
    testProperty "prop_sp_vp_identity"         prop_sp_vp_identity
    ],
  testGroup "Testing fixed-width RSA padding functions" [
    testProperty "prop_oaep_inverts"           prop_oaep_inverts,
    testProperty "prop_pkcs_inverts"         $ prop_pkcs_inverts g,
    testProperty "prop_sign_works"             prop_sign_works
    ],
  testGroup "Testing top-level functions" [
    testProperty "prop_encrypt_inverts"      $ prop_encrypt_inverts      g,
    testProperty "prop_encrypt_plus_inverts" $ prop_encrypt_plus_inverts g
    ]
  ]