summaryrefslogtreecommitdiff
path: root/Data
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-04-14 12:50:25 -0400
committerjoe <joe@jerkface.net>2016-04-14 12:51:36 -0400
commit47fbb4b70ee6c74937ed4b55540b612aacc3de80 (patch)
tree3d3577a0e3706512cd2c49938e91acf72e203249 /Data
parent880f16b4e52bbf96dd531c1c4b864423b057b770 (diff)
parent37d5a99e9f2303780a7cdbf4730ace6eff58a466 (diff)
Merged openpgp package into openpgp-util
Diffstat (limited to 'Data')
-rw-r--r--Data/OpenPGP.hs1363
-rw-r--r--Data/OpenPGP/Internal.hs20
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
7module 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
68import Numeric
69import Control.Monad
70import Control.Arrow
71import Control.Applicative
72import Data.Monoid
73import Data.Bits
74import Data.Word
75import Data.Char
76import Data.List
77import Data.Maybe
78import Data.OpenPGP.Internal
79import qualified Data.ByteString as BS
80import qualified Data.ByteString.Lazy as LZ
81
82#ifdef CEREAL
83import Data.Serialize
84import qualified Data.ByteString as B
85import qualified Data.ByteString.UTF8 as B (toString, fromString)
86#define BINARY_CLASS Serialize
87#else
88import Data.Binary
89import Data.Binary.Get
90import Data.Binary.Put
91import qualified Data.ByteString.Lazy as B
92import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString)
93#define BINARY_CLASS Binary
94#endif
95
96import qualified Codec.Compression.Zlib.Raw as Zip
97import qualified Codec.Compression.Zlib as Zlib
98import qualified Codec.Compression.BZip as BZip2
99
100#ifdef CEREAL
101getRemainingByteString :: Get B.ByteString
102getRemainingByteString = remaining >>= getByteString
103
104getSomeByteString :: Word64 -> Get B.ByteString
105getSomeByteString = getByteString . fromIntegral
106
107putSomeByteString :: B.ByteString -> Put
108putSomeByteString = putByteString
109
110localGet :: Get a -> B.ByteString -> Get a
111localGet g bs = case runGet g bs of
112 Left s -> fail s
113 Right v -> return v
114
115compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
116compress algo = toStrictBS . lazyCompress algo . toLazyBS
117
118decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
119decompress algo = toStrictBS . lazyDecompress algo . toLazyBS
120
121toStrictBS :: LZ.ByteString -> B.ByteString
122toStrictBS = B.concat . LZ.toChunks
123
124toLazyBS :: B.ByteString -> LZ.ByteString
125toLazyBS = LZ.fromChunks . (:[])
126
127lazyEncode :: (Serialize a) => a -> LZ.ByteString
128lazyEncode = toLazyBS . encode
129#else
130getRemainingByteString :: Get B.ByteString
131getRemainingByteString = getRemainingLazyByteString
132
133getSomeByteString :: Word64 -> Get B.ByteString
134getSomeByteString = getLazyByteString . fromIntegral
135
136putSomeByteString :: B.ByteString -> Put
137putSomeByteString = putLazyByteString
138
139#if MIN_VERSION_binary(0,6,4)
140localGet :: Get a -> B.ByteString -> Get a
141localGet 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
147localGet :: Get a -> B.ByteString -> Get a
148localGet g bs = return $ runGet g bs
149#endif
150
151compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
152compress = lazyCompress
153
154decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString
155decompress = lazyDecompress
156
157lazyEncode :: (Binary a) => a -> LZ.ByteString
158lazyEncode = encode
159#endif
160
161lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString
162lazyCompress Uncompressed = id
163lazyCompress ZIP = Zip.compress
164lazyCompress ZLIB = Zlib.compress
165lazyCompress BZip2 = BZip2.compress
166lazyCompress x = error ("No implementation for " ++ show x)
167
168lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString
169lazyDecompress Uncompressed = id
170lazyDecompress ZIP = Zip.decompress
171lazyDecompress ZLIB = Zlib.decompress
172lazyDecompress BZip2 = BZip2.decompress
173lazyDecompress x = error ("No implementation for " ++ show x)
174
175assertProp :: (Monad m, Show a) => (a -> Bool) -> a -> m a
176assertProp f x
177 | f x = return $! x
178 | otherwise = fail $ "Assertion failed for: " ++ show x
179
180pad :: Int -> String -> String
181pad l s = replicate (l - length s) '0' ++ s
182
183padBS :: Int -> B.ByteString -> B.ByteString
184padBS l s = B.replicate (fromIntegral l - B.length s) 0 `B.append` s
185
186checksum :: B.ByteString -> Word16
187checksum = fromIntegral .
188 B.foldl (\c i -> (c + fromIntegral i) `mod` 65536) (0::Integer)
189
190data 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
272instance 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
297get_packet_bytes :: Maybe Word32 -> Bool -> Get [B.ByteString]
298get_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
305parse_new_length :: Get (Maybe Word32, Bool)
306parse_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
323parse_old_length :: Word8 -> Get (Maybe Word32)
324parse_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
338public_key_fields :: KeyAlgorithm -> [Char]
339public_key_fields RSA = ['n', 'e']
340public_key_fields RSA_E = public_key_fields RSA
341public_key_fields RSA_S = public_key_fields RSA
342public_key_fields ELGAMAL = ['p', 'g', 'y']
343public_key_fields DSA = ['p', 'q', 'g', 'y']
344public_key_fields ECDSA = ['c','l','x', 'y']
345public_key_fields _ = undefined -- Nothing in the spec. Maybe empty
346
347-- http://tools.ietf.org/html/rfc4880#section-5.5.3
348secret_key_fields :: KeyAlgorithm -> [Char]
349secret_key_fields RSA = ['d', 'p', 'q', 'u']
350secret_key_fields RSA_E = secret_key_fields RSA
351secret_key_fields RSA_S = secret_key_fields RSA
352secret_key_fields ELGAMAL = ['x']
353secret_key_fields DSA = ['x']
354secret_key_fields ECDSA = ['d']
355secret_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
361signature_packet_start :: Packet -> B.ByteString
362signature_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
379signature_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
383calculate_signature_trailer :: Packet -> B.ByteString
384calculate_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
396calculate_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 ]
403calculate_signature_trailer x =
404 error ("Trying to calculate signature trailer for: " ++ show x)
405
406
407encode_public_key_material :: Packet -> [B.ByteString]
408encode_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) ]
420encode_public_key_material k = map (encode . (key k !)) (public_key_fields $ key_algorithm k)
421
422decode_public_key_material :: KeyAlgorithm -> Get [(Char,MPI)]
423decode_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)]
436decode_public_key_material algorithm = mapM (\f -> fmap ((,)f) get) (public_key_fields algorithm)
437
438put_packet :: Packet -> (B.ByteString, Word8)
439put_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)
446put_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
468put_packet (SymmetricSessionKeyPacket version salgo s2k encd) =
469 (B.concat [encode version, encode salgo, encode s2k, encd], 3)
470put_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
483put_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)
495put_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)
518put_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
535put_packet (CompressedDataPacket { compression_algorithm = algorithm,
536 message = message }) =
537 (B.append (encode algorithm) $ compress algorithm $ encode message, 8)
538put_packet MarkerPacket = (B.fromString "PGP", 10)
539put_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
549put_packet (TrustPacket bytes) = (bytes, 12)
550put_packet (UserIDPacket txt) = (B.fromString txt, 13)
551put_packet (EncryptedDataPacket 0 encrypted_data) = (encrypted_data, 9)
552put_packet (EncryptedDataPacket version encrypted_data) =
553 (B.concat [encode version, encrypted_data], 18)
554put_packet (ModificationDetectionCodePacket bstr) = (bstr, 19)
555put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag)
556put_packet x = error ("Unsupported Packet version or type in put_packet: " ++ show x)
557
558parse_packet :: Word8 -> Get Packet
559-- AsymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.1
560parse_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
566parse_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
617parse_packet 3 = SymmetricSessionKeyPacket
618 <$> (assertProp (==4) =<< get)
619 <*> get
620 <*> get
621 <*> getRemainingByteString
622-- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4
623parse_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
639parse_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
668parse_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
698parse_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
702parse_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
710parse_packet 9 = EncryptedDataPacket 0 <$> getRemainingByteString
711-- MarkerPacket, http://tools.ietf.org/html/rfc4880#section-5.8
712parse_packet 10 = return MarkerPacket
713-- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9
714parse_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
727parse_packet 12 = fmap TrustPacket getRemainingByteString
728-- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11
729parse_packet 13 =
730 fmap (UserIDPacket . B.toString) getRemainingByteString
731-- Public-Subkey Packet, http://tools.ietf.org/html/rfc4880#section-5.5.1.2
732parse_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
736parse_packet 18 = EncryptedDataPacket <$> get <*> getRemainingByteString
737-- ModificationDetectionCodePacket, http://tools.ietf.org/html/rfc4880#section-5.14
738parse_packet 19 =
739 fmap ModificationDetectionCodePacket getRemainingByteString
740-- Represent unsupported packets as their tag and literal bytes
741parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString
742
743-- | Helper method for fingerprints and such
744fingerprint_material :: Packet -> [B.ByteString]
745fingerprint_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
754fingerprint_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'))
758fingerprint_material _ =
759 error "Unsupported Packet version or type in fingerprint_material."
760
761enum_to_word8 :: (Enum a) => a -> Word8
762enum_to_word8 = fromIntegral . fromEnum
763
764enum_from_word8 :: (Enum a) => Word8 -> a
765enum_from_word8 = toEnum . fromIntegral
766
767data S2K =
768 SimpleS2K HashAlgorithm |
769 SaltedS2K HashAlgorithm Word64 |
770 IteratedSaltedS2K HashAlgorithm Word64 Word32 |
771 S2K Word8 B.ByteString
772 deriving (Show, Read, Eq)
773
774instance 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.
794string2key :: (HashAlgorithm -> LZ.ByteString -> BS.ByteString) -> S2K -> LZ.ByteString -> LZ.ByteString
795string2key hsh (SimpleS2K halgo) s = infiniHashes (hsh halgo) s
796string2key hsh (SaltedS2K halgo salt) s =
797 infiniHashes (hsh halgo) (lazyEncode salt `LZ.append` s)
798string2key 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)
802string2key _ s2k _ = error $ "Unsupported S2K specifier: " ++ show s2k
803
804infiniHashes :: (LZ.ByteString -> BS.ByteString) -> LZ.ByteString -> LZ.ByteString
805infiniHashes hsh s = LZ.fromChunks (hs 0)
806 where
807 hs c = hsh (LZ.replicate c 0 `LZ.append` s) : hs (c+1)
808
809data HashAlgorithm = MD5 | SHA1 | RIPEMD160 | SHA256 | SHA384 | SHA512 | SHA224 | HashAlgorithm Word8
810 deriving (Show, Read, Eq)
811
812instance 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
830instance BINARY_CLASS HashAlgorithm where
831 put = put . enum_to_word8
832 get = fmap enum_from_word8 get
833
834data KeyAlgorithm = RSA | RSA_E | RSA_S | ELGAMAL | DSA | ECC | ECDSA | DH | KeyAlgorithm Word8
835 deriving (Show, Read, Eq)
836
837instance 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
857instance BINARY_CLASS KeyAlgorithm where
858 put = put . enum_to_word8
859 get = fmap enum_from_word8 get
860
861data SymmetricAlgorithm = Unencrypted | IDEA | TripleDES | CAST5 | Blowfish | AES128 | AES192 | AES256 | Twofish | SymmetricAlgorithm Word8
862 deriving (Show, Read, Eq)
863
864instance 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
886instance BINARY_CLASS SymmetricAlgorithm where
887 put = put . enum_to_word8
888 get = fmap enum_from_word8 get
889
890data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | CompressionAlgorithm Word8
891 deriving (Show, Read, Eq)
892
893instance 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
905instance BINARY_CLASS CompressionAlgorithm where
906 put = put . enum_to_word8
907 get = fmap enum_from_word8 get
908
909data RevocationCode = NoReason | KeySuperseded | KeyCompromised | KeyRetired | UserIDInvalid | RevocationCode Word8 deriving (Show, Read, Eq)
910
911instance 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
925instance 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
930newtype Message = Message [Packet] deriving (Show, Read, Eq)
931instance BINARY_CLASS Message where
932 put (Message xs) = mapM_ put xs
933 get = fmap Message listUntilEnd
934
935instance Monoid Message where
936 mempty = Message []
937 mappend (Message a) (Message b) = Message (a ++ b)
938
939-- | Data needed to verify a signature
940data 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
948instance 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>
970signatures :: Message -> [SignatureOver]
971signatures (Message [CompressedDataPacket _ m]) = signatures m
972signatures (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
980paired_sigs :: Maybe Packet -> [Packet] -> [SignatureOver]
981paired_sigs _ [] = []
982paired_sigs _ (p@(PublicKeyPacket {is_subkey = False}):ps) =
983 KeySignature p (takeWhile isSignaturePacket ps) :
984 paired_sigs (Just p) (dropWhile isSignaturePacket ps)
985paired_sigs _ (p@(SecretKeyPacket {is_subkey = False}):ps) =
986 KeySignature p (takeWhile isSignaturePacket ps) :
987 paired_sigs (Just p) (dropWhile isSignaturePacket ps)
988paired_sigs (Just k) (p@(PublicKeyPacket {is_subkey = True}):ps) =
989 SubkeySignature k p (takeWhile isSignaturePacket ps) :
990 paired_sigs (Just k) (dropWhile isSignaturePacket ps)
991paired_sigs (Just k) (p@(SecretKeyPacket {is_subkey = True}):ps) =
992 SubkeySignature k p (takeWhile isSignaturePacket ps) :
993 paired_sigs (Just k) (dropWhile isSignaturePacket ps)
994paired_sigs (Just k) (p@(UserIDPacket {}):ps) =
995 CertificationSignature k p (takeWhile isSignaturePacket ps) :
996 paired_sigs (Just k) (dropWhile isSignaturePacket ps)
997paired_sigs k (_:ps) = paired_sigs k ps
998
999-- | <http://tools.ietf.org/html/rfc4880#section-3.2>
1000newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord)
1001instance 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
1025listUntilEnd :: (BINARY_CLASS a) => Get [a]
1026listUntilEnd = 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>
1034data 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
1081instance 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
1109put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8)
1110put_signature_subpacket (SignatureCreationTimePacket time) =
1111 (encode time, 2)
1112put_signature_subpacket (SignatureExpirationTimePacket time) =
1113 (encode time, 3)
1114put_signature_subpacket (ExportableCertificationPacket exportable) =
1115 (encode $ enum_to_word8 exportable, 4)
1116put_signature_subpacket (TrustSignaturePacket depth trust) =
1117 (B.concat [encode depth, encode trust], 5)
1118put_signature_subpacket (RegularExpressionPacket regex) =
1119 (B.concat [B.fromString regex, B.singleton 0], 6)
1120put_signature_subpacket (RevocablePacket exportable) =
1121 (encode $ enum_to_word8 exportable, 7)
1122put_signature_subpacket (KeyExpirationTimePacket time) =
1123 (encode time, 9)
1124put_signature_subpacket (PreferredSymmetricAlgorithmsPacket algos) =
1125 (B.concat $ map encode algos, 11)
1126put_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
1132put_signature_subpacket (IssuerPacket keyid) =
1133 (encode (fst $ head $ readHex $ takeFromEnd 16 keyid :: Word64), 16)
1134put_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
1146put_signature_subpacket (PreferredHashAlgorithmsPacket algos) =
1147 (B.concat $ map encode algos, 21)
1148put_signature_subpacket (PreferredCompressionAlgorithmsPacket algos) =
1149 (B.concat $ map encode algos, 22)
1150put_signature_subpacket (KeyServerPreferencesPacket no_modify) =
1151 (B.singleton (if no_modify then 0x80 else 0x0), 23)
1152put_signature_subpacket (PreferredKeyServerPacket uri) =
1153 (B.fromString uri, 24)
1154put_signature_subpacket (PrimaryUserIDPacket isprimary) =
1155 (encode $ enum_to_word8 isprimary, 25)
1156put_signature_subpacket (PolicyURIPacket uri) =
1157 (B.fromString uri, 26)
1158put_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
1171put_signature_subpacket (SignerUserIDPacket userid) =
1172 (B.fromString userid, 28)
1173put_signature_subpacket (ReasonForRevocationPacket code string) =
1174 (B.concat [encode code, B.fromString string], 29)
1175put_signature_subpacket (FeaturesPacket supports_mdc) =
1176 (B.singleton $ if supports_mdc then 0x01 else 0x00, 30)
1177put_signature_subpacket (SignatureTargetPacket kalgo halgo hash) =
1178 (B.concat [encode kalgo, encode halgo, hash], 31)
1179put_signature_subpacket (EmbeddedSignaturePacket packet)
1180 | isSignaturePacket packet = (fst $ put_packet packet, 32)
1181 | otherwise = error $ "Tried to put non-SignaturePacket in EmbeddedSignaturePacket: " ++ show packet
1182put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) =
1183 (bytes, tag)
1184
1185parse_signature_subpacket :: Word8 -> Get SignatureSubpacket
1186-- SignatureCreationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.4
1187parse_signature_subpacket 2 = fmap SignatureCreationTimePacket get
1188-- SignatureExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.10
1189parse_signature_subpacket 3 = fmap SignatureExpirationTimePacket get
1190-- ExportableCertificationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.11
1191parse_signature_subpacket 4 =
1192 fmap (ExportableCertificationPacket . enum_from_word8) get
1193-- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.13
1194parse_signature_subpacket 5 = liftM2 TrustSignaturePacket get get
1195-- TrustSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.14
1196parse_signature_subpacket 6 = fmap
1197 (RegularExpressionPacket . B.toString . B.init) getRemainingByteString
1198-- RevocablePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.12
1199parse_signature_subpacket 7 =
1200 fmap (RevocablePacket . enum_from_word8) get
1201-- KeyExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.6
1202parse_signature_subpacket 9 = fmap KeyExpirationTimePacket get
1203-- PreferredSymmetricAlgorithms, http://tools.ietf.org/html/rfc4880#section-5.2.3.7
1204parse_signature_subpacket 11 =
1205 fmap PreferredSymmetricAlgorithmsPacket listUntilEnd
1206-- RevocationKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.15
1207parse_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
1223parse_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
1227parse_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
1241parse_signature_subpacket 21 =
1242 fmap PreferredHashAlgorithmsPacket listUntilEnd
1243-- PreferredCompressionAlgorithmsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.9
1244parse_signature_subpacket 22 =
1245 fmap PreferredCompressionAlgorithmsPacket listUntilEnd
1246-- KeyServerPreferencesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.17
1247parse_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
1254parse_signature_subpacket 24 =
1255 fmap (PreferredKeyServerPacket . B.toString) getRemainingByteString
1256-- PrimaryUserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.19
1257parse_signature_subpacket 25 =
1258 fmap (PrimaryUserIDPacket . enum_from_word8) get
1259-- PolicyURIPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.20
1260parse_signature_subpacket 26 =
1261 fmap (PolicyURIPacket . B.toString) getRemainingByteString
1262-- KeyFlagsPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.21
1263parse_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
1276parse_signature_subpacket 28 =
1277 fmap (SignerUserIDPacket . B.toString) getRemainingByteString
1278-- ReasonForRevocationPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.23
1279parse_signature_subpacket 29 = liftM2 ReasonForRevocationPacket get
1280 (fmap B.toString getRemainingByteString)
1281-- FeaturesPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.24
1282parse_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
1289parse_signature_subpacket 31 =
1290 liftM3 SignatureTargetPacket get get getRemainingByteString
1291-- EmbeddedSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.26
1292parse_signature_subpacket 32 =
1293 fmap EmbeddedSignaturePacket (parse_packet 2)
1294-- Represent unsupported packets as their tag and literal bytes
1295parse_signature_subpacket tag =
1296 fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString
1297
1298-- | Find the keyid that issued a SignaturePacket
1299signature_issuer :: Packet -> Maybe String
1300signature_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
1309signature_issuer _ = Nothing
1310
1311-- | Find a key with the given Fingerprint/KeyID
1312find_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
1317find_key fpr (Message (x@(PublicKeyPacket {}):xs)) keyid =
1318 find_key' fpr x xs keyid
1319find_key fpr (Message (x@(SecretKeyPacket {}):xs)) keyid =
1320 find_key' fpr x xs keyid
1321find_key fpr (Message (_:xs)) keyid =
1322 find_key fpr (Message xs) keyid
1323find_key _ _ _ = Nothing
1324
1325find_key' :: (Packet -> String) -> Packet -> [Packet] -> String -> Maybe Packet
1326find_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
1332takeFromEnd :: Int -> String -> String
1333takeFromEnd l = reverse . take l . reverse
1334
1335-- | SignaturePacket smart constructor
1336--
1337-- <http://tools.ietf.org/html/rfc4880#section-5.2>
1338signaturePacket ::
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
1348signaturePacket 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
1361isSignaturePacket :: Packet -> Bool
1362isSignaturePacket (SignaturePacket {}) = True
1363isSignaturePacket _ = 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 @@
1module Data.OpenPGP.Internal where
2
3import Data.Word
4import Data.Bits
5
6decode_s2k_count :: Word8 -> Word32
7decode_s2k_count c = (16 + (fromIntegral c .&. 15)) `shiftL`
8 ((fromIntegral c `shiftR` 4) + 6)
9
10encode_s2k_count :: Word32 -> Word8
11encode_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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-19 14:29:04 +0000