summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--keys.hs84
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 @@
4{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DeriveDataTypeable #-} 6{-# LANGUAGE DeriveDataTypeable #-}
7{-# LANGUAGE CPP #-}
7module Main where 8module Main where
8 9
9import Debug.Trace 10import Debug.Trace
@@ -217,7 +218,15 @@ parseUID str = UserIDRecord {
217 218
218derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy 219derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
219 220
220listKeys pkts = do 221fpmatch grip key =
222 (==) Nothing
223 (fmap (backend (fingerprint key)) grip >>= guard . not)
224 where
225 backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
226
227listKeys pkts = listKeysFiltered Nothing pkts
228
229listKeysFiltered grip pkts = do
221 let (certs,bs) = getBindings pkts 230 let (certs,bs) = getBindings pkts
222 as = accBindings bs 231 as = accBindings bs
223 defaultkind (k:_) hs = k 232 defaultkind (k:_) hs = k
@@ -232,7 +241,9 @@ listKeys pkts = do
232 code (c,(m,s),_,_,_) = (fingerprint_material m,-c) 241 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
233 ownerkey (_,(a,_),_,_,_) = a 242 ownerkey (_,(a,_),_,_,_) = a
234 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b 243 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
235 gs = groupBy sameMaster (sortBy (comparing code) as) 244 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True
245 matchgrip _ = False
246 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
236 subs <- gs 247 subs <- gs
237 let (code,(top,sub), kind, hashed,claimants):_ = subs 248 let (code,(top,sub), kind, hashed,claimants):_ = subs
238 subkeys = do 249 subkeys = do
@@ -533,16 +544,26 @@ multiCommand ti choices =
533-} 544-}
534 545
535data Arguments = 546data Arguments =
536 List 547 List { homedir :: Maybe FilePath }
537 | AutoSign {input :: FilePath, output :: FilePath} 548 | WorkingKey { homedir :: Maybe FilePath }
549 | AutoSign { homedir :: Maybe FilePath, input :: FilePath, output :: FilePath}
538 deriving (Show, Data, Typeable) 550 deriving (Show, Data, Typeable)
539 551
552#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
553
540main = do 554main = do
541 args <- cmdArgs $ modes 555 args <- cmdArgs $ modes
542 [ List &= help "list key pairs for which secrets are known" 556 [ List HOMEOPTION
543 &= auto 557 &= help "List key pairs in the secret keyring."
544 , AutoSign (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) 558 &= auto
545 &= help "auto-sign tor-style uids" ] 559 , WorkingKey HOMEOPTION
560 &= help "Shows the current working key set that will be used to make signatures."
561 , AutoSign HOMEOPTION (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile)
562 &= (help . concat)
563 [ "Copies the first file to the second while adding"
564 , " signatures for tor-style uids that match"
565 , " cross-certified keys." ]
566 ]
546 &= program "keys" 567 &= program "keys"
547 &= summary "keys - a pgp key editing utility" 568 &= summary "keys - a pgp key editing utility"
548 doCmd args 569 doCmd args
@@ -558,14 +579,51 @@ main = do
558 579
559 homevar = "GNUPGHOME" 580 homevar = "GNUPGHOME"
560 appdir = ".gnupg" 581 appdir = ".gnupg"
582 optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
561 583
562 doCmd List = do 584 getHomeDir cmd = do
563 homedir <- envhomedir Nothing 585 homedir <- envhomedir (homedir cmd)
564 flip (maybe (putStrLn "Could not find home directory.")) 586 flip (maybe (error "Could not determine home directory."))
565 homedir $ \homedir -> do 587 homedir $ \homedir -> do
566 -- putStrLn $ "homedir = " ++show homedir 588 -- putStrLn $ "homedir = " ++show homedir
567 let secring = homedir ++ "/" ++ "secring.gpg" 589 let secring = homedir ++ "/" ++ "secring.gpg"
568 -- putStrLn $ "secring = " ++ show secring 590 -- putStrLn $ "secring = " ++ show secring
569 (Message msg) <- readPacketsFromFile secring 591 workingkey <- getWorkingKey homedir
570 putStrLn $ listKeys msg 592 return (homedir,secring,workingkey)
593
594 getWorkingKey homedir = do
595 let o = Nothing
596 h = Just homedir
597 args = ["hi"]
598 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
599 let optfiles = map (second ((h++"/")++))
600 (maybe optfile_alts' (:[]) o')
601 optfile_alts' = zip (False:repeat True) optfile_alts
602 o' = fmap (False,) o
603 in filterM (doesFileExist . snd) optfiles
604 args <- flip (maybe $ return []) ofile $
605 \(forgive,fname) -> parseOptionFile fname
606 let config = map (topair . words) args
607 where topair (x:xs) = (x,xs)
608 return $ lookup "default-key" config >>= listToMaybe
609
610
611 doCmd cmd@(List {}) = do
612 (homedir,secring,grip) <- getHomeDir cmd
613 (Message sec) <- readPacketsFromFile secring
614 putStrLn $ listKeys sec
615
616 doCmd cmd@(WorkingKey {}) = do
617 (homedir,secring,grip) <- getHomeDir cmd
618 (Message sec) <- readPacketsFromFile secring
619 putStrLn $ listKeysFiltered grip sec
620 return ()
621
622 doCmd cmd@(AutoSign {}) = do
623 (homedir,secring,grip) <- getHomeDir cmd
624 (Message sec) <- readPacketsFromFile secring
625 (Message pub) <- readPacketsFromFile (input cmd)
626 putStrLn $ "Inspecting packets..."
627 putStrLn $ listKeys pub
628 return ()
571 629