Autosign command with --passphrase-fd option.

1 files changed, 82 insertions, 56 deletions

diff --git a/keys.hs b/keys.hs
index 6fdd408..844b544 100644
--- a/keys.hs
+++ b/keys.hs
@@ -13,9 +13,10 @@ import Data.OpenPGP
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.ByteString      as S
+import qualified Data.ByteString.Char8 as S8
 import Control.Monad
 import qualified Text.Show.Pretty as PP
-import Text.PrettyPrint as PP
+import Text.PrettyPrint as PP hiding ((<>))
 import Data.List
 import Data.OpenPGP.CryptoAPI
 import Data.Ord
@@ -40,6 +41,10 @@ import Data.Char
 import Control.Arrow (second)
 import Data.Traversable
 import System.Console.CmdArgs
+-- import System.Posix.Time
+import Data.Time.Clock.POSIX
+import System.Posix.IO (fdToHandle,fdRead)
+import Data.Monoid ((<>))
 
 data RSAPublicKey = RSAKey MPI MPI
 
@@ -97,6 +102,9 @@ backsig _                           = Nothing
 isSubkeySignature (SubkeySignature {}) = True
 isSubkeySignature _                    = False
 
+isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k
+isMasterKey _ = False
+
 usage (NotationDataPacket
         { human_readable = True
         , notation_name  = "usage@"
@@ -126,6 +134,9 @@ grip k = drop 32 $ fingerprint k
 
 smallpr k = drop 24 $ fingerprint k
 
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+
 disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
  where
     grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
@@ -165,7 +176,7 @@ getBindings pkts = (sigs,bindings)
         keys <- disjoint_fp keys
         let (bs,sigs) = verifyBindings keys pkts
         return . ((keys,sigs),) $ do
-            b <- bs
+            b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
             i <- map signature_issuer (signatures_over b)
             i <- maybeToList i
             who <- maybeToList $ find_key fingerprint (Message keys) i
@@ -236,9 +247,9 @@ fpmatch grip key =
  where
     backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
 
-listKeys pkts = listKeysFiltered Nothing pkts
+listKeys pkts = listKeysFiltered [] pkts
 
-listKeysFiltered grip pkts = do
+listKeysFiltered grips pkts = do
     let (certs,bs) = getBindings pkts
         as = accBindings bs
         defaultkind (k:_) hs = k
@@ -253,7 +264,8 @@ listKeysFiltered grip pkts = do
         code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
         ownerkey (_,(a,_),_,_,_) = a
         sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
-        matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True
+        matchgrip _ | null grips = True
+        matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True
         matchgrip _ = False
         gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
     subs <- gs
@@ -269,7 +281,7 @@ listKeysFiltered grip pkts = do
                 -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
             concat  [ " "
                     -- , grip top
-                    , ar
+                    , (if not (null claimants) then trace ("claimants: "++show claimants) else id) ar
                     , formkind 
                     , " "
                     , fingerprint sub 
@@ -286,8 +298,16 @@ listKeysFiltered grip pkts = do
             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 issuers = do
+                    sig_over <- signatures_over sig
+                    i <- maybeToList $ signature_issuer sig_over
+                    maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i)))
+                (primary,secondary) = partition (==top) issuers
+            
+            -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return ()
+            -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return ()
+            guard (not (null primary))
+
             let UserIDPacket uid = user_id sig
                 parsed = parseUID uid
                 ar = maybe " --> " (const " <-> ") $ do
@@ -300,7 +320,8 @@ listKeysFiltered grip pkts = do
                             match = ( (==subdom) . take (fromIntegral len))
                         guard (len >= 16)
                         listToMaybe $ filter match torkeys
-            " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
+            unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ]
+                    ++ map (\k -> "      " ++ "^ signed: " ++ fingerprint k) secondary
         (_,sigs) = unzip certs
     "master-key " ++ fingerprint top ++ "\n" ++ uid ++"  ...\n" ++ subkeys ++ "\n"
     
