Add uid to top of keys output.

1 files changed, 54 insertions, 22 deletions

diff --git a/keys.hs b/keys.hs
index e5966ca..c0b5baa 100644
--- a/keys.hs
+++ b/keys.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns  #-}
+{-# LANGUAGE TupleSections #-}
 module Main where
 
 import Data.Binary
@@ -30,6 +31,9 @@ isUserID _                 = False
 isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
 isEmbeddedSignature _                            = False
 
+isCertificationSig (CertificationSignature {}) = True
+isCertificationSig _                           = True
+
 issuer (IssuerPacket issuer) = Just issuer
 issuer _                     = Nothing
 backsig (EmbeddedSignaturePacket s) = Just s
@@ -63,37 +67,53 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig
         guard (not . null $ signatures_over v)
         return v
 
-grip k = drop (24+8) $ fingerprint k
+grip k = drop 32 $ fingerprint k
 
 smallpr k = drop 24 $ fingerprint k
 
-disjoint_fp ks = transpose grouped
+disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
  where
     grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
     samepr a b = smallpr a == smallpr b
 
+    {-
+    -- useful for testing
+    group2 :: [a] -> [[a]]
+    group2 (x:y:ys) = [x,y]:group2 ys
+    group2 [x]      = [[x]]
+    group2 []       = []
+    -}
+
 getBindings ::
   [Packet]
-  -> [(Word8,
+  -> 
+    ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
+                                   --   that were used for the verifications
+    , [(Word8,
        (Packet, Packet),
        [String],
        [SignatureSubpacket],
-       [Packet])]
-getBindings pkts = do
-    let (keys,nonkeys) = partition isKey pkts
-    keys <- disjoint_fp keys
-    b <- fst $ verifyBindings keys pkts
-    i <- map signature_issuer (signatures_over b)
-    i <- maybeToList i
-    who <- maybeToList $ find_key fingerprint (Message keys) i
-    let (code,claimants) = 
-            case () of
-                _ | who == topkey b -> (1,[])
-                _ | who == subkey b -> (2,[])
-                _                   -> (0,[who])
-    let hashed = signatures_over b >>= hashed_subpackets
-        kind = guard (code==1) >> hashed >>= maybeToList . usage
-    return (code,(topkey b,subkey b), kind, hashed,claimants)
+       [Packet])] -- ^ binding signatures
+    )
+getBindings pkts = (sigs,bindings)
+ where
+    (sigs,concat->bindings) = unzip $ do
+        let (keys,nonkeys) = partition isKey pkts
+        keys <- disjoint_fp keys
+        let (bs,sigs) = verifyBindings keys pkts
+        return . ((keys,sigs),) $ do
+            b <- bs
+            i <- map signature_issuer (signatures_over b)
+            i <- maybeToList i
+            who <- maybeToList $ find_key fingerprint (Message keys) i
+            let (code,claimants) = 
+                    case () of
+                        _ | who == topkey b -> (1,[])
+                        _ | who == subkey b -> (2,[])
+                        _                   -> (0,[who])
+            let hashed = signatures_over b >>= hashed_subpackets
+                kind = guard (code==1) >> hashed >>= maybeToList . usage
+            return (code,(topkey b,subkey b), kind, hashed,claimants)
 
 accBindings ::
   Bits t =>
@@ -113,7 +133,7 @@ accBindings bs = as
         = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
 
 listKeys pkts = do
-    let bs = getBindings pkts
+    let (certs,bs) = getBindings pkts
         as = accBindings bs
         defaultkind (k:_) hs = k
         defaultkind []    hs = maybe "subkey"
@@ -140,7 +160,19 @@ listKeys pkts = do
                 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
             " "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n"
                -- ++ ppShow hashed
-    "master-key " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
+        uid = maybe "" id . listToMaybe $ do
+            (keys,sigs) <- certs
+            sig <- sigs
+            guard (isCertificationSig sig)
+            guard (topkey sig == top)
+            sig_over <- signatures_over sig
+            guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top)
+            let UserIDPacket uid = user_id sig
+            return uid
+        (_,sigs) = unzip certs
+    unlines 
+        [ uid 
+        , "master-key " ++ fingerprint top ++ "\n" ++ subkeys ]
     
 
 {-