diff options
Diffstat (limited to 'Data')
-rw-r--r-- | Data/OpenPGP.hs | 1363 | ||||
-rw-r--r-- | Data/OpenPGP/Internal.hs | 20 |
2 files changed, 1383 insertions, 0 deletions
diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs new file mode 100644 index 0000000..74aae5f --- /dev/null +++ b/Data/OpenPGP.hs | |||
@@ -0,0 +1,1363 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
2 | -- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880> | ||
3 | -- | ||
4 | -- The recommended way to import this module is: | ||
5 | -- | ||
6 | -- > import qualified Data.OpenPGP as OpenPGP | ||
7 | module Data.OpenPGP ( | ||
8 | Packet( | ||
9 | AsymmetricSessionKeyPacket, | ||
10 | OnePassSignaturePacket, | ||
11 | SymmetricSessionKeyPacket, | ||
12 | PublicKeyPacket, | ||
13 | SecretKeyPacket, | ||
14 | CompressedDataPacket, | ||
15 | MarkerPacket, | ||
16 | LiteralDataPacket, | ||
17 | TrustPacket, | ||
18 | UserIDPacket, | ||
19 | EncryptedDataPacket, | ||
20 | ModificationDetectionCodePacket, | ||
21 | UnsupportedPacket, | ||
22 | compression_algorithm, | ||
23 | content, | ||
24 | encrypted_data, | ||
25 | filename, | ||
26 | format, | ||
27 | hash_algorithm, | ||
28 | hashed_subpackets, | ||
29 | hash_head, | ||
30 | key, | ||
31 | is_subkey, | ||
32 | v3_days_of_validity, | ||
33 | key_algorithm, | ||
34 | key_id, | ||
35 | message, | ||
36 | nested, | ||
37 | s2k_useage, | ||
38 | s2k, | ||
39 | signature, | ||
40 | signature_type, | ||
41 | symmetric_algorithm, | ||
42 | timestamp, | ||
43 | trailer, | ||
44 | unhashed_subpackets, | ||
45 | version | ||
46 | ), | ||
47 | isSignaturePacket, | ||
48 | signaturePacket, | ||
49 | Message(..), | ||
50 | SignatureSubpacket(..), | ||
51 | S2K(..), | ||
52 | string2key, | ||
53 | HashAlgorithm(..), | ||
54 | KeyAlgorithm(..), | ||
55 | SymmetricAlgorithm(..), | ||
56 | CompressionAlgorithm(..), | ||
57 | RevocationCode(..), | ||
58 | MPI(..), | ||
59 | find_key, | ||
60 | fingerprint_material, | ||
61 | SignatureOver(..), | ||
62 | signatures, | ||
63 | signature_issuer, | ||
64 | public_key_fields, | ||
65 | secret_key_fields | ||
66 | ) where | ||
67 | |||
68 | import Numeric | ||
69 | import Control.Monad | ||
70 | import Control.Arrow | ||
71 | import Control.Applicative | ||
72 | import Data.Monoid | ||
73 | import Data.Bits | ||
74 | import Data.Word | ||
75 | import Data.Char | ||
76 | import Data.List | ||
77 | import Data.Maybe | ||
78 | import Data.OpenPGP.Internal | ||
79 | import qualified Data.ByteString as BS | ||
80 | import qualified Data.ByteString.Lazy as LZ | ||
81 | |||
82 | #ifdef CEREAL | ||
83 | import Data.Serialize | ||
84 | import qualified Data.ByteString as B | ||
85 | import qualified Data.ByteString.UTF8 as B (toString, fromString) | ||
86 | #define BINARY_CLASS Serialize | ||
87 | #else | ||
88 | import Data.Binary | ||
89 | import Data.Binary.Get | ||
90 | import Data.Binary.Put | ||
91 | import qualified Data.ByteString.Lazy as B | ||
92 | import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString) | ||
93 | #define BINARY_CLASS Binary | ||
94 | #endif | ||
95 | |||
96 | import qualified Codec.Compression.Zlib.Raw as Zip | ||
97 | import qualified Codec.Compression.Zlib as Zlib | ||
98 | import qualified Codec.Compression.BZip as BZip2 | ||
99 | |||
100 | #ifdef CEREAL | ||
101 | getRemainingByteString :: Get B.ByteString | ||
102 | getRemainingByteString = remaining >>= getByteString | ||
103 | |||
104 | getSomeByteString :: Word64 -> Get B.ByteString | ||
105 | getSomeByteString = getByteString . fromIntegral | ||
106 | |||
107 | putSomeByteString :: B.ByteString -> Put | ||
108 | putSomeByteString = putByteString | ||
109 | |||
110 | localGet :: Get a -> B.ByteString -> Get a | ||
111 | localGet g bs = case runGet g bs of | ||
112 | Left s -> fail s | ||
113 | Right v -> return v | ||
114 | |||
115 | compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
116 | compress algo = toStrictBS . lazyCompress algo . toLazyBS | ||
117 | |||
118 | decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
119 | decompress algo = toStrictBS . lazyDecompress algo . toLazyBS | ||
120 | |||
121 | toStrictBS :: LZ.ByteString -> B.ByteString | ||
122 | toStrictBS = B.concat . LZ.toChunks | ||
123 | |||
124 | toLazyBS :: B.ByteString -> LZ.ByteString | ||
125 | toLazyBS = LZ.fromChunks . (:[]) | ||
126 | |||
127 | lazyEncode :: (Serialize a) => a -> LZ.ByteString | ||
128 | lazyEncode = toLazyBS . encode | ||
129 | #else | ||
130 | getRemainingByteString :: Get B.ByteString | ||
131 | getRemainingByteString = getRemainingLazyByteString | ||
132 | |||
133 | getSomeByteString :: Word64 -> Get B.ByteString | ||
134 | getSomeByteString = getLazyByteString . fromIntegral | ||
135 | |||
136 | putSomeByteString :: B.ByteString -> Put | ||
137 | putSomeByteString = putLazyByteString | ||
138 | |||
139 | #if MIN_VERSION_binary(0,6,4) | ||
140 | localGet :: Get a -> B.ByteString -> Get a | ||
141 | localGet g bs = case runGetOrFail g bs of | ||
142 | Left (_,_,s) -> fail s | ||
143 | Right (leftover,_,v) | ||
144 | | B.null leftover -> return v | ||
145 | | otherwise -> fail $ "Leftover in localGet: " ++ show leftover | ||
146 | #else | ||
147 | localGet :: Get a -> B.ByteString -> Get a | ||
148 | localGet g bs = return $ runGet g bs | ||
149 | #endif | ||
150 | |||
151 | compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
152 | compress = lazyCompress | ||
153 | |||
154 | decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
155 | decompress = lazyDecompress | ||
156 | |||
157 | lazyEncode :: (Binary a) => a -> LZ.ByteString | ||
158 | lazyEncode = encode | ||
159 | #endif | ||
160 | |||
161 | lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString | ||
162 | lazyCompress Uncompressed = id | ||
163 | lazyCompress ZIP = Zip.compress | ||
164 | lazyCompress ZLIB = Zlib.compress | ||
165 | lazyCompress BZip2 = BZip2.compress | ||
166 | lazyCompress x = error ("No implementation for " ++ show x) | ||
167 | |||
168 | lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString | ||
169 | lazyDecompress Uncompressed = id | ||
170 | lazyDecompress ZIP = Zip.decompress | ||
171 | lazyDecompress ZLIB = Zlib.decompress | ||
172 | lazyDecompress BZip2 = BZip2.decompress | ||
173 | lazyDecompress x = error ("No implementation for " ++ show x) | ||
174 | |||
175 | assertProp :: (Monad m, Show a) => (a -> Bool) -> a -> m a | ||
176 | assertProp f x | ||
177 | | f x = return $! x | ||
178 | | otherwise = fail $ "Assertion failed for: " ++ show x | ||
179 | |||
180 | pad :: Int -> String -> String | ||
181 | pad l s = replicate (l - length s) '0' ++ s | ||
182 | |||
183 | padBS :: Int -> B.ByteString -> B.ByteString | ||
184 | padBS l s = B.replicate (fromIntegral l - B.length s) 0 `B.append` s | ||
185 | |||
186 | checksum :: B.ByteString -> Word16 | ||
187 | checksum = fromIntegral . | ||
188 | B.foldl (\c i -> (c + fromIntegral i) `mod` 65536) (0::Integer) | ||
189 | |||
190 | data Packet = | ||
191 | AsymmetricSessionKeyPacket { | ||
192 | version::Word8, | ||
193 | key_id::String, | ||
194 | key_algorithm::KeyAlgorithm, | ||
195 | encrypted_data::B.ByteString | ||
196 | } | | ||
197 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.1> | ||
198 | SignaturePacket { | ||
199 | version::Word8, | ||
200 | signature_type::Word8, | ||
201 | key_algorithm::KeyAlgorithm, | ||
202 | hash_algorithm::HashAlgorithm, | ||
203 | hashed_subpackets::[SignatureSubpacket], | ||
204 | unhashed_subpackets::[SignatureSubpacket], | ||
205 | hash_head::Word16, | ||
206 | signature::[MPI], | ||
207 | trailer::B.ByteString | ||
208 | } | | ||
209 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.2> | ||
210 | SymmetricSessionKeyPacket { | ||
211 | version::Word8, | ||
212 | symmetric_algorithm::SymmetricAlgorithm, | ||
213 | s2k::S2K, | ||
214 | encrypted_data::B.ByteString | ||
215 | } | | ||
216 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.3> | ||
217 | OnePassSignaturePacket { | ||
218 | version::Word8, | ||
219 | signature_type::Word8, | ||
220 | hash_algorithm::HashAlgorithm, | ||
221 | key_algorithm::KeyAlgorithm, | ||
222 | key_id::String, | ||
223 | nested::Word8 | ||
224 | } | | ||
225 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.4> | ||
226 | PublicKeyPacket { | ||
227 | version::Word8, | ||
228 | timestamp::Word32, | ||
229 | key_algorithm::KeyAlgorithm, | ||
230 | key::[(Char,MPI)], | ||
231 | is_subkey::Bool, | ||
232 | v3_days_of_validity::Maybe Word16 | ||
233 | } | | ||
234 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.5.1.1> (also subkey) | ||
235 | SecretKeyPacket { | ||
236 | version::Word8, | ||
237 | timestamp::Word32, | ||
238 | key_algorithm::KeyAlgorithm, | ||
239 | key::[(Char,MPI)], | ||
240 | s2k_useage::Word8, | ||
241 | s2k::S2K, -- ^ This is meaningless if symmetric_algorithm == Unencrypted | ||
242 | symmetric_algorithm::SymmetricAlgorithm, | ||
243 | encrypted_data::B.ByteString, | ||
244 | is_subkey::Bool | ||
245 | } | | ||
246 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.5.1.3> (also subkey) | ||
247 | CompressedDataPacket { | ||
248 | compression_algorithm::CompressionAlgorithm, | ||
249 | message::Message | ||
250 | } | | ||
251 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.6> | ||
252 | MarkerPacket | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.8> | ||
253 | LiteralDataPacket { | ||
254 | format::Char, | ||
255 | filename::String, | ||
256 | timestamp::Word32, | ||
257 | content::B.ByteString | ||
258 | } | | ||
259 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.9> | ||
260 | TrustPacket B.ByteString | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.10> | ||
261 | UserIDPacket String | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.11> | ||
262 | EncryptedDataPacket { | ||
263 | version::Word8, | ||
264 | encrypted_data::B.ByteString | ||
265 | } | | ||
266 | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.13> | ||
267 | -- or <http://tools.ietf.org/html/rfc4880#section-5.7> when version is 0 | ||
268 | ModificationDetectionCodePacket B.ByteString | -- ^ <http://tools.ietf.org/html/rfc4880#section-5.14> | ||
269 | UnsupportedPacket Word8 B.ByteString | ||
270 | deriving (Show, Read, Eq) | ||
271 | |||
272 | instance BINARY_CLASS Packet where | ||
273 | put p = do | ||
274 | -- First two bits are 1 for new packet format | ||
275 | put ((tag .|. 0xC0) :: Word8) | ||
276 | case tag of | ||
277 | 19 -> put =<< assertProp (<192) (blen :: Word8) | ||
278 | _ -> do | ||
279 | -- Use 5-octet lengths | ||
280 | put (255 :: Word8) | ||
281 | put (blen :: Word32) | ||
282 | putSomeByteString body | ||
283 | where | ||
284 | blen :: (Num a) => a | ||
285 | blen = fromIntegral $ B.length body | ||
286 | (body, tag) = put_packet p | ||
287 | get = do | ||
288 | tag <- get | ||
289 | let (t, l) = | ||
290 | if (tag .&. 64) /= 0 then | ||
291 | (tag .&. 63, parse_new_length) | ||
292 | else | ||
293 | ((tag `shiftR` 2) .&. 15, (,) <$> parse_old_length tag <*> pure False) | ||
294 | packet <- uncurry get_packet_bytes =<< l | ||
295 | localGet (parse_packet t) (B.concat packet) | ||
296 | |||
297 | get_packet_bytes :: Maybe Word32 -> Bool -> Get [B.ByteString] | ||
298 | get_packet_bytes len partial = do | ||
299 | -- This forces the whole packet to be consumed | ||
300 | packet <- maybe getRemainingByteString (getSomeByteString . fromIntegral) len | ||
301 | if not partial then return [packet] else | ||
302 | (packet:) <$> (uncurry get_packet_bytes =<< parse_new_length) | ||
303 | |||
304 | -- http://tools.ietf.org/html/rfc4880#section-4.2.2 | ||
305 | parse_new_length :: Get (Maybe Word32, Bool) | ||
306 | parse_new_length = fmap (first Just) $ do | ||
307 | len <- fmap fromIntegral (get :: Get Word8) | ||
308 | case len of | ||
309 | -- One octet length | ||
310 | _ | len < 192 -> return (len, False) | ||
311 | -- Two octet length | ||
312 | _ | len > 191 && len < 224 -> do | ||
313 | second <- fmap fromIntegral (get :: Get Word8) | ||
314 | return (((len - 192) `shiftL` 8) + second + 192, False) | ||
315 | -- Five octet length | ||
316 | 255 -> (,) <$> (get :: Get Word32) <*> pure False | ||
317 | -- Partial length (streaming) | ||
318 | _ | len >= 224 && len < 255 -> | ||
319 | return (1 `shiftL` (fromIntegral len .&. 0x1F), True) | ||
320 | _ -> fail "Unsupported new packet length." | ||
321 | |||
322 | -- http://tools.ietf.org/html/rfc4880#section-4.2.1 | ||
323 | parse_old_length :: Word8 -> Get (Maybe Word32) | ||
324 | parse_old_length tag = | ||
325 | case tag .&. 3 of | ||
326 | -- One octet length | ||
327 | 0 -> fmap (Just . fromIntegral) (get :: Get Word8) | ||
328 | -- Two octet length | ||
329 | 1 -> fmap (Just . fromIntegral) (get :: Get Word16) | ||
330 | -- Four octet length | ||
331 | 2 -> fmap Just get | ||
332 | -- Indeterminate length | ||
333 | 3 -> return Nothing | ||
334 | -- Error | ||
335 | _ -> fail "Unsupported old packet length." | ||
336 | |||
337 | -- http://tools.ietf.org/html/rfc4880#section-5.5.2 | ||
338 | public_key_fields :: KeyAlgorithm -> [Char] | ||
339 | public_key_fields RSA = ['n', 'e'] | ||
340 | public_key_fields RSA_E = public_key_fields RSA | ||
341 | public_key_fields RSA_S = public_key_fields RSA | ||
342 | public_key_fields ELGAMAL = ['p', 'g', 'y'] | ||
343 | public_key_fields DSA = ['p', 'q', 'g', 'y'] | ||
344 | public_key_fields ECDSA = ['c','l','x', 'y'] | ||
345 | public_key_fields _ = undefined -- Nothing in the spec. Maybe empty | ||
346 | |||
347 | -- http://tools.ietf.org/html/rfc4880#section-5.5.3 | ||
348 | secret_key_fields :: KeyAlgorithm -> [Char] | ||
349 | secret_key_fields RSA = ['d', 'p', 'q', 'u'] | ||
350 | secret_key_fields RSA_E = secret_key_fields RSA | ||
351 | secret_key_fields RSA_S = secret_key_fields RSA | ||
352 | secret_key_fields ELGAMAL = ['x'] | ||
353 | secret_key_fields DSA = ['x'] | ||
354 | secret_key_fields ECDSA = ['d'] | ||
355 | secret_key_fields _ = undefined -- Nothing in the spec. Maybe empty | ||
356 | |||
357 | (!) :: (Eq k) => [(k,v)] -> k -> v | ||
358 | (!) xs k = let Just x = lookup k xs in x | ||
359 | |||
360 | -- Need this seperate for trailer calculation | ||
361 | signature_packet_start :: Packet -> B.ByteString | ||
362 | signature_packet_start (SignaturePacket { | ||
363 | version = 4, | ||
364 | signature_type = signature_type, | ||
365 | key_algorithm = key_algorithm, | ||
366 | hash_algorithm = hash_algorithm, | ||
367 | hashed_subpackets = hashed_subpackets | ||
368 | }) = | ||
369 | B.concat [ | ||
370 | encode (0x04 :: Word8), | ||
371 | encode signature_type, | ||
372 | encode key_algorithm, | ||
373 | encode hash_algorithm, | ||
374 | encode ((fromIntegral $ B.length hashed_subs) :: Word16), | ||
375 | hashed_subs | ||
376 | ] | ||
377 | where | ||
378 | hashed_subs = B.concat $ map encode hashed_subpackets | ||
379 | signature_packet_start x = | ||
380 | error ("Trying to get start of signature packet for: " ++ show x) | ||
381 | |||
382 | -- The trailer is just the top of the body plus some crap | ||
383 | calculate_signature_trailer :: Packet -> B.ByteString | ||
384 | calculate_signature_trailer (SignaturePacket { version = v, | ||
385 | signature_type = signature_type, | ||
386 | unhashed_subpackets = unhashed_subpackets | ||
387 | }) | v `elem` [2,3] = | ||
388 | B.concat [ | ||
389 | encode signature_type, | ||
390 | encode creation_time | ||
391 | ] | ||
392 | where | ||
393 | Just (SignatureCreationTimePacket creation_time) = find isCreation unhashed_subpackets | ||
394 | isCreation (SignatureCreationTimePacket {}) = True | ||
395 | isCreation _ = False | ||
396 | calculate_signature_trailer p@(SignaturePacket {version = 4}) = | ||
397 | B.concat [ | ||
398 | signature_packet_start p, | ||
399 | encode (0x04 :: Word8), | ||
400 | encode (0xff :: Word8), | ||
401 | encode (fromIntegral (B.length $ signature_packet_start p) :: Word32) | ||
402 | ] | ||
403 | calculate_signature_trailer x = | ||
404 | error ("Trying to calculate signature trailer for: " ++ show x) | ||
405 | |||
406 | |||
407 | encode_public_key_material :: Packet -> [B.ByteString] | ||
408 | encode_public_key_material k | key_algorithm k == ECDSA = do | ||
409 | -- http://tools.ietf.org/html/rfc6637 | ||
410 | c <- maybeToList $ lookup 'c' (key k) | ||
411 | MPI l <- maybeToList $ lookup 'l' (key k) | ||
412 | MPI x <- maybeToList $ lookup 'x' (key k) | ||
413 | MPI y <- maybeToList $ lookup 'y' (key k) | ||
414 | let (bitlen,oid) = B.splitAt 2 (encode c) | ||
415 | len16 = decode bitlen :: Word16 | ||
416 | (fullbytes,rembits) = len16 `quotRem` 8 | ||
417 | len8 = fromIntegral (fullbytes + if rembits/=0 then 1 else 0) :: Word8 | ||
418 | xy = 4*(4^l) + x*(2^l) + y | ||
419 | [ len8 `B.cons` oid, encode (MPI xy) ] | ||
420 | encode_public_key_material k = map (encode . (key k !)) (public_key_fields $ key_algorithm k) | ||
421 | |||
422 | decode_public_key_material :: KeyAlgorithm -> Get [(Char,MPI)] | ||
423 | decode_public_key_material ECDSA = do | ||
424 | -- http://tools.ietf.org/html/rfc6637 | ||
425 | oidlen <- get :: Get Word8 | ||
426 | oidbytes <- getSomeByteString (fromIntegral oidlen) | ||
427 | let mpiFromBytes bytes = MPI (B.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bytes) | ||
428 | oid = mpiFromBytes oidbytes | ||
429 | MPI xy <- get | ||
430 | let integerBytesize i = fromIntegral $ LZ.length (encode (MPI i)) - 2 | ||
431 | width = ( integerBytesize xy - 1 ) `div` 2 | ||
432 | (fx,y) = xy `quotRem` (256^width) | ||
433 | x = fx `rem` (256^width) | ||
434 | l = width*8 | ||
435 | return [('c',oid), ('l',MPI l), ('x',MPI x), ('y',MPI y)] | ||
436 | decode_public_key_material algorithm = mapM (\f -> fmap ((,)f) get) (public_key_fields algorithm) | ||
437 | |||
438 | put_packet :: Packet -> (B.ByteString, Word8) | ||
439 | put_packet (AsymmetricSessionKeyPacket version key_id key_algorithm dta) = | ||
440 | (B.concat [ | ||
441 | encode version, | ||
442 | encode (fst $ head $ readHex $ takeFromEnd 16 key_id :: Word64), | ||
443 | encode key_algorithm, | ||
444 | dta | ||
445 | ], 1) | ||
446 | put_packet (SignaturePacket { version = v, | ||
447 | unhashed_subpackets = unhashed_subpackets, | ||
448 | key_algorithm = key_algorithm, | ||
449 | hash_algorithm = hash_algorithm, | ||
450 | hash_head = hash_head, | ||
451 | signature = signature, | ||
452 | trailer = trailer }) | v `elem` [2,3] = | ||
453 | -- TODO: Assert that there are no subpackets we cannot encode? | ||
454 | (B.concat $ [ | ||
455 | B.singleton v, | ||
456 | B.singleton 0x05, | ||
457 | trailer, -- signature_type and creation_time | ||
458 | encode keyid, | ||
459 | encode key_algorithm, | ||
460 | encode hash_algorithm, | ||
461 | encode hash_head | ||
462 | ] ++ map encode signature, 2) | ||
463 | where | ||
464 | keyid = fst $ head $ readHex $ takeFromEnd 16 keyidS :: Word64 | ||
465 | Just (IssuerPacket keyidS) = find isIssuer unhashed_subpackets | ||
466 | isIssuer (IssuerPacket {}) = True | ||
467 | isIssuer _ = False | ||
468 | put_packet (SymmetricSessionKeyPacket version salgo s2k encd) = | ||
469 | (B.concat [encode version, encode salgo, encode s2k, encd], 3) | ||
470 | put_packet (SignaturePacket { version = 4, | ||
471 | unhashed_subpackets = unhashed_subpackets, | ||
472 | hash_head = hash_head, | ||
473 | signature = signature, | ||
474 | trailer = trailer }) = | ||
475 | (B.concat $ [ | ||
476 | trailer_top, | ||
477 | encode (fromIntegral $ B.length unhashed :: Word16), | ||
478 | unhashed, encode hash_head | ||
479 | ] ++ map encode signature, 2) | ||
480 | where | ||
481 | trailer_top = B.reverse $ B.drop 6 $ B.reverse trailer | ||
482 | unhashed = B.concat $ map encode unhashed_subpackets | ||
483 | put_packet (OnePassSignaturePacket { version = version, | ||
484 | signature_type = signature_type, | ||
485 | hash_algorithm = hash_algorithm, | ||
486 | key_algorithm = key_algorithm, | ||
487 | key_id = key_id, | ||
488 | nested = nested }) = | ||
489 | (B.concat [ | ||
490 | encode version, encode signature_type, | ||
491 | encode hash_algorithm, encode key_algorithm, | ||
492 | encode (fst $ head $ readHex $ takeFromEnd 16 key_id :: Word64), | ||
493 | encode nested | ||
494 | ], 4) | ||
495 | put_packet (SecretKeyPacket { version = version, timestamp = timestamp, | ||
496 | key_algorithm = algorithm, key = key, | ||
497 | s2k_useage = s2k_useage, s2k = s2k, | ||
498 | symmetric_algorithm = symmetric_algorithm, | ||
499 | encrypted_data = encrypted_data, | ||
500 | is_subkey = is_subkey }) = | ||
501 | (B.concat $ p : | ||
502 | (if s2k_useage `elem` [254,255] then | ||
503 | [encode s2k_useage, encode symmetric_algorithm, encode s2k] | ||
504 | else | ||
505 | [encode symmetric_algorithm] | ||
506 | ) ++ | ||
507 | (if symmetric_algorithm /= Unencrypted then | ||
508 | -- For V3 keys, the "encrypted data" has an unencrypted checksum | ||
509 | -- of the unencrypted MPIs on the end | ||
510 | [encrypted_data] | ||
511 | else s ++ | ||
512 | [encode $ checksum $ B.concat s]), | ||
513 | if is_subkey then 7 else 5) | ||
514 | where | ||
515 | p = fst (put_packet $ | ||
516 | PublicKeyPacket version timestamp algorithm key False Nothing) | ||
517 | s = map (encode . (key !)) (secret_key_fields algorithm) | ||
518 | put_packet p@(PublicKeyPacket { version = v, timestamp = timestamp, | ||
519 | key_algorithm = algorithm, key = key, | ||
520 | is_subkey = is_subkey }) | ||
521 | | v == 3 = | ||
522 | final (B.concat $ [ | ||
523 | B.singleton 3, encode timestamp, | ||
524 | encode v3_days, | ||
525 | encode algorithm | ||
526 | ] ++ material) | ||
527 | | v == 4 = | ||
528 | final (B.concat $ [ | ||
529 | B.singleton 4, encode timestamp, encode algorithm | ||
530 | ] ++ material) | ||
531 | where | ||
532 | Just v3_days = v3_days_of_validity p | ||
533 | final x = (x, if is_subkey then 14 else 6) | ||
534 | material = encode_public_key_material p | ||
535 | put_packet (CompressedDataPacket { compression_algorithm = algorithm, | ||
536 | message = message }) = | ||
537 | (B.append (encode algorithm) $ compress algorithm $ encode message, 8) | ||
538 | put_packet MarkerPacket = (B.fromString "PGP", 10) | ||
539 | put_packet (LiteralDataPacket { format = format, filename = filename, | ||
540 | timestamp = timestamp, content = content | ||
541 | }) = | ||
542 | (B.concat [ | ||
543 | encode format, encode filename_l, lz_filename, | ||
544 | encode timestamp, content | ||
545 | ], 11) | ||
546 | where | ||
547 | filename_l = (fromIntegral $ B.length lz_filename) :: Word8 | ||
548 | lz_filename = B.fromString filename | ||
549 | put_packet (TrustPacket bytes) = (bytes, 12) | ||
550 | put_packet (UserIDPacket txt) = (B.fromString txt, 13) | ||
551 | put_packet (EncryptedDataPacket 0 encrypted_data) = (encrypted_data, 9) | ||
552 | put_packet (EncryptedDataPacket version encrypted_data) = | ||
553 | (B.concat [encode version, encrypted_data], 18) | ||
554 | put_packet (ModificationDetectionCodePacket bstr) = (bstr, 19) | ||
555 | put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag) | ||
556 | put_packet x = error ("Unsupported Packet version or type in put_packet: " ++ show x) | ||
557 | |||
558 | parse_packet :: Word8 -> Get Packet | ||
559 | -- AsymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.1 | ||
560 | parse_packet 1 = AsymmetricSessionKeyPacket | ||
561 | <$> (assertProp (==3) =<< get) | ||
562 | <*> fmap (pad 16 . map toUpper . flip showHex "") (get :: Get Word64) | ||
563 | <*> get | ||
564 | <*> getRemainingByteString | ||
565 | -- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2 | ||
566 | parse_packet 2 = do | ||
567 | version <- get | ||
568 | case version of | ||
569 | _ | version `elem` [2,3] -> do | ||
570 | _ <- assertProp (==5) =<< (get :: Get Word8) | ||
571 | signature_type <- get | ||
572 | creation_time <- get :: Get Word32 | ||
573 | keyid <- get :: Get Word64 | ||
574 | key_algorithm <- get | ||
575 | hash_algorithm <- get | ||
576 | hash_head <- get | ||
577 | signature <- listUntilEnd | ||
578 | return SignaturePacket { | ||
579 | version = version, | ||
580 | signature_type = signature_type, | ||
581 | key_algorithm = key_algorithm, | ||
582 | hash_algorithm = hash_algorithm, | ||
583 | hashed_subpackets = [], | ||
584 | unhashed_subpackets = [ | ||
585 | SignatureCreationTimePacket creation_time, | ||
586 | IssuerPacket $ pad 16 $ map toUpper $ showHex keyid "" | ||
587 | ], | ||
588 | hash_head = hash_head, | ||
589 | signature = signature, | ||
590 | trailer = B.concat [encode signature_type, encode creation_time] | ||
591 | } | ||
592 | 4 -> do | ||
593 | signature_type <- get | ||
594 | key_algorithm <- get | ||
595 | hash_algorithm <- get | ||
596 | hashed_size <- fmap fromIntegral (get :: Get Word16) | ||
597 | hashed_data <- getSomeByteString hashed_size | ||
598 | hashed <- localGet listUntilEnd hashed_data | ||
599 | unhashed_size <- fmap fromIntegral (get :: Get Word16) | ||
600 | unhashed_data <- getSomeByteString unhashed_size | ||
601 | unhashed <- localGet listUntilEnd unhashed_data | ||
602 | hash_head <- get | ||
603 | signature <- listUntilEnd | ||
604 | return SignaturePacket { | ||
605 | version = version, | ||
606 | signature_type = signature_type, | ||
607 | key_algorithm = key_algorithm, | ||
608 | hash_algorithm = hash_algorithm, | ||
609 | hashed_subpackets = hashed, | ||
610 | unhashed_subpackets = unhashed, | ||
611 | hash_head = hash_head, | ||
612 | signature = signature, | ||
613 | 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)] | ||
614 | } | ||
615 | x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "." | ||
616 | -- SymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.3 | ||
617 | parse_packet 3 = SymmetricSessionKeyPacket | ||
618 | <$> (assertProp (==4) =<< get) | ||
619 | <*> get | ||
620 | <*> get | ||
621 | <*> getRemainingByteString | ||
622 | -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 | ||
623 | parse_packet 4 = do | ||
624 | version <- get | ||
625 | signature_type <- get | ||
626 | hash_algo <- get | ||
627 | key_algo <- get | ||
628 | key_id <- get :: Get Word64 | ||
629 | nested <- get | ||
630 | return OnePassSignaturePacket { | ||
631 | version = version, | ||
632 | signature_type = signature_type, | ||
633 | hash_algorithm = hash_algo, | ||
634 | key_algorithm = key_algo, | ||
635 | key_id = pad 16 $ map toUpper $ showHex key_id "", | ||
636 | nested = nested | ||
637 | } | ||
638 | -- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3 | ||
639 | parse_packet 5 = do | ||
640 | -- Parse PublicKey part | ||
641 | (PublicKeyPacket { | ||
642 | version = version, | ||
643 | timestamp = timestamp, | ||
644 | key_algorithm = algorithm, | ||
645 | key = key | ||
646 | }) <- parse_packet 6 | ||
647 | s2k_useage <- get :: Get Word8 | ||
648 | let k = SecretKeyPacket version timestamp algorithm key s2k_useage | ||
649 | (symmetric_algorithm, s2k) <- case () of | ||
650 | _ | s2k_useage `elem` [255, 254] -> (,) <$> get <*> get | ||
651 | _ | s2k_useage > 0 -> | ||
652 | -- s2k_useage is symmetric_type in this case | ||
653 | (,) <$> localGet get (encode s2k_useage) <*> pure (SimpleS2K MD5) | ||
654 | _ -> | ||
655 | return (Unencrypted, S2K 100 B.empty) | ||
656 | if symmetric_algorithm /= Unencrypted then do { | ||
657 | encrypted <- getRemainingByteString; | ||
658 | return (k s2k symmetric_algorithm encrypted False) | ||
659 | } else do | ||
660 | skey <- foldM (\m f -> do | ||
661 | mpi <- get :: Get MPI | ||
662 | return $ (f,mpi):m) [] (secret_key_fields algorithm) | ||
663 | chk <- get | ||
664 | when (checksum (B.concat $ map (encode . snd) skey) /= chk) $ | ||
665 | fail "Checksum verification failed for unencrypted secret key" | ||
666 | return ((k s2k symmetric_algorithm B.empty False) {key = key ++ skey}) | ||
667 | -- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2 | ||
668 | parse_packet 6 = do | ||
669 | version <- get :: Get Word8 | ||
670 | case version of | ||
671 | 3 -> do | ||
672 | timestamp <- get | ||
673 | days <- get | ||
674 | algorithm <- get | ||
675 | key <- decode_public_key_material algorithm | ||
676 | return PublicKeyPacket { | ||
677 | version = version, | ||
678 | timestamp = timestamp, | ||
679 | key_algorithm = algorithm, | ||
680 | key = key, | ||
681 | is_subkey = False, | ||
682 | v3_days_of_validity = Just days | ||
683 | } | ||
684 | 4 -> do | ||
685 | timestamp <- get | ||
686 | algorithm <- get | ||
687 | key <- decode_public_key_material algorithm | ||
688 | return PublicKeyPacket { | ||
689 | version = 4, | ||
690 | timestamp = timestamp, | ||
691 | key_algorithm = algorithm, | ||
692 | key = key, | ||
693 | is_subkey = False, | ||
694 | v3_days_of_validity = Nothing | ||
695 | } | ||
696 | x -> fail $ "Unsupported PublicKeyPacket version " ++ show x ++ "." | ||
697 | -- Secret-SubKey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.4 | ||
698 | parse_packet 7 = do | ||
699 | p <- parse_packet 5 | ||
700 | return p {is_subkey = True} | ||
701 | -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 | ||
702 | parse_packet 8 = do | ||
703 | algorithm <- get | ||
704 | message <- localGet get =<< (decompress algorithm <$> getRemainingByteString) | ||
705 | return CompressedDataPacket { | ||
706 | compression_algorithm = algorithm, | ||
707 | message = message | ||
708 | } | ||
709 | -- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.7 | ||
710 | parse_packet 9 = EncryptedDataPacket 0 <$> getRemainingByteString | ||
711 | -- MarkerPacket, http://tools.ietf.org/html/rfc4880#section-5.8 | ||
712 | parse_packet 10 = return MarkerPacket | ||
713 | -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9 | ||
714 | parse_packet 11 = do | ||
715 | format <- get | ||
716 | filenameLength <- get :: Get Word8 | ||
717 | filename <- getSomeByteString (fromIntegral filenameLength) | ||
718 | timestamp <- get | ||
719 | content <- getRemainingByteString | ||
720 | return LiteralDataPacket { | ||
721 | format = format, | ||
722 | filename = B.toString filename, | ||
723 | timestamp = timestamp, | ||
724 | content = content | ||
725 | } | ||
726 | -- TrustPacket, http://tools.ietf.org/html/rfc4880#section-5.10 | ||
727 | parse_packet 12 = fmap TrustPacket getRemainingByteString | ||
728 | -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 | ||
729 | parse_packet 13 = | ||
730 | fmap (UserIDPacket . B.toString) getRemainingByteString | ||
731 | -- Public-Subkey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.2 | ||
732 | parse_packet 14 = do | ||
733 | p <- parse_packet 6 | ||
734 | return p {is_subkey = True} | ||
735 | -- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.13 | ||
736 | parse_packet 18 = EncryptedDataPacket <$> get <*> getRemainingByteString | ||
737 | -- ModificationDetectionCodePacket, http://tools.ietf.org/html/rfc4880#section-5.14 | ||
738 | parse_packet 19 = | ||
739 | fmap ModificationDetectionCodePacket getRemainingByteString | ||
740 | -- Represent unsupported packets as their tag and literal bytes | ||
741 | parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString | ||
742 | |||
743 | -- | Helper method for fingerprints and such | ||
744 | fingerprint_material :: Packet -> [B.ByteString] | ||
745 | fingerprint_material p | version p == 4 = | ||
746 | [ | ||
747 | B.singleton 0x99, | ||
748 | encode (6 + fromIntegral (B.length material) :: Word16), | ||
749 | B.singleton 4, encode (timestamp p), encode (key_algorithm p), | ||
750 | material | ||
751 | ] | ||
752 | where | ||
753 | material = B.concat $ encode_public_key_material p | ||
754 | fingerprint_material p | version p `elem` [2, 3] = [n, e] | ||
755 | where | ||
756 | n = B.drop 2 (encode (key p ! 'n')) | ||
757 | e = B.drop 2 (encode (key p ! 'e')) | ||
758 | fingerprint_material _ = | ||
759 | error "Unsupported Packet version or type in fingerprint_material." | ||
760 | |||
761 | enum_to_word8 :: (Enum a) => a -> Word8 | ||
762 | enum_to_word8 = fromIntegral . fromEnum | ||
763 | |||
764 | enum_from_word8 :: (Enum a) => Word8 -> a | ||
765 | enum_from_word8 = toEnum . fromIntegral | ||
766 | |||
767 | data S2K = | ||
768 | SimpleS2K HashAlgorithm | | ||
769 | SaltedS2K HashAlgorithm Word64 | | ||
770 | IteratedSaltedS2K HashAlgorithm Word64 Word32 | | ||
771 | S2K Word8 B.ByteString | ||
772 | deriving (Show, Read, Eq) | ||
773 | |||
774 | instance BINARY_CLASS S2K where | ||
775 | put (SimpleS2K halgo) = put (0::Word8) >> put halgo | ||
776 | put (SaltedS2K halgo salt) = put (1::Word8) >> put halgo >> put salt | ||
777 | put (IteratedSaltedS2K halgo salt count) = put (3::Word8) >> put halgo | ||
778 | >> put salt >> put (encode_s2k_count count) | ||
779 | put (S2K t body) = put t >> putSomeByteString body | ||
780 | |||
781 | get = do | ||
782 | t <- get :: Get Word8 | ||
783 | case t of | ||
784 | 0 -> SimpleS2K <$> get | ||
785 | 1 -> SaltedS2K <$> get <*> get | ||
786 | 3 -> IteratedSaltedS2K <$> get <*> get <*> (decode_s2k_count <$> get) | ||
787 | _ -> S2K t <$> getRemainingByteString | ||
788 | |||
789 | -- | Take a hash function and an 'S2K' value and generate the bytes | ||
790 | -- needed for creating a symmetric key. | ||
791 | -- | ||
792 | -- Return value is always infinite length. | ||
793 | -- Take the first n bytes you need for your keysize. | ||
794 | string2key :: (HashAlgorithm -> LZ.ByteString -> BS.ByteString) -> S2K -> LZ.ByteString -> LZ.ByteString | ||
795 | string2key hsh (SimpleS2K halgo) s = infiniHashes (hsh halgo) s | ||
796 | string2key hsh (SaltedS2K halgo salt) s = | ||
797 | infiniHashes (hsh halgo) (lazyEncode salt `LZ.append` s) | ||
798 | string2key hsh (IteratedSaltedS2K halgo salt count) s = | ||
799 | infiniHashes (hsh halgo) $ | ||
800 | LZ.take (max (fromIntegral count) (LZ.length s)) | ||
801 | (LZ.cycle $ lazyEncode salt `LZ.append` s) | ||
802 | string2key _ s2k _ = error $ "Unsupported S2K specifier: " ++ show s2k | ||
803 | |||
804 | infiniHashes :: (LZ.ByteString -> BS.ByteString) -> LZ.ByteString -> LZ.ByteString | ||
805 | infiniHashes hsh s = LZ.fromChunks (hs 0) | ||
806 | where | ||
807 | hs c = hsh (LZ.replicate c 0 `LZ.append` s) : hs (c+1) | ||
808 | |||
809 | data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | HashAlgorithm Word8 | ||
810 | deriving (Show, Read, Eq) | ||
811 | |||
812 | instance Enum HashAlgorithm where | ||
813 | toEnum 01 = MD5 | ||
814 | toEnum 02 = SHA1 | ||
815 | toEnum 03 = RIPEMD160 | ||
816 | toEnum 08 = SHA256 | ||
817 | toEnum 09 = SHA384 | ||
818 | toEnum 10 = SHA512 | ||
819 | toEnum 11 = SHA224 | ||
820 | toEnum x = HashAlgorithm $ fromIntegral x | ||
821 | fromEnum MD5 = 01 | ||
822 | fromEnum SHA1 = 02 | ||
823 | fromEnum RIPEMD160 = 03 | ||
824 | fromEnum SHA256 = 08 | ||
825 | fromEnum SHA384 = 09 | ||
826 | fromEnum SHA512 = 10 | ||
827 | fromEnum SHA224 = 11 | ||
828 | fromEnum (HashAlgorithm x) = fromIntegral x | ||
829 | |||
830 | instance BINARY_CLASS HashAlgorithm where | ||
831 | put = put . enum_to_word8 | ||
832 | get = fmap enum_from_word8 get | ||
833 | |||
834 | data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | KeyAlgorithm Word8 | ||
835 | deriving (Show, Read, Eq) | ||
836 | |||
837 | instance Enum KeyAlgorithm where | ||
838 | toEnum 01 = RSA | ||
839 | toEnum 02 = RSA_E | ||
840 | toEnum 03 = RSA_S | ||
841 | toEnum 16 = ELGAMAL | ||
842 | toEnum 17 = DSA | ||
843 | toEnum 18 = ECC | ||
844 | toEnum 19 = ECDSA | ||
845 | toEnum 21 = DH | ||
846 | toEnum x = KeyAlgorithm $ fromIntegral x | ||
847 | fromEnum RSA = 01 | ||
848 | fromEnum RSA_E = 02 | ||
849 | fromEnum RSA_S = 03 | ||
850 | fromEnum ELGAMAL = 16 | ||
851 | fromEnum DSA = 17 | ||
852 | fromEnum ECC = 18 | ||
853 | fromEnum ECDSA = 19 | ||
854 | fromEnum DH = 21 | ||
855 | fromEnum (KeyAlgorithm x) = fromIntegral x | ||
856 | |||
857 | instance BINARY_CLASS KeyAlgorithm where | ||
858 | put = put . enum_to_word8 | ||
859 | get = fmap enum_from_word8 get | ||
860 | |||
861 | data SymmetricAlgorithm = Unencrypted | IDEA | TripleDES | CAST5 | Blowfish | AES128 | AES192 | AES256 | Twofish | SymmetricAlgorithm Word8 | ||
862 | deriving (Show, Read, Eq) | ||
863 | |||
864 | instance Enum SymmetricAlgorithm where | ||
865 | toEnum 00 = Unencrypted | ||
866 | toEnum 01 = IDEA | ||
867 | toEnum 02 = TripleDES | ||
868 | toEnum 03 = CAST5 | ||
869 | toEnum 04 = Blowfish | ||
870 | toEnum 07 = AES128 | ||
871 | toEnum 08 = AES192 | ||
872 | toEnum 09 = AES256 | ||
873 | toEnum 10 = Twofish | ||
874 | toEnum x = SymmetricAlgorithm $ fromIntegral x | ||
875 | fromEnum Unencrypted = 00 | ||
876 | fromEnum IDEA = 01 | ||
877 | fromEnum TripleDES = 02 | ||
878 | fromEnum CAST5 = 03 | ||
879 | fromEnum Blowfish = 04 | ||
880 | fromEnum AES128 = 07 | ||
881 | fromEnum AES192 = 08 | ||
882 | fromEnum AES256 = 09 | ||
883 | fromEnum Twofish = 10 | ||
884 | fromEnum (SymmetricAlgorithm x) = fromIntegral x | ||
885 | |||
886 | instance BINARY_CLASS SymmetricAlgorithm where | ||
887 | put = put . enum_to_word8 | ||
888 | get = fmap enum_from_word8 get | ||
889 | |||
890 | data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | CompressionAlgorithm Word8 | ||
891 | deriving (Show, Read, Eq) | ||
892 | |||
893 | instance Enum CompressionAlgorithm where | ||
894 | toEnum 0 = Uncompressed | ||
895 | toEnum 1 = ZIP | ||
896 | toEnum 2 = ZLIB | ||
897 | toEnum 3 = BZip2 | ||
898 | toEnum x = CompressionAlgorithm $ fromIntegral x | ||
899 | fromEnum Uncompressed = 0 | ||
900 | fromEnum ZIP = 1 | ||
901 | fromEnum ZLIB = 2 | ||
902 | fromEnum BZip2 = 3 | ||
903 | fromEnum (CompressionAlgorithm x) = fromIntegral x | ||
904 | |||
905 | instance BINARY_CLASS CompressionAlgorithm where | ||
906 | put = put . enum_to_word8 | ||
907 | get = fmap enum_from_word8 get | ||
908 | |||
909 | data RevocationCode = NoReason | KeySuperseded | KeyCompromised | KeyRetired | UserIDInvalid | RevocationCode Word8 deriving (Show, Read, Eq) | ||
910 | |||
911 | instance Enum RevocationCode where | ||
912 | toEnum 00 = NoReason | ||
913 | toEnum 01 = KeySuperseded | ||
914 | toEnum 02 = KeyCompromised | ||
915 | toEnum 03 = KeyRetired | ||
916 | toEnum 32 = UserIDInvalid | ||
917 | toEnum x = RevocationCode $ fromIntegral x | ||
918 | fromEnum NoReason = 00 | ||
919 | fromEnum KeySuperseded = 01 | ||
920 | fromEnum KeyCompromised = 02 | ||
921 | fromEnum KeyRetired = 03 | ||
922 | fromEnum UserIDInvalid = 32 | ||
923 | fromEnum (RevocationCode x) = fromIntegral x | ||
924 | |||
925 | instance BINARY_CLASS RevocationCode where | ||
926 | put = put . enum_to_word8 | ||
927 | get = fmap enum_from_word8 get | ||
928 | |||
929 | -- | A message is encoded as a list that takes the entire file | ||
930 | newtype Message = Message [Packet] deriving (Show, Read, Eq) | ||
931 | instance BINARY_CLASS Message where | ||
932 | put (Message xs) = mapM_ put xs | ||
933 | get = fmap Message listUntilEnd | ||
934 | |||
935 | instance Monoid Message where | ||
936 | mempty = Message [] | ||
937 | mappend (Message a) (Message b) = Message (a ++ b) | ||
938 | |||
939 | -- | Data needed to verify a signature | ||
940 | data SignatureOver = | ||
941 | DataSignature {literal::Packet, signatures_over::[Packet]} | | ||
942 | KeySignature {topkey::Packet, signatures_over::[Packet]} | | ||
943 | SubkeySignature {topkey::Packet, subkey::Packet, signatures_over::[Packet]} | | ||
944 | CertificationSignature {topkey::Packet, user_id::Packet, signatures_over::[Packet]} | ||
945 | deriving (Show, Read, Eq) | ||
946 | |||
947 | -- To get the signed-over bytes | ||
948 | instance BINARY_CLASS SignatureOver where | ||
949 | put (DataSignature (LiteralDataPacket {content = c}) _) = | ||
950 | putSomeByteString c | ||
951 | put (KeySignature k _) = mapM_ putSomeByteString (fingerprint_material k) | ||
952 | put (SubkeySignature k s _) = mapM_ (mapM_ putSomeByteString) | ||
953 | [fingerprint_material k, fingerprint_material s] | ||
954 | put (CertificationSignature k (UserIDPacket s) _) = | ||
955 | mapM_ (mapM_ putSomeByteString) [fingerprint_material k, [ | ||
956 | B.singleton 0xB4, | ||
957 | encode ((fromIntegral $ B.length bs) :: Word32), | ||
958 | bs | ||
959 | ]] | ||
960 | where | ||
961 | bs = B.fromString s | ||
962 | put x = fail $ "Malformed signature: " ++ show x | ||
963 | get = fail "Cannot meaningfully parse bytes to be signed over." | ||
964 | |||
965 | -- | Extract signed objects from a well-formatted message | ||
966 | -- | ||
967 | -- Recurses into CompressedDataPacket | ||
968 | -- | ||
969 | -- <http://tools.ietf.org/html/rfc4880#section-11> | ||
970 | signatures :: Message -> [SignatureOver] | ||
971 | signatures (Message [CompressedDataPacket _ m]) = signatures m | ||
972 | signatures (Message ps) = | ||
973 | maybe (paired_sigs Nothing ps) (\p -> [DataSignature p sigs]) (find isDta ps) | ||
974 | where | ||
975 | sigs = filter isSignaturePacket ps | ||
976 | isDta (LiteralDataPacket {}) = True | ||
977 | isDta _ = False | ||
978 | |||
979 | -- TODO: UserAttribute | ||
980 | paired_sigs :: Maybe Packet -> [Packet] -> [SignatureOver] | ||
981 | paired_sigs _ [] = [] | ||
982 | paired_sigs _ (p@(PublicKeyPacket {is_subkey = False}):ps) = | ||
983 | KeySignature p (takeWhile isSignaturePacket ps) : | ||
984 | paired_sigs (Just p) (dropWhile isSignaturePacket ps) | ||
985 | paired_sigs _ (p@(SecretKeyPacket {is_subkey = False}):ps) = | ||
986 | KeySignature p (takeWhile isSignaturePacket ps) : | ||
987 | paired_sigs (Just p) (dropWhile isSignaturePacket ps) | ||
988 | paired_sigs (Just k) (p@(PublicKeyPacket {is_subkey = True}):ps) = | ||
989 | SubkeySignature k p (takeWhile isSignaturePacket ps) : | ||
990 | paired_sigs (Just k) (dropWhile isSignaturePacket ps) | ||
991 | paired_sigs (Just k) (p@(SecretKeyPacket {is_subkey = True}):ps) = | ||
992 | SubkeySignature k p (takeWhile isSignaturePacket ps) : | ||
993 | paired_sigs (Just k) (dropWhile isSignaturePacket ps) | ||
994 | paired_sigs (Just k) (p@(UserIDPacket {}):ps) = | ||
995 | CertificationSignature k p (takeWhile isSignaturePacket ps) : | ||
996 | paired_sigs (Just k) (dropWhile isSignaturePacket ps) | ||
997 | paired_sigs k (_:ps) = paired_sigs k ps | ||
998 | |||
999 | -- | <http://tools.ietf.org/html/rfc4880#section-3.2> | ||
1000 | newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) | ||
1001 | instance BINARY_CLASS MPI where | ||
1002 | put (MPI i) | ||
1003 | | i >= 0 = do | ||
1004 | put (bitl :: Word16) | ||
1005 | putSomeByteString bytes | ||
1006 | | otherwise = fail $ "MPI is less than 0: " ++ show i | ||
1007 | where | ||
1008 | (bytes, bitl) | ||
1009 | | B.null bytes' = (B.singleton 0, 1) | ||
1010 | | otherwise = | ||
1011 | (bytes', (fromIntegral (B.length bytes') - 1) * 8 + sigBit) | ||
1012 | |||
1013 | sigBit = fst $ until ((==0) . snd) | ||
1014 | (first (+1) . second (`shiftR` 1)) (0,B.index bytes 0) | ||
1015 | bytes' = B.reverse $ B.unfoldr (\x -> | ||
1016 | if x == 0 then Nothing else | ||
1017 | Just (fromIntegral x, x `shiftR` 8) | ||
1018 | ) i | ||
1019 | get = do | ||
1020 | length <- fmap fromIntegral (get :: Get Word16) | ||
1021 | bytes <- getSomeByteString =<< assertProp (>0) ((length + 7) `div` 8) | ||
1022 | return (MPI (B.foldl (\a b -> | ||
1023 | a `shiftL` 8 .|. fromIntegral b) 0 bytes)) | ||
1024 | |||
1025 | listUntilEnd :: (BINARY_CLASS a) => Get [a] | ||
1026 | listUntilEnd = do | ||
1027 | done <- isEmpty | ||
1028 | if done then return [] else do | ||
1029 | next <- get | ||
1030 | rest <- listUntilEnd | ||
1031 | return (next:rest) | ||
1032 | |||
1033 | -- | <http://tools.ietf.org/html/rfc4880#section-5.2.3.1> | ||
1034 | data SignatureSubpacket = | ||
1035 | SignatureCreationTimePacket Word32 | | ||
1036 | SignatureExpirationTimePacket Word32 | -- ^ seconds after CreationTime | ||
1037 | ExportableCertificationPacket Bool | | ||
1038 | TrustSignaturePacket {depth::Word8, trust::Word8} | | ||
1039 | RegularExpressionPacket String | | ||
1040 | RevocablePacket Bool | | ||
1041 | KeyExpirationTimePacket Word32 | -- ^ seconds after key CreationTime | ||
1042 | PreferredSymmetricAlgorithmsPacket [SymmetricAlgorithm] | | ||
1043 | RevocationKeyPacket { | ||
1044 | sensitive::Bool, | ||
1045 | revocation_key_algorithm::KeyAlgorithm, | ||
1046 | revocation_key_fingerprint::String | ||
1047 | } | | ||
1048 | IssuerPacket String | | ||
1049 | NotationDataPacket { | ||
1050 | human_readable::Bool, | ||
1051 | notation_name::String, | ||
1052 | notation_value::String | ||
1053 | } | | ||
1054 | PreferredHashAlgorithmsPacket [HashAlgorithm] | | ||
1055 | PreferredCompressionAlgorithmsPacket [CompressionAlgorithm] | | ||
1056 | KeyServerPreferencesPacket {keyserver_no_modify::Bool} | | ||
1057 | PreferredKeyServerPacket String | | ||
1058 | PrimaryUserIDPacket Bool | | ||
1059 | PolicyURIPacket String | | ||
1060 | KeyFlagsPacket { | ||
1061 | certify_keys::Bool, | ||
1062 | sign_data::Bool, | ||
1063 | encrypt_communication::Bool, | ||
1064 | encrypt_storage::Bool, | ||
1065 | split_key::Bool, | ||
1066 | authentication::Bool, | ||
1067 | group_key::Bool | ||
1068 | } | | ||
1069 | SignerUserIDPacket String | | ||
1070 | ReasonForRevocationPacket RevocationCode String | | ||
1071 | FeaturesPacket {supports_mdc::Bool} | | ||
1072 | SignatureTargetPacket { | ||
1073 | target_key_algorithm::KeyAlgorithm, | ||
1074 | target_hash_algorithm::HashAlgorithm, | ||
1075 | hash::B.ByteString | ||
1076 | } | | ||
1077 | EmbeddedSignaturePacket Packet | | ||
1078 | UnsupportedSignatureSubpacket Word8 B.ByteString | ||
1079 | deriving (Show, Read, Eq) | ||
1080 | |||
1081 | instance BINARY_CLASS SignatureSubpacket where | ||
1082 | put p = do | ||
1083 | -- Use 5-octet-length + 1 for tag as the first packet body octet | ||
1084 | put (255 :: Word8) | ||
1085 | put (fromIntegral (B.length body) + 1 :: Word32) | ||
1086 | put tag | ||
1087 | putSomeByteString body | ||
1088 | where | ||
1089 | (body, tag) = put_signature_subpacket p | ||
1090 | get = do | ||
1091 | len <- fmap fromIntegral (get :: Get Word8) | ||
1092 | len <- case len of | ||
1093 | _ | len >= 192 && len < 255 -> do -- Two octet length | ||
1094 | second <- fmap fromIntegral (get :: Get Word8) | ||
1095 | return $ ((len - 192) `shiftL` 8) + second + 192 | ||
1096 | 255 -> -- Five octet length | ||
1097 | fmap fromIntegral (get :: Get Word32) | ||
1098 | _ -> -- One octet length, no furthur processing | ||
1099 | return len | ||
1100 | tag <- fmap stripCrit get :: Get Word8 | ||
1101 | -- This forces the whole packet to be consumed | ||
1102 | packet <- getSomeByteString (len-1) | ||
1103 | localGet (parse_signature_subpacket tag) packet | ||
1104 | where | ||
1105 | -- TODO: Decide how to actually encode the "is critical" data | ||
1106 | -- instead of just ignoring it | ||
1107 | stripCrit tag = if tag .&. 0x80 == 0x80 then tag .&. 0x7f else tag | ||
1108 | |||
1109 | put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8) | ||
1110 | put_signature_subpacket (SignatureCreationTimePacket time) = | ||
1111 | (encode time, 2) | ||
1112 | put_signature_subpacket (SignatureExpirationTimePacket time) = | ||
1113 | (encode time, 3) | ||
1114 | put_signature_subpacket (ExportableCertificationPacket exportable) = | ||
1115 | (encode $ enum_to_word8 exportable, 4) | ||
1116 | put_signature_subpacket (TrustSignaturePacket depth trust) = | ||
1117 | (B.concat [encode depth, encode trust], 5) | ||
1118 | put_signature_subpacket (RegularExpressionPacket regex) = | ||
1119 | (B.concat [B.fromString regex, B.singleton 0], 6) | ||
1120 | put_signature_subpacket (RevocablePacket exportable) = | ||
1121 | (encode $ enum_to_word8 exportable, 7) | ||
1122 | put_signature_subpacket (KeyExpirationTimePacket time) = | ||
1123 | (encode time, 9) | ||
1124 | put_signature_subpacket (PreferredSymmetricAlgorithmsPacket algos) = | ||
1125 | (B.concat $ map encode algos, 11) | ||
1126 | put_signature_subpacket (RevocationKeyPacket sensitive kalgo fpr) = | ||
1127 | (B.concat [encode bitfield, encode kalgo, fprb], 12) | ||
1128 | where | ||
1129 | bitfield = 0x80 .|. (if sensitive then 0x40 else 0x0) :: Word8 | ||
1130 | fprb = padBS 20 $ B.drop 2 $ encode (MPI fpri) | ||
1131 | fpri = fst $ head $ readHex fpr | ||
1132 | put_signature_subpacket (IssuerPacket keyid) = | ||
1133 | (encode (fst $ head $ readHex $ takeFromEnd 16 keyid :: Word64), 16) | ||
1134 | put_signature_subpacket (NotationDataPacket human_readable name value) = | ||
1135 | (B.concat [ | ||
1136 | B.pack [flag1,0,0,0], | ||
1137 | encode (fromIntegral (B.length namebs) :: Word16), | ||
1138 | encode (fromIntegral (B.length valuebs) :: Word16), | ||
1139 | namebs, | ||
1140 | valuebs | ||
1141 | ], 20) | ||
1142 | where | ||
1143 | valuebs = B.fromString value | ||
1144 | namebs = B.fromString name | ||
1145 | flag1 = if human_readable then 0x80 else 0x0 | ||
1146 | put_signature_subpacket (PreferredHashAlgorithmsPacket algos) = | ||
1147 | (B.concat $ map encode algos, 21) | ||
1148 | put_signature_subpacket (PreferredCompressionAlgorithmsPacket algos) = | ||
1149 | (B.concat $ map encode algos, 22) | ||
1150 | put_signature_subpacket (KeyServerPreferencesPacket no_modify) = | ||
1151 | (B.singleton (if no_modify then 0x80 else 0x0), 23) | ||
1152 | put_signature_subpacket (PreferredKeyServerPacket uri) = | ||
1153 | (B.fromString uri, 24) | ||
1154 | put_signature_subpacket (PrimaryUserIDPacket isprimary) = | ||
1155 | (encode $ enum_to_word8 isprimary, 25) | ||
1156 | put_signature_subpacket (PolicyURIPacket uri) = | ||
1157 | (B.fromString uri, 26) | ||
1158 | put_signature_subpacket (KeyFlagsPacket certify sign encryptC encryptS split auth group) = | ||
1159 | (B.singleton $ | ||
1160 | flag 0x01 certify .|. | ||
1161 | flag 0x02 sign .|. | ||
1162 | flag 0x04 encryptC .|. | ||
1163 | flag 0x08 encryptS .|. | ||
1164 | flag 0x10 split .|. | ||
1165 | flag 0x20 auth .|. | ||
1166 | flag 0x80 group | ||
1167 | , 27) | ||
1168 | where | ||
1169 | flag x True = x | ||
1170 | flag _ False = 0x0 | ||
1171 | put_signature_subpacket (SignerUserIDPacket userid) = | ||
1172 | (B.fromString userid, 28) | ||
1173 | put_signature_subpacket (ReasonForRevocationPacket code string) = | ||
1174 | (B.concat [encode code, B.fromString string], 29) | ||
1175 | put_signature_subpacket (FeaturesPacket supports_mdc) = | ||
1176 | (B.singleton $ if supports_mdc then 0x01 else 0x00, 30) | ||
1177 | put_signature_subpacket (SignatureTargetPacket kalgo halgo hash) = | ||
1178 | (B.concat [encode kalgo, encode halgo, hash], 31) | ||
1179 | put_signature_subpacket (EmbeddedSignaturePacket packet) | ||
1180 | | isSignaturePacket packet = (fst $ put_packet packet, 32) | ||
1181 | | otherwise = error $ "Tried to put non-SignaturePacket in EmbeddedSignaturePacket: " ++ show packet | ||
1182 | put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) = | ||
1183 | (bytes, tag) | ||
1184 | |||
1185 | parse_signature_subpacket :: Word8 -> Get SignatureSubpacket | ||
1186 | -- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4 | ||
1187 | parse_signature_subpacket 2 = fmap SignatureCreationTimePacket get | ||
1188 | -- SignatureExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.10 | ||
1189 | parse_signature_subpacket 3 = fmap SignatureExpirationTimePacket get | ||
1190 | -- ExportableCertificationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.11 | ||
1191 | parse_signature_subpacket 4 = | ||
1192 | fmap (ExportableCertificationPacket . enum_from_word8) get | ||
1193 | -- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.13 | ||
1194 | parse_signature_subpacket 5 = liftM2 TrustSignaturePacket get get | ||
1195 | -- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.14 | ||
1196 | parse_signature_subpacket 6 = fmap | ||
1197 | (RegularExpressionPacket . B.toString . B.init) getRemainingByteString | ||
1198 | -- RevocablePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.12 | ||
1199 | parse_signature_subpacket 7 = | ||
1200 | fmap (RevocablePacket . enum_from_word8) get | ||
1201 | -- KeyExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.6 | ||
1202 | parse_signature_subpacket 9 = fmap KeyExpirationTimePacket get | ||
1203 | -- PreferredSymmetricAlgorithms, http://tools.ietf.org/html/rfc4880#section-5.2.3.7 | ||
1204 | parse_signature_subpacket 11 = | ||
1205 | fmap PreferredSymmetricAlgorithmsPacket listUntilEnd | ||
1206 | -- RevocationKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.15 | ||
1207 | parse_signature_subpacket 12 = do | ||
1208 | bitfield <- get :: Get Word8 | ||
1209 | kalgo <- get | ||
1210 | fpr <- getSomeByteString 20 | ||
1211 | -- bitfield must have bit 0x80 set, says the spec | ||
1212 | return RevocationKeyPacket { | ||
1213 | sensitive = bitfield .&. 0x40 == 0x40, | ||
1214 | revocation_key_algorithm = kalgo, | ||
1215 | revocation_key_fingerprint = | ||
1216 | pad 40 $ map toUpper $ foldr (padB `oo` showHex) "" (B.unpack fpr) | ||
1217 | } | ||
1218 | where | ||
1219 | oo = (.) . (.) | ||
1220 | padB s | odd $ length s = '0':s | ||
1221 | | otherwise = s | ||
1222 | -- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5 | ||
1223 | parse_signature_subpacket 16 = do | ||
1224 | keyid <- get :: Get Word64 | ||
1225 | return $ IssuerPacket (pad 16 $ map toUpper $ showHex keyid "") | ||
1226 | -- NotationDataPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.16 | ||
1227 | parse_signature_subpacket 20 = do | ||
1228 | (flag1,_,_,_) <- get4word8 | ||
1229 | (m,n) <- liftM2 (,) get get :: Get (Word16,Word16) | ||
1230 | name <- fmap B.toString $ getSomeByteString $ fromIntegral m | ||
1231 | value <- fmap B.toString $ getSomeByteString $ fromIntegral n | ||
1232 | return NotationDataPacket { | ||
1233 | human_readable = flag1 .&. 0x80 == 0x80, | ||
1234 | notation_name = name, | ||
1235 | notation_value = value | ||
1236 | } | ||
1237 | where | ||
1238 | get4word8 :: Get (Word8,Word8,Word8,Word8) | ||
1239 | get4word8 = liftM4 (,,,) get get get get | ||
1240 | -- PreferredHashAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.8 | ||
1241 | parse_signature_subpacket 21 = | ||
1242 | fmap PreferredHashAlgorithmsPacket listUntilEnd | ||
1243 | -- PreferredCompressionAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.9 | ||
1244 | parse_signature_subpacket 22 = | ||
1245 | fmap PreferredCompressionAlgorithmsPacket listUntilEnd | ||
1246 | -- KeyServerPreferencesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.17 | ||
1247 | parse_signature_subpacket 23 = do | ||
1248 | empty <- isEmpty | ||
1249 | flag1 <- if empty then return 0 else get :: Get Word8 | ||
1250 | return KeyServerPreferencesPacket { | ||
1251 | keyserver_no_modify = flag1 .&. 0x80 == 0x80 | ||
1252 | } | ||
1253 | -- PreferredKeyServerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.18 | ||
1254 | parse_signature_subpacket 24 = | ||
1255 | fmap (PreferredKeyServerPacket . B.toString) getRemainingByteString | ||
1256 | -- PrimaryUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.19 | ||
1257 | parse_signature_subpacket 25 = | ||
1258 | fmap (PrimaryUserIDPacket . enum_from_word8) get | ||
1259 | -- PolicyURIPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.20 | ||
1260 | parse_signature_subpacket 26 = | ||
1261 | fmap (PolicyURIPacket . B.toString) getRemainingByteString | ||
1262 | -- KeyFlagsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.21 | ||
1263 | parse_signature_subpacket 27 = do | ||
1264 | empty <- isEmpty | ||
1265 | flag1 <- if empty then return 0 else get :: Get Word8 | ||
1266 | return KeyFlagsPacket { | ||
1267 | certify_keys = flag1 .&. 0x01 == 0x01, | ||
1268 | sign_data = flag1 .&. 0x02 == 0x02, | ||
1269 | encrypt_communication = flag1 .&. 0x04 == 0x04, | ||
1270 | encrypt_storage = flag1 .&. 0x08 == 0x08, | ||
1271 | split_key = flag1 .&. 0x10 == 0x10, | ||
1272 | authentication = flag1 .&. 0x20 == 0x20, | ||
1273 | group_key = flag1 .&. 0x80 == 0x80 | ||
1274 | } | ||
1275 | -- SignerUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.22 | ||
1276 | parse_signature_subpacket 28 = | ||
1277 | fmap (SignerUserIDPacket . B.toString) getRemainingByteString | ||
1278 | -- ReasonForRevocationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.23 | ||
1279 | parse_signature_subpacket 29 = liftM2 ReasonForRevocationPacket get | ||
1280 | (fmap B.toString getRemainingByteString) | ||
1281 | -- FeaturesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.24 | ||
1282 | parse_signature_subpacket 30 = do | ||
1283 | empty <- isEmpty | ||
1284 | flag1 <- if empty then return 0 else get :: Get Word8 | ||
1285 | return FeaturesPacket { | ||
1286 | supports_mdc = flag1 .&. 0x01 == 0x01 | ||
1287 | } | ||
1288 | -- SignatureTargetPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.25 | ||
1289 | parse_signature_subpacket 31 = | ||
1290 | liftM3 SignatureTargetPacket get get getRemainingByteString | ||
1291 | -- EmbeddedSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.26 | ||
1292 | parse_signature_subpacket 32 = | ||
1293 | fmap EmbeddedSignaturePacket (parse_packet 2) | ||
1294 | -- Represent unsupported packets as their tag and literal bytes | ||
1295 | parse_signature_subpacket tag = | ||
1296 | fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString | ||
1297 | |||
1298 | -- | Find the keyid that issued a SignaturePacket | ||
1299 | signature_issuer :: Packet -> Maybe String | ||
1300 | signature_issuer (SignaturePacket {hashed_subpackets = hashed, | ||
1301 | unhashed_subpackets = unhashed}) = | ||
1302 | case issuers of | ||
1303 | IssuerPacket issuer : _ -> Just issuer | ||
1304 | _ -> Nothing | ||
1305 | where | ||
1306 | issuers = filter isIssuer hashed ++ filter isIssuer unhashed | ||
1307 | isIssuer (IssuerPacket {}) = True | ||
1308 | isIssuer _ = False | ||
1309 | signature_issuer _ = Nothing | ||
1310 | |||
1311 | -- | Find a key with the given Fingerprint/KeyID | ||
1312 | find_key :: | ||
1313 | (Packet -> String) -- ^ Extract Fingerprint/KeyID from packet | ||
1314 | -> Message -- ^ List of packets (some of which are keys) | ||
1315 | -> String -- ^ Fingerprint/KeyID to search for | ||
1316 | -> Maybe Packet | ||
1317 | find_key fpr (Message (x@(PublicKeyPacket {}):xs)) keyid = | ||
1318 | find_key' fpr x xs keyid | ||
1319 | find_key fpr (Message (x@(SecretKeyPacket {}):xs)) keyid = | ||
1320 | find_key' fpr x xs keyid | ||
1321 | find_key fpr (Message (_:xs)) keyid = | ||
1322 | find_key fpr (Message xs) keyid | ||
1323 | find_key _ _ _ = Nothing | ||
1324 | |||
1325 | find_key' :: (Packet -> String) -> Packet -> [Packet] -> String -> Maybe Packet | ||
1326 | find_key' fpr x xs keyid | ||
1327 | | thisid == keyid = Just x | ||
1328 | | otherwise = find_key fpr (Message xs) keyid | ||
1329 | where | ||
1330 | thisid = takeFromEnd (length keyid) (fpr x) | ||
1331 | |||
1332 | takeFromEnd :: Int -> String -> String | ||
1333 | takeFromEnd l = reverse . take l . reverse | ||
1334 | |||
1335 | -- | SignaturePacket smart constructor | ||
1336 | -- | ||
1337 | -- <http://tools.ietf.org/html/rfc4880#section-5.2> | ||
1338 | signaturePacket :: | ||
1339 | Word8 -- ^ Signature version (probably 4) | ||
1340 | -> Word8 -- ^ Signature type <http://tools.ietf.org/html/rfc4880#section-5.2.1> | ||
1341 | -> KeyAlgorithm | ||
1342 | -> HashAlgorithm | ||
1343 | -> [SignatureSubpacket] -- ^ Hashed subpackets (these get signed) | ||
1344 | -> [SignatureSubpacket] -- ^ Unhashed subpackets (these do not get signed) | ||
1345 | -> Word16 -- ^ Left 16 bits of the signed hash value | ||
1346 | -> [MPI] -- ^ The raw MPIs of the signature | ||
1347 | -> Packet | ||
1348 | signaturePacket version signature_type key_algorithm hash_algorithm hashed_subpackets unhashed_subpackets hash_head signature = | ||
1349 | let p = SignaturePacket { | ||
1350 | version = version, | ||
1351 | signature_type = signature_type, | ||
1352 | key_algorithm = key_algorithm, | ||
1353 | hash_algorithm = hash_algorithm, | ||
1354 | hashed_subpackets = hashed_subpackets, | ||
1355 | unhashed_subpackets = unhashed_subpackets, | ||
1356 | hash_head = hash_head, | ||
1357 | signature = signature, | ||
1358 | trailer = undefined | ||
1359 | } in p { trailer = calculate_signature_trailer p } | ||
1360 | |||
1361 | isSignaturePacket :: Packet -> Bool | ||
1362 | isSignaturePacket (SignaturePacket {}) = True | ||
1363 | isSignaturePacket _ = False | ||
diff --git a/Data/OpenPGP/Internal.hs b/Data/OpenPGP/Internal.hs new file mode 100644 index 0000000..b2bd506 --- /dev/null +++ b/Data/OpenPGP/Internal.hs | |||
@@ -0,0 +1,20 @@ | |||
1 | module Data.OpenPGP.Internal where | ||
2 | |||
3 | import Data.Word | ||
4 | import Data.Bits | ||
5 | |||
6 | decode_s2k_count :: Word8 -> Word32 | ||
7 | decode_s2k_count c = (16 + (fromIntegral c .&. 15)) `shiftL` | ||
8 | ((fromIntegral c `shiftR` 4) + 6) | ||
9 | |||
10 | encode_s2k_count :: Word32 -> Word8 | ||
11 | encode_s2k_count iterations | ||
12 | | iterations >= 65011712 = 255 | ||
13 | | decode_s2k_count result < iterations = result+1 | ||
14 | | otherwise = result | ||
15 | where | ||
16 | result = fromIntegral $ (fromIntegral c `shiftL` 4) .|. (count - 16) | ||
17 | (count, c) = encode_s2k_count' (iterations `shiftR` 6) (0::Word8) | ||
18 | encode_s2k_count' count c | ||
19 | | count < 32 = (count, c) | ||
20 | | otherwise = encode_s2k_count' (count `shiftR` 1) (c+1) | ||