@@ -554,10 +575,16 @@ multiCommand ti choices =
     strip (cmd,(action,_)) = fmap (cmd,) action
 -}
 
+
+trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
+
 data Arguments = 
         List { homedir :: Maybe FilePath }
         | WorkingKey { homedir :: Maybe FilePath }
-        | AutoSign { homedir :: Maybe FilePath, input :: FilePath, output :: FilePath}
+        | AutoSign { homedir :: Maybe FilePath
+                   , passphrase_fd :: Maybe Int
+                   , input :: FilePath
+                   , output :: FilePath}
   deriving (Show, Data, Typeable)
 
 #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
@@ -569,7 +596,12 @@ main = do
             &= 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) 
+        , AutoSign HOMEOPTION 
+                   (def &= opt ("passphrase"::String) 
+                        &= help (unlines ["file descriptor from"
+                                         ,"which to read passphrase"]))
+                   (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"
@@ -636,7 +668,7 @@ main = do
 
     uidScan pub = scanl (\(mkey,u) w -> 
                              case () of
-                              _ | isMaster w -> (w,u)
+                              _ | isMasterKey w -> (w,u)
                               _ | isUserID w -> (mkey,w)
                               _ | otherwise  -> (mkey,u) 
                             )
@@ -644,13 +676,13 @@ main = do
                           ws
                         where 
                             w0:ws = pub
-                            isMaster k@(PublicKeyPacket {}) = not $ is_subkey k
-                            isMaster _ = False
 
-    signSelfAuthTorKeys g sec grip xs = ys
+    signSelfAuthTorKeys pw g sec grip timestamp xs = ys
      where
         keys = filter isKey sec
-        selfkey = find_key fingerprint (Message keys) (fromJust grip)
+        selfkey = find_key fingerprint (Message keys) (fromJust grip) >>= decryptKey
+            where
+                decryptKey k = decryptSecretKey pw k
         mainpubkey = fst (head xs)
         uid:xs' = map snd xs
         (sigs, xs'') = span isSignaturePacket xs'
@@ -668,20 +700,32 @@ main = do
         has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs
         sigs' = if has_self
                     then sigs
-                    -- else sigs  ++ (filter isSignaturePacket $ signatures_over new_sig)
-                    -- else trace ("new_sig = "++ show (filter isSignaturePacket $ signatures_over new_sig)) sigs
-                    -- else trace ("selfkey "++ show (fmap fingerprint selfkey)) sigs
-                    else trace (traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ signatures_over new_sig
-                    -- else trace (traceSig (mainpubkey) (uid) ([last sigs])) sigs ++ signatures_over new_sig
+                    {-
+                    else trace ( "key params: "++params (fromJust selfkey)++"\n"
+                                ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig)
+                    -}
+                    else sigs ++ signatures_over new_sig
+        modsig sig = sig { signature = map id (signature sig) }
+            where plus1 (MPI x) = MPI (x+1)
+        params newtop = public ++ map fst (key newtop) ++ "}"
+                where
+                    public = case newtop of
+                                PublicKeyPacket {} -> "public{"
+                                SecretKeyPacket {} -> if L.null (encrypted_data newtop )
+                                                            then "secret{"
+                                                            else "encrypted{"
+                                _                  -> "??????{"
         traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey)
                                         ,"new_sig topkey:"++ (show . fingerprint $ newtop)
+                                        ,"new_sig topkey params: "++ params newtop
                                         ,"new_sig user_id:"++ (show newuid)
                                         ,"new_sig |over| = " ++ (show . length $ new_sig)
                                         ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig)
                                         ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig)
                                         ,"new_sig type: " ++ (show . map signature_type $ new_sig)
-                                        -- ,"new_sig signature:" ++ (show . concatMap signature $ new_sig)
+                                        ,"new_sig signature:" ++ (show . concatMap signature $ new_sig)
                                         ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig)
