1 files changed, 71 insertions, 13 deletions

diff --git a/keys.hs b/keys.hs
index 4eb9603..b5d1986 100644
--- a/keys.hs
+++ b/keys.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
 module Main where
 
 import Debug.Trace
@@ -217,7 +218,15 @@ parseUID str = UserIDRecord {
 
 derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
 
-listKeys pkts = do
+fpmatch grip key = 
+    (==) Nothing
+         (fmap (backend (fingerprint key)) grip >>= guard . not)
+ where
+    backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
+
+listKeys pkts = listKeysFiltered Nothing pkts
+
+listKeysFiltered grip pkts = do
     let (certs,bs) = getBindings pkts
         as = accBindings bs
         defaultkind (k:_) hs = k
@@ -232,7 +241,9 @@ listKeys pkts = do
         code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
         ownerkey (_,(a,_),_,_,_) = a
         sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
-        gs = groupBy sameMaster (sortBy (comparing code) as)
+        matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True
+        matchgrip _ = False
+        gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
     subs <- gs
     let (code,(top,sub), kind, hashed,claimants):_ = subs
         subkeys = do
@@ -533,16 +544,26 @@ multiCommand ti choices =
 -}
 
 data Arguments = 
-        List
-        | AutoSign {input :: FilePath, output :: FilePath}
+        List { homedir :: Maybe FilePath }
+        | WorkingKey { homedir :: Maybe FilePath }
+        | AutoSign { homedir :: Maybe FilePath, input :: FilePath, output :: FilePath}
   deriving (Show, Data, Typeable)
 
+#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
+
 main = do
     args <- cmdArgs $ modes 
-        [ List &= help "list key pairs for which secrets are known"
-               &= auto
-        , AutoSign (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) 
-            &= help "auto-sign tor-style uids" ] 
+        [ List HOMEOPTION
+            &= help "List key pairs in the secret keyring."
+            &= auto
+        , WorkingKey HOMEOPTION
+            &= help "Shows the current working key set that will be used to make signatures."
+        , AutoSign HOMEOPTION (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) 
+            &= (help . concat)
+                    [ "Copies the first file to the second while adding"
+                    , " signatures for tor-style uids that match"
+                    , " cross-certified keys." ]
+        ]
         &= program "keys"
         &= summary "keys - a pgp key editing utility"
     doCmd args
@@ -558,14 +579,51 @@ main = do
 
     homevar = "GNUPGHOME"
     appdir  = ".gnupg"
+    optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
 
-    doCmd List = do
-        homedir <- envhomedir Nothing
-        flip (maybe (putStrLn "Could not find home directory."))
+    getHomeDir cmd = do
+        homedir <- envhomedir (homedir cmd)
+        flip (maybe (error "Could not determine home directory."))
              homedir $ \homedir -> do
         -- putStrLn $ "homedir = " ++show homedir
         let secring = homedir ++ "/" ++ "secring.gpg"
         -- putStrLn $ "secring = " ++ show secring
-        (Message msg) <- readPacketsFromFile secring
-        putStrLn $ listKeys msg
+        workingkey <- getWorkingKey homedir
+        return (homedir,secring,workingkey)
+
+    getWorkingKey homedir = do
+        let o = Nothing
+            h = Just homedir
+            args = ["hi"]
+        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> 
+                let optfiles = map (second ((h++"/")++)) 
+                                   (maybe optfile_alts' (:[]) o')
+                    optfile_alts' = zip (False:repeat True) optfile_alts
+                    o' = fmap (False,) o
+                in filterM (doesFileExist . snd) optfiles
+        args <- flip (maybe $ return []) ofile $ 
+            \(forgive,fname) -> parseOptionFile fname
+        let config = map (topair . words) args
+                        where topair (x:xs) = (x,xs)
+        return $ lookup "default-key" config >>= listToMaybe
+
+
+    doCmd cmd@(List {}) = do
+        (homedir,secring,grip) <- getHomeDir cmd
+        (Message sec) <- readPacketsFromFile secring
+        putStrLn $ listKeys sec
+
+    doCmd cmd@(WorkingKey {}) = do
+        (homedir,secring,grip) <- getHomeDir cmd
+        (Message sec) <- readPacketsFromFile secring
+        putStrLn $ listKeysFiltered grip sec
+        return ()
+
+    doCmd cmd@(AutoSign {}) = do
+        (homedir,secring,grip) <- getHomeDir cmd
+        (Message sec) <- readPacketsFromFile secring
+        (Message pub) <- readPacketsFromFile (input cmd)
+        putStrLn $ "Inspecting packets..."
+        putStrLn $ listKeys pub
+        return ()