forked from depressed-pho/HsOpenSSL
/
DSA.hsc
365 lines (311 loc) · 13 KB
/
DSA.hsc
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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
{- -*- haskell -*- -}
{-# OPTIONS_HADDOCK prune #-}
-- | The Digital Signature Algorithm (FIPS 186-2).
-- See <http://www.openssl.org/docs/crypto/dsa.html>
#include "HsOpenSSL.h"
module OpenSSL.DSA
( -- * Type
DSAKey(..)
, DSAPubKey
, DSAKeyPair
, DSA -- private
-- * Key and parameter generation
, generateDSAParameters
, generateDSAKey
, generateDSAParametersAndKey
-- * Signing and verification
, signDigestedDataWithDSA
, verifyDigestedDataWithDSA
-- * Extracting fields of DSA objects
, dsaPrivate
, dsaPubKeyToTuple
, dsaKeyPairToTuple
, tupleToDSAPubKey
, tupleToDSAKeyPair
) where
import Control.Monad
import qualified Data.ByteString as BS
import Data.Typeable
import Foreign
import Foreign.C (CString)
import Foreign.C.Types
import OpenSSL.BN
import OpenSSL.Utils
#if !(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612)
import System.IO.Unsafe
#endif
-- | The type of a DSA public key, includes parameters p, q, g and public.
newtype DSAPubKey = DSAPubKey (ForeignPtr DSA)
deriving Typeable
-- | The type of a DSA keypair, includes parameters p, q, g, public and private.
newtype DSAKeyPair = DSAKeyPair (ForeignPtr DSA)
deriving Typeable
-- DSAPubKey and DSAKeyPair are in fact the same type at the OpenSSL
-- level, but we want to treat them differently for type-safety.
data DSA
-- |@'DSAKey' a@ is either 'DSAPubKey' or 'DSAKeyPair'.
class DSAKey k where
-- |Return the length of key.
dsaSize :: k -> Int
dsaSize dsa
= unsafePerformIO $
withDSAPtr dsa $ \ dsaPtr ->
fmap fromIntegral (_size dsaPtr)
-- |Return the public prime number of the key.
dsaP :: k -> Integer
dsaP = peekI (#peek DSA, p)
-- |Return the public 160-bit subprime, @q | p - 1@ of the key.
dsaQ :: k -> Integer
dsaQ = peekI (#peek DSA, q)
-- |Return the public generator of subgroup of the key.
dsaG :: k -> Integer
dsaG = peekI (#peek DSA, g)
-- |Return the public key @y = g^x@.
dsaPublic :: k -> Integer
dsaPublic = peekI (#peek DSA, pub_key)
-- private
withDSAPtr :: k -> (Ptr DSA -> IO a) -> IO a
peekDSAPtr :: Ptr DSA -> IO (Maybe k)
absorbDSAPtr :: Ptr DSA -> IO (Maybe k)
instance DSAKey DSAPubKey where
withDSAPtr (DSAPubKey fp) = withForeignPtr fp
peekDSAPtr dsaPtr = _pubDup dsaPtr >>= absorbDSAPtr
absorbDSAPtr dsaPtr = fmap (Just . DSAPubKey) (newForeignPtr _free dsaPtr)
instance DSAKey DSAKeyPair where
withDSAPtr (DSAKeyPair fp) = withForeignPtr fp
peekDSAPtr dsaPtr
= do hasP <- hasDSAPrivateKey dsaPtr
if hasP then
_privDup dsaPtr >>= absorbDSAPtr
else
return Nothing
absorbDSAPtr dsaPtr
= do hasP <- hasDSAPrivateKey dsaPtr
if hasP then
fmap (Just . DSAKeyPair) (newForeignPtr _free dsaPtr)
else
return Nothing
hasDSAPrivateKey :: Ptr DSA -> IO Bool
hasDSAPrivateKey dsaPtr
= fmap (/= nullPtr) ((#peek DSA, priv_key) dsaPtr)
foreign import ccall unsafe "&DSA_free"
_free :: FunPtr (Ptr DSA -> IO ())
foreign import ccall unsafe "DSA_free"
dsa_free :: Ptr DSA -> IO ()
foreign import ccall unsafe "BN_free"
_bn_free :: Ptr BIGNUM -> IO ()
foreign import ccall unsafe "DSA_new"
_dsa_new :: IO (Ptr DSA)
foreign import ccall unsafe "DSA_generate_key"
_dsa_generate_key :: Ptr DSA -> IO ()
foreign import ccall unsafe "HsOpenSSL_dsa_sign"
_dsa_sign :: Ptr DSA -> CString -> CInt -> Ptr (Ptr BIGNUM) -> Ptr (Ptr BIGNUM) -> IO CInt
foreign import ccall unsafe "HsOpenSSL_dsa_verify"
_dsa_verify :: Ptr DSA -> CString -> CInt -> Ptr BIGNUM -> Ptr BIGNUM -> IO CInt
foreign import ccall safe "DSA_generate_parameters"
_generate_params :: CInt -> Ptr CChar -> CInt -> Ptr CInt -> Ptr CInt -> Ptr () -> Ptr () -> IO (Ptr DSA)
foreign import ccall unsafe "HsOpenSSL_DSAPublicKey_dup"
_pubDup :: Ptr DSA -> IO (Ptr DSA)
foreign import ccall unsafe "HsOpenSSL_DSAPrivateKey_dup"
_privDup :: Ptr DSA -> IO (Ptr DSA)
foreign import ccall unsafe "DSA_size"
_size :: Ptr DSA -> IO CInt
peekI :: DSAKey k => (Ptr DSA -> IO (Ptr BIGNUM)) -> k -> Integer
peekI peeker dsa
= unsafePerformIO $
withDSAPtr dsa $ \ dsaPtr ->
do bn <- peeker dsaPtr
when (bn == nullPtr) $ fail "peekI: got a nullPtr"
peekBN (wrapBN bn)
-- | Generate DSA parameters (*not* a key, but required for a key). This is a
-- compute intensive operation. See FIPS 186-2, app 2. This agrees with the
-- test vectors given in FIP 186-2, app 5
generateDSAParameters :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024
-> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes
-> IO (Int, Int, Integer, Integer, Integer) -- ^ (iteration count, generator count, p, q, g)
generateDSAParameters nbits mseed = do
when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size"
alloca (\i1 ->
alloca (\i2 ->
(\x -> case mseed of
Nothing -> x (nullPtr, 0)
Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do
ptr <- _generate_params (fromIntegral nbits) seedptr (fromIntegral seedlen) i1 i2 nullPtr nullPtr
failIfNull_ ptr
itcount <- peek i1
gencount <- peek i2
p <- (#peek DSA, p) ptr >>= peekBN . wrapBN
q <- (#peek DSA, q) ptr >>= peekBN . wrapBN
g <- (#peek DSA, g) ptr >>= peekBN . wrapBN
dsa_free ptr
return (fromIntegral itcount, fromIntegral gencount, p, q, g))))
{-
-- | This function just runs the example DSA generation, as given in FIP 186-2,
-- app 5. The return values should be:
-- (105,
-- "8df2a494492276aa3d25759bb06869cbeac0d83afb8d0cf7cbb8324f0d7882e5d0762fc5b7210
-- eafc2e9adac32ab7aac49693dfbf83724c2ec0736ee31c80291",
-- "c773218c737ec8ee993b4f2ded30f48edace915f",
-- "626d027839ea0a13413163a55b4cb500299d5522956cefcb3bff10f399ce2c2e71cb9de5fa24
-- babf58e5b79521925c9cc42e9f6f464b088cc572af53e6d78802"), as given at the bottom of
-- page 21
test_generateParameters = do
let seed = BS.pack [0xd5, 0x01, 0x4e, 0x4b,
0x60, 0xef, 0x2b, 0xa8,
0xb6, 0x21, 0x1b, 0x40,
0x62, 0xba, 0x32, 0x24,
0xe0, 0x42, 0x7d, 0xd3]
(a, b, p, q, g) <- generateParameters 512 $ Just seed
return (a, toHex p, toHex q, g)
-}
-- | Generate a new DSA keypair, given valid parameters
generateDSAKey :: Integer -- ^ p
-> Integer -- ^ q
-> Integer -- ^ g
-> IO DSAKeyPair
generateDSAKey p q g = do
ptr <- _dsa_new
fmap unwrapBN (newBN p) >>= (#poke DSA, p) ptr
fmap unwrapBN (newBN q) >>= (#poke DSA, q) ptr
fmap unwrapBN (newBN g) >>= (#poke DSA, g) ptr
_dsa_generate_key ptr
fmap DSAKeyPair (newForeignPtr _free ptr)
-- |Return the private key @x@.
dsaPrivate :: DSAKeyPair -> Integer
dsaPrivate = peekI (#peek DSA, priv_key)
-- | Convert a DSAPubKey object to a tuple of its members in the
-- order p, q, g, and public.
dsaPubKeyToTuple :: DSAKeyPair -> (Integer, Integer, Integer, Integer)
dsaPubKeyToTuple dsa
= let p = peekI (#peek DSA, p) dsa
q = peekI (#peek DSA, q) dsa
g = peekI (#peek DSA, g) dsa
pub = peekI (#peek DSA, pub_key) dsa
in
(p, q, g, pub)
-- | Convert a DSAKeyPair object to a tuple of its members in the
-- order p, q, g, public and private.
dsaKeyPairToTuple :: DSAKeyPair -> (Integer, Integer, Integer, Integer, Integer)
dsaKeyPairToTuple dsa
= let p = peekI (#peek DSA, p) dsa
q = peekI (#peek DSA, q) dsa
g = peekI (#peek DSA, g) dsa
pub = peekI (#peek DSA, pub_key ) dsa
pri = peekI (#peek DSA, priv_key) dsa
in
(p, q, g, pub, pri)
-- | Convert a tuple of members (in the same format as from
-- 'dsaPubKeyToTuple') into a DSAPubKey object
tupleToDSAPubKey :: (Integer, Integer, Integer, Integer) -> DSAPubKey
tupleToDSAPubKey (p, q, g, pub) = unsafePerformIO $ do
ptr <- _dsa_new
fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr
fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr
fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr
fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key) ptr
(#poke DSA, priv_key) ptr nullPtr
fmap DSAPubKey (newForeignPtr _free ptr)
-- | Convert a tuple of members (in the same format as from
-- 'dsaPubKeyToTuple') into a DSAPubKey object
tupleToDSAKeyPair :: (Integer, Integer, Integer, Integer, Integer) -> DSAKeyPair
tupleToDSAKeyPair (p, q, g, pub, pri) = unsafePerformIO $ do
ptr <- _dsa_new
fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr
fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr
fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr
fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key ) ptr
fmap unwrapBN (newBN pri) >>= (#poke DSA, priv_key) ptr
fmap DSAKeyPair (newForeignPtr _free ptr)
-- | A utility function to generate both the parameters and the key pair at the
-- same time. Saves serialising and deserialising the parameters too
generateDSAParametersAndKey :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024
-> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes
-> IO DSAKeyPair
generateDSAParametersAndKey nbits mseed =
(\x -> case mseed of
Nothing -> x (nullPtr, 0)
Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do
ptr <- _generate_params (fromIntegral nbits) seedptr (fromIntegral seedlen) nullPtr nullPtr nullPtr nullPtr
failIfNull_ ptr
_dsa_generate_key ptr
fmap DSAKeyPair (newForeignPtr _free ptr))
-- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you
-- use anything else, YMMV. Returns a pair of Integers which, together, are
-- the signature
signDigestedDataWithDSA :: DSAKeyPair -> BS.ByteString -> IO (Integer, Integer)
signDigestedDataWithDSA dsa bytes =
BS.useAsCStringLen bytes (\(ptr, len) ->
alloca (\rptr ->
alloca (\sptr ->
withDSAPtr dsa (\dsaptr -> do
_dsa_sign dsaptr ptr (fromIntegral len) rptr sptr >>= failIf_ (== 0)
r <- peek rptr >>= peekBN . wrapBN
peek rptr >>= _bn_free
s <- peek sptr >>= peekBN . wrapBN
peek sptr >>= _bn_free
return (r, s)))))
-- | Verify pre-digested data given a signature.
verifyDigestedDataWithDSA :: DSAKey k => k -> BS.ByteString -> (Integer, Integer) -> IO Bool
verifyDigestedDataWithDSA dsa bytes (r, s) =
BS.useAsCStringLen bytes (\(ptr, len) ->
withBN r (\bnR ->
withBN s (\bnS ->
withDSAPtr dsa (\dsaptr ->
fmap (== 1)
(_dsa_verify dsaptr ptr (fromIntegral len) (unwrapBN bnR) (unwrapBN bnS))))))
instance Eq DSAPubKey where
a == b
= dsaP a == dsaP b &&
dsaQ a == dsaQ b &&
dsaG a == dsaG b &&
dsaPublic a == dsaPublic b
instance Eq DSAKeyPair where
a == b
= dsaP a == dsaP b &&
dsaQ a == dsaQ b &&
dsaG a == dsaG b &&
dsaPublic a == dsaPublic b &&
dsaPrivate a == dsaPrivate b
instance Ord DSAPubKey where
a `compare` b
| dsaP a < dsaP b = LT
| dsaP a > dsaP b = GT
| dsaQ a < dsaQ b = LT
| dsaQ a > dsaQ b = GT
| dsaG a < dsaG b = LT
| dsaG a > dsaG b = GT
| dsaPublic a < dsaPublic b = LT
| dsaPublic a > dsaPublic b = GT
| otherwise = EQ
instance Ord DSAKeyPair where
a `compare` b
| dsaP a < dsaP b = LT
| dsaP a > dsaP b = GT
| dsaQ a < dsaQ b = LT
| dsaQ a > dsaQ b = GT
| dsaG a < dsaG b = LT
| dsaG a > dsaG b = GT
| dsaPublic a < dsaPublic b = LT
| dsaPublic a > dsaPublic b = GT
| dsaPrivate a < dsaPrivate b = LT
| dsaPrivate a > dsaPrivate b = GT
| otherwise = EQ
instance Show DSAPubKey where
show a
= concat [ "DSAPubKey {"
, "dsaP = ", show (dsaP a), ", "
, "dsaQ = ", show (dsaQ a), ", "
, "dsaG = ", show (dsaG a), ", "
, "dsaPublic = ", show (dsaPublic a)
, "}"
]
instance Show DSAKeyPair where
show a
= concat [ "DSAPubKey {"
, "dsaP = ", show (dsaP a), ", "
, "dsaQ = ", show (dsaQ a), ", "
, "dsaG = ", show (dsaG a), ", "
, "dsaPublic = ", show (dsaPublic a), ", "
, "dsaPrivate = ", show (dsaPrivate a)
, "}"
]