summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--keys.hs138
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
13import qualified Data.ByteString.Lazy as L 13import qualified Data.ByteString.Lazy as L
14import qualified Data.ByteString.Lazy.Char8 as Char8 14import qualified Data.ByteString.Lazy.Char8 as Char8
15import qualified Data.ByteString as S 15import qualified Data.ByteString as S
16import qualified Data.ByteString.Char8 as S8
16import Control.Monad 17import Control.Monad
17import qualified Text.Show.Pretty as PP 18import qualified Text.Show.Pretty as PP
18import Text.PrettyPrint as PP 19import Text.PrettyPrint as PP hiding ((<>))
19import Data.List 20import Data.List
20import Data.OpenPGP.CryptoAPI 21import Data.OpenPGP.CryptoAPI
21import Data.Ord 22import Data.Ord
@@ -40,6 +41,10 @@ import Data.Char
40import Control.Arrow (second) 41import Control.Arrow (second)
41import Data.Traversable 42import Data.Traversable
42import System.Console.CmdArgs 43import System.Console.CmdArgs
44-- import System.Posix.Time
45import Data.Time.Clock.POSIX
46import System.Posix.IO (fdToHandle,fdRead)
47import Data.Monoid ((<>))
43 48
44data RSAPublicKey = RSAKey MPI MPI 49data RSAPublicKey = RSAKey MPI MPI
45 50
@@ -97,6 +102,9 @@ backsig _ = Nothing
97isSubkeySignature (SubkeySignature {}) = True 102isSubkeySignature (SubkeySignature {}) = True
98isSubkeySignature _ = False 103isSubkeySignature _ = False
99 104
105isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k
106isMasterKey _ = False
107
100usage (NotationDataPacket 108usage (NotationDataPacket
101 { human_readable = True 109 { human_readable = True
102 , notation_name = "usage@" 110 , notation_name = "usage@"
@@ -126,6 +134,9 @@ grip k = drop 32 $ fingerprint k
126 134
127smallpr k = drop 24 $ fingerprint k 135smallpr k = drop 24 $ fingerprint k
128 136
137matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
138
139
129disjoint_fp ks = {- concatMap group2 $ -} transpose grouped 140disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
130 where 141 where
131 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks 142 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
@@ -165,7 +176,7 @@ getBindings pkts = (sigs,bindings)
165 keys <- disjoint_fp keys 176 keys <- disjoint_fp keys
166 let (bs,sigs) = verifyBindings keys pkts 177 let (bs,sigs) = verifyBindings keys pkts
167 return . ((keys,sigs),) $ do 178 return . ((keys,sigs),) $ do
168 b <- bs 179 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
169 i <- map signature_issuer (signatures_over b) 180 i <- map signature_issuer (signatures_over b)
170 i <- maybeToList i 181 i <- maybeToList i
171 who <- maybeToList $ find_key fingerprint (Message keys) i 182 who <- maybeToList $ find_key fingerprint (Message keys) i
@@ -236,9 +247,9 @@ fpmatch grip key =
236 where 247 where
237 backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) 248 backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
238 249
239listKeys pkts = listKeysFiltered Nothing pkts 250listKeys pkts = listKeysFiltered [] pkts
240 251
241listKeysFiltered grip pkts = do 252listKeysFiltered grips pkts = do
242 let (certs,bs) = getBindings pkts 253 let (certs,bs) = getBindings pkts
243 as = accBindings bs 254 as = accBindings bs
244 defaultkind (k:_) hs = k 255 defaultkind (k:_) hs = k
@@ -253,7 +264,8 @@ listKeysFiltered grip pkts = do
253 code (c,(m,s),_,_,_) = (fingerprint_material m,-c) 264 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
254 ownerkey (_,(a,_),_,_,_) = a 265 ownerkey (_,(a,_),_,_,_) = a
255 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b 266 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
256 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True 267 matchgrip _ | null grips = True
268 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True
257 matchgrip _ = False 269 matchgrip _ = False
258 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) 270 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
259 subs <- gs 271 subs <- gs
@@ -269,7 +281,7 @@ listKeysFiltered grip pkts = do
269 -- torhash = maybe "" id $ derToBase32 <$> derRSA sub 281 -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
270 concat [ " " 282 concat [ " "
271 -- , grip top 283 -- , grip top
272 , ar 284 , (if not (null claimants) then trace ("claimants: "++show claimants) else id) ar
273 , formkind 285 , formkind
274 , " " 286 , " "
275 , fingerprint sub 287 , fingerprint sub
@@ -286,8 +298,16 @@ listKeysFiltered grip pkts = do
286 sig <- sigs 298 sig <- sigs
287 guard (isCertificationSig sig) 299 guard (isCertificationSig sig)
288 guard (topkey sig == top) 300 guard (topkey sig == top)
289 sig_over <- signatures_over sig 301 let issuers = do
290 guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top) 302 sig_over <- signatures_over sig
303 i <- maybeToList $ signature_issuer sig_over
304 maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i)))
305 (primary,secondary) = partition (==top) issuers
306
307 -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return ()
308 -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return ()
309 guard (not (null primary))
310
291 let UserIDPacket uid = user_id sig 311 let UserIDPacket uid = user_id sig
292 parsed = parseUID uid 312 parsed = parseUID uid
293 ar = maybe " --> " (const " <-> ") $ do 313 ar = maybe " --> " (const " <-> ") $ do
@@ -300,7 +320,8 @@ listKeysFiltered grip pkts = do
300 match = ( (==subdom) . take (fromIntegral len)) 320 match = ( (==subdom) . take (fromIntegral len))
301 guard (len >= 16) 321 guard (len >= 16)
302 listToMaybe $ filter match torkeys 322 listToMaybe $ filter match torkeys
303 " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n" 323 unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ]
324 ++ map (\k -> " " ++ "^ signed: " ++ fingerprint k) secondary
304 (_,sigs) = unzip certs 325 (_,sigs) = unzip certs
305 "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" 326 "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n"
306 327
@@ -554,10 +575,16 @@ multiCommand ti choices =
554 strip (cmd,(action,_)) = fmap (cmd,) action 575 strip (cmd,(action,_)) = fmap (cmd,) action
555-} 576-}
556 577
578
579trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
580
557data Arguments = 581data Arguments =
558 List { homedir :: Maybe FilePath } 582 List { homedir :: Maybe FilePath }
559 | WorkingKey { homedir :: Maybe FilePath } 583 | WorkingKey { homedir :: Maybe FilePath }
560 | AutoSign { homedir :: Maybe FilePath, input :: FilePath, output :: FilePath} 584 | AutoSign { homedir :: Maybe FilePath
585 , passphrase_fd :: Maybe Int
586 , input :: FilePath
587 , output :: FilePath}
561 deriving (Show, Data, Typeable) 588 deriving (Show, Data, Typeable)
562 589
563#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) 590#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
@@ -569,7 +596,12 @@ main = do
569 &= auto 596 &= auto
570 , WorkingKey HOMEOPTION 597 , WorkingKey HOMEOPTION
571 &= help "Shows the current working key set that will be used to make signatures." 598 &= help "Shows the current working key set that will be used to make signatures."
572 , AutoSign HOMEOPTION (def &= argPos 1 &= typFile ) (def &=argPos 2 &= typFile) 599 , AutoSign HOMEOPTION
600 (def &= opt ("passphrase"::String)
601 &= help (unlines ["file descriptor from"
602 ,"which to read passphrase"]))
603 (def &= argPos 1 &= typFile )
604 (def &=argPos 2 &= typFile)
573 &= (help . concat) 605 &= (help . concat)
574 [ "Copies the first file to the second while adding" 606 [ "Copies the first file to the second while adding"
575 , " signatures for tor-style uids that match" 607 , " signatures for tor-style uids that match"
@@ -636,7 +668,7 @@ main = do
636 668
637 uidScan pub = scanl (\(mkey,u) w -> 669 uidScan pub = scanl (\(mkey,u) w ->
638 case () of 670 case () of
639 _ | isMaster w -> (w,u) 671 _ | isMasterKey w -> (w,u)
640 _ | isUserID w -> (mkey,w) 672 _ | isUserID w -> (mkey,w)
641 _ | otherwise -> (mkey,u) 673 _ | otherwise -> (mkey,u)
642 ) 674 )
@@ -644,13 +676,13 @@ main = do
644 ws 676 ws
645 where 677 where
646 w0:ws = pub 678 w0:ws = pub
647 isMaster k@(PublicKeyPacket {}) = not $ is_subkey k
648 isMaster _ = False
649 679
650 signSelfAuthTorKeys g sec grip xs = ys 680 signSelfAuthTorKeys pw g sec grip timestamp xs = ys
651 where 681 where
652 keys = filter isKey sec 682 keys = filter isKey sec
653 selfkey = find_key fingerprint (Message keys) (fromJust grip) 683 selfkey = find_key fingerprint (Message keys) (fromJust grip) >>= decryptKey
684 where
685 decryptKey k = decryptSecretKey pw k
654 mainpubkey = fst (head xs) 686 mainpubkey = fst (head xs)
655 uid:xs' = map snd xs 687 uid:xs' = map snd xs
656 (sigs, xs'') = span isSignaturePacket xs' 688 (sigs, xs'') = span isSignaturePacket xs'
@@ -668,20 +700,32 @@ main = do
668 has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs 700 has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs
669 sigs' = if has_self 701 sigs' = if has_self
670 then sigs 702 then sigs
671 -- else sigs ++ (filter isSignaturePacket $ signatures_over new_sig) 703 {-
672 -- else trace ("new_sig = "++ show (filter isSignaturePacket $ signatures_over new_sig)) sigs 704 else trace ( "key params: "++params (fromJust selfkey)++"\n"
673 -- else trace ("selfkey "++ show (fmap fingerprint selfkey)) sigs 705 ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig)
674 else trace (traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ signatures_over new_sig 706 -}
675 -- else trace (traceSig (mainpubkey) (uid) ([last sigs])) sigs ++ signatures_over new_sig 707 else sigs ++ signatures_over new_sig
708 modsig sig = sig { signature = map id (signature sig) }
709 where plus1 (MPI x) = MPI (x+1)
710 params newtop = public ++ map fst (key newtop) ++ "}"
711 where
712 public = case newtop of
713 PublicKeyPacket {} -> "public{"
714 SecretKeyPacket {} -> if L.null (encrypted_data newtop )
715 then "secret{"
716 else "encrypted{"
717 _ -> "??????{"
676 traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey) 718 traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey)
677 ,"new_sig topkey:"++ (show . fingerprint $ newtop) 719 ,"new_sig topkey:"++ (show . fingerprint $ newtop)
720 ,"new_sig topkey params: "++ params newtop
678 ,"new_sig user_id:"++ (show newuid) 721 ,"new_sig user_id:"++ (show newuid)
679 ,"new_sig |over| = " ++ (show . length $ new_sig) 722 ,"new_sig |over| = " ++ (show . length $ new_sig)
680 ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig) 723 ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig)
681 ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig) 724 ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig)
682 ,"new_sig type: " ++ (show . map signature_type $ new_sig) 725 ,"new_sig type: " ++ (show . map signature_type $ new_sig)
683 -- ,"new_sig signature:" ++ (show . concatMap signature $ new_sig) 726 ,"new_sig signature:" ++ (show . concatMap signature $ new_sig)
684 ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) 727 ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig)
728 ,"issuer = " ++ show (map signature_issuer new_sig)
685 ]) 729 ])
686 new_sig = fst $ sign (Message (maybeToList selfkey)) 730 new_sig = fst $ sign (Message (maybeToList selfkey))
687 (CertificationSignature mainpubkey 731 (CertificationSignature mainpubkey
@@ -691,7 +735,6 @@ main = do
691 (fromJust grip) 735 (fromJust grip)
692 timestamp 736 timestamp
693 g 737 g
694 timestamp = trace "TODO: timestamp" 23420
695 ys = uid:sigs'++xs'' 738 ys = uid:sigs'++xs''
696 739
697 doCmd cmd@(List {}) = do 740 doCmd cmd@(List {}) = do
@@ -702,7 +745,7 @@ main = do
702 doCmd cmd@(WorkingKey {}) = do 745 doCmd cmd@(WorkingKey {}) = do
703 (homedir,secring,grip) <- getHomeDir cmd 746 (homedir,secring,grip) <- getHomeDir cmd
704 (Message sec) <- readPacketsFromFile secring 747 (Message sec) <- readPacketsFromFile secring
705 putStrLn $ listKeysFiltered grip sec 748 putStrLn $ listKeysFiltered (maybeToList grip) sec
706 return () 749 return ()
707 750
708 doCmd cmd@(AutoSign {}) = do 751 doCmd cmd@(AutoSign {}) = do
@@ -710,7 +753,12 @@ main = do
710 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg 753 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
711 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321" 754 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
712 ) <- getPGPEnviron cmd 755 ) <- getPGPEnviron cmd
713 putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip) 756 S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd))
757 pw <- case passphrase_fd cmd of
758 Just fd -> do pwh <- fdToHandle (toEnum fd)
759 fmap trimCR $ S.hGetContents pwh
760 Nothing -> return ""
761 -- putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip)
714 (Message pub) <- readPacketsFromFile (input cmd) 762 (Message pub) <- readPacketsFromFile (input cmd)
715 putStrLn $ listKeys pub 763 putStrLn $ listKeys pub
716 -- forM_ (zip [1..] pub) $ \(i,k) -> do 764 -- forM_ (zip [1..] pub) $ \(i,k) -> do
@@ -735,41 +783,19 @@ main = do
735 isTorID _ = False 783 isTorID _ = False
736 784
737 g <- newGenIO 785 g <- newGenIO
786 -- timestamp <- epochTime
787 timestamp <- floor <$> Data.Time.Clock.POSIX.getPOSIXTime
738 let xs:xss = groupBy (\_ (b,_)->not b) marked 788 let xs:xss = groupBy (\_ (b,_)->not b) marked
739 pub' = map (snd . cleanup) xs 789 pub' = map (snd . cleanup) xs
740 ++ concatMap (signSelfAuthTorKeys (g::SystemRandom) sec grip) 790 ++ concatMap (signSelfAuthTorKeys pw (g::SystemRandom) sec grip timestamp)
741 (map (map cleanup) xss) 791 (map (map cleanup) xss)
742 cleanup (_,(topkey,_,pkt)) = (topkey,pkt) 792 cleanup (_,(topkey,_,pkt)) = (topkey,pkt)
743 putStrLn $ "-------- signed ------> " 793 putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub')
744 putStrLn $ listKeys (sec++pub') 794 putStrLn ""
745 {- 795 putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub')
746 putStrLn $ "------------------- forM_ (zip [1..] marked) $ \\(i,(flag,(_,u,p)))" 796
747 forM_ (zip [1..] marked) $ \(i,(flag,(_,u,p))) -> do 797 let signed_bs = encode (Message pub')
748 putStrLn $ show i ++ ": " ++ show (flag, p) 798 L.writeFile (output cmd) signed_bs
749 let marked2 = groupBy (\_ (b,_)->b) (map (\(b,(k,u,v))->(b,(fingerprint k,u,v))) marked)
750 putStrLn $ "------------------- marked2 ..."
751 forM_ marked2 $ \v -> do
752 putStrLn $ show v
753 -}
754 {-
755 putStrLn $ "TOR ID = " ++ show (cursor uidz)
756 putStrLn $ "parsed = " ++ show parsed
757 -- forM_ (zip [1..] sec) $ \(i,k) -> do
758 -- putStrLn $ show i ++ ": " ++ show k
759 putStrLn $ "tor bindings = " ++ show torbindings
760 putStrLn $ "should_sign = " ++ show should_sign
761 -}
762 putStrLn $ "-------------------"
763 -- extract all tor keys into base32 hash keyed map
764 -- use 'signatures' to get signed keys only
765 -- zipperSpan to tor-style UserIDPacket
766 -- zipperSpan to SignaturePacket with usage@=tor
767 -- check the back sig
768 -- If it's good, then
769 -- VOUCH for this UID:
770 -- add a new SignaturePacket after the last SignaturePacket
771 -- for the tor-style UserIDPacket
772 return ()
773 799
774groupBindings pub = 800groupBindings pub =
775 let (sigs,bindings) = getBindings pub 801 let (sigs,bindings) = getBindings pub