diff options
author | Stephen Paul Weber <singpolyma@singpolyma.net> | 2012-04-27 10:19:09 -0500 |
---|---|---|
committer | Stephen Paul Weber <singpolyma@singpolyma.net> | 2012-04-27 10:19:53 -0500 |
commit | 016decabcc3644dfbe16eaba35ec69d6c2b8bad2 (patch) | |
tree | 1b34c03e44da37c919605b67e9e84ad4af17d2a6 /Data/OpenPGP.hs | |
parent | a68241e614534c252fad871a32ac8296727ee7bf (diff) | |
parent | 913c09eb763e35bfba79f655c3fe3a6cec593a56 (diff) |
Merge branch 'cpp'
* cpp:
Second openpgp-cereal package using CPP
Closes #4
Diffstat (limited to 'Data/OpenPGP.hs')
-rw-r--r-- | Data/OpenPGP.hs | 236 |
1 files changed, 146 insertions, 90 deletions
diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs index 8c248d8..7c3e8ba 100644 --- a/Data/OpenPGP.hs +++ b/Data/OpenPGP.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# LANGUAGE CPP #-} | ||
1 | -- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880> | 2 | -- | Main implementation of the OpenPGP message format <http://tools.ietf.org/html/rfc4880> |
2 | -- | 3 | -- |
3 | -- The recommended way to import this module is: | 4 | -- The recommended way to import this module is: |
@@ -61,15 +62,83 @@ import Data.Word | |||
61 | import Data.Char | 62 | import Data.Char |
62 | import Data.Maybe | 63 | import Data.Maybe |
63 | import qualified Data.ByteString.Lazy as LZ | 64 | import qualified Data.ByteString.Lazy as LZ |
64 | import qualified Data.ByteString.Lazy.UTF8 as LZ (toString, fromString) | ||
65 | 65 | ||
66 | #ifdef CEREAL | ||
67 | import Data.Serialize | ||
68 | import qualified Data.ByteString as B | ||
69 | import qualified Data.ByteString.UTF8 as B (toString, fromString) | ||
70 | #define BINARY_CLASS Serialize | ||
71 | #else | ||
66 | import Data.Binary | 72 | import Data.Binary |
67 | import Data.Binary.Get | 73 | import Data.Binary.Get |
68 | import Data.Binary.Put | 74 | import Data.Binary.Put |
75 | import qualified Data.ByteString.Lazy as B | ||
76 | import qualified Data.ByteString.Lazy.UTF8 as B (toString, fromString) | ||
77 | #define BINARY_CLASS Binary | ||
78 | #endif | ||
79 | |||
69 | import qualified Codec.Compression.Zlib.Raw as Zip | 80 | import qualified Codec.Compression.Zlib.Raw as Zip |
70 | import qualified Codec.Compression.Zlib as Zlib | 81 | import qualified Codec.Compression.Zlib as Zlib |
71 | import qualified Codec.Compression.BZip as BZip2 | 82 | import qualified Codec.Compression.BZip as BZip2 |
72 | 83 | ||
84 | #ifdef CEREAL | ||
85 | getRemainingByteString :: Get B.ByteString | ||
86 | getRemainingByteString = remaining >>= getByteString | ||
87 | |||
88 | getSomeByteString :: Word64 -> Get B.ByteString | ||
89 | getSomeByteString = getByteString . fromIntegral | ||
90 | |||
91 | putSomeByteString :: B.ByteString -> Put | ||
92 | putSomeByteString = putByteString | ||
93 | |||
94 | unsafeRunGet :: Get a -> B.ByteString -> a | ||
95 | unsafeRunGet g bs = let Right v = runGet g bs in v | ||
96 | |||
97 | compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
98 | compress algo = toStrictBS . lazyCompress algo . toLazyBS | ||
99 | |||
100 | decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
101 | decompress algo = toStrictBS . lazyDecompress algo . toLazyBS | ||
102 | |||
103 | toStrictBS :: LZ.ByteString -> B.ByteString | ||
104 | toStrictBS = B.concat . LZ.toChunks | ||
105 | |||
106 | toLazyBS :: B.ByteString -> LZ.ByteString | ||
107 | toLazyBS = LZ.fromChunks . (:[]) | ||
108 | #else | ||
109 | getRemainingByteString :: Get B.ByteString | ||
110 | getRemainingByteString = getRemainingLazyByteString | ||
111 | |||
112 | getSomeByteString :: Word64 -> Get B.ByteString | ||
113 | getSomeByteString = getLazyByteString . fromIntegral | ||
114 | |||
115 | putSomeByteString :: B.ByteString -> Put | ||
116 | putSomeByteString = putLazyByteString | ||
117 | |||
118 | unsafeRunGet :: Get a -> B.ByteString -> a | ||
119 | unsafeRunGet = runGet | ||
120 | |||
121 | compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
122 | compress = lazyCompress | ||
123 | |||
124 | decompress :: CompressionAlgorithm -> B.ByteString -> B.ByteString | ||
125 | decompress = lazyDecompress | ||
126 | #endif | ||
127 | |||
128 | lazyCompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString | ||
129 | lazyCompress Uncompressed = id | ||
130 | lazyCompress ZIP = Zip.compress | ||
131 | lazyCompress ZLIB = Zlib.compress | ||
132 | lazyCompress BZip2 = BZip2.compress | ||
133 | lazyCompress x = error ("No implementation for " ++ show x) | ||
134 | |||
135 | lazyDecompress :: CompressionAlgorithm -> LZ.ByteString -> LZ.ByteString | ||
136 | lazyDecompress Uncompressed = id | ||
137 | lazyDecompress ZIP = Zip.decompress | ||
138 | lazyDecompress ZLIB = Zlib.decompress | ||
139 | lazyDecompress BZip2 = BZip2.decompress | ||
140 | lazyDecompress x = error ("No implementation for " ++ show x) | ||
141 | |||
73 | data Packet = | 142 | data Packet = |
74 | SignaturePacket { | 143 | SignaturePacket { |
75 | version::Word8, | 144 | version::Word8, |
@@ -80,7 +149,7 @@ data Packet = | |||
80 | unhashed_subpackets::[SignatureSubpacket], | 149 | unhashed_subpackets::[SignatureSubpacket], |
81 | hash_head::Word16, | 150 | hash_head::Word16, |
82 | signature::[MPI], | 151 | signature::[MPI], |
83 | trailer::LZ.ByteString | 152 | trailer::B.ByteString |
84 | } | | 153 | } | |
85 | OnePassSignaturePacket { | 154 | OnePassSignaturePacket { |
86 | version::Word8, | 155 | version::Word8, |
@@ -107,8 +176,8 @@ data Packet = | |||
107 | s2k_hash_algorithm::Maybe HashAlgorithm, | 176 | s2k_hash_algorithm::Maybe HashAlgorithm, |
108 | s2k_salt::Maybe Word64, | 177 | s2k_salt::Maybe Word64, |
109 | s2k_count::Maybe Word32, | 178 | s2k_count::Maybe Word32, |
110 | encrypted_data::LZ.ByteString, | 179 | encrypted_data::B.ByteString, |
111 | private_hash::Maybe LZ.ByteString -- the hash may be in the encrypted data | 180 | private_hash::Maybe B.ByteString -- the hash may be in the encrypted data |
112 | } | | 181 | } | |
113 | CompressedDataPacket { | 182 | CompressedDataPacket { |
114 | compression_algorithm::CompressionAlgorithm, | 183 | compression_algorithm::CompressionAlgorithm, |
@@ -118,20 +187,20 @@ data Packet = | |||
118 | format::Char, | 187 | format::Char, |
119 | filename::String, | 188 | filename::String, |
120 | timestamp::Word32, | 189 | timestamp::Word32, |
121 | content::LZ.ByteString | 190 | content::B.ByteString |
122 | } | | 191 | } | |
123 | UserIDPacket String | | 192 | UserIDPacket String | |
124 | UnsupportedPacket Word8 LZ.ByteString | 193 | UnsupportedPacket Word8 B.ByteString |
125 | deriving (Show, Read, Eq) | 194 | deriving (Show, Read, Eq) |
126 | 195 | ||
127 | instance Binary Packet where | 196 | instance BINARY_CLASS Packet where |
128 | put p = do | 197 | put p = do |
129 | -- First two bits are 1 for new packet format | 198 | -- First two bits are 1 for new packet format |
130 | put ((tag .|. 0xC0) :: Word8) | 199 | put ((tag .|. 0xC0) :: Word8) |
131 | -- Use 5-octet lengths | 200 | -- Use 5-octet lengths |
132 | put (255 :: Word8) | 201 | put (255 :: Word8) |
133 | put ((fromIntegral $ LZ.length body) :: Word32) | 202 | put ((fromIntegral $ B.length body) :: Word32) |
134 | putLazyByteString body | 203 | putSomeByteString body |
135 | where | 204 | where |
136 | (body, tag) = put_packet p | 205 | (body, tag) = put_packet p |
137 | get = do | 206 | get = do |
@@ -143,8 +212,8 @@ instance Binary Packet where | |||
143 | ((tag `shiftR` 2) .&. 15, parse_old_length tag) | 212 | ((tag `shiftR` 2) .&. 15, parse_old_length tag) |
144 | len <- l | 213 | len <- l |
145 | -- This forces the whole packet to be consumed | 214 | -- This forces the whole packet to be consumed |
146 | packet <- getLazyByteString (fromIntegral len) | 215 | packet <- getSomeByteString (fromIntegral len) |
147 | return $ runGet (parse_packet t) packet | 216 | return $ unsafeRunGet (parse_packet t) packet |
148 | 217 | ||
149 | -- http://tools.ietf.org/html/rfc4880#section-4.2.2 | 218 | -- http://tools.ietf.org/html/rfc4880#section-4.2.2 |
150 | parse_new_length :: Get Word32 | 219 | parse_new_length :: Get Word32 |
@@ -199,7 +268,7 @@ secret_key_fields _ = undefined -- Nothing in the spec. Maybe empty | |||
199 | (!) xs = fromJust . (`lookup` xs) | 268 | (!) xs = fromJust . (`lookup` xs) |
200 | 269 | ||
201 | -- Need this seperate for trailer calculation | 270 | -- Need this seperate for trailer calculation |
202 | signature_packet_start :: Packet -> LZ.ByteString | 271 | signature_packet_start :: Packet -> B.ByteString |
203 | signature_packet_start (SignaturePacket { | 272 | signature_packet_start (SignaturePacket { |
204 | version = 4, | 273 | version = 4, |
205 | signature_type = signature_type, | 274 | signature_type = signature_type, |
@@ -207,50 +276,50 @@ signature_packet_start (SignaturePacket { | |||
207 | hash_algorithm = hash_algorithm, | 276 | hash_algorithm = hash_algorithm, |
208 | hashed_subpackets = hashed_subpackets | 277 | hashed_subpackets = hashed_subpackets |
209 | }) = | 278 | }) = |
210 | LZ.concat [ | 279 | B.concat [ |
211 | encode (0x04 :: Word8), | 280 | encode (0x04 :: Word8), |
212 | encode signature_type, | 281 | encode signature_type, |
213 | encode key_algorithm, | 282 | encode key_algorithm, |
214 | encode hash_algorithm, | 283 | encode hash_algorithm, |
215 | encode ((fromIntegral $ LZ.length hashed_subs) :: Word16), | 284 | encode ((fromIntegral $ B.length hashed_subs) :: Word16), |
216 | hashed_subs | 285 | hashed_subs |
217 | ] | 286 | ] |
218 | where | 287 | where |
219 | hashed_subs = LZ.concat $ map encode hashed_subpackets | 288 | hashed_subs = B.concat $ map encode hashed_subpackets |
220 | signature_packet_start _ = | 289 | signature_packet_start _ = |
221 | error "Trying to get start of signature packet for non signature packet." | 290 | error "Trying to get start of signature packet for non signature packet." |
222 | 291 | ||
223 | -- The trailer is just the top of the body plus some crap | 292 | -- The trailer is just the top of the body plus some crap |
224 | calculate_signature_trailer :: Packet -> LZ.ByteString | 293 | calculate_signature_trailer :: Packet -> B.ByteString |
225 | calculate_signature_trailer p = | 294 | calculate_signature_trailer p = |
226 | LZ.concat [ | 295 | B.concat [ |
227 | signature_packet_start p, | 296 | signature_packet_start p, |
228 | encode (0x04 :: Word8), | 297 | encode (0x04 :: Word8), |
229 | encode (0xff :: Word8), | 298 | encode (0xff :: Word8), |
230 | encode (fromIntegral (LZ.length $ signature_packet_start p) :: Word32) | 299 | encode (fromIntegral (B.length $ signature_packet_start p) :: Word32) |
231 | ] | 300 | ] |
232 | 301 | ||
233 | put_packet :: (Num a) => Packet -> (LZ.ByteString, a) | 302 | put_packet :: (Num a) => Packet -> (B.ByteString, a) |
234 | put_packet (SignaturePacket { version = 4, | 303 | put_packet (SignaturePacket { version = 4, |
235 | unhashed_subpackets = unhashed_subpackets, | 304 | unhashed_subpackets = unhashed_subpackets, |
236 | hash_head = hash_head, | 305 | hash_head = hash_head, |
237 | signature = signature, | 306 | signature = signature, |
238 | trailer = trailer }) = | 307 | trailer = trailer }) = |
239 | (LZ.concat $ [ | 308 | (B.concat $ [ |
240 | trailer_top, | 309 | trailer_top, |
241 | encode (fromIntegral $ LZ.length unhashed :: Word16), | 310 | encode (fromIntegral $ B.length unhashed :: Word16), |
242 | unhashed, encode hash_head | 311 | unhashed, encode hash_head |
243 | ] ++ map encode signature, 2) | 312 | ] ++ map encode signature, 2) |
244 | where | 313 | where |
245 | trailer_top = LZ.reverse $ LZ.drop 6 $ LZ.reverse trailer | 314 | trailer_top = B.reverse $ B.drop 6 $ B.reverse trailer |
246 | unhashed = LZ.concat $ map encode unhashed_subpackets | 315 | unhashed = B.concat $ map encode unhashed_subpackets |
247 | put_packet (OnePassSignaturePacket { version = version, | 316 | put_packet (OnePassSignaturePacket { version = version, |
248 | signature_type = signature_type, | 317 | signature_type = signature_type, |
249 | hash_algorithm = hash_algorithm, | 318 | hash_algorithm = hash_algorithm, |
250 | key_algorithm = key_algorithm, | 319 | key_algorithm = key_algorithm, |
251 | key_id = key_id, | 320 | key_id = key_id, |
252 | nested = nested }) = | 321 | nested = nested }) = |
253 | (LZ.concat [ encode version, encode signature_type, | 322 | (B.concat [ encode version, encode signature_type, |
254 | encode hash_algorithm, encode key_algorithm, | 323 | encode hash_algorithm, encode key_algorithm, |
255 | encode (fst $ head $ readHex key_id :: Word64), | 324 | encode (fst $ head $ readHex key_id :: Word64), |
256 | encode nested ], 4) | 325 | encode nested ], 4) |
@@ -263,7 +332,7 @@ put_packet (SecretKeyPacket { version = version, timestamp = timestamp, | |||
263 | s2k_salt = s2k_salt, | 332 | s2k_salt = s2k_salt, |
264 | s2k_count = s2k_count, | 333 | s2k_count = s2k_count, |
265 | encrypted_data = encrypted_data }) = | 334 | encrypted_data = encrypted_data }) = |
266 | (LZ.concat $ [p, encode s2k_useage] ++ | 335 | (B.concat $ [p, encode s2k_useage] ++ |
267 | (if s2k_useage `elem` [255, 254] then | 336 | (if s2k_useage `elem` [255, 254] then |
268 | [encode $ fromJust symmetric_type, encode s2k_t, | 337 | [encode $ fromJust symmetric_type, encode s2k_t, |
269 | encode $ fromJust s2k_hash_algo] ++ | 338 | encode $ fromJust s2k_hash_algo] ++ |
@@ -276,39 +345,32 @@ put_packet (SecretKeyPacket { version = version, timestamp = timestamp, | |||
276 | else s ++ | 345 | else s ++ |
277 | -- XXX: Checksum is part of encrypted_data for V4 ONLY | 346 | -- XXX: Checksum is part of encrypted_data for V4 ONLY |
278 | if s2k_useage == 254 then | 347 | if s2k_useage == 254 then |
279 | [LZ.replicate 20 0] -- TODO SHA1 Checksum | 348 | [B.replicate 20 0] -- TODO SHA1 Checksum |
280 | else | 349 | else |
281 | [encode (fromIntegral $ | 350 | [encode (fromIntegral $ |
282 | LZ.foldl (\c i -> (c + fromIntegral i) `mod` 65536) | 351 | B.foldl (\c i -> (c + fromIntegral i) `mod` 65536) |
283 | (0::Integer) (LZ.concat s) :: Word16)]), 5) | 352 | (0::Integer) (B.concat s) :: Word16)]), 5) |
284 | where | 353 | where |
285 | (Just s2k_t) = s2k_type | 354 | (Just s2k_t) = s2k_type |
286 | p = fst (put_packet $ PublicKeyPacket version timestamp algorithm key | 355 | p = fst (put_packet $ PublicKeyPacket version timestamp algorithm key |
287 | :: (LZ.ByteString, Integer)) -- Supress warning | 356 | :: (B.ByteString, Integer)) -- Supress warning |
288 | s = map (encode . (key !)) (secret_key_fields algorithm) | 357 | s = map (encode . (key !)) (secret_key_fields algorithm) |
289 | put_packet (PublicKeyPacket { version = 4, timestamp = timestamp, | 358 | put_packet (PublicKeyPacket { version = 4, timestamp = timestamp, |
290 | key_algorithm = algorithm, key = key }) = | 359 | key_algorithm = algorithm, key = key }) = |
291 | (LZ.concat $ [LZ.singleton 4, encode timestamp, encode algorithm] ++ | 360 | (B.concat $ [B.singleton 4, encode timestamp, encode algorithm] ++ |
292 | map (encode . (key !)) (public_key_fields algorithm), 6) | 361 | map (encode . (key !)) (public_key_fields algorithm), 6) |
293 | put_packet (CompressedDataPacket { compression_algorithm = algorithm, | 362 | put_packet (CompressedDataPacket { compression_algorithm = algorithm, |
294 | message = message }) = | 363 | message = message }) = |
295 | (LZ.append (encode algorithm) $ compress $ encode message, 8) | 364 | (B.append (encode algorithm) $ compress algorithm $ encode message, 8) |
296 | where | ||
297 | compress = case algorithm of | ||
298 | Uncompressed -> id | ||
299 | ZIP -> Zip.compress | ||
300 | ZLIB -> Zlib.compress | ||
301 | BZip2 -> BZip2.compress | ||
302 | x -> error ("No implementation for " ++ show x) | ||
303 | put_packet (LiteralDataPacket { format = format, filename = filename, | 365 | put_packet (LiteralDataPacket { format = format, filename = filename, |
304 | timestamp = timestamp, content = content | 366 | timestamp = timestamp, content = content |
305 | }) = | 367 | }) = |
306 | (LZ.concat [encode format, encode filename_l, lz_filename, | 368 | (B.concat [encode format, encode filename_l, lz_filename, |
307 | encode timestamp, content], 11) | 369 | encode timestamp, content], 11) |
308 | where | 370 | where |
309 | filename_l = (fromIntegral $ LZ.length lz_filename) :: Word8 | 371 | filename_l = (fromIntegral $ B.length lz_filename) :: Word8 |
310 | lz_filename = LZ.fromString filename | 372 | lz_filename = B.fromString filename |
311 | put_packet (UserIDPacket txt) = (LZ.fromString txt, 13) | 373 | put_packet (UserIDPacket txt) = (B.fromString txt, 13) |
312 | put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag) | 374 | put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag) |
313 | put_packet _ = error "Unsupported Packet version or type in put_packet." | 375 | put_packet _ = error "Unsupported Packet version or type in put_packet." |
314 | 376 | ||
@@ -323,11 +385,11 @@ parse_packet 2 = do | |||
323 | key_algorithm <- get | 385 | key_algorithm <- get |
324 | hash_algorithm <- get | 386 | hash_algorithm <- get |
325 | hashed_size <- fmap fromIntegral (get :: Get Word16) | 387 | hashed_size <- fmap fromIntegral (get :: Get Word16) |
326 | hashed_data <- getLazyByteString hashed_size | 388 | hashed_data <- getSomeByteString hashed_size |
327 | let hashed = runGet listUntilEnd hashed_data | 389 | let hashed = unsafeRunGet listUntilEnd hashed_data |
328 | unhashed_size <- fmap fromIntegral (get :: Get Word16) | 390 | unhashed_size <- fmap fromIntegral (get :: Get Word16) |
329 | unhashed_data <- getLazyByteString unhashed_size | 391 | unhashed_data <- getSomeByteString unhashed_size |
330 | let unhashed = runGet listUntilEnd unhashed_data | 392 | let unhashed = unsafeRunGet listUntilEnd unhashed_data |
331 | hash_head <- get | 393 | hash_head <- get |
332 | signature <- listUntilEnd | 394 | signature <- listUntilEnd |
333 | return SignaturePacket { | 395 | return SignaturePacket { |
@@ -339,7 +401,7 @@ parse_packet 2 = do | |||
339 | unhashed_subpackets = unhashed, | 401 | unhashed_subpackets = unhashed, |
340 | hash_head = hash_head, | 402 | hash_head = hash_head, |
341 | signature = signature, | 403 | signature = signature, |
342 | trailer = LZ.concat [encode version, encode signature_type, encode key_algorithm, encode hash_algorithm, encode (fromIntegral hashed_size :: Word16), hashed_data, LZ.pack [4, 0xff], encode ((6 + fromIntegral hashed_size) :: Word32)] | 404 | 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)] |
343 | } | 405 | } |
344 | x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "." | 406 | x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "." |
345 | -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 | 407 | -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 |
@@ -386,14 +448,14 @@ parse_packet 5 = do | |||
386 | _ -> | 448 | _ -> |
387 | return (k Nothing Nothing Nothing Nothing Nothing) | 449 | return (k Nothing Nothing Nothing Nothing Nothing) |
388 | if s2k_useage > 0 then do { | 450 | if s2k_useage > 0 then do { |
389 | encrypted <- getRemainingLazyByteString; | 451 | encrypted <- getRemainingByteString; |
390 | return (k' encrypted Nothing) | 452 | return (k' encrypted Nothing) |
391 | } else do | 453 | } else do |
392 | key <- foldM (\m f -> do | 454 | key <- foldM (\m f -> do |
393 | mpi <- get :: Get MPI | 455 | mpi <- get :: Get MPI |
394 | return $ (f,mpi):m) key (secret_key_fields algorithm) | 456 | return $ (f,mpi):m) key (secret_key_fields algorithm) |
395 | private_hash <- getRemainingLazyByteString | 457 | private_hash <- getRemainingByteString |
396 | return ((k' LZ.empty (Just private_hash)) {key = key}) | 458 | return ((k' B.empty (Just private_hash)) {key = key}) |
397 | -- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2 | 459 | -- PublicKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.2 |
398 | parse_packet 6 = do | 460 | parse_packet 6 = do |
399 | version <- get :: Get Word8 | 461 | version <- get :: Get Word8 |
@@ -414,51 +476,45 @@ parse_packet 6 = do | |||
414 | -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 | 476 | -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 |
415 | parse_packet 8 = do | 477 | parse_packet 8 = do |
416 | algorithm <- get | 478 | algorithm <- get |
417 | message <- getRemainingLazyByteString | 479 | message <- getRemainingByteString |
418 | let decompress = case algorithm of | ||
419 | Uncompressed -> id | ||
420 | ZIP -> Zip.decompress | ||
421 | ZLIB -> Zlib.decompress | ||
422 | BZip2 -> BZip2.decompress | ||
423 | x -> error ("No implementation for " ++ show x) | ||
424 | return CompressedDataPacket { | 480 | return CompressedDataPacket { |
425 | compression_algorithm = algorithm, | 481 | compression_algorithm = algorithm, |
426 | message = runGet (get :: Get Message) (decompress message) | 482 | message = unsafeRunGet get (decompress algorithm message) |
427 | } | 483 | } |
428 | -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9 | 484 | -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9 |
429 | parse_packet 11 = do | 485 | parse_packet 11 = do |
430 | format <- get | 486 | format <- get |
431 | filenameLength <- get :: Get Word8 | 487 | filenameLength <- get :: Get Word8 |
432 | filename <- getLazyByteString (fromIntegral filenameLength) | 488 | filename <- getSomeByteString (fromIntegral filenameLength) |
433 | timestamp <- get | 489 | timestamp <- get |
434 | content <- getRemainingLazyByteString | 490 | content <- getRemainingByteString |
435 | return LiteralDataPacket { | 491 | return LiteralDataPacket { |
436 | format = format, | 492 | format = format, |
437 | filename = LZ.toString filename, | 493 | filename = B.toString filename, |
438 | timestamp = timestamp, | 494 | timestamp = timestamp, |
439 | content = content | 495 | content = content |
440 | } | 496 | } |
441 | -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 | 497 | -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 |
442 | parse_packet 13 = | 498 | parse_packet 13 = |
443 | fmap (UserIDPacket . LZ.toString) getRemainingLazyByteString | 499 | fmap (UserIDPacket . B.toString) getRemainingByteString |
444 | -- Represent unsupported packets as their tag and literal bytes | 500 | -- Represent unsupported packets as their tag and literal bytes |
445 | parse_packet tag = fmap (UnsupportedPacket tag) getRemainingLazyByteString | 501 | parse_packet tag = fmap (UnsupportedPacket tag) getRemainingByteString |
446 | 502 | ||
447 | -- | Helper method for fingerprints and such | 503 | -- | Helper method for fingerprints and such |
448 | fingerprint_material :: Packet -> [LZ.ByteString] | 504 | fingerprint_material :: Packet -> [B.ByteString] |
449 | fingerprint_material (PublicKeyPacket {version = 4, | 505 | fingerprint_material (PublicKeyPacket {version = 4, |
450 | timestamp = timestamp, | 506 | timestamp = timestamp, |
451 | key_algorithm = algorithm, | 507 | key_algorithm = algorithm, |
452 | key = key}) = | 508 | key = key}) = |
453 | [ | 509 | [ |
454 | LZ.singleton 0x99, | 510 | B.singleton 0x99, |
455 | encode (6 + fromIntegral (LZ.length material) :: Word16), | 511 | encode (6 + fromIntegral (B.length material) :: Word16), |
456 | LZ.singleton 4, encode timestamp, encode algorithm, | 512 | B.singleton 4, encode timestamp, encode algorithm, |
457 | material | 513 | material |
458 | ] | 514 | ] |
459 | where | 515 | where |
460 | material = | 516 | material = |
461 | LZ.concat $ map (encode . (key !)) (public_key_fields algorithm) | 517 | B.concat $ map (encode . (key !)) (public_key_fields algorithm) |
462 | -- Proxy to make SecretKeyPacket work | 518 | -- Proxy to make SecretKeyPacket work |
463 | fingerprint_material (SecretKeyPacket {version = 4, | 519 | fingerprint_material (SecretKeyPacket {version = 4, |
464 | timestamp = timestamp, | 520 | timestamp = timestamp, |
@@ -470,8 +526,8 @@ fingerprint_material (SecretKeyPacket {version = 4, | |||
470 | key = key} | 526 | key = key} |
471 | fingerprint_material p | version p `elem` [2, 3] = [n, e] | 527 | fingerprint_material p | version p `elem` [2, 3] = [n, e] |
472 | where | 528 | where |
473 | n = LZ.drop 2 (encode (key p ! 'n')) | 529 | n = B.drop 2 (encode (key p ! 'n')) |
474 | e = LZ.drop 2 (encode (key p ! 'e')) | 530 | e = B.drop 2 (encode (key p ! 'e')) |
475 | fingerprint_material _ = | 531 | fingerprint_material _ = |
476 | error "Unsupported Packet version or type in fingerprint_material." | 532 | error "Unsupported Packet version or type in fingerprint_material." |
477 | 533 | ||
@@ -502,7 +558,7 @@ instance Enum HashAlgorithm where | |||
502 | fromEnum SHA224 = 11 | 558 | fromEnum SHA224 = 11 |
503 | fromEnum (HashAlgorithm x) = fromIntegral x | 559 | fromEnum (HashAlgorithm x) = fromIntegral x |
504 | 560 | ||
505 | instance Binary HashAlgorithm where | 561 | instance BINARY_CLASS HashAlgorithm where |
506 | put = put . enum_to_word8 | 562 | put = put . enum_to_word8 |
507 | get = fmap enum_from_word8 get | 563 | get = fmap enum_from_word8 get |
508 | 564 | ||
@@ -529,7 +585,7 @@ instance Enum KeyAlgorithm where | |||
529 | fromEnum DH = 21 | 585 | fromEnum DH = 21 |
530 | fromEnum (KeyAlgorithm x) = fromIntegral x | 586 | fromEnum (KeyAlgorithm x) = fromIntegral x |
531 | 587 | ||
532 | instance Binary KeyAlgorithm where | 588 | instance BINARY_CLASS KeyAlgorithm where |
533 | put = put . enum_to_word8 | 589 | put = put . enum_to_word8 |
534 | get = fmap enum_from_word8 get | 590 | get = fmap enum_from_word8 get |
535 | 591 | ||
@@ -548,13 +604,13 @@ instance Enum CompressionAlgorithm where | |||
548 | fromEnum BZip2 = 3 | 604 | fromEnum BZip2 = 3 |
549 | fromEnum (CompressionAlgorithm x) = fromIntegral x | 605 | fromEnum (CompressionAlgorithm x) = fromIntegral x |
550 | 606 | ||
551 | instance Binary CompressionAlgorithm where | 607 | instance BINARY_CLASS CompressionAlgorithm where |
552 | put = put . enum_to_word8 | 608 | put = put . enum_to_word8 |
553 | get = fmap enum_from_word8 get | 609 | get = fmap enum_from_word8 get |
554 | 610 | ||
555 | -- A message is encoded as a list that takes the entire file | 611 | -- A message is encoded as a list that takes the entire file |
556 | newtype Message = Message [Packet] deriving (Show, Read, Eq) | 612 | newtype Message = Message [Packet] deriving (Show, Read, Eq) |
557 | instance Binary Message where | 613 | instance BINARY_CLASS Message where |
558 | put (Message xs) = mapM_ put xs | 614 | put (Message xs) = mapM_ put xs |
559 | get = fmap Message listUntilEnd | 615 | get = fmap Message listUntilEnd |
560 | 616 | ||
@@ -569,24 +625,24 @@ signatures_and_data (Message lst) = | |||
569 | isDta _ = False | 625 | isDta _ = False |
570 | 626 | ||
571 | newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) | 627 | newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) |
572 | instance Binary MPI where | 628 | instance BINARY_CLASS MPI where |
573 | put (MPI i) = do | 629 | put (MPI i) = do |
574 | put (((fromIntegral . LZ.length $ bytes) - 1) * 8 | 630 | put (((fromIntegral . B.length $ bytes) - 1) * 8 |
575 | + floor (logBase (2::Double) $ fromIntegral (bytes `LZ.index` 0)) | 631 | + floor (logBase (2::Double) $ fromIntegral (bytes `B.index` 0)) |
576 | + 1 :: Word16) | 632 | + 1 :: Word16) |
577 | putLazyByteString bytes | 633 | putSomeByteString bytes |
578 | where | 634 | where |
579 | bytes = LZ.reverse $ LZ.unfoldr (\x -> | 635 | bytes = B.reverse $ B.unfoldr (\x -> |
580 | if x == 0 then Nothing else | 636 | if x == 0 then Nothing else |
581 | Just (fromIntegral x, x `shiftR` 8) | 637 | Just (fromIntegral x, x `shiftR` 8) |
582 | ) i | 638 | ) i |
583 | get = do | 639 | get = do |
584 | length <- fmap fromIntegral (get :: Get Word16) | 640 | length <- fmap fromIntegral (get :: Get Word16) |
585 | bytes <- getLazyByteString ((length + 7) `div` 8) | 641 | bytes <- getSomeByteString ((length + 7) `div` 8) |
586 | return (MPI (LZ.foldl (\a b -> | 642 | return (MPI (B.foldl (\a b -> |
587 | a `shiftL` 8 .|. fromIntegral b) 0 bytes)) | 643 | a `shiftL` 8 .|. fromIntegral b) 0 bytes)) |
588 | 644 | ||
589 | listUntilEnd :: (Binary a) => Get [a] | 645 | listUntilEnd :: (BINARY_CLASS a) => Get [a] |
590 | listUntilEnd = do | 646 | listUntilEnd = do |
591 | done <- isEmpty | 647 | done <- isEmpty |
592 | if done then return [] else do | 648 | if done then return [] else do |
@@ -597,16 +653,16 @@ listUntilEnd = do | |||
597 | data SignatureSubpacket = | 653 | data SignatureSubpacket = |
598 | SignatureCreationTimePacket Word32 | | 654 | SignatureCreationTimePacket Word32 | |
599 | IssuerPacket String | | 655 | IssuerPacket String | |
600 | UnsupportedSignatureSubpacket Word8 LZ.ByteString | 656 | UnsupportedSignatureSubpacket Word8 B.ByteString |
601 | deriving (Show, Read, Eq) | 657 | deriving (Show, Read, Eq) |
602 | 658 | ||
603 | instance Binary SignatureSubpacket where | 659 | instance BINARY_CLASS SignatureSubpacket where |
604 | put p = do | 660 | put p = do |
605 | -- Use 5-octet-length + 1 for tag as the first packet body octet | 661 | -- Use 5-octet-length + 1 for tag as the first packet body octet |
606 | put (255 :: Word8) | 662 | put (255 :: Word8) |
607 | put (fromIntegral (LZ.length body) + 1 :: Word32) | 663 | put (fromIntegral (B.length body) + 1 :: Word32) |
608 | put tag | 664 | put tag |
609 | putLazyByteString body | 665 | putSomeByteString body |
610 | where | 666 | where |
611 | (body, tag) = put_signature_subpacket p | 667 | (body, tag) = put_signature_subpacket p |
612 | get = do | 668 | get = do |
@@ -621,8 +677,8 @@ instance Binary SignatureSubpacket where | |||
621 | return len | 677 | return len |
622 | tag <- get :: Get Word8 | 678 | tag <- get :: Get Word8 |
623 | -- This forces the whole packet to be consumed | 679 | -- This forces the whole packet to be consumed |
624 | packet <- getLazyByteString (len-1) | 680 | packet <- getSomeByteString (len-1) |
625 | return $ runGet (parse_signature_subpacket tag) packet | 681 | return $ unsafeRunGet (parse_signature_subpacket tag) packet |
626 | 682 | ||
627 | -- | Find the keyid that issued a SignaturePacket | 683 | -- | Find the keyid that issued a SignaturePacket |
628 | signature_issuer :: Packet -> Maybe String | 684 | signature_issuer :: Packet -> Maybe String |
@@ -635,7 +691,7 @@ signature_issuer (SignaturePacket {hashed_subpackets = hashed, | |||
635 | isIssuer _ = False | 691 | isIssuer _ = False |
636 | signature_issuer _ = Nothing | 692 | signature_issuer _ = Nothing |
637 | 693 | ||
638 | put_signature_subpacket :: SignatureSubpacket -> (LZ.ByteString, Word8) | 694 | put_signature_subpacket :: SignatureSubpacket -> (B.ByteString, Word8) |
639 | put_signature_subpacket (SignatureCreationTimePacket time) = | 695 | put_signature_subpacket (SignatureCreationTimePacket time) = |
640 | (encode time, 2) | 696 | (encode time, 2) |
641 | put_signature_subpacket (IssuerPacket keyid) = | 697 | put_signature_subpacket (IssuerPacket keyid) = |
@@ -652,7 +708,7 @@ parse_signature_subpacket 16 = do | |||
652 | return $ IssuerPacket (map toUpper $ showHex keyid "") | 708 | return $ IssuerPacket (map toUpper $ showHex keyid "") |
653 | -- Represent unsupported packets as their tag and literal bytes | 709 | -- Represent unsupported packets as their tag and literal bytes |
654 | parse_signature_subpacket tag = | 710 | parse_signature_subpacket tag = |
655 | fmap (UnsupportedSignatureSubpacket tag) getRemainingLazyByteString | 711 | fmap (UnsupportedSignatureSubpacket tag) getRemainingByteString |
656 | 712 | ||
657 | decode_s2k_count :: Word8 -> Word32 | 713 | decode_s2k_count :: Word8 -> Word32 |
658 | decode_s2k_count c = (16 + (fromIntegral c .&. 15)) `shiftL` | 714 | decode_s2k_count c = (16 + (fromIntegral c .&. 15)) `shiftL` |