+                                        ,"issuer = " ++ show (map signature_issuer new_sig)
                                         ])
         new_sig = fst $ sign (Message (maybeToList selfkey)) 
                              (CertificationSignature mainpubkey
@@ -691,7 +735,6 @@ main = do
                              (fromJust grip)
                              timestamp
                              g
-        timestamp = trace "TODO: timestamp" 23420 
         ys = uid:sigs'++xs''
 
     doCmd cmd@(List {}) = do
@@ -702,7 +745,7 @@ main = do
     doCmd cmd@(WorkingKey {}) = do
         (homedir,secring,grip) <- getHomeDir cmd
         (Message sec) <- readPacketsFromFile secring
-        putStrLn $ listKeysFiltered grip sec
+        putStrLn $ listKeysFiltered (maybeToList grip) sec
         return ()
 
     doCmd cmd@(AutoSign {}) = do
@@ -710,7 +753,12 @@ main = do
           , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
           , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
           ) <- getPGPEnviron cmd
-        putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip)
+        S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd))
+        pw <- case passphrase_fd cmd of
+                Just fd -> do pwh <- fdToHandle (toEnum fd)
+                              fmap trimCR $ S.hGetContents pwh
+                Nothing -> return ""
+        -- putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip)
         (Message pub) <- readPacketsFromFile (input cmd)
         putStrLn $ listKeys pub
         -- forM_ (zip [1..] pub) $ \(i,k) -> do
@@ -735,41 +783,19 @@ main = do
                     isTorID _                  = False
 
         g <- newGenIO
+        -- timestamp <- epochTime
+        timestamp <- floor <$> Data.Time.Clock.POSIX.getPOSIXTime
         let xs:xss = groupBy (\_ (b,_)->not b) marked
             pub' = map (snd . cleanup) xs 
-                    ++ concatMap (signSelfAuthTorKeys (g::SystemRandom) sec grip)
+                    ++ concatMap (signSelfAuthTorKeys pw (g::SystemRandom) sec grip timestamp)
                                  (map (map cleanup) xss)
             cleanup (_,(topkey,_,pkt)) = (topkey,pkt)
-        putStrLn $ "-------- signed ------> "
-        putStrLn $ listKeys (sec++pub')
-        {-
-        putStrLn $ "------------------- forM_ (zip [1..] marked) $ \\(i,(flag,(_,u,p)))"
-        forM_ (zip [1..] marked) $ \(i,(flag,(_,u,p))) -> do
-            putStrLn $ show i ++ ": " ++ show (flag, p)
-        let marked2 = groupBy (\_ (b,_)->b) (map (\(b,(k,u,v))->(b,(fingerprint k,u,v))) marked)
-        putStrLn $ "------------------- marked2 ..."
-        forM_ marked2 $ \v -> do
-            putStrLn $ show v
-        -}
-        {-
-        putStrLn $ "TOR ID = " ++ show (cursor uidz)
-        putStrLn $ "parsed = " ++ show parsed
-        -- forM_ (zip [1..] sec) $ \(i,k) -> do
-        --    putStrLn $ show i ++ ": " ++ show k
-        putStrLn $ "tor bindings = " ++ show torbindings
-        putStrLn $ "should_sign = " ++ show should_sign
-        -}
-        putStrLn $ "-------------------"
-        -- extract all tor keys into base32 hash keyed map
-        --   use 'signatures' to get signed keys only
-        -- zipperSpan to tor-style UserIDPacket
-        -- zipperSpan to SignaturePacket with usage@=tor
-        -- check the back sig
-        -- If it's good, then 
-        --  VOUCH for this UID:
-        --    add a new SignaturePacket after the last SignaturePacket
-        --    for the tor-style UserIDPacket
-        return ()
+        putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub')
+        putStrLn ""
+        putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub'))  (sec++pub')
+
+        let signed_bs = encode (Message pub')
+        L.writeFile (output cmd) signed_bs
 
 groupBindings pub = 
         let (sigs,bindings) = getBindings pub