diff options
Diffstat (limited to 'Data/OpenPGP.hs')
-rw-r--r-- | Data/OpenPGP.hs | 573 |
1 files changed, 573 insertions, 0 deletions
diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs new file mode 100644 index 0000000..1c76202 --- /dev/null +++ b/Data/OpenPGP.hs | |||
@@ -0,0 +1,573 @@ | |||
1 | module Data.OpenPGP (Message(..), Packet(..), SignatureSubpacket(..), HashAlgorithm(..), KeyAlgorithm(..), CompressionAlgorithm(..), MPI(..), fingerprint_material, signatures_and_data, signature_issuer) where | ||
2 | |||
3 | import Control.Monad | ||
4 | import Data.Bits | ||
5 | import Data.Word | ||
6 | import Data.Map (Map, (!)) | ||
7 | import qualified Data.Map as Map | ||
8 | import qualified Data.ByteString.Lazy as LZ | ||
9 | import qualified Data.ByteString.Lazy.UTF8 as LZ (toString, fromString) | ||
10 | |||
11 | import Data.Binary | ||
12 | import Data.Binary.Get | ||
13 | import Data.Binary.Put | ||
14 | import qualified Codec.Compression.Zlib.Raw as Zip | ||
15 | import qualified Codec.Compression.Zlib as Zlib | ||
16 | import qualified Codec.Compression.BZip as BZip2 | ||
17 | |||
18 | import qualified Data.BaseConvert as BaseConvert | ||
19 | |||
20 | data Packet = | ||
21 | SignaturePacket { | ||
22 | version::Word8, | ||
23 | signature_type::Word8, | ||
24 | key_algorithm::KeyAlgorithm, | ||
25 | hash_algorithm::HashAlgorithm, | ||
26 | hashed_subpackets::[SignatureSubpacket], | ||
27 | unhashed_subpackets::[SignatureSubpacket], | ||
28 | hash_head::Word16, | ||
29 | signature::MPI, | ||
30 | trailer::LZ.ByteString | ||
31 | } | | ||
32 | OnePassSignaturePacket { | ||
33 | version::Word8, | ||
34 | signature_type::Word8, | ||
35 | hash_algorithm::HashAlgorithm, | ||
36 | key_algorithm::KeyAlgorithm, | ||
37 | key_id::String, | ||
38 | nested::Word8 | ||
39 | } | | ||
40 | PublicKeyPacket { | ||
41 | version::Word8, | ||
42 | timestamp::Word32, | ||
43 | key_algorithm::KeyAlgorithm, | ||
44 | key::Map Char MPI | ||
45 | } | | ||
46 | SecretKeyPacket { | ||
47 | version::Word8, | ||
48 | timestamp::Word32, | ||
49 | key_algorithm::KeyAlgorithm, | ||
50 | key::Map Char MPI, | ||
51 | s2k_useage::Word8, | ||
52 | symmetric_type::Word8, | ||
53 | s2k_type::Word8, | ||
54 | s2k_hash_algorithm::HashAlgorithm, | ||
55 | s2k_salt::Word64, | ||
56 | s2k_count::Word8, | ||
57 | encrypted_data::LZ.ByteString, | ||
58 | private_hash::LZ.ByteString | ||
59 | } | | ||
60 | CompressedDataPacket { | ||
61 | compression_algorithm::CompressionAlgorithm, | ||
62 | message::Message | ||
63 | } | | ||
64 | LiteralDataPacket { | ||
65 | format::Char, | ||
66 | filename::String, | ||
67 | timestamp::Word32, | ||
68 | content::LZ.ByteString | ||
69 | } | | ||
70 | UserIDPacket String | ||
71 | deriving (Show, Read, Eq) | ||
72 | |||
73 | instance Binary Packet where | ||
74 | put p = do | ||
75 | -- First two bits are 1 for new packet format | ||
76 | put ((tag .|. 0xC0) :: Word8) | ||
77 | -- Use 5-octet lengths | ||
78 | put (255 :: Word8) | ||
79 | put ((fromIntegral $ LZ.length body) :: Word32) | ||
80 | putLazyByteString body | ||
81 | where (body, tag) = put_packet p | ||
82 | get = do | ||
83 | tag <- get :: Get Word8 | ||
84 | let (t, l) = | ||
85 | if (tag .&. 64) /= 0 then | ||
86 | (tag .&. 63, parse_new_length) | ||
87 | else | ||
88 | ((tag `shiftR` 2) .&. 15, parse_old_length tag) | ||
89 | len <- l | ||
90 | -- This forces the whole packet to be consumed | ||
91 | packet <- getLazyByteString (fromIntegral len) | ||
92 | return $ runGet (parse_packet t) packet | ||
93 | |||
94 | -- http://tools.ietf.org/html/rfc4880#section-4.2.2 | ||
95 | parse_new_length :: Get Word32 | ||
96 | parse_new_length = do | ||
97 | len <- fmap fromIntegral (get :: Get Word8) | ||
98 | case len of | ||
99 | -- One octet length | ||
100 | _ | len < 192 -> return len | ||
101 | -- Two octet length | ||
102 | _ | len > 191 && len < 224 -> do | ||
103 | second <- fmap fromIntegral (get :: Get Word8) | ||
104 | return $ ((len - 192) `shiftL` 8) + second + 192 | ||
105 | -- Five octet length | ||
106 | 255 -> get :: Get Word32 | ||
107 | -- TODO: Partial body lengths. 1 << (len & 0x1F) | ||
108 | _ -> fail "Unsupported new packet length." | ||
109 | |||
110 | -- http://tools.ietf.org/html/rfc4880#section-4.2.1 | ||
111 | parse_old_length :: Word8 -> Get Word32 | ||
112 | parse_old_length tag = | ||
113 | case (tag .&. 3) of | ||
114 | -- One octet length | ||
115 | 0 -> fmap fromIntegral (get :: Get Word8) | ||
116 | -- Two octet length | ||
117 | 1 -> fmap fromIntegral (get :: Get Word16) | ||
118 | -- Four octet length | ||
119 | 2 -> get | ||
120 | -- Indeterminate length | ||
121 | 3 -> fmap fromIntegral remaining | ||
122 | -- Error | ||
123 | _ -> fail "Unsupported old packet length." | ||
124 | |||
125 | -- http://tools.ietf.org/html/rfc4880#section-5.5.2 | ||
126 | public_key_fields :: KeyAlgorithm -> [Char] | ||
127 | public_key_fields RSA = ['n', 'e'] | ||
128 | public_key_fields RSA_E = public_key_fields RSA | ||
129 | public_key_fields RSA_S = public_key_fields RSA | ||
130 | public_key_fields ELGAMAL = ['p', 'g', 'y'] | ||
131 | public_key_fields DSA = ['p', 'q', 'g', 'y'] | ||
132 | public_key_fields _ = undefined -- Nothing in the spec. Maybe empty | ||
133 | |||
134 | -- http://tools.ietf.org/html/rfc4880#section-5.5.3 | ||
135 | secret_key_fields :: KeyAlgorithm -> [Char] | ||
136 | secret_key_fields RSA = ['d', 'p', 'q', 'u'] | ||
137 | secret_key_fields RSA_E = secret_key_fields RSA | ||
138 | secret_key_fields RSA_S = secret_key_fields RSA | ||
139 | secret_key_fields ELGAMAL = ['x'] | ||
140 | secret_key_fields DSA = ['x'] | ||
141 | secret_key_fields _ = undefined -- Nothing in the spec. Maybe empty | ||
142 | |||
143 | -- Need this seperate for trailer calculation | ||
144 | signature_packet_start :: Packet -> LZ.ByteString | ||
145 | signature_packet_start (SignaturePacket { | ||
146 | version = 4, | ||
147 | signature_type = signature_type, | ||
148 | key_algorithm = key_algorithm, | ||
149 | hash_algorithm = hash_algorithm, | ||
150 | hashed_subpackets = hashed_subpackets | ||
151 | }) = | ||
152 | LZ.concat $ [ | ||
153 | encode (0x04 :: Word8), | ||
154 | encode signature_type, | ||
155 | encode key_algorithm, | ||
156 | encode hash_algorithm, | ||
157 | encode ((fromIntegral $ LZ.length hashed_subs) :: Word16), | ||
158 | hashed_subs | ||
159 | ] | ||
160 | where hashed_subs = LZ.concat $ map encode hashed_subpackets | ||
161 | signature_packet_start _ = | ||
162 | error "Trying to get start of signature packet for non signature packet." | ||
163 | |||
164 | -- The trailer is just the top of the body plus some crap | ||
165 | calculate_signature_trailer :: Packet -> LZ.ByteString | ||
166 | calculate_signature_trailer p = | ||
167 | LZ.concat [ | ||
168 | signature_packet_start p, | ||
169 | encode (0x04 :: Word8), | ||
170 | encode (0xff :: Word8), | ||
171 | encode ((fromIntegral (LZ.length $ signature_packet_start p)) :: Word32) | ||
172 | ] | ||
173 | |||
174 | put_packet :: (Num a) => Packet -> (LZ.ByteString, a) | ||
175 | put_packet (SignaturePacket { version = 4, | ||
176 | signature_type = signature_type, | ||
177 | key_algorithm = key_algorithm, | ||
178 | hash_algorithm = hash_algorithm, | ||
179 | hashed_subpackets = hashed_subpackets, | ||
180 | unhashed_subpackets = unhashed_subpackets, | ||
181 | hash_head = hash_head, | ||
182 | signature = signature }) = | ||
183 | (LZ.concat [ LZ.singleton 4, encode signature_type, | ||
184 | encode key_algorithm, encode hash_algorithm, | ||
185 | encode (fromIntegral $ LZ.length hashed :: Word16), | ||
186 | hashed, | ||
187 | encode (fromIntegral $ LZ.length unhashed :: Word16), | ||
188 | unhashed, | ||
189 | encode hash_head, encode signature ], 2) | ||
190 | where hashed = LZ.concat $ map encode hashed_subpackets | ||
191 | unhashed = LZ.concat $ map encode unhashed_subpackets | ||
192 | put_packet (OnePassSignaturePacket { version = version, | ||
193 | signature_type = signature_type, | ||
194 | hash_algorithm = hash_algorithm, | ||
195 | key_algorithm = key_algorithm, | ||
196 | key_id = key_id, | ||
197 | nested = nested }) = | ||
198 | (LZ.concat [ encode version, encode signature_type, | ||
199 | encode hash_algorithm, encode key_algorithm, | ||
200 | encode (BaseConvert.toNum 16 key_id :: Word64), | ||
201 | encode nested ], 4) | ||
202 | put_packet (SecretKeyPacket { version = version, timestamp = timestamp, | ||
203 | key_algorithm = algorithm, key = key, | ||
204 | s2k_useage = s2k_useage, | ||
205 | symmetric_type = symmetric_type, | ||
206 | s2k_type = s2k_type, | ||
207 | s2k_hash_algorithm = s2k_hash_algo, | ||
208 | s2k_salt = s2k_salt, | ||
209 | encrypted_data = encrypted_data }) = | ||
210 | (LZ.concat $ [p, encode s2k_useage] ++ | ||
211 | (if s2k_useage `elem` [255, 254] then | ||
212 | -- TODO: if s2k_type == 3 reverse ugly bit manipulation | ||
213 | [encode symmetric_type, encode s2k_type, encode s2k_hash_algo] ++ | ||
214 | if s2k_type `elem` [1, 3] then [encode s2k_salt] else [] | ||
215 | else []) ++ | ||
216 | (if s2k_useage > 0 then | ||
217 | [encrypted_data] | ||
218 | else s) ++ | ||
219 | (if s2k_useage == 254 then | ||
220 | [LZ.replicate 20 0] -- TODO SHA1 Checksum | ||
221 | else | ||
222 | [encode $ (fromIntegral $ | ||
223 | LZ.foldl (\c i -> (c + (fromIntegral i)) `mod` 65536) | ||
224 | (0::Integer) (LZ.concat s) :: Word16)]), 5) | ||
225 | where | ||
226 | p = fst (put_packet $ | ||
227 | PublicKeyPacket version timestamp algorithm key | ||
228 | :: (LZ.ByteString, Integer)) -- Supress warning | ||
229 | s = map (encode . (key !)) (secret_key_fields algorithm) | ||
230 | put_packet (PublicKeyPacket { version = 4, timestamp = timestamp, | ||
231 | key_algorithm = algorithm, key = key }) = | ||
232 | (LZ.concat $ [LZ.singleton 4, encode timestamp, encode algorithm] ++ | ||
233 | map (encode . (key !)) (public_key_fields algorithm), 6) | ||
234 | put_packet (CompressedDataPacket { compression_algorithm = algorithm, | ||
235 | message = message }) = | ||
236 | (LZ.append (encode algorithm) $ compress $ encode message, 8) | ||
237 | where compress = case algorithm of | ||
238 | Uncompressed -> id | ||
239 | ZIP -> Zip.compress | ||
240 | ZLIB -> Zlib.compress | ||
241 | BZip2 -> BZip2.compress | ||
242 | put_packet (LiteralDataPacket { format = format, filename = filename, | ||
243 | timestamp = timestamp, content = content | ||
244 | }) = | ||
245 | (LZ.concat [encode format, encode filename_l, lz_filename, | ||
246 | encode timestamp, content], 11) | ||
247 | where | ||
248 | filename_l = (fromIntegral $ LZ.length lz_filename) :: Word8 | ||
249 | lz_filename = LZ.fromString filename | ||
250 | put_packet (UserIDPacket txt) = (LZ.fromString txt, 13) | ||
251 | put_packet _ = error "Unsupported Packet version or type in put_packet." | ||
252 | |||
253 | parse_packet :: Word8 -> Get Packet | ||
254 | -- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2 | ||
255 | parse_packet 2 = do | ||
256 | version <- get | ||
257 | case version of | ||
258 | 3 -> undefined -- TODO: V3 sigs | ||
259 | 4 -> do | ||
260 | signature_type <- get | ||
261 | key_algorithm <- get | ||
262 | hash_algorithm <- get | ||
263 | hashed_size <- fmap fromIntegral (get :: Get Word16) | ||
264 | hashed_data <- getLazyByteString hashed_size | ||
265 | let hashed = runGet get_signature_subpackets hashed_data | ||
266 | unhashed_size <- fmap fromIntegral (get :: Get Word16) | ||
267 | unhashed_data <- getLazyByteString unhashed_size | ||
268 | let unhashed = runGet get_signature_subpackets unhashed_data | ||
269 | hash_head <- get | ||
270 | signature <- get | ||
271 | return (SignaturePacket { | ||
272 | version = version, | ||
273 | signature_type = signature_type, | ||
274 | key_algorithm = key_algorithm, | ||
275 | hash_algorithm = hash_algorithm, | ||
276 | hashed_subpackets = hashed, | ||
277 | unhashed_subpackets = unhashed, | ||
278 | hash_head = hash_head, | ||
279 | signature = signature, | ||
280 | trailer = LZ.concat [encode version, encode signature_type, encode key_algorithm, encode hash_algorithm, encode (fromIntegral hashed_size :: Word16), hashed_data, LZ.pack [4, 0xff], encode ((6 + (fromIntegral hashed_size)) :: Word32)] | ||
281 | }) | ||
282 | x -> fail $ "Unknown SignaturePacket version " ++ (show x) ++ "." | ||
283 | -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 | ||
284 | parse_packet 4 = do | ||
285 | version <- get | ||
286 | signature_type <- get | ||
287 | hash_algo <- get | ||
288 | key_algo <- get | ||
289 | key_id <- get :: Get Word64 | ||
290 | nested <- get | ||
291 | return (OnePassSignaturePacket { | ||
292 | version = version, | ||
293 | signature_type = signature_type, | ||
294 | hash_algorithm = hash_algo, | ||
295 | key_algorithm = key_algo, | ||
296 | key_id = (BaseConvert.toString 16 key_id), | ||
297 | nested = nested | ||
298 | }) | ||
299 | -- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3 | ||
300 | parse_packet 5 = do | ||
301 | -- Parse PublicKey part | ||
302 | (PublicKeyPacket { | ||
303 | version = version, | ||
304 | timestamp = timestamp, | ||
305 | key_algorithm = algorithm, | ||
306 | key = key | ||
307 | }) <- parse_packet 6 | ||
308 | s2k_useage <- get :: Get Word8 | ||
309 | let k = SecretKeyPacket version timestamp algorithm key s2k_useage | ||
310 | k' <- case s2k_useage of | ||
311 | _ | s2k_useage `elem` [255, 254] -> do | ||
312 | symmetric_type <- get | ||
313 | s2k_type <- get | ||
314 | s2k_hash_algorithm <- get | ||
315 | s2k_salt <- if s2k_type `elem` [1, 3] then get | ||
316 | else return undefined | ||
317 | s2k_count <- if s2k_type == 3 then do | ||
318 | c <- fmap fromIntegral (get :: Get Word8) | ||
319 | return $ fromIntegral $ | ||
320 | (16 + (c .&. 15)) `shiftL` ((c `shiftR` 4) + 6) | ||
321 | else return undefined | ||
322 | return (k symmetric_type s2k_type s2k_hash_algorithm | ||
323 | s2k_salt s2k_count) | ||
324 | _ | s2k_useage > 0 -> | ||
325 | -- s2k_useage is symmetric_type in this case | ||
326 | return (k s2k_useage undefined undefined undefined undefined) | ||
327 | _ -> | ||
328 | return (k undefined undefined undefined undefined undefined) | ||
329 | if s2k_useage > 0 then do | ||
330 | encrypted <- getRemainingLazyByteString | ||
331 | return (k' encrypted undefined) | ||
332 | else do | ||
333 | key <- foldM (\m f -> do | ||
334 | mpi <- get :: Get MPI | ||
335 | return $ Map.insert f mpi m) key (secret_key_fields algorithm) | ||
336 | private_hash <- getRemainingLazyByteString | ||
337 | return ((k' undefined private_hash) {key = key}) | ||
338 | -- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2 | ||
339 | parse_packet 6 = do | ||
340 | version <- get :: Get Word8 | ||
341 | case version of | ||
342 | 4 -> do | ||
343 | timestamp <- get | ||
344 | algorithm <- get | ||
345 | key <- mapM (\f -> do | ||
346 | mpi <- get :: Get MPI | ||
347 | return (f, mpi)) (public_key_fields algorithm) | ||
348 | return (PublicKeyPacket { | ||
349 | version = 4, | ||
350 | timestamp = timestamp, | ||
351 | key_algorithm = algorithm, | ||
352 | key = Map.fromList key | ||
353 | }) | ||
354 | x -> fail $ "Unsupported PublicKeyPacket version " ++ (show x) ++ "." | ||
355 | -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 | ||
356 | parse_packet 8 = do | ||
357 | algorithm <- get | ||
358 | message <- getRemainingLazyByteString | ||
359 | let decompress = case algorithm of | ||
360 | Uncompressed -> id | ||
361 | ZIP -> Zip.decompress | ||
362 | ZLIB -> Zlib.decompress | ||
363 | BZip2 -> BZip2.decompress | ||
364 | return (CompressedDataPacket { | ||
365 | compression_algorithm = algorithm, | ||
366 | message = runGet (get :: Get Message) (decompress message) | ||
367 | }) | ||
368 | -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9 | ||
369 | parse_packet 11 = do | ||
370 | format <- get | ||
371 | filenameLength <- get :: Get Word8 | ||
372 | filename <- getLazyByteString (fromIntegral filenameLength) | ||
373 | timestamp <- get | ||
374 | content <- getRemainingLazyByteString | ||
375 | return (LiteralDataPacket { | ||
376 | format = format, | ||
377 | filename = LZ.toString filename, | ||
378 | timestamp = timestamp, | ||
379 | content = content | ||
380 | }) | ||
381 | -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 | ||
382 | parse_packet 13 = | ||
383 | fmap UserIDPacket (fmap LZ.toString getRemainingLazyByteString) | ||
384 | -- Fail nicely for unimplemented packets | ||
385 | parse_packet x = fail $ "Unimplemented OpenPGP packet tag " ++ (show x) ++ "." | ||
386 | |||
387 | -- Helper method for fingerprints and such | ||
388 | fingerprint_material :: Packet -> [LZ.ByteString] | ||
389 | fingerprint_material (PublicKeyPacket {version = 4, | ||
390 | timestamp = timestamp, | ||
391 | key_algorithm = algorithm, | ||
392 | key = key}) = | ||
393 | [ | ||
394 | LZ.singleton 0x99, | ||
395 | encode (6 + fromIntegral (LZ.length material) :: Word16), | ||
396 | LZ.singleton 4, encode timestamp, encode algorithm, | ||
397 | material | ||
398 | ] | ||
399 | where material = LZ.concat $ | ||
400 | map (\f -> encode (key ! f)) (public_key_fields algorithm) | ||
401 | fingerprint_material p | (version p) `elem` [2, 3] = [n, e] | ||
402 | where n = LZ.drop 2 (encode (key p ! 'n')) | ||
403 | e = LZ.drop 2 (encode (key p ! 'e')) | ||
404 | fingerprint_material _ = | ||
405 | error "Unsupported Packet version or type in fingerprint_material." | ||
406 | |||
407 | data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | ||
408 | deriving (Show, Read, Eq) | ||
409 | instance Binary HashAlgorithm where | ||
410 | put MD5 = put (01 :: Word8) | ||
411 | put SHA1 = put (02 :: Word8) | ||
412 | put RIPEMD160 = put (03 :: Word8) | ||
413 | put SHA256 = put (08 :: Word8) | ||
414 | put SHA384 = put (09 :: Word8) | ||
415 | put SHA512 = put (10 :: Word8) | ||
416 | put SHA224 = put (11 :: Word8) | ||
417 | get = do | ||
418 | tag <- get :: Get Word8 | ||
419 | case tag of | ||
420 | 01 -> return MD5 | ||
421 | 02 -> return SHA1 | ||
422 | 03 -> return RIPEMD160 | ||
423 | 08 -> return SHA256 | ||
424 | 09 -> return SHA384 | ||
425 | 10 -> return SHA512 | ||
426 | 11 -> return SHA224 | ||
427 | x -> fail $ "Unknown HashAlgorithm " ++ (show x) ++ "." | ||
428 | |||
429 | data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | ||
430 | deriving (Show, Read, Eq) | ||
431 | instance Binary KeyAlgorithm where | ||
432 | put RSA = put (01 :: Word8) | ||
433 | put RSA_E = put (02 :: Word8) | ||
434 | put RSA_S = put (03 :: Word8) | ||
435 | put ELGAMAL = put (16 :: Word8) | ||
436 | put DSA = put (17 :: Word8) | ||
437 | put ECC = put (18 :: Word8) | ||
438 | put ECDSA = put (19 :: Word8) | ||
439 | put DH = put (21 :: Word8) | ||
440 | get = do | ||
441 | tag <- get :: Get Word8 | ||
442 | case tag of | ||
443 | 01 -> return RSA | ||
444 | 02 -> return RSA_E | ||
445 | 03 -> return RSA_S | ||
446 | 16 -> return ELGAMAL | ||
447 | 17 -> return DSA | ||
448 | 18 -> return ECC | ||
449 | 19 -> return ECDSA | ||
450 | 21 -> return DH | ||
451 | x -> fail $ "Unknown KeyAlgorithm " ++ (show x) ++ "." | ||
452 | |||
453 | data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | ||
454 | deriving (Show, Read, Eq) | ||
455 | instance Binary CompressionAlgorithm where | ||
456 | put Uncompressed = put (0 :: Word8) | ||
457 | put ZIP = put (1 :: Word8) | ||
458 | put ZLIB = put (2 :: Word8) | ||
459 | put BZip2 = put (3 :: Word8) | ||
460 | get = do | ||
461 | tag <- get :: Get Word8 | ||
462 | case tag of | ||
463 | 0 -> return Uncompressed | ||
464 | 1 -> return ZIP | ||
465 | 2 -> return ZLIB | ||
466 | 3 -> return BZip2 | ||
467 | x -> fail $ "Unknown CompressionAlgorithm " ++ (show x) ++ "." | ||
468 | |||
469 | -- A message is encoded as a list that takes the entire file | ||
470 | newtype Message = Message [Packet] deriving (Show, Read, Eq) | ||
471 | instance Binary Message where | ||
472 | put (Message []) = return () | ||
473 | put (Message (x:xs)) = do | ||
474 | put x | ||
475 | put (Message xs) | ||
476 | get = do | ||
477 | done <- isEmpty | ||
478 | if done then do | ||
479 | return (Message []) | ||
480 | else do | ||
481 | next_packet <- get :: Get Packet | ||
482 | (Message tail) <- get :: Get Message | ||
483 | return (Message (next_packet:tail)) | ||
484 | |||
485 | signatures_and_data :: Message -> ([Packet], [Packet]) | ||
486 | signatures_and_data (Message ((CompressedDataPacket {message = m}):_)) = | ||
487 | signatures_and_data m | ||
488 | signatures_and_data (Message lst) = | ||
489 | (filter isSig lst, filter isDta lst) | ||
490 | where isSig (SignaturePacket {}) = True | ||
491 | isSig _ = False | ||
492 | isDta (LiteralDataPacket {}) = True | ||
493 | isDta _ = False | ||
494 | |||
495 | newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) | ||
496 | instance Binary MPI where | ||
497 | put (MPI i) = do | ||
498 | put (((fromIntegral . LZ.length $ bytes) - 1) * 8 | ||
499 | + floor (logBase (2::Double) $ fromIntegral (bytes `LZ.index` 0)) | ||
500 | + 1 :: Word16) | ||
501 | putLazyByteString bytes | ||
502 | where bytes = LZ.unfoldr (\x -> if x == 0 then Nothing | ||
503 | else Just (fromIntegral x, x `shiftR` 8)) i | ||
504 | get = do | ||
505 | length <- fmap fromIntegral (get :: Get Word16) | ||
506 | bytes <- getLazyByteString ((length + 7) `div` 8) | ||
507 | return (MPI (LZ.foldr (\b a -> | ||
508 | a `shiftL` 8 .|. fromIntegral b) 0 bytes)) | ||
509 | |||
510 | data SignatureSubpacket = | ||
511 | SignatureCreationTimePacket Word32 | | ||
512 | IssuerPacket String | ||
513 | deriving (Show, Read, Eq) | ||
514 | |||
515 | instance Binary SignatureSubpacket where | ||
516 | put p = do | ||
517 | -- Use 5-octet-length + 1 for tag as the first packet body octet | ||
518 | put (255 :: Word8) | ||
519 | put ((fromIntegral $ LZ.length body) + 1 :: Word32) | ||
520 | put tag | ||
521 | putLazyByteString body | ||
522 | where (body, tag) = put_signature_subpacket p | ||
523 | get = do | ||
524 | len <- fmap fromIntegral (get :: Get Word8) | ||
525 | len <- case len of | ||
526 | _ | len > 190 && len < 255 -> do -- Two octet length | ||
527 | second <- fmap fromIntegral (get :: Get Word8) | ||
528 | return $ ((len - 192) `shiftR` 8) + second + 192 | ||
529 | 255 -> -- Five octet length | ||
530 | fmap fromIntegral (get :: Get Word32) | ||
531 | _ -> -- One octet length, no furthur processing | ||
532 | return len | ||
533 | tag <- get :: Get Word8 | ||
534 | -- This forces the whole packet to be consumed | ||
535 | packet <- getLazyByteString len | ||
536 | return $ runGet (parse_signature_subpacket tag) packet | ||
537 | |||
538 | signature_issuer :: Packet -> Maybe String | ||
539 | signature_issuer (SignaturePacket {hashed_subpackets = hashed, | ||
540 | unhashed_subpackets = unhashed}) = | ||
541 | if (length issuers) > 0 then Just issuer else Nothing | ||
542 | where IssuerPacket issuer = issuers !! 0 | ||
543 | issuers = (filter isIssuer hashed) ++ (filter isIssuer unhashed) | ||
544 | isIssuer (IssuerPacket {}) = True | ||
545 | isIssuer _ = False | ||
546 | signature_issuer _ = Nothing | ||
547 | |||
548 | put_signature_subpacket :: SignatureSubpacket -> (LZ.ByteString, Word8) | ||
549 | put_signature_subpacket (SignatureCreationTimePacket time) = | ||
550 | (encode time, 2) | ||
551 | put_signature_subpacket (IssuerPacket keyid) = | ||
552 | (encode ((BaseConvert.toNum 16 keyid) :: Word64), 16) | ||
553 | |||
554 | get_signature_subpackets :: Get [SignatureSubpacket] | ||
555 | get_signature_subpackets = do | ||
556 | done <- isEmpty | ||
557 | if done then do | ||
558 | return [] | ||
559 | else do | ||
560 | next_packet <- get :: Get SignatureSubpacket | ||
561 | tail <- get_signature_subpackets | ||
562 | return (next_packet:tail) | ||
563 | |||
564 | parse_signature_subpacket :: Word8 -> Get SignatureSubpacket | ||
565 | -- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4 | ||
566 | parse_signature_subpacket 2 = fmap SignatureCreationTimePacket get | ||
567 | -- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5 | ||
568 | parse_signature_subpacket 16 = do | ||
569 | keyid <- get :: Get Word64 | ||
570 | return $ IssuerPacket (BaseConvert.toString 16 keyid) | ||
571 | -- Fail nicely for unimplemented packets | ||
572 | parse_signature_subpacket x = | ||
573 | fail $ "Unimplemented OpenPGP signature subpacket tag " ++ (show x) ++ "." | ||