From 15f7f3c50e0b21db5d14e088810c5de70512d0d8 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sun, 11 Aug 2013 05:51:07 -0400
Subject: keys utility

---
 keys.hs | 141 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 141 insertions(+)
 create mode 100644 keys.hs

diff --git a/keys.hs b/keys.hs
new file mode 100644
index 0000000..cdd3592
--- /dev/null
+++ b/keys.hs
@@ -0,0 +1,141 @@
+module Main where
+
+import Data.Binary
+import Data.OpenPGP
+import qualified Data.ByteString.Lazy as L
+import Control.Monad
+import Text.Show.Pretty
+import Data.List
+import Data.OpenPGP.CryptoAPI
+import Data.Ord
+import Data.Maybe
+import Data.Bits
+
+getPackets :: IO [Packet]
+getPackets = do
+    input <- L.getContents
+    case decodeOrFail input of
+        Right (_,_,Message pkts) -> return pkts
+        Left  (_,_,_)            -> return []
+
+
+isKey (PublicKeyPacket {}) = True
+isKey (SecretKeyPacket {}) = True
+isKey _                    = False
+
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
+isEmbeddedSignature _                            = False
+
+issuer (IssuerPacket issuer) = Just issuer
+issuer _                     = Nothing
+backsig (EmbeddedSignaturePacket s) = Just s
+backsig _                           = Nothing
+
+isSubkeySignature (SubkeySignature {}) = True
+isSubkeySignature _                    = False
+
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+verifyBindings keys []      = []
+verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded
+ where
+    verified = do
+        sig <- signatures (Message nonkeys)
+        let v = verify (Message keys) sig
+        guard (not . null $ signatures_over v)
+        return v
+    (top,_) = partition isSubkeySignature verified
+    embedded = do
+        sub <- top
+        let sigover = signatures_over sub
+            unhashed = sigover >>= unhashed_subpackets
+            subsigs = mapMaybe backsig unhashed
+        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
+        let v = verify (Message [subkey sub]) sig
+        guard (not . null $ signatures_over v)
+        return v
+
+smallpr k = drop 24 $ fingerprint k
+
+disjoint_fp ks = transpose grouped
+ where
+    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
+    samepr a b = smallpr a == smallpr b
+
+getBindings ::
+  [Packet]
+  -> [(Word8,
+       (Packet, Packet),
+       [String],
+       [SignatureSubpacket],
+       [Packet])]
+getBindings pkts = do
+    let (keys,nonkeys) = partition isKey pkts
+    keys <- disjoint_fp (keys)
+    b <- verifyBindings keys pkts -- nonkeys
+    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 =>
+  [(t, (Packet, Packet), [a], [a1], [a2])]
+  -> [(t, (Packet, Packet), [a], [a1], [a2])]
+accBindings bs = as
+  where
+    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
+    as = map (foldl1 combine) gs
+    bindingPair (_,p,_,_,_) = pub2 p
+      where
+        pub2 (a,b) = (pub a, pub b)
+        pub a = fingerprint_material a
+    samePair a b = bindingPair a == bindingPair b
+    combine (ac,p,akind,ahashed,aclaimaints)
+            (bc,_,bkind,bhashed,bclaimaints)
+        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
+
+listKeys pkts = do
+    let bs = getBindings pkts
+        as = accBindings bs
+        defaultkind []    = "subkey"
+        defaultkind (k:_) = k
+        kinds = map (\(_,_,k,_,_)->defaultkind k) as
+        kindwidth = maximum $ map length kinds
+        kindcol = min 20 kindwidth
+        sameMaster (_,(a,_),_,_,_) (_,(b,_),_,_,_) = fingerprint_material a==fingerprint_material b
+        gs = groupBy sameMaster as
+    subs <- gs
+    let (code,(top,sub), kind, hashed,claimants):_ = subs
+        subkeys = do
+            (code,(top,sub), kind, hashed,claimants) <- subs
+            let ar = case code of
+                        0 -> " ??? "
+                        1 -> " --> "
+                        2 -> " <-- "
+                        3 -> " <-> "
+                formkind = take kindcol $ defaultkind kind ++ repeat ' '
+            " "++smallpr top ++ ar ++ formkind++" "++ fingerprint sub ++"\n"
+    "gpg " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
+    
+
+
+main = do
+    pkts <- getPackets
+    putStrLn $ listKeys pkts
+    return ()
-- 
cgit v1.2.3