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