diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs --- a/Data/OpenPGP.hs +++ b/Data/OpenPGP.hs @@ -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 diff --git a/Data/OpenPGP/Arbitrary.hs b/Data/OpenPGP/Arbitrary.hs --- a/Data/OpenPGP/Arbitrary.hs +++ b/Data/OpenPGP/Arbitrary.hs @@ -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" diff --git a/README b/README --- a/README +++ b/README @@ -8,8 +8,8 @@ encoding/decoding. For performing cryptography, see - or - + or + It is intended that you use qualified imports with this library. diff --git a/openpgp.cabal b/openpgp.cabal --- a/openpgp.cabal +++ b/openpgp.cabal @@ -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 - or - + or + . 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, diff --git a/tests/data/002182-002.sig b/tests/data/002182-002.sig new file mode 100644 Binary files /dev/null and b/tests/data/002182-002.sig differ