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
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
|
{-# LANGUAGE CPP #-}
-- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880>
--
-- The recommended way to import this module is:
--
-- > import qualified Data.OpenPGP as OpenPGP
module Data.OpenPGP (
Packet(
OnePassSignaturePacket,
PublicKeyPacket,
SecretKeyPacket,
CompressedDataPacket,
LiteralDataPacket,
UserIDPacket,
UnsupportedPacket,
compression_algorithm,
content,
encrypted_data,
filename,
format,
hash_algorithm,
hashed_subpackets,
hash_head,
key,
key_algorithm,
key_id,
message,
nested,
private_hash,
s2k_count,
s2k_hash_algorithm,
s2k_salt,
s2k_type,
s2k_useage,
signature,
signature_type,
symmetric_type,
timestamp,
trailer,
unhashed_subpackets,
version
),
isSignaturePacket,
signaturePacket,
Message(..),
SignatureSubpacket(..),
HashAlgorithm(..),
KeyAlgorithm(..),
CompressionAlgorithm(..),
MPI(..),
find_key,
fingerprint_material,
signatures_and_data,
signature_issuer
) where
import Numeric
import Control.Monad
import Data.Bits
import Data.Word
import Data.Char
import Data.Maybe
import Data.OpenPGP.Internal
import qualified Data.ByteString.Lazy as LZ
#ifdef CEREAL
import Data.Serialize
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B (toString, fromString)
#define BINARY_CLASS Serialize
#else
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString)
#define BINARY_CLASS Binary
#endif
import qualified Codec.Compression.Zlib.Raw as Zip
import qualified Codec.Compression.Zlib as Zlib
import qualified Codec.Compression.BZip as BZip2
#ifdef CEREAL
getRemainingByteString :: Get B.ByteString
getRemainingByteString = remaining >>= getByteString
getSomeByteString :: Word64 -> Get B.ByteString
getSomeByteString = getByteString . fromIntegral
putSomeByteString :: B.ByteString -> Put
putSomeByteString = putByteString
unsafeRunGet :: Get a -> B.ByteString -> a
unsafeRunGet g bs = let Right v = runGet g bs in v
compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
compress algo = toStrictBS . lazyCompress algo . toLazyBS
decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
decompress algo = toStrictBS . lazyDecompress algo . toLazyBS
toStrictBS :: LZ.ByteString -> B.ByteString
toStrictBS = B.concat . LZ.toChunks
toLazyBS :: B.ByteString -> LZ.ByteString
toLazyBS = LZ.fromChunks . (:[])
#else
getRemainingByteString :: Get B.ByteString
getRemainingByteString = getRemainingLazyByteString
getSomeByteString :: Word64 -> Get B.ByteString
getSomeByteString = getLazyByteString . fromIntegral
putSomeByteString :: B.ByteString -> Put
putSomeByteString = putLazyByteString
unsafeRunGet :: Get a -> B.ByteString -> a
unsafeRunGet = runGet
compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
compress = lazyCompress
decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
decompress = lazyDecompress
#endif
lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString
lazyCompress Uncompressed = id
lazyCompress ZIP = Zip.compress
lazyCompress ZLIB = Zlib.compress
lazyCompress BZip2 = BZip2.compress
lazyCompress x = error ("No implementation for " ++ show x)
lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString
lazyDecompress Uncompressed = id
lazyDecompress ZIP = Zip.decompress
lazyDecompress ZLIB = Zlib.decompress
lazyDecompress BZip2 = BZip2.decompress
lazyDecompress x = error ("No implementation for " ++ show x)
data Packet =
SignaturePacket {
version::Word8,
signature_type::Word8,
key_algorithm::KeyAlgorithm,
hash_algorithm::HashAlgorithm,
hashed_subpackets::[SignatureSubpacket],
unhashed_subpackets::[SignatureSubpacket],
hash_head::Word16,
signature::[MPI],
trailer::B.ByteString
} |
OnePassSignaturePacket {
version::Word8,
signature_type::Word8,
hash_algorithm::HashAlgorithm,
key_algorithm::KeyAlgorithm,
key_id::String,
nested::Word8
} |
PublicKeyPacket {
version::Word8,
timestamp::Word32,
key_algorithm::KeyAlgorithm,
key::[(Char,MPI)]
} |
SecretKeyPacket {
version::Word8,
timestamp::Word32,
key_algorithm::KeyAlgorithm,
key::[(Char,MPI)],
s2k_useage::Word8, -- determines if the Maybes are Just or Nothing
symmetric_type::Maybe Word8,
s2k_type::Maybe Word8,
s2k_hash_algorithm::Maybe HashAlgorithm,
s2k_salt::Maybe Word64,
s2k_count::Maybe Word32,
encrypted_data::B.ByteString,
private_hash::Maybe B.ByteString -- the hash may be in the encrypted data
} |
CompressedDataPacket {
compression_algorithm::CompressionAlgorithm,
message::Message
} |
LiteralDataPacket {
format::Char,
filename::String,
timestamp::Word32,
content::B.ByteString
} |
UserIDPacket String |
UnsupportedPacket Word8 B.ByteString
deriving (Show, Read, Eq)
instance BINARY_CLASS Packet where
put p = do
-- First two bits are 1 for new packet format
put ((tag .|. 0xC0) :: Word8)
-- Use 5-octet lengths
put (255 :: Word8)
put ((fromIntegral $ B.length body) :: Word32)
putSomeByteString body
where
(body, tag) = put_packet p
get = do
tag <- get :: Get Word8
let (t, l) =
if (tag .&. 64) /= 0 then
(tag .&. 63, parse_new_length)
else
((tag `shiftR` 2) .&. 15, parse_old_length tag)
len <- l
-- This forces the whole packet to be consumed
packet <- getSomeByteString (fromIntegral len)
return $ unsafeRunGet (parse_packet t) packet
-- http://tools.ietf.org/html/rfc4880#section-4.2.2
parse_new_length :: Get Word32
parse_new_length = do
len <- fmap fromIntegral (get :: Get Word8)
case len of
-- One octet length
_ | len < 192 -> return len
-- Two octet length
_ | len > 191 && len < 224 -> do
second <- fmap fromIntegral (get :: Get Word8)
return $ ((len - 192) `shiftL` 8) + second + 192
-- Five octet length
255 -> get :: Get Word32
-- TODO: Partial body lengths. 1 << (len & 0x1F)
_ -> fail "Unsupported new packet length."
-- http://tools.ietf.org/html/rfc4880#section-4.2.1
parse_old_length :: Word8 -> Get Word32
parse_old_length tag =
case tag .&. 3 of
-- One octet length
0 -> fmap fromIntegral (get :: Get Word8)
-- Two octet length
1 -> fmap fromIntegral (get :: Get Word16)
-- Four octet length
2 -> get
-- Indeterminate length
3 -> fmap fromIntegral remaining
-- Error
_ -> fail "Unsupported old packet length."
-- http://tools.ietf.org/html/rfc4880#section-5.5.2
public_key_fields :: KeyAlgorithm -> [Char]
public_key_fields RSA = ['n', 'e']
public_key_fields RSA_E = public_key_fields RSA
public_key_fields RSA_S = public_key_fields RSA
public_key_fields ELGAMAL = ['p', 'g', 'y']
public_key_fields DSA = ['p', 'q', 'g', 'y']
public_key_fields _ = undefined -- Nothing in the spec. Maybe empty
-- http://tools.ietf.org/html/rfc4880#section-5.5.3
secret_key_fields :: KeyAlgorithm -> [Char]
secret_key_fields RSA = ['d', 'p', 'q', 'u']
secret_key_fields RSA_E = secret_key_fields RSA
secret_key_fields RSA_S = secret_key_fields RSA
secret_key_fields ELGAMAL = ['x']
secret_key_fields DSA = ['x']
secret_key_fields _ = undefined -- Nothing in the spec. Maybe empty
(!) :: (Eq k) => [(k,v)] -> k -> v
(!) xs = fromJust . (`lookup` xs)
-- Need this seperate for trailer calculation
signature_packet_start :: Packet -> B.ByteString
signature_packet_start (SignaturePacket {
version = 4,
signature_type = signature_type,
key_algorithm = key_algorithm,
hash_algorithm = hash_algorithm,
hashed_subpackets = hashed_subpackets
}) =
B.concat [
encode (0x04 :: Word8),
encode signature_type,
encode key_algorithm,
encode hash_algorithm,
encode ((fromIntegral $ B.length hashed_subs) :: Word16),
hashed_subs
]
where
hashed_subs = B.concat $ map encode hashed_subpackets
signature_packet_start _ =
error "Trying to get start of signature packet for non signature packet."
-- The trailer is just the top of the body plus some crap
calculate_signature_trailer :: Packet -> B.ByteString
calculate_signature_trailer p =
B.concat [
signature_packet_start p,
encode (0x04 :: Word8),
encode (0xff :: Word8),
encode (fromIntegral (B.length $ signature_packet_start p) :: Word32)
]
put_packet :: (Num a) => Packet -> (B.ByteString, a)
put_packet (SignaturePacket { version = 4,
unhashed_subpackets = unhashed_subpackets,
hash_head = hash_head,
signature = signature,
trailer = trailer }) =
(B.concat $ [
trailer_top,
encode (fromIntegral $ B.length unhashed :: Word16),
unhashed, encode hash_head
] ++ map encode signature, 2)
where
trailer_top = B.reverse $ B.drop 6 $ B.reverse trailer
unhashed = B.concat $ map encode unhashed_subpackets
put_packet (OnePassSignaturePacket { version = version,
signature_type = signature_type,
hash_algorithm = hash_algorithm,
key_algorithm = key_algorithm,
key_id = key_id,
nested = nested }) =
(B.concat [ encode version, encode signature_type,
encode hash_algorithm, encode key_algorithm,
encode (fst $ head $ readHex key_id :: Word64),
encode nested ], 4)
put_packet (SecretKeyPacket { version = version, timestamp = timestamp,
key_algorithm = algorithm, key = key,
s2k_useage = s2k_useage,
symmetric_type = symmetric_type,
s2k_type = s2k_type,
s2k_hash_algorithm = s2k_hash_algo,
s2k_salt = s2k_salt,
s2k_count = s2k_count,
encrypted_data = encrypted_data }) =
(B.concat $ [p, encode s2k_useage] ++
(if s2k_useage `elem` [255, 254] then
[encode $ fromJust symmetric_type, encode s2k_t,
encode $ fromJust s2k_hash_algo] ++
(if s2k_t `elem` [1,3] then [encode $ fromJust s2k_salt] else []) ++
if s2k_t == 3 then
[encode $ encode_s2k_count $ fromJust s2k_count] else []
else []) ++
(if s2k_useage > 0 then
[encrypted_data]
else s ++
-- XXX: Checksum is part of encrypted_data for V4 ONLY
if s2k_useage == 254 then
[B.replicate 20 0] -- TODO SHA1 Checksum
else
[encode (fromIntegral $
B.foldl (\c i -> (c + fromIntegral i) `mod` 65536)
(0::Integer) (B.concat s) :: Word16)]), 5)
where
(Just s2k_t) = s2k_type
p = fst (put_packet $ PublicKeyPacket version timestamp algorithm key
:: (B.ByteString, Integer)) -- Supress warning
s = map (encode . (key !)) (secret_key_fields algorithm)
put_packet (PublicKeyPacket { version = 4, timestamp = timestamp,
key_algorithm = algorithm, key = key }) =
(B.concat $ [B.singleton 4, encode timestamp, encode algorithm] ++
map (encode . (key !)) (public_key_fields algorithm), 6)
put_packet (CompressedDataPacket { compression_algorithm = algorithm,
message = message }) =
(B.append (encode algorithm) $ compress algorithm $ encode message, 8)
put_packet (LiteralDataPacket { format = format, filename = filename,
timestamp = timestamp, content = content
}) =
(B.concat [encode format, encode filename_l, lz_filename,
encode timestamp, content], 11)
where
filename_l = (fromIntegral $ B.length lz_filename) :: Word8
lz_filename = B.fromString filename
put_packet (UserIDPacket txt) = (B.fromString txt, 13)
put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag)
put_packet _ = error "Unsupported Packet version or type in put_packet."
parse_packet :: Word8 -> Get Packet
-- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2
parse_packet 2 = do
version <- get
case version of
3 -> error "V3 signatures are not supported yet" -- TODO: V3 sigs
4 -> do
signature_type <- get
key_algorithm <- get
hash_algorithm <- get
hashed_size <- fmap fromIntegral (get :: Get Word16)
hashed_data <- getSomeByteString hashed_size
let hashed = unsafeRunGet listUntilEnd hashed_data
unhashed_size <- fmap fromIntegral (get :: Get Word16)
unhashed_data <- getSomeByteString unhashed_size
let unhashed = unsafeRunGet listUntilEnd unhashed_data
hash_head <- get
signature <- listUntilEnd
return SignaturePacket {
version = version,
signature_type = signature_type,
key_algorithm = key_algorithm,
hash_algorithm = hash_algorithm,
hashed_subpackets = hashed,
unhashed_subpackets = unhashed,
hash_head = hash_head,
signature = signature,
trailer = B.concat [encode version, encode signature_type, encode key_algorithm, encode hash_algorithm, encode (fromIntegral hashed_size :: Word16), hashed_data, B.pack [4, 0xff], encode ((6 + fromIntegral hashed_size) :: Word32)]
}
x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "."
-- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4
parse_packet 4 = do
version <- get
signature_type <- get
hash_algo <- get
key_algo <- get
key_id <- get :: Get Word64
nested <- get
return OnePassSignaturePacket {
version = version,
signature_type = signature_type,
hash_algorithm = hash_algo,
key_algorithm = key_algo,
key_id = map toUpper $ showHex key_id "",
nested = nested
}
-- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3
parse_packet 5 = do
-- Parse PublicKey part
(PublicKeyPacket {
version = version,
timestamp = timestamp,
key_algorithm = algorithm,
key = key
}) <- parse_packet 6
s2k_useage <- get :: Get Word8
let k = SecretKeyPacket version timestamp algorithm key s2k_useage
k' <- case s2k_useage of
_ | s2k_useage `elem` [255, 254] -> do
symmetric_type <- get
s2k_type <- get
s2k_hash_algorithm <- get
s2k_salt <- if s2k_type `elem` [1, 3] then get
else return undefined
s2k_count <- if s2k_type == 3 then fmap decode_s2k_count get else
return undefined
return (k (Just symmetric_type) (Just s2k_type)
(Just s2k_hash_algorithm) (Just s2k_salt) (Just s2k_count))
_ | s2k_useage > 0 ->
-- s2k_useage is symmetric_type in this case
return (k (Just s2k_useage) Nothing Nothing Nothing Nothing)
_ ->
return (k Nothing Nothing Nothing Nothing Nothing)
if s2k_useage > 0 then do {
encrypted <- getRemainingByteString;
return (k' encrypted Nothing)
} else do
key <- foldM (\m f -> do
mpi <- get :: Get MPI
return $ (f,mpi):m) key (secret_key_fields algorithm)
private_hash <- getRemainingByteString
return ((k' B.empty (Just private_hash)) {key = key})
-- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2
parse_packet 6 = do
version <- get :: Get Word8
case version of
4 -> do
timestamp <- get
algorithm <- get
key <- mapM (\f -> do
mpi <- get :: Get MPI
return (f, mpi)) (public_key_fields algorithm)
return PublicKeyPacket {
version = 4,
timestamp = timestamp,
key_algorithm = algorithm,
key = key
}
x -> fail $ "Unsupported PublicKeyPacket version " ++ show x ++ "."
-- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6
parse_packet 8 = do
algorithm <- get
message <- getRemainingByteString
return CompressedDataPacket {
compression_algorithm = algorithm,
message = unsafeRunGet get (decompress algorithm message)
}
-- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9
parse_packet 11 = do
format <- get
filenameLength <- get :: Get Word8
filename <- getSomeByteString (fromIntegral filenameLength)
timestamp <- get
content <- getRemainingByteString
return LiteralDataPacket {
format = format,
filename = B.toString filename,
timestamp = timestamp,
content = content
}
-- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11
parse_packet 13 =
fmap (UserIDPacket . B.toString) getRemainingByteString
-- Represent unsupported packets as their tag and literal bytes
parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString
-- | Helper method for fingerprints and such
fingerprint_material :: Packet -> [B.ByteString]
fingerprint_material (PublicKeyPacket {version = 4,
timestamp = timestamp,
key_algorithm = algorithm,
key = key}) =
[
B.singleton 0x99,
encode (6 + fromIntegral (B.length material) :: Word16),
B.singleton 4, encode timestamp, encode algorithm,
material
]
where
material =
B.concat $ map (encode . (key !)) (public_key_fields algorithm)
-- Proxy to make SecretKeyPacket work
fingerprint_material (SecretKeyPacket {version = 4,
timestamp = timestamp,
key_algorithm = algorithm,
key = key}) =
fingerprint_material PublicKeyPacket {version = 4,
timestamp = timestamp,
key_algorithm = algorithm,
key = key}
fingerprint_material p | version p `elem` [2, 3] = [n, e]
where
n = B.drop 2 (encode (key p ! 'n'))
e = B.drop 2 (encode (key p ! 'e'))
fingerprint_material _ =
error "Unsupported Packet version or type in fingerprint_material."
enum_to_word8 :: (Enum a) => a -> Word8
enum_to_word8 = fromIntegral . fromEnum
enum_from_word8 :: (Enum a) => Word8 -> a
enum_from_word8 = toEnum . fromIntegral
data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | HashAlgorithm Word8
deriving (Show, Read, Eq)
instance Enum HashAlgorithm where
toEnum 01 = MD5
toEnum 02 = SHA1
toEnum 03 = RIPEMD160
toEnum 08 = SHA256
toEnum 09 = SHA384
toEnum 10 = SHA512
toEnum 11 = SHA224
toEnum x = HashAlgorithm $ fromIntegral x
fromEnum MD5 = 01
fromEnum SHA1 = 02
fromEnum RIPEMD160 = 03
fromEnum SHA256 = 08
fromEnum SHA384 = 09
fromEnum SHA512 = 10
fromEnum SHA224 = 11
fromEnum (HashAlgorithm x) = fromIntegral x
instance BINARY_CLASS HashAlgorithm where
put = put . enum_to_word8
get = fmap enum_from_word8 get
data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | KeyAlgorithm Word8
deriving (Show, Read, Eq)
instance Enum KeyAlgorithm where
toEnum 01 = RSA
toEnum 02 = RSA_E
toEnum 03 = RSA_S
toEnum 16 = ELGAMAL
toEnum 17 = DSA
toEnum 18 = ECC
toEnum 19 = ECDSA
toEnum 21 = DH
toEnum x = KeyAlgorithm $ fromIntegral x
fromEnum RSA = 01
fromEnum RSA_E = 02
fromEnum RSA_S = 03
fromEnum ELGAMAL = 16
fromEnum DSA = 17
fromEnum ECC = 18
fromEnum ECDSA = 19
fromEnum DH = 21
fromEnum (KeyAlgorithm x) = fromIntegral x
instance BINARY_CLASS KeyAlgorithm where
put = put . enum_to_word8
get = fmap enum_from_word8 get
data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | CompressionAlgorithm Word8
deriving (Show, Read, Eq)
instance Enum CompressionAlgorithm where
toEnum 0 = Uncompressed
toEnum 1 = ZIP
toEnum 2 = ZLIB
toEnum 3 = BZip2
toEnum x = CompressionAlgorithm $ fromIntegral x
fromEnum Uncompressed = 0
fromEnum ZIP = 1
fromEnum ZLIB = 2
fromEnum BZip2 = 3
fromEnum (CompressionAlgorithm x) = fromIntegral x
instance BINARY_CLASS CompressionAlgorithm where
put = put . enum_to_word8
get = fmap enum_from_word8 get
-- A message is encoded as a list that takes the entire file
newtype Message = Message [Packet] deriving (Show, Read, Eq)
instance BINARY_CLASS Message where
put (Message xs) = mapM_ put xs
get = fmap Message listUntilEnd
-- | Extract all signature and data packets from a 'Message'
signatures_and_data :: Message -> ([Packet], [Packet])
signatures_and_data (Message ((CompressedDataPacket {message = m}):_)) =
signatures_and_data m
signatures_and_data (Message lst) =
(filter isSignaturePacket lst, filter isDta lst)
where
isDta (LiteralDataPacket {}) = True
isDta _ = False
newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord)
instance BINARY_CLASS MPI where
put (MPI i) = do
put (((fromIntegral . B.length $ bytes) - 1) * 8
+ floor (logBase (2::Double) $ fromIntegral (bytes `B.index` 0))
+ 1 :: Word16)
putSomeByteString bytes
where
bytes = B.reverse $ B.unfoldr (\x ->
if x == 0 then Nothing else
Just (fromIntegral x, x `shiftR` 8)
) i
get = do
length <- fmap fromIntegral (get :: Get Word16)
bytes <- getSomeByteString ((length + 7) `div` 8)
return (MPI (B.foldl (\a b ->
a `shiftL` 8 .|. fromIntegral b) 0 bytes))
listUntilEnd :: (BINARY_CLASS a) => Get [a]
listUntilEnd = do
done <- isEmpty
if done then return [] else do
next <- get
rest <- listUntilEnd
return (next:rest)
-- http://tools.ietf.org/html/rfc4880#section-5.2.3.1
data SignatureSubpacket =
SignatureCreationTimePacket Word32 |
SignatureExpirationTimePacket Word32 | -- seconds after CreationTime
ExportableCertificationPacket Bool |
TrustSignaturePacket {depth::Word8, trust::Word8} |
IssuerPacket String |
UnsupportedSignatureSubpacket Word8 B.ByteString
deriving (Show, Read, Eq)
instance BINARY_CLASS SignatureSubpacket where
put p = do
-- Use 5-octet-length + 1 for tag as the first packet body octet
put (255 :: Word8)
put (fromIntegral (B.length body) + 1 :: Word32)
put tag
putSomeByteString body
where
(body, tag) = put_signature_subpacket p
get = do
len <- fmap fromIntegral (get :: Get Word8)
len <- case len of
_ | len > 190 && len < 255 -> do -- Two octet length
second <- fmap fromIntegral (get :: Get Word8)
return $ ((len - 192) `shiftR` 8) + second + 192
255 -> -- Five octet length
fmap fromIntegral (get :: Get Word32)
_ -> -- One octet length, no furthur processing
return len
tag <- fmap stripCrit get :: Get Word8
-- This forces the whole packet to be consumed
packet <- getSomeByteString (len-1)
return $ unsafeRunGet (parse_signature_subpacket tag) packet
where
-- TODO: Decide how to actually encode the "is critical" data
-- instead of just ignoring it
stripCrit tag = if tag .&. 0x80 == 0x80 then tag .&. 0x7f else tag
put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8)
put_signature_subpacket (SignatureCreationTimePacket time) =
(encode time, 2)
put_signature_subpacket (SignatureExpirationTimePacket time) =
(encode time, 3)
put_signature_subpacket (ExportableCertificationPacket exportable) =
(encode $ enum_to_word8 exportable, 4)
put_signature_subpacket (TrustSignaturePacket depth trust) =
(B.concat [encode depth, encode trust], 5)
put_signature_subpacket (IssuerPacket keyid) =
(encode (fst $ head $ readHex keyid :: Word64), 16)
put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) =
(bytes, tag)
parse_signature_subpacket :: Word8 -> Get SignatureSubpacket
-- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4
parse_signature_subpacket 2 = fmap SignatureCreationTimePacket get
-- SignatureExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.10
parse_signature_subpacket 3 = fmap SignatureExpirationTimePacket get
-- ExportableCertificationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.11
parse_signature_subpacket 4 =
fmap (ExportableCertificationPacket . enum_from_word8) get
-- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.13
parse_signature_subpacket 5 =
liftM2 TrustSignaturePacket get get
-- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5
parse_signature_subpacket 16 = do
keyid <- get :: Get Word64
return $ IssuerPacket (map toUpper $ showHex keyid "")
-- Represent unsupported packets as their tag and literal bytes
parse_signature_subpacket tag =
fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString
-- | Find the keyid that issued a SignaturePacket
signature_issuer :: Packet -> Maybe String
signature_issuer (SignaturePacket {hashed_subpackets = hashed,
unhashed_subpackets = unhashed}) =
if length issuers > 0 then Just issuer else Nothing
where IssuerPacket issuer = issuers !! 0
issuers = filter isIssuer hashed ++ filter isIssuer unhashed
isIssuer (IssuerPacket {}) = True
isIssuer _ = False
signature_issuer _ = Nothing
find_key :: (Packet -> String) -> Message -> String -> Maybe Packet
find_key fpr (Message (x@(PublicKeyPacket {}):xs)) keyid =
find_key' fpr x xs keyid
find_key fpr (Message (x@(SecretKeyPacket {}):xs)) keyid =
find_key' fpr x xs keyid
find_key fpr (Message (_:xs)) keyid =
find_key fpr (Message xs) keyid
find_key _ _ _ = Nothing
find_key' :: (Packet -> String) -> Packet -> [Packet] -> String -> Maybe Packet
find_key' fpr x xs keyid
| thisid == keyid = Just x
| otherwise = find_key fpr (Message xs) keyid
where
thisid = reverse $ take (length keyid) (reverse (fpr x))
-- | SignaturePacket smart constructor
signaturePacket :: Word8 -> Word8 -> KeyAlgorithm -> HashAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> Word16 -> [MPI] -> Packet
signaturePacket version signature_type key_algorithm hash_algorithm hashed_subpackets unhashed_subpackets hash_head signature =
let p = SignaturePacket {
version = version,
signature_type = signature_type,
key_algorithm = key_algorithm,
hash_algorithm = hash_algorithm,
hashed_subpackets = hashed_subpackets,
unhashed_subpackets = unhashed_subpackets,
hash_head = hash_head,
signature = signature,
trailer = undefined
} in p { trailer = calculate_signature_trailer p }
isSignaturePacket :: Packet -> Bool
isSignaturePacket (SignaturePacket {}) = True
isSignaturePacket _ = False
|