summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs210
1 files changed, 147 insertions, 63 deletions
diff --git a/kiki.hs b/kiki.hs
index 610dd5b..211b0a4 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -41,12 +41,69 @@ import DotLock
41import LengthPrefixedBE 41import LengthPrefixedBE
42import KeyRing 42import KeyRing
43import Base58 43import Base58
44import qualified CryptoCoins 44import qualified CryptoCoins
45import Data.OpenPGP.Util (verify,fingerprint) 45import Data.OpenPGP.Util (verify,fingerprint)
46 46
47-- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} 47-- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
48-- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} 48-- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
49 49
50{-
51 -
52 -
53 accBindings :: forall t a a1 a2.
54 Bits t =>
55 [(t, (Packet, Packet), [a], [a1], [a2])]
56 -> [(t, (Packet, Packet), [a], [a1], [a2])]
57 bitcoinAddress :: Word8 -> Packet -> String
58 cannonical_eckey :: forall b b1.
59 (Integral b1, Integral b) =>
60 b -> b1 -> [Word8]
61 commands :: [(String, String)]
62 decode_sshrsa :: Char8.ByteString -> Maybe RSAPublicKey
63 disjoint_fp :: [Packet] -> [[Packet]]
64 doAutosign :: forall t. t -> KeyData -> [PacketUpdate]
65 fpmatch :: Maybe [Char] -> Packet -> Bool
66 getBindings :: [Packet]
67 -> ([([Packet], [SignatureOver])],
68 [(Word8,
69 (Packet, Packet),
70 [String],
71 [SignatureSubpacket],
72 [Packet])])
73 isCertificationSig :: SignatureOver -> Bool
74 isSubkeySignature :: SignatureOver -> Bool
75 kiki :: forall a.
76 (Eq a, Data.String.IsString a) =>
77 a -> [[Char]] -> IO ()
78 kiki_sync_help :: IO ()
79 listKeys :: [Packet] -> [Char]
80 listKeysFiltered :: [[Char]] -> [Packet] -> [Char]
81 :Main.main :: IO ()
82 main :: IO ()
83 partitionStaticArguments :: forall a.
84 Ord a =>
85 [(a, Int)] -> [a] -> ([[a]], [a])
86 readPublicKey :: Char8.ByteString -> RSAPublicKey
87 show_all :: KeyDB -> IO ()
88 show_key :: forall t.
89 String -> t -> Map.Map KeyRing.KeyKey KeyData -> IO ()
90 show_pem :: String -> String -> KeyDB -> IO ()
91 show_ssh :: String -> String -> KeyDB -> IO ()
92 show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO ()
93 show_wip :: String -> String -> KeyDB -> IO ()
94 show_wk :: FilePath
95 -> Maybe [Char] -> Map.Map KeyRing.KeyKey KeyData -> IO ()
96 smallpr :: Packet -> [Char]
97 sshrsa :: Integer -> Integer -> Char8.ByteString
98 toLast :: forall x. (x -> x) -> [x] -> [x]
99 verifyBindings :: [Packet]
100 -> [Packet] -> ([SignatureOver], [SignatureOver])
101 warn :: String -> IO ()
102 whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
103 -
104 -
105 -}
106
50warn str = hPutStrLn stderr str 107warn str = hPutStrLn stderr str
51 108
52sshrsa :: Integer -> Integer -> Char8.ByteString 109sshrsa :: Integer -> Integer -> Char8.ByteString
@@ -65,7 +122,7 @@ decode_sshrsa bs = do
65 LengthPrefixedBE n <- get 122 LengthPrefixedBE n <- get
66 return $ RSAKey (MPI n) (MPI e) 123 return $ RSAKey (MPI n) (MPI e)
67 return rsakey 124 return rsakey
68 125
69isCertificationSig (CertificationSignature {}) = True 126isCertificationSig (CertificationSignature {}) = True
70isCertificationSig _ = True 127isCertificationSig _ = True
71 128
@@ -284,18 +341,19 @@ toLast f [] = []
284toLast f [x] = [f x] 341toLast f [x] = [f x]
285toLast f (x:xs) = x : toLast f xs 342toLast f (x:xs) = x : toLast f xs
286 343
344-- partitionStaticArguments :: Ord a => [(a, Int)] -> [a] -> ([[a]], [a])
287partitionStaticArguments specs args = psa args 345partitionStaticArguments specs args = psa args
288 where 346 where
289 smap = Map.fromList specs 347 smap = Map.fromList specs
290 psa [] = ([],[]) 348 psa [] = ([],[])
291 psa (a:as) = 349 psa (a:as) =
292 case Map.lookup a smap of 350 case Map.lookup a smap of
293 Nothing -> second (a:) $ psa as 351 Nothing -> second (a:) $ psa as
294 Just n -> first ((a:take n as):) $ psa (drop n as) 352 Just n -> first ((a:take n as):) $ psa (drop n as)
295 353
296show_wk secring_file grip db = do 354show_wk secring_file grip db = do
297 let sec_db = Map.filter gripmatch db 355 let sec_db = Map.filter gripmatch db
298 gripmatch (KeyData p _ _ _) = 356 gripmatch (KeyData p _ _ _) =
299 Map.member secring_file (locations p) 357 Map.member secring_file (locations p)
300 Message sec = flattenKeys False sec_db 358 Message sec = flattenKeys False sec_db
301 putStrLn $ listKeysFiltered (maybeToList grip) sec 359 putStrLn $ listKeysFiltered (maybeToList grip) sec
@@ -304,7 +362,7 @@ show_all db = do
304 let Message packets = flattenKeys True db 362 let Message packets = flattenKeys True db
305 putStrLn $ listKeys packets 363 putStrLn $ listKeys packets
306 364
307show_whose_key input_key db = 365show_whose_key input_key db =
308 flip (maybe $ return ()) input_key $ \input_key -> do 366 flip (maybe $ return ()) input_key $ \input_key -> do
309 let ks = whoseKey input_key db 367 let ks = whoseKey input_key db
310 case ks of 368 case ks of
@@ -327,7 +385,7 @@ show_pem keyspec wkgrip db = do
327 385
328show_ssh keyspec wkgrip db = do 386show_ssh keyspec wkgrip db = do
329 let s = parseSpec wkgrip keyspec 387 let s = parseSpec wkgrip keyspec
330 flip (maybe . void $ warn (keyspec ++ ": not found")) 388 flip (maybe . void $ warn (keyspec ++ ": not found"))
331 (selectPublicKey s db) 389 (selectPublicKey s db)
332 $ \k -> do 390 $ \k -> do
333 let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k 391 let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
@@ -337,7 +395,7 @@ show_ssh keyspec wkgrip db = do
337 395
338show_key keyspec wkgrip db = do 396show_key keyspec wkgrip db = do
339 let s = parseSpec "" keyspec 397 let s = parseSpec "" keyspec
340 let ps = do 398 let ps = do
341 (_,k) <- filterMatches (fst s) (Map.toList db) 399 (_,k) <- filterMatches (fst s) (Map.toList db)
342 mp <- flattenTop "" True k 400 mp <- flattenTop "" True k
343 return $ packet mp 401 return $ packet mp
@@ -363,7 +421,7 @@ cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
363 pad32 xs = replicate zlen 0 ++ xs 421 pad32 xs = replicate zlen 0 ++ xs
364 where 422 where
365 zlen = 32 - length xs 423 zlen = 32 - length xs
366 424
367 425
368bitcoinAddress network_id k = address 426bitcoinAddress network_id k = address
369 where 427 where
@@ -379,7 +437,7 @@ whoseKey rsakey db = filter matchkey (Map.elems db)
379 matchkey (KeyData k _ _ subs) = 437 matchkey (KeyData k _ _ subs) =
380 any (ismatch k) $ Map.elems subs 438 any (ismatch k) $ Map.elems subs
381 439
382 ismatch k (SubKey mp sigs) = 440 ismatch k (SubKey mp sigs) =
383 Just rsakey == rsaKeyFromPacket (packet mp) 441 Just rsakey == rsaKeyFromPacket (packet mp)
384 && any (check (packet k) (packet mp)) sigs 442 && any (check (packet k) (packet mp)) sigs
385 443
@@ -401,7 +459,7 @@ whoseKey rsakey db = filter matchkey (Map.elems db)
401 459
402 460
403 461
404kiki_usage = putStr . unlines $ 462kiki_sync_help = putStr . unlines $
405 {- 463 {-
406 ["kiki - a pgp key editing utility" 464 ["kiki - a pgp key editing utility"
407 ,"" 465 ,""
@@ -463,14 +521,15 @@ kiki_usage = putStr . unlines $
463 ," format. Users incognisant of the fact that the public key (which" 521 ," format. Users incognisant of the fact that the public key (which"
464 ," is also stored separately) is in this file, often think of it as" 522 ," is also stored separately) is in this file, often think of it as"
465 ," their secret key file." 523 ," their secret key file."
466 ,"" 524 ,""
467 ," Each KEYSPEC specifies that a key should match the content and" 525 ," Each KEYSPEC specifies that a key should match the content and"
468 ," timestamp of an external PKCS #1 private RSA key file." 526 ," timestamp of an external PKCS #1 private RSA key file."
469 ," " 527 ," "
470 ," KEYSPEC ::= SPEC=FILE{CMD} " 528 ," KEYSPEC ::= SPEC=FILE{CMD} "
471 ,"" 529 ,""
472 ," The form of SPEC is documented below. If there is only one master" 530 ," The form of SPEC is documented below. If there is only one master"
473 ," key in your keyring and only one key is used for each purpose, then" ," it is possible for SPEC in this case to merely be a tag which offers" 531 ," key in your keyring and only one key is used for each purpose, then"
532 ," it is possible for SPEC in this case to merely be a tag which offers"
474 ," information about what this key is used for, for example, any of" 533 ," information about what this key is used for, for example, any of"
475 ," `tor', `ssh-client', `ssh-host', or `strongswan' will do." 534 ," `tor', `ssh-client', `ssh-host', or `strongswan' will do."
476 ,"" 535 ,""
@@ -478,7 +537,7 @@ kiki_usage = putStr . unlines $
478 ," executed in order to create the FILE." 537 ," executed in order to create the FILE."
479 538
480 ,"" 539 ,""
481 ,"Output:" 540{- ,"Output:"
482 ," --show-wk Show fingerprints for the working key (which will be used to" 541 ," --show-wk Show fingerprints for the working key (which will be used to"
483 ," make signatures) and all its subkeys and UID." 542 ," make signatures) and all its subkeys and UID."
484 ,"" 543 ,""
@@ -503,6 +562,7 @@ kiki_usage = putStr . unlines $
503 ,"" 562 ,""
504 ," --help Shows this help screen." 563 ," --help Shows this help screen."
505 ,"" 564 ,""
565 -}
506 ,"Specifying keys on the kiki command line:" 566 ,"Specifying keys on the kiki command line:"
507 ,"" 567 ,""
508 ," SPEC ::= MASTER/SUBKEY" 568 ," SPEC ::= MASTER/SUBKEY"
@@ -516,7 +576,7 @@ kiki_usage = putStr . unlines $
516 ,"" 576 ,""
517 ," MASTER may be any of" 577 ," MASTER may be any of"
518 ," * The tail end of a fingerprint prefixed by 'fp:'" 578 ," * The tail end of a fingerprint prefixed by 'fp:'"
519 ," * A sub-string of a user id (without slashes) prefixed by 'u:'" 579 ," * A sub-string of a user id (without slashes) prefixed by 'u:'"
520 ," * 40 characters of hexidecimal (kiki will assume this to be a fingerprint)" 580 ," * 40 characters of hexidecimal (kiki will assume this to be a fingerprint)"
521 ," * A sub-string of a user id (without slashes, the prefix 'u:' is optional)" 581 ," * A sub-string of a user id (without slashes, the prefix 'u:' is optional)"
522 ,"" 582 ,""
@@ -570,63 +630,76 @@ doAutosign rt kd@(KeyData k ksigs umap submap) = ops
570 = fingerprint_material a==fingerprint_material b 630 = fingerprint_material a==fingerprint_material b
571 gs = groupBy sameMaster (sortBy (comparing code) bindings') 631 gs = groupBy sameMaster (sortBy (comparing code) bindings')
572 632
573 633processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
574kiki "sync" args_raw = do 634 where
575 let (args,trail1) = break (=="--") args_raw 635 (args,trail1) = break (=="--") args_raw
576 trail = drop 1 trail1 636 trail = drop 1 trail1
577 (sargs,margs) = 637 commonArgSpec = [ ("--homedir",1)
638 , ("--passphrase-fd",1)
639 ]
640 (sargs,margs) =
578 (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs k xs) k m) 641 (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs k xs) k m)
579 Map.empty 642 Map.empty
580 gargs) 643 gargs)
581 where (sargs,vargs) = partitionStaticArguments sargspec args 644 where (sargs,vargs) = partitionStaticArguments (commonArgSpec ++ sargspec) args
582 sargspec = [ ("--homedir",1) 645 argspec = map fst sargspec ++ polyVariadicArgs
583 , ("--passphrase-fd",1)
584 , ("--import",0)
585 , ("--autosign",0)
586 , ("--import-if-authentic",0)
587 , ("--show-wk",0)
588 , ("--show-all",0)
589 , ("--show-whose-key",0)
590 , ("--show-key",1)
591 , ("--show-pem",1)
592 , ("--show-ssh",1)
593 , ("--show-wip",1)
594 , ("--help",0)
595 ]
596 argspec = map fst sargspec ++ ["--keyrings"
597 ,"--keypairs"
598 ,"--wallets"
599 ,"--hosts"]
600 -- "--bitcoin-keypairs"
601 -- Disabled. We shouldn't accept private key
602 -- data on the command line.
603 args' = if map (take 1) (take 1 vargs) == ["-"] 646 args' = if map (take 1) (take 1 vargs) == ["-"]
604 then vargs 647 then vargs
605 else "--keyrings":vargs 648 else defaultPoly:vargs
649 -- grouped args
606 gargs = (sargs ++) 650 gargs = (sargs ++)
607 . toLast (++trail) 651 . toLast (++trail)
608 . groupBy (\_ s-> take 1 s /= "-") 652 . groupBy (\_ s-> take 1 s /= "-")
609 $ args' 653 $ args'
610 appendArgs k xs opt = 654 appendArgs k xs opt =
611 if k `elem` argspec 655 if k `elem` argspec
612 then Just . maybe xs (++xs) $ opt 656 then Just . maybe xs (++xs) $ opt
613 else error . unlines $ [ "unrecognized option "++k 657 else error . unlines $ [ "unrecognized option "++k
614 , "Use --help for usage." ] 658 , "Use --help for usage." ]
659
660data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
661
662parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd }
663 where
664 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
665 homespec = join . take 1 <$> Map.lookup "--homedir" margs
666 passfd = fmap (FileDesc . read) passphrase_fd
667
668parseKeySpecs = map $ \specfile -> do
669 let (spec,efilecmd) = break (=='=') specfile
670 guard $ take 1 efilecmd=="="
671 let filecmd = drop 1 efilecmd
672 let (file,bcmdb0) = break (=='{') filecmd
673 bcmdb = if null bcmdb0 then "{}" else bcmdb0
674 guard $ take 1 bcmdb=="{"
675 let bdmcb = (dropWhile isSpace . reverse) bcmdb
676 guard $ take 1 bdmcb == "}"
677 let cmd = (drop 1 . reverse . drop 1) bdmcb
678 Just (spec,file,cmd)
679
680--kiki :: (Eq a, Data.String.IsString a) => a -> [String] -> IO ()
681kiki "sync" args_raw = do
682 let (sargs,margs) = processArgs sargspec polyVariadicArgs "--keyrings" args_raw
683 sargspec = [ ("--import",0)
684 , ("--autosign",0)
685 , ("--import-if-authentic",0)
686 , ("--show-wk",0)
687 {-, ("--show-all",0)
688 , ("--show-whose-key",0)
689 , ("--show-key",1)
690 , ("--show-pem",1)
691 , ("--show-ssh",1)
692 , ("--show-wip",1) -}
693 , ("--help",0)
694 ]
695 polyVariadicArgs = ["--keyrings"
696 ,"--keypairs"
697 ,"--wallets"
698 ,"--hosts"]
615 -- putStrLn $ "margs = " ++ show (Map.assocs margs) 699 -- putStrLn $ "margs = " ++ show (Map.assocs margs)
616 unkeysRef <- newIORef Map.empty 700 unkeysRef <- newIORef Map.empty
617 pwRef <- newIORef Nothing 701 pwRef <- newIORef Nothing
618 let keypairs0 = 702 let keypairs0 = parseKeySpecs (fromMaybe [] $ Map.lookup "--keypairs" margs)
619 flip map (fromMaybe [] $ Map.lookup "--keypairs" margs) $ \specfile -> do
620 let (spec,efilecmd) = break (=='=') specfile
621 guard $ take 1 efilecmd=="="
622 let filecmd = drop 1 efilecmd
623 let (file,bcmdb0) = break (=='{') filecmd
624 bcmdb = if null bcmdb0 then "{}" else bcmdb0
625 guard $ take 1 bcmdb=="{"
626 let bdmcb = (dropWhile isSpace . reverse) bcmdb
627 guard $ take 1 bdmcb == "}"
628 let cmd = (drop 1 . reverse . drop 1) bdmcb
629 Just (spec,file,cmd)
630 keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs 703 keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs
631 wallets = fromMaybe [] $ Map.lookup "--wallets" margs 704 wallets = fromMaybe [] $ Map.lookup "--wallets" margs
632 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs 705 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
@@ -636,16 +709,16 @@ kiki "sync" args_raw = do
636 exitFailure 709 exitFailure
637 710
638 input_key <- maybe (return Nothing) 711 input_key <- maybe (return Nothing)
639 (const $ fmap (Just . readPublicKey) Char8.getContents) 712 (const $ fmap (Just . readPublicKey) Char8.getContents)
640 $ Map.lookup "--show-whose-key" margs 713 $ Map.lookup "--show-whose-key" margs
641 714
642 let keypairs = catMaybes keypairs0 715 let keypairs = catMaybes keypairs0
643 homespec = join . take 1 <$> Map.lookup "--homedir" margs 716 homespec = join . take 1 <$> Map.lookup "--homedir" margs
644 passfd = fmap (FileDesc . read) passphrase_fd 717 passfd = fmap (FileDesc . read) passphrase_fd
645 pems = flip map keypairs 718 pems = flip map keypairs
646 $ \(usage,path,cmd) -> 719 $ \(usage,path,cmd) ->
647 let cmd' = guard (not $ null cmd) >> return cmd 720 let cmd' = guard (not $ null cmd) >> return cmd
648 in (ArgFile path, (MutableRef cmd', PEMFile usage)) 721 in (ArgFile path, (MutableRef cmd', PEMFile usage))
649 walts = map (\fname -> (ArgFile fname, (MutableRef Nothing, WalletFile))) 722 walts = map (\fname -> (ArgFile fname, (MutableRef Nothing, WalletFile)))
650 wallets 723 wallets
651 rings = map (\fname -> (ArgFile fname, (MutableRef Nothing, KeyRingFile passfd))) 724 rings = map (\fname -> (ArgFile fname, (MutableRef Nothing, KeyRingFile passfd)))
@@ -674,19 +747,19 @@ kiki "sync" args_raw = do
674 , homeSpec = homespec 747 , homeSpec = homespec
675 } 748 }
676 749
677 KikiResult rt report <- runKeyRing kikiOp 750 KikiResult rt report <- runKeyRing kikiOp
678 751
679 case rt of 752 case rt of
680 KikiSuccess rt -> do -- interpret --show-* commands. 753 KikiSuccess rt -> do -- interpret --show-* commands.
681 let grip = rtGrip rt 754 let grip = rtGrip rt
682 let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip) 755 let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip)
683 ,("--show-all",const show_all) 756 {-,("--show-all",const show_all)
684 ,("--show-whose-key", const $ show_whose_key input_key) 757 ,("--show-whose-key", const $ show_whose_key input_key)
685 ,("--show-key",\[x] -> show_key x $ fromMaybe "" grip) 758 ,("--show-key",\[x] -> show_key x $ fromMaybe "" grip)
686 ,("--show-pem",\[x] -> show_pem x $ fromMaybe "" grip) 759 ,("--show-pem",\[x] -> show_pem x $ fromMaybe "" grip)
687 ,("--show-ssh",\[x] -> show_ssh x $ fromMaybe "" grip) 760 ,("--show-ssh",\[x] -> show_ssh x $ fromMaybe "" grip)
688 ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip) 761 ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip)-}
689 ,("--help", \_ _ ->kiki_usage)] 762 ,("--help", \_ _ ->kiki_sync_help)]
690 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs 763 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
691 764
692 forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt) 765 forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt)
@@ -698,18 +771,29 @@ kiki "sync" args_raw = do
698kiki "working-key" args = do 771kiki "working-key" args = do
699 kiki "sync" ["--show-wk"] 772 kiki "sync" ["--show-wk"]
700 773
701kiki "help" args = do 774-- Generic help
775kiki "help" [] = do
702 putStrLn "Valid commands are:" 776 putStrLn "Valid commands are:"
703 let longest = maximum $ map (length . fst) commands 777 let longest = maximum $ map (length . fst) commands
704 pad cmd = take (longest+3) $ cmd ++ repeat ' ' 778 pad cmd = take (longest+3) $ cmd ++ repeat ' '
705 forM commands $ \(cmd,help) -> do 779 forM commands $ \(cmd,help) -> do
706 putStrLn $ " " ++ pad cmd ++ help 780 putStrLn $ " " ++ pad cmd ++ help
781 putStr . unlines $ [""
782 ,"See 'kiki help <command>' for more information on a specific command."
783 ]
707 return () 784 return ()
708 785
786kiki "help" args = forM_ args $ \arg -> case lookup arg commands of
787 Nothing -> putStrLn $ "No help available for commmand '" ++ arg ++ "'."
788 _ -> kiki arg ["--help"]
789
790kiki "show" args = return ()
791
709commands :: [(String,String)] 792commands :: [(String,String)]
710commands = 793commands =
711 [ ( "help", "display usage information" ) 794 [ ( "help", "display usage information" )
712 , ( "sync", "update key files of various kinds by propogating information" ) 795 , ( "sync", "update key files of various kinds by propogating information" )
796 , ( "show", "display information from your keyrings")
713 , ( "working-key", "show the current working master key and its subkeys" ) 797 , ( "working-key", "show the current working master key and its subkeys" )
714 ] 798 ]
715 799