From 4c55c7c8db59cd21aa648789d1abfc0b9d2f3c03 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sun, 11 Aug 2013 20:07:50 -0400
Subject: interpret gpg key flags in keys utility

---
 keys.hs | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------
 1 file changed, 82 insertions(+), 13 deletions(-)

(limited to 'keys.hs')

diff --git a/keys.hs b/keys.hs
index cdd3592..e5966ca 100644
--- a/keys.hs
+++ b/keys.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ViewPatterns #-}
 module Main where
 
 import Data.Binary
@@ -44,15 +45,14 @@ usage (NotationDataPacket
         }) = Just u
 usage _    = Nothing
 
-verifyBindings keys []      = []
-verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded
+verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
  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
+    (top,othersigs) = partition isSubkeySignature verified
     embedded = do
         sub <- top
         let sigover = signatures_over sub
@@ -63,6 +63,8 @@ verifyBindings keys nonkeys = top ++ filter isSubkeySignature embedded
         guard (not . null $ signatures_over v)
         return v
 
+grip k = drop (24+8) $ fingerprint k
+
 smallpr k = drop 24 $ fingerprint k
 
 disjoint_fp ks = transpose grouped
@@ -79,8 +81,8 @@ getBindings ::
        [Packet])]
 getBindings pkts = do
     let (keys,nonkeys) = partition isKey pkts
-    keys <- disjoint_fp (keys)
-    b <- verifyBindings keys pkts -- nonkeys
+    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
@@ -113,13 +115,19 @@ accBindings bs = as
 listKeys pkts = do
     let bs = getBindings pkts
         as = accBindings bs
-        defaultkind []    = "subkey"
-        defaultkind (k:_) = k
-        kinds = map (\(_,_,k,_,_)->defaultkind k) as
+        defaultkind (k:_) hs = k
+        defaultkind []    hs = maybe "subkey"
+                                     id
+                                     ( listToMaybe 
+                                     . mapMaybe (fmap usageString . keyflags)
+                                     $ hs)
+        kinds = map (\(_,_,k,h,_)->defaultkind k h) as
         kindwidth = maximum $ map length kinds
         kindcol = min 20 kindwidth
-        sameMaster (_,(a,_),_,_,_) (_,(b,_),_,_,_) = fingerprint_material a==fingerprint_material b
-        gs = groupBy sameMaster as
+        code (c,_,_,_,_) = -c
+        ownerkey (_,(a,_),_,_,_) = a
+        sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
+        gs = groupBy sameMaster (sortBy (comparing code) as)
     subs <- gs
     let (code,(top,sub), kind, hashed,claimants):_ = subs
         subkeys = do
@@ -129,11 +137,72 @@ listKeys pkts = do
                         1 -> " --> "
                         2 -> " <-- "
                         3 -> " <-> "
-                formkind = take kindcol $ defaultkind kind ++ repeat ' '
-            " "++smallpr top ++ ar ++ formkind++" "++ fingerprint sub ++"\n"
-    "gpg " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
+                formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
+            " "++grip top ++ ar ++ formkind++" "++ fingerprint sub ++ "\n"
+               -- ++ ppShow hashed
+    "master-key " ++ fingerprint top ++ "\n" ++ subkeys ++ "\n"
     
 
+{-
+, KeyFlagsPacket
+    { certify_keys = False
+    , sign_data = True
+    , encrypt_communication = True
+    , encrypt_storage = True
+    , split_key = False
+    , authentication = True
+    , group_key = False
+    }
+-}
+data PGPKeyFlags =
+    Special
+    | Vouch
+    | Sign
+    | VouchSign
+    | Communication
+    | VouchCommunication
+    | SignCommunication
+    | VouchSignCommunication
+    | Storage
+    | VouchStorage
+    | SignStorage
+    | VouchSignStorage
+    | Encrypt
+    | VouchEncrypt
+    | SignEncrypt
+    | VouchSignEncrypt
+ deriving (Eq,Show,Read,Enum)
+
+usageString flgs = 
+ case flgs of
+    Special -> "special"
+    Vouch -> "vouch"
+    Sign -> "sign"
+    VouchSign -> "vouch-sign"
+    Communication -> "communication"
+    VouchCommunication -> "vouch-communication"
+    SignCommunication -> "sign-communication"
+    VouchSignCommunication -> "vouch-sign-communication"
+    Storage -> "storage"
+    VouchStorage -> "vouch-storage"
+    SignStorage -> "sign-storage"
+    VouchSignStorage -> "vouch-sign-storage"
+    Encrypt -> "encrypt"
+    VouchEncrypt -> "vouch-encrypt"
+    SignEncrypt -> "sign-encrypt"
+    VouchSignEncrypt -> "vouch-sign-encrypt"
+
+
+keyflags flgs@(KeyFlagsPacket {}) =
+    Just . toEnum $
+        (   bit 0x1 certify_keys 
+        .|. bit 0x2 sign_data
+        .|. bit 0x4 encrypt_communication
+        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
+ where
+    bit v f = if f flgs then v else 0
+keyflags _ = Nothing
+
 
 main = do
     pkts <- getPackets
-- 
cgit v1.2.3