From fbe310013a5e0f82e261cb6a3d08fc4c1d16c113 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 5 Oct 2013 16:45:38 -0400 Subject: Autosign command with --passphrase-fd option. --- keys.hs | 138 ++++++++++++++++++++++++++++++++++++++-------------------------- 1 file 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 -- cgit v1.2.3