openpgp 0.4 → 0.5
raw patch · 5 files changed
+165/−89 lines, 5 filesdep ~basedep ~binarybinary-added
Dependency ranges changed: base, binary
Files
- Data/OpenPGP.hs +135/−70
- Data/OpenPGP/Arbitrary.hs +22/−12
- README +2/−2
- openpgp.cabal +6/−5
- tests/data/002182-002.sig binary
Data/OpenPGP.hs view
@@ -6,13 +6,16 @@ -- > import qualified Data.OpenPGP as OpenPGP module Data.OpenPGP ( Packet(+ AsymmetricSessionKeyPacket, OnePassSignaturePacket, PublicKeyPacket, SecretKeyPacket, CompressedDataPacket, MarkerPacket, LiteralDataPacket,+ TrustPacket, UserIDPacket,+ EncryptedDataPacket, ModificationDetectionCodePacket, UnsupportedPacket, compression_algorithm,@@ -62,7 +65,8 @@ import Numeric import Control.Monad-import Control.Exception (assert)+import Control.Arrow+import Control.Applicative import Data.Bits import Data.Word import Data.Char@@ -99,8 +103,10 @@ putSomeByteString :: B.ByteString -> Put putSomeByteString = putByteString -unsafeRunGet :: Get a -> B.ByteString -> a-unsafeRunGet g bs = let Right v = runGet g bs in v+localGet :: Get a -> B.ByteString -> Get a+localGet g bs = case runGet g bs of+ Left s -> fail s+ Right v -> return v compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString compress algo = toStrictBS . lazyCompress algo . toLazyBS@@ -123,8 +129,12 @@ putSomeByteString :: B.ByteString -> Put putSomeByteString = putLazyByteString -unsafeRunGet :: Get a -> B.ByteString -> a-unsafeRunGet = runGet+localGet :: Get a -> B.ByteString -> Get a+localGet g bs = case runGetOrFail g bs of+ Left (_,_,s) -> fail s+ Right (leftover,_,v)+ | B.null leftover -> return v+ | otherwise -> fail $ "Leftover in localGet: " ++ show leftover compress :: CompressionAlgorithm -> B.ByteString -> B.ByteString compress = lazyCompress@@ -147,10 +157,24 @@ lazyDecompress BZip2 = BZip2.decompress lazyDecompress x = error ("No implementation for " ++ show x) -assertProp :: (a -> Bool) -> a -> a-assertProp f x = assert (f x) x+assertProp :: (Monad m, Show a) => (a -> Bool) -> a -> m a+assertProp f x+ | f x = return $! x+ | otherwise = fail $ "Assertion failed for: " ++ show x +pad :: Int -> String -> String+pad l s = replicate (l - length s) '0' ++ s++padBS :: Int -> B.ByteString -> B.ByteString+padBS l s = B.replicate (fromIntegral l - B.length s) 0 `B.append` s+ data Packet =+ AsymmetricSessionKeyPacket {+ version::Word8,+ key_id::String,+ key_algorithm::KeyAlgorithm,+ encrypted_data::B.ByteString+ } | SignaturePacket { version::Word8, signature_type::Word8,@@ -204,7 +228,12 @@ timestamp::Word32, content::B.ByteString } |+ TrustPacket B.ByteString | UserIDPacket String |+ EncryptedDataPacket {+ version::Word8, -- 0 for old-skool no-MDC (tag 9)+ encrypted_data::B.ByteString+ } | ModificationDetectionCodePacket B.ByteString | UnsupportedPacket Word8 B.ByteString deriving (Show, Read, Eq)@@ -214,7 +243,7 @@ -- First two bits are 1 for new packet format put ((tag .|. 0xC0) :: Word8) case tag of- 19 -> put (assertProp (<192) blen :: Word8)+ 19 -> put =<< assertProp (<192) (blen :: Word8) _ -> do -- Use 5-octet lengths put (255 :: Word8)@@ -225,45 +254,53 @@ blen = fromIntegral $ B.length body (body, tag) = put_packet p get = do- tag <- get :: Get Word8- let (t, l) =- if (tag .&. 64) /= 0 then- (tag .&. 63, parse_new_length)- else- ((tag `shiftR` 2) .&. 15, parse_old_length tag)- len <- l- -- This forces the whole packet to be consumed- packet <- getSomeByteString (fromIntegral len)- return $ unsafeRunGet (parse_packet t) packet+ (t, packet) <- get_packet_bytes+ localGet (parse_packet t) (B.concat packet) +get_packet_bytes :: Get (Word8, [B.ByteString])+get_packet_bytes = do+ tag <- get+ let (t, l) =+ if (tag .&. 64) /= 0 then+ (tag .&. 63, fmap (first Just) parse_new_length)+ else+ ((tag `shiftR` 2) .&. 15, (,) <$> parse_old_length tag <*> pure False)+ (len, partial) <- l+ -- This forces the whole packet to be consumed+ packet <- maybe getRemainingByteString (getSomeByteString . fromIntegral) len+ if not partial then return (t, [packet]) else+ (,) t <$> ((packet:) . snd) <$> get_packet_bytes+ -- http://tools.ietf.org/html/rfc4880#section-4.2.2-parse_new_length :: Get Word32+parse_new_length :: Get (Word32, Bool) parse_new_length = do len <- fmap fromIntegral (get :: Get Word8) case len of -- One octet length- _ | len < 192 -> return len+ _ | len < 192 -> return (len, False) -- Two octet length _ | len > 191 && len < 224 -> do second <- fmap fromIntegral (get :: Get Word8)- return $ ((len - 192) `shiftL` 8) + second + 192+ return (((len - 192) `shiftL` 8) + second + 192, False) -- Five octet length- 255 -> get :: Get Word32- -- TODO: Partial body lengths. 1 << (len & 0x1F)+ 255 -> (,) <$> (get :: Get Word32) <*> pure False+ -- Partial length (streaming)+ _ | len >= 224 && len < 255 ->+ return (1 `shiftL` (fromIntegral len .&. 0x1F), True) _ -> fail "Unsupported new packet length." -- http://tools.ietf.org/html/rfc4880#section-4.2.1-parse_old_length :: Word8 -> Get Word32+parse_old_length :: Word8 -> Get (Maybe Word32) parse_old_length tag = case tag .&. 3 of -- One octet length- 0 -> fmap fromIntegral (get :: Get Word8)+ 0 -> fmap (Just . fromIntegral) (get :: Get Word8) -- Two octet length- 1 -> fmap fromIntegral (get :: Get Word16)+ 1 -> fmap (Just . fromIntegral) (get :: Get Word16) -- Four octet length- 2 -> get+ 2 -> fmap Just get -- Indeterminate length- 3 -> fmap fromIntegral remaining+ 3 -> return Nothing -- Error _ -> fail "Unsupported old packet length." @@ -334,7 +371,14 @@ calculate_signature_trailer x = error ("Trying to calculate signature trailer for: " ++ show x) -put_packet :: (Num a) => Packet -> (B.ByteString, a)+put_packet :: Packet -> (B.ByteString, Word8)+put_packet (AsymmetricSessionKeyPacket version key_id key_algorithm dta) =+ (B.concat [+ encode version,+ encode (fst $ head $ readHex key_id :: Word64),+ encode key_algorithm,+ dta+ ], 1) put_packet (SignaturePacket { version = v, unhashed_subpackets = unhashed_subpackets, key_algorithm = key_algorithm,@@ -376,10 +420,12 @@ key_algorithm = key_algorithm, key_id = key_id, nested = nested }) =- (B.concat [ encode version, encode signature_type,- encode hash_algorithm, encode key_algorithm,- encode (fst $ head $ readHex key_id :: Word64),- encode nested ], 4)+ (B.concat [+ encode version, encode signature_type,+ encode hash_algorithm, encode key_algorithm,+ encode (fst $ head $ readHex key_id :: Word64),+ encode nested+ ], 4) put_packet (SecretKeyPacket { version = version, timestamp = timestamp, key_algorithm = algorithm, key = key, s2k_useage = s2k_useage,@@ -412,8 +458,7 @@ where (Just s2k_t) = s2k_type p = fst (put_packet $- PublicKeyPacket version timestamp algorithm key False Nothing- :: (B.ByteString, Integer)) -- Supress warning+ PublicKeyPacket version timestamp algorithm key False Nothing) s = map (encode . (key !)) (secret_key_fields algorithm) put_packet p@(PublicKeyPacket { version = v, timestamp = timestamp, key_algorithm = algorithm, key = key,@@ -438,23 +483,35 @@ put_packet (LiteralDataPacket { format = format, filename = filename, timestamp = timestamp, content = content }) =- (B.concat [encode format, encode filename_l, lz_filename,- encode timestamp, content], 11)+ (B.concat [+ encode format, encode filename_l, lz_filename,+ encode timestamp, content+ ], 11) where filename_l = (fromIntegral $ B.length lz_filename) :: Word8 lz_filename = B.fromString filename+put_packet (TrustPacket bytes) = (bytes, 12) put_packet (UserIDPacket txt) = (B.fromString txt, 13)+put_packet (EncryptedDataPacket 0 encrypted_data) = (encrypted_data, 9)+put_packet (EncryptedDataPacket version encrypted_data) =+ (B.concat [encode version, encrypted_data], 18) put_packet (ModificationDetectionCodePacket bstr) = (bstr, 19) put_packet (UnsupportedPacket tag bytes) = (bytes, fromIntegral tag) put_packet x = error ("Unsupported Packet version or type in put_packet: " ++ show x) parse_packet :: Word8 -> Get Packet+-- AsymmetricSessionKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.1+parse_packet 1 = AsymmetricSessionKeyPacket+ <$> (assertProp (==3) =<< get)+ <*> fmap (pad 16 . map toUpper . flip showHex "") (get :: Get Word64)+ <*> get+ <*> getRemainingByteString -- SignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.2 parse_packet 2 = do version <- get case version of _ | version `elem` [2,3] -> do- _ <- fmap (assertProp (==5)) (get :: Get Word8)+ _ <- assertProp (==5) =<< (get :: Get Word8) signature_type <- get creation_time <- get :: Get Word32 keyid <- get :: Get Word64@@ -470,7 +527,7 @@ hashed_subpackets = [], unhashed_subpackets = [ SignatureCreationTimePacket creation_time,- IssuerPacket $ pad $ map toUpper $ showHex keyid ""+ IssuerPacket $ pad 16 $ map toUpper $ showHex keyid "" ], hash_head = hash_head, signature = signature,@@ -482,10 +539,10 @@ hash_algorithm <- get hashed_size <- fmap fromIntegral (get :: Get Word16) hashed_data <- getSomeByteString hashed_size- let hashed = unsafeRunGet listUntilEnd hashed_data+ hashed <- localGet listUntilEnd hashed_data unhashed_size <- fmap fromIntegral (get :: Get Word16) unhashed_data <- getSomeByteString unhashed_size- let unhashed = unsafeRunGet listUntilEnd unhashed_data+ unhashed <- localGet listUntilEnd unhashed_data hash_head <- get signature <- listUntilEnd return SignaturePacket {@@ -500,8 +557,6 @@ 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)] } x -> fail $ "Unknown SignaturePacket version " ++ show x ++ "."- where- pad s = replicate (16 - length s) '0' ++ s -- OnePassSignaturePacket, http://tools.ietf.org/html/rfc4880#section-5.4 parse_packet 4 = do version <- get@@ -515,11 +570,9 @@ signature_type = signature_type, hash_algorithm = hash_algo, key_algorithm = key_algo,- key_id = pad $ map toUpper $ showHex key_id "",+ key_id = pad 16 $ map toUpper $ showHex key_id "", nested = nested }- where- pad s = replicate (16 - length s) '0' ++ s -- SecretKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.5.3 parse_packet 5 = do -- Parse PublicKey part@@ -593,11 +646,13 @@ -- CompressedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.6 parse_packet 8 = do algorithm <- get- message <- getRemainingByteString+ message <- localGet get =<< (decompress algorithm <$> getRemainingByteString) return CompressedDataPacket { compression_algorithm = algorithm,- message = unsafeRunGet get (decompress algorithm message)+ message = message }+-- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.7+parse_packet 9 = EncryptedDataPacket 0 <$> getRemainingByteString -- MarkerPacket, http://tools.ietf.org/html/rfc4880#section-5.8 parse_packet 10 = return MarkerPacket -- LiteralDataPacket, http://tools.ietf.org/html/rfc4880#section-5.9@@ -613,6 +668,8 @@ timestamp = timestamp, content = content }+-- TrustPacket, http://tools.ietf.org/html/rfc4880#section-5.10+parse_packet 12 = fmap TrustPacket getRemainingByteString -- UserIDPacket, http://tools.ietf.org/html/rfc4880#section-5.11 parse_packet 13 = fmap (UserIDPacket . B.toString) getRemainingByteString@@ -620,6 +677,8 @@ parse_packet 14 = do p <- parse_packet 6 return p {is_subkey = True}+-- EncryptedDataPacket, http://tools.ietf.org/html/rfc4880#section-5.13+parse_packet 18 = EncryptedDataPacket <$> get <*> getRemainingByteString -- ModificationDetectionCodePacket, http://tools.ietf.org/html/rfc4880#section-5.14 parse_packet 19 = fmap ModificationDetectionCodePacket getRemainingByteString@@ -789,20 +848,26 @@ newtype MPI = MPI Integer deriving (Show, Read, Eq, Ord) instance BINARY_CLASS MPI where- put (MPI i) = do- put (((fromIntegral . B.length $ bytes) - 1) * 8- + floor (logBase (2::Double) $ fromIntegral (bytes `B.index` 0))- + 1 :: Word16)- putSomeByteString bytes+ put (MPI i)+ | i >= 0 = do+ put (bitl :: Word16)+ putSomeByteString bytes+ | otherwise = fail $ "MPI is less than 0: " ++ show i where- bytes = if B.null bytes' then B.singleton 0 else bytes'+ (bytes, bitl)+ | B.null bytes' = (B.singleton 0, 1)+ | otherwise =+ (bytes', (fromIntegral (B.length bytes') - 1) * 8 + sigBit)++ sigBit = fst $ until ((==0) . snd)+ (first (+1) . second (`shiftR` 1)) (0,B.index bytes 0) bytes' = B.reverse $ B.unfoldr (\x -> if x == 0 then Nothing else Just (fromIntegral x, x `shiftR` 8)- ) (assertProp (>=0) i)+ ) i get = do length <- fmap fromIntegral (get :: Get Word16)- bytes <- getSomeByteString ((length + 7) `div` 8)+ bytes <- getSomeByteString =<< assertProp (>0) ((length + 7) `div` 8) return (MPI (B.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0 bytes)) @@ -884,7 +949,7 @@ tag <- fmap stripCrit get :: Get Word8 -- This forces the whole packet to be consumed packet <- getSomeByteString (len-1)- return $ unsafeRunGet (parse_signature_subpacket tag) packet+ localGet (parse_signature_subpacket tag) packet where -- TODO: Decide how to actually encode the "is critical" data -- instead of just ignoring it@@ -911,7 +976,7 @@ (B.concat [encode bitfield, encode kalgo, fprb], 12) where bitfield = 0x80 .|. (if sensitive then 0x40 else 0x0) :: Word8- fprb = B.drop 2 $ encode (MPI fpri)+ fprb = padBS 20 $ B.drop 2 $ encode (MPI fpri) fpri = fst $ head $ readHex fpr put_signature_subpacket (IssuerPacket keyid) = (encode (fst $ head $ readHex keyid :: Word64), 16)@@ -960,8 +1025,9 @@ (B.singleton $ if supports_mdc then 0x01 else 0x00, 30) put_signature_subpacket (SignatureTargetPacket kalgo halgo hash) = (B.concat [encode kalgo, encode halgo, hash], 31)-put_signature_subpacket (EmbeddedSignaturePacket packet) =- (fst $ put_packet (assertProp isSignaturePacket packet), 32)+put_signature_subpacket (EmbeddedSignaturePacket packet)+ | isSignaturePacket packet = (fst $ put_packet packet, 32)+ | otherwise = error $ "Tried to put non-SignaturePacket in EmbeddedSignaturePacket: " ++ show packet put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) = (bytes, tag) @@ -996,19 +1062,16 @@ sensitive = bitfield .&. 0x40 == 0x40, revocation_key_algorithm = kalgo, revocation_key_fingerprint =- pad $ map toUpper $ foldr (padB `oo` showHex) "" (B.unpack fpr)+ pad 40 $ map toUpper $ foldr (padB `oo` showHex) "" (B.unpack fpr) } where oo = (.) . (.) padB s | odd $ length s = '0':s | otherwise = s- pad s = replicate (40 - length s) '0' ++ s -- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5 parse_signature_subpacket 16 = do keyid <- get :: Get Word64- return $ IssuerPacket (pad $ map toUpper $ showHex keyid "")- where- pad s = replicate (16 - length s) '0' ++ s+ return $ IssuerPacket (pad 16 $ map toUpper $ showHex keyid "") -- NotationDataPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.16 parse_signature_subpacket 20 = do (flag1,_,_,_) <- get4word8@@ -1088,11 +1151,13 @@ signature_issuer :: Packet -> Maybe String signature_issuer (SignaturePacket {hashed_subpackets = hashed, unhashed_subpackets = unhashed}) =- if length issuers > 0 then Just issuer else Nothing- where IssuerPacket issuer = issuers !! 0- issuers = filter isIssuer hashed ++ filter isIssuer unhashed- isIssuer (IssuerPacket {}) = True- isIssuer _ = False+ case issuers of+ IssuerPacket issuer : _ -> Just issuer+ _ -> Nothing+ where+ issuers = filter isIssuer hashed ++ filter isIssuer unhashed+ isIssuer (IssuerPacket {}) = True+ isIssuer _ = False signature_issuer _ = Nothing find_key :: (Packet -> String) -> Message -> String -> Maybe Packet
Data/OpenPGP/Arbitrary.hs view
@@ -9,11 +9,16 @@ instance Arbitrary Packet where arbitrary- = do x <- choose (0 :: Int, 9)+ = do x <- choose (0 :: Int, 12) case x of 0 -> do x1 <- arbitrary x2 <- arbitrary x3 <- arbitrary+ x4 <- arbitrary+ return (AsymmetricSessionKeyPacket x1 x2 x3 x4)+ 1 -> do x1 <- arbitrary+ x2 <- arbitrary+ x3 <- arbitrary x4 <- resize 10 (listOf arbitrary) x5 <- resize 10 (listOf arbitrary) x6 <- arbitrary@@ -26,21 +31,21 @@ creation_time <- arbitrary keyid <- vectorOf 16 (elements (['0'..'9'] ++ ['A'..'F'])) return (signaturePacket version x1 x2 x3 [] [SignatureCreationTimePacket creation_time, IssuerPacket keyid] x6 x7)- 1 -> do x1 <- arbitrary+ 2 -> do x1 <- arbitrary x2 <- arbitrary x3 <- arbitrary x4 <- arbitrary x5 <- arbitrary x6 <- arbitrary return (OnePassSignaturePacket x1 x2 x3 x4 x5 x6)- 2 -> do x1 <- arbitrary+ 3 -> do x1 <- arbitrary x2 <- arbitrary x3 <- arbitrary x4 <- arbitrary x5 <- arbitrary x6 <- arbitrary return (PublicKeyPacket x1 x2 x3 x4 x5 x6)- 3 -> do x1 <- arbitrary+ 4 -> do x1 <- arbitrary x2 <- arbitrary x3 <- arbitrary x4 <- arbitrary@@ -54,22 +59,27 @@ x12 <- arbitrary x13 <- arbitrary return (SecretKeyPacket x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)- 4 -> do x1 <- arbitrary+ 5 -> do x1 <- arbitrary x2 <- arbitrary return (CompressedDataPacket x1 x2)- 5 -> return MarkerPacket- 6 -> do x1 <- arbitrary+ 6 -> return MarkerPacket+ 7 -> do x1 <- arbitrary x2 <- arbitrary x3 <- arbitrary x4 <- arbitrary return (LiteralDataPacket x1 x2 x3 x4)- 7 -> do x1 <- arbitrary- return (UserIDPacket x1) 8 -> do x1 <- arbitrary- return (ModificationDetectionCodePacket x1)+ return (TrustPacket x1) 9 -> do x1 <- arbitrary- x2 <- arbitrary- return (UnsupportedPacket x1 x2)+ return (UserIDPacket x1)+ 10 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (EncryptedDataPacket x1 x2)+ 11 -> do x1 <- arbitrary+ return (ModificationDetectionCodePacket x1)+ 12 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (UnsupportedPacket x1 x2) _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
README view
@@ -8,8 +8,8 @@ encoding/decoding. For performing cryptography, see-<http://hackage.haskell.org/openpgp-crypto-api> or-<http://hackage.haskell.org/openpgp-Crypto>+<http://hackage.haskell.org/package/openpgp-crypto-api> or+<http://hackage.haskell.org/package/openpgp-Crypto> It is intended that you use qualified imports with this library.
openpgp.cabal view
@@ -1,5 +1,5 @@ name: openpgp-version: 0.4+version: 0.5 cabal-version: >= 1.8 license: OtherLicense license-file: COPYING@@ -24,8 +24,8 @@ encoding/decoding. . For performing cryptography, see- <http://hackage.haskell.org/openpgp-crypto-api> or- <http://hackage.haskell.org/openpgp-Crypto>+ <http://hackage.haskell.org/package/openpgp-crypto-api> or+ <http://hackage.haskell.org/package/openpgp-Crypto> . It is intended that you use qualified imports with this library. .@@ -112,6 +112,7 @@ tests/data/000076-007.secret_subkey, tests/data/000077-002.sig, tests/data/000078-012.ring_trust,+ tests/data/002182-002.sig, tests/data/compressedsig-bzip2.gpg, tests/data/compressedsig.gpg, tests/data/compressedsig-zlib.gpg,@@ -133,7 +134,7 @@ base == 4.*, bytestring, utf8-string,- binary,+ binary >= 0.6.4.0, zlib, bzlib @@ -148,7 +149,7 @@ base == 4.*, bytestring, utf8-string,- binary,+ binary >= 0.6.4.0, zlib, bzlib, HUnit,
+ tests/data/002182-002.sig view
binary file changed (absent → 363 bytes)