RevocationKeyPacket

2 files changed, 35 insertions, 1 deletions

diff --git a/Arbitrary.patch b/Arbitrary.patch
index aa09db0..b86896d 100644
--- a/Arbitrary.patch
+++ b/Arbitrary.patch
@@ -19,7 +19,7 @@
                             return (SymmetricAlgorithm x1)
                     _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
 
-@@ -116,7 +115,7 @@
+@@ -134,7 +133,7 @@
 
  instance Arbitrary MPI where
          arbitrary
@@ -28,6 +28,13 @@
                 return (MPI x1)
 
 
+@@ -160,5 +160,5 @@
+                            return (PreferredSymmetricAlgorithmsPacket x1)
+                    8 -> do x1 <- arbitrary
+                            x2 <- arbitrary
+-                           x3 <- arbitrary
++                           x3 <- vectorOf 40 (elements (['0'..'9'] ++ ['A'..'F']))
+                            return (RevocationKeyPacket x1 x2 x3)
 @@ -166 +165 @@
 -                   9 -> do x1 <- arbitrary
 +                   9 -> do x1 <- vectorOf 16 (elements (['0'..'9'] ++ ['A'..'F']))
diff --git a/Data/OpenPGP.hs b/Data/OpenPGP.hs
index 90450f5..194cccf 100644
--- a/Data/OpenPGP.hs
+++ b/Data/OpenPGP.hs
@@ -694,6 +694,11 @@ data SignatureSubpacket =
         RevocablePacket Bool |
         KeyExpirationTimePacket Word32 | -- seconds after key CreationTime
         PreferredSymmetricAlgorithmsPacket [SymmetricAlgorithm] |
+        RevocationKeyPacket {
+                sensitive::Bool,
+                revocation_key_algorithm::KeyAlgorithm,
+                revocation_key_fingerprint::String
+        } |
         IssuerPacket String |
         UnsupportedSignatureSubpacket Word8 B.ByteString
         deriving (Show, Read, Eq)
@@ -743,6 +748,12 @@ put_signature_subpacket (KeyExpirationTimePacket time) =
         (encode time, 9)
 put_signature_subpacket (PreferredSymmetricAlgorithmsPacket algos) =
         (B.concat $ map encode algos, 11)
+put_signature_subpacket (RevocationKeyPacket sensitive kalgo fpr) =
+        (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)
+        fpri = fst $ head $ readHex fpr
 put_signature_subpacket (IssuerPacket keyid) =
         (encode (fst $ head $ readHex keyid :: Word64), 16)
 put_signature_subpacket (UnsupportedSignatureSubpacket tag bytes) =
@@ -769,6 +780,22 @@ parse_signature_subpacket  9 = fmap KeyExpirationTimePacket get
 -- KeyExpirationTimePacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.6
 parse_signature_subpacket 11 =
         fmap PreferredSymmetricAlgorithmsPacket listUntilEnd
+-- RevocationKeyPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.15
+parse_signature_subpacket 12 = do
+        bitfield <- get :: Get Word8
+        kalgo <- get
+        fpr <- getSomeByteString 20
+        -- bitfield must have bit 0x80 set, says the spec
+        return $ RevocationKeyPacket {
+                sensitive = if bitfield .&. 0x40 == 0x40 then True else False,
+                revocation_key_algorithm = kalgo,
+                revocation_key_fingerprint =
+                        map toUpper $ foldr (pad `oo` showHex) "" (B.unpack fpr)
+        }
+        where
+        oo = (.) . (.)
+        pad s | odd $ length s = '0':s
+              | otherwise = s
 -- IssuerPacket, http://tools.ietf.org/html/rfc4880#section-5.2.3.5
 parse_signature_subpacket 16 = do
         keyid <- get :: Get Word64