1 files changed, 159 insertions, 65 deletions

diff --git a/kiki.hs b/kiki.hs
index 685c3df..b7092dc 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -41,12 +41,69 @@ import DotLock
 import LengthPrefixedBE
 import KeyRing
 import Base58
-import qualified CryptoCoins 
+import qualified CryptoCoins
 import Data.OpenPGP.Util (verify,fingerprint)
 
 -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
 -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
 
+{-
+ -
+ -
+    accBindings :: forall t a a1 a2.
+                   Bits t =>
+                   [(t, (Packet, Packet), [a], [a1], [a2])]
+                   -> [(t, (Packet, Packet), [a], [a1], [a2])]
+    bitcoinAddress :: Word8 -> Packet -> String
+    cannonical_eckey :: forall b b1.
+                        (Integral b1, Integral b) =>
+                        b -> b1 -> [Word8]
+    commands :: [(String, String)]
+    decode_sshrsa :: Char8.ByteString -> Maybe RSAPublicKey
+    disjoint_fp :: [Packet] -> [[Packet]]
+    doAutosign :: forall t. t -> KeyData -> [PacketUpdate]
+    fpmatch :: Maybe [Char] -> Packet -> Bool
+    getBindings :: [Packet]
+                   -> ([([Packet], [SignatureOver])],
+                       [(Word8,
+                         (Packet, Packet),
+                         [String],
+                         [SignatureSubpacket],
+                         [Packet])])
+    isCertificationSig :: SignatureOver -> Bool
+    isSubkeySignature :: SignatureOver -> Bool
+    kiki :: forall a.
+            (Eq a, Data.String.IsString a) =>
+            a -> [[Char]] -> IO ()
+    kiki_sync_help :: IO ()
+    listKeys :: [Packet] -> [Char]
+    listKeysFiltered :: [[Char]] -> [Packet] -> [Char]
+    :Main.main :: IO ()
+    main :: IO ()
+    partitionStaticArguments :: forall a.
+                                Ord a =>
+                                [(a, Int)] -> [a] -> ([[a]], [a])
+    readPublicKey :: Char8.ByteString -> RSAPublicKey
+    show_all :: KeyDB -> IO ()
+    show_key :: forall t.
+                String -> t -> Map.Map KeyRing.KeyKey KeyData -> IO ()
+    show_pem :: String -> String -> KeyDB -> IO ()
+    show_ssh :: String -> String -> KeyDB -> IO ()
+    show_whose_key :: Maybe RSAPublicKey -> KeyDB -> IO ()
+    show_wip :: String -> String -> KeyDB -> IO ()
+    show_wk :: FilePath
+               -> Maybe [Char] -> Map.Map KeyRing.KeyKey KeyData -> IO ()
+    smallpr :: Packet -> [Char]
+    sshrsa :: Integer -> Integer -> Char8.ByteString
+    toLast :: forall x. (x -> x) -> [x] -> [x]
+    verifyBindings :: [Packet]
+                      -> [Packet] -> ([SignatureOver], [SignatureOver])
+    warn :: String -> IO ()
+    whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
+ -
+ -
+ -}
+
 warn str = hPutStrLn stderr str
 
 sshrsa :: Integer -> Integer -> Char8.ByteString
@@ -65,7 +122,7 @@ decode_sshrsa bs = do
             LengthPrefixedBE n <- get
             return $ RSAKey (MPI n) (MPI e)
     return rsakey
-        
+
 isCertificationSig (CertificationSignature {}) = True
 isCertificationSig _                           = True
 
@@ -284,18 +341,19 @@ toLast f []  = []
 toLast f [x] = [f x]
 toLast f (x:xs) = x : toLast f xs
 
+-- partitionStaticArguments :: Ord a => [(a, Int)] -> [a] -> ([[a]], [a])
 partitionStaticArguments specs args = psa args
  where
     smap = Map.fromList specs
     psa [] = ([],[])
-    psa (a:as) = 
+    psa (a:as) =
       case Map.lookup a smap of
         Nothing -> second (a:) $ psa as
         Just n  -> first ((a:take n as):) $ psa (drop n as)
 
 show_wk secring_file grip db = do
     let sec_db = Map.filter gripmatch db
-        gripmatch (KeyData p _ _ _) = 
+        gripmatch (KeyData p _ _ _) =
             Map.member secring_file (locations p)
         Message sec = flattenKeys False sec_db
     putStrLn $ listKeysFiltered (maybeToList grip) sec
@@ -304,7 +362,7 @@ show_all db = do
     let Message packets = flattenKeys True db
     putStrLn $ listKeys packets
 
-show_whose_key input_key db = 
+show_whose_key input_key db =
     flip (maybe $ return ()) input_key $ \input_key -> do
     let ks = whoseKey input_key db
     case ks of
@@ -327,7 +385,7 @@ show_pem keyspec wkgrip db = do
 
 show_ssh keyspec wkgrip db = do
     let s = parseSpec wkgrip keyspec
-    flip (maybe . void $ warn (keyspec ++ ": not found")) 
+    flip (maybe . void $ warn (keyspec ++ ": not found"))
          (selectPublicKey s db)
          $ \k -> do
     let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
@@ -337,7 +395,7 @@ show_ssh keyspec wkgrip db = do
 
 show_key keyspec wkgrip db = do
     let s = parseSpec "" keyspec
-    let ps = do 
+    let ps = do
             (_,k) <- filterMatches (fst s) (Map.toList db)
             mp <- flattenTop "" True k
             return $ packet mp
@@ -363,7 +421,7 @@ cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
   pad32 xs = replicate zlen 0 ++ xs
     where
         zlen = 32 - length xs
-    
+
 
 bitcoinAddress network_id k = address
     where
@@ -379,7 +437,7 @@ whoseKey rsakey db = filter matchkey (Map.elems db)
     matchkey (KeyData k _ _ subs) =
         any (ismatch k) $ Map.elems subs
 
-    ismatch k (SubKey mp sigs) = 
+    ismatch k (SubKey mp sigs) =
           Just rsakey == rsaKeyFromPacket (packet mp)
        && any (check (packet k) (packet mp)) sigs
 
@@ -474,7 +532,7 @@ kiki_usage cmd = putStr $
         ,"                format. Users incognisant of the fact that the public key (which"
         ,"                is also stored separately) is in this file, often think of it as"
         ,"                their secret key file."
-        ,""              
+        ,""
         ,"                Each KEYSPEC specifies that a key should match the content and"
         ,"                timestamp of an external PKCS #1 private RSA key file."
         ,"                "
@@ -489,7 +547,7 @@ kiki_usage cmd = putStr $
         ,"                If neither SPEC or FILE match any keys, then the CMD will be "
         ,"                executed in order to create the FILE."
         ,""
-        ,"Output:"
+{-        ,"Output:"
         ,"     --show-wk  Show fingerprints for the working key (which will be used to"
         ,"                make signatures) and all its subkeys and UID."
         ,""
@@ -514,6 +572,7 @@ kiki_usage cmd = putStr $
         ,""
         ,"     --help     Shows this help screen."
         ,""
+ -}
         ,"Specifying keys on the kiki command line:"
         ,""
         ,"  SPEC ::= MASTER/SUBKEY"
@@ -527,7 +586,7 @@ kiki_usage cmd = putStr $
         ,""
         ,"  MASTER may be any of"
         ,"     * The tail end of a fingerprint prefixed by 'fp:'"
-        ,"     * A sub-string of a user id (without slashes) prefixed by 'u:'" 
+        ,"     * A sub-string of a user id (without slashes) prefixed by 'u:'"
         ,"     * 40 characters of hexidecimal (kiki will assume this to be a fingerprint)"
         ,"     * A sub-string of a user id (without slashes, the prefix 'u:' is optional)"
         ,""
@@ -581,62 +640,76 @@ doAutosign rt kd@(KeyData k ksigs umap submap) = ops
                         = fingerprint_material a==fingerprint_material b
                    gs = groupBy sameMaster (sortBy (comparing code) bindings')
 
-sync bModifyInput cmdarg args_raw = do
-    let (args,trail1) = break (=="--") args_raw
+processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
+    where
+        (args,trail1) = break (=="--") args_raw
         trail = drop 1 trail1
-        (sargs,margs) = 
+        commonArgSpec = [ ("--homedir",1)
+                        , ("--passphrase-fd",1)
+                        ]
+        (sargs,margs) =
                 (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs k xs) k m)
                                Map.empty
                                gargs)
-                    where (sargs,vargs) = partitionStaticArguments sargspec args
-                          sargspec = [ ("--homedir",1)
-                                     , ("--passphrase-fd",1)
-                                     , ("--import",0)
-                                     , ("--autosign",0)
-                                     , ("--import-if-authentic",0)
-                                     , ("--show-wk",0)
-                                     , ("--show-all",0)
-                                     , ("--show-whose-key",0)
-                                     , ("--show-key",1)
-                                     , ("--show-pem",1)
-                                     , ("--show-ssh",1)
-                                     , ("--show-wip",1)
-                                     , ("--help",0)
-                                     ]
-                          argspec = map fst sargspec ++ ["--keyrings"
-                                                        ,"--keypairs"
-                                                        ,"--wallets"
-                                                        ,"--hosts"] 
-                                        -- "--bitcoin-keypairs"
-                                        -- Disabled.  We shouldn't accept private key
-                                        -- data on the command line.
+                    where (sargs,vargs) = partitionStaticArguments (commonArgSpec ++ sargspec) args
+                          argspec = map fst sargspec ++ polyVariadicArgs
                           args' = if map (take 1) (take 1 vargs) == ["-"]
                                     then vargs
-                                    else "--keyrings":vargs
+                                    else defaultPoly:vargs
+                          -- grouped args
                           gargs = (sargs ++)
-                                  . toLast (++trail) 
+                                  . toLast (++trail)
                                   . groupBy (\_ s-> take 1 s /= "-")
                                   $ args'
-                          appendArgs k xs opt = 
+                          appendArgs k xs opt =
                             if k `elem` argspec
                               then Just . maybe xs (++xs) $ opt
                               else error . unlines $ [ "unrecognized option "++k
                                                      , "Use --help for usage." ]
+
+data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
+
+parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd }
+    where
+        passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
+        homespec = join . take 1 <$> Map.lookup "--homedir" margs
+        passfd = fmap (FileDesc . read) passphrase_fd
+
+parseKeySpecs = map $ \specfile -> do
+    let (spec,efilecmd) = break (=='=') specfile
+    guard $ take 1 efilecmd=="="
+    let filecmd = drop 1 efilecmd
+    let (file,bcmdb0) = break (=='{') filecmd
+        bcmdb = if null bcmdb0 then "{}" else bcmdb0
+    guard $ take 1 bcmdb=="{"
+    let bdmcb = (dropWhile isSpace . reverse) bcmdb
+    guard $ take 1 bdmcb == "}"
+    let cmd = (drop 1 . reverse . drop 1) bdmcb
+    Just (spec,file,cmd)
+
+--kiki :: (Eq a, Data.String.IsString a) => a -> [String] -> IO ()
+sync bExport bSecret cmdarg args_raw = do
+    let (sargs,margs) = processArgs sargspec polyVariadicArgs "--keyrings" args_raw
+        sargspec = [ ("--import",0)
+                   , ("--autosign",0)
+                   , ("--import-if-authentic",0)
+                   , ("--show-wk",0)
+                   {-, ("--show-all",0)
+                   , ("--show-whose-key",0)
+                   , ("--show-key",1)
+                   , ("--show-pem",1)
+                   , ("--show-ssh",1)
+                   , ("--show-wip",1) -}
+                   , ("--help",0)
+                   ]
+        polyVariadicArgs = ["--keyrings"
+                           ,"--keypairs"
+                           ,"--wallets"
+                           ,"--hosts"]
     -- putStrLn $ "margs = " ++ show (Map.assocs margs)
     unkeysRef <- newIORef Map.empty
     pwRef <- newIORef Nothing
-    let keypairs0 =
-            flip map (fromMaybe [] $ Map.lookup "--keypairs" margs) $ \specfile -> do
-                let (spec,efilecmd) = break (=='=') specfile
-                guard $ take 1 efilecmd=="="
-                let filecmd = drop 1 efilecmd
-                let (file,bcmdb0) = break (=='{') filecmd
-                    bcmdb = if null bcmdb0 then "{}" else bcmdb0
-                guard $ take 1 bcmdb=="{"
-                let bdmcb = (dropWhile isSpace . reverse) bcmdb
-                guard $ take 1 bdmcb == "}"
-                let cmd = (drop 1 . reverse . drop 1) bdmcb
-                Just (spec,file,cmd)
+    let keypairs0 = parseKeySpecs (fromMaybe [] $ Map.lookup "--keypairs" margs)
         keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs
         wallets   = fromMaybe [] $ Map.lookup "--wallets" margs
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
@@ -646,18 +719,18 @@ sync bModifyInput cmdarg args_raw = do
         exitFailure
 
     input_key <- maybe (return Nothing)
-                       (const $ fmap (Just . readPublicKey) Char8.getContents) 
+                       (const $ fmap (Just . readPublicKey) Char8.getContents)
                     $ Map.lookup "--show-whose-key" margs
 
     let keypairs = catMaybes keypairs0
         homespec = join . take 1 <$> Map.lookup "--homedir" margs
         passfd = fmap (FileDesc . read) passphrase_fd
-        reftyp = if bModifyInput then MutableRef Nothing
+        reftyp = if bExport then MutableRef Nothing
                                  else ConstRef
         pems = flip map keypairs 
                 $ \(usage,path,cmd) ->
                     let cmd' = guard (not $ null cmd) >> return cmd
-                    in if bModifyInput
+                    in if bExport
                         then (ArgFile path, (MutableRef cmd', PEMFile usage)) 
                         else if isNothing cmd'
                                 then (ArgFile path, (ConstRef, PEMFile usage))
@@ -678,12 +751,12 @@ sync bModifyInput cmdarg args_raw = do
                                     return guardAuthentic
         kikiOp = KeyRingOperation
             { kFiles = Map.fromList $
-                [ ( HomeSec, (MutableRef Nothing, KeyRingFile passfd)  )
+                [ ( HomeSec, (if bSecret then MutableRef Nothing else ConstRef, KeyRingFile passfd)  )
                 , ( HomePub, (MutableRef Nothing, KeyRingFile Nothing) )
                 ]
                 ++ rings
-                ++ pems
-                ++ walts
+                ++ if bSecret then pems else []
+                ++ if bSecret then walts else []
                 ++ hosts
             , kImports = Map.fromList [ ( HomePub, importStyle ) ]
             , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs
@@ -697,12 +770,13 @@ sync bModifyInput cmdarg args_raw = do
       KikiSuccess rt -> do -- interpret --show-* commands.
             let grip = rtGrip rt
             let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip)
-                                      ,("--show-all",const show_all)
+                                      {-,("--show-all",const show_all)
                                       ,("--show-whose-key", const $ show_whose_key input_key)
                                       ,("--show-key",\[x] -> show_key x $ fromMaybe "" grip)
                                       ,("--show-pem",\[x] -> show_pem x $ fromMaybe "" grip)
                                       ,("--show-ssh",\[x] -> show_ssh x $ fromMaybe "" grip)
-                                      ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip)]
+                                      ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip)-}
+                                      ]
                 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
 
             forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt)
@@ -712,33 +786,53 @@ sync bModifyInput cmdarg args_raw = do
         putStrLn $ fname ++ ": " ++ reportString act
 
 kiki "sync-secret" args_raw =
-    sync True "sync-secret" args_raw
+    sync True True "sync-secret" args_raw
+
+kiki "sync-public" args_raw =
+    sync True False "sync-public" args_raw
 
 kiki "import-secret" args_raw =
-    sync False "import-secret" args_raw
+    sync False True "import-secret" args_raw
+
+kiki "import-public" args_raw =
+    sync False False "import-public" args_raw
 
 kiki "working-key" args = do
     if "--help" `notElem` args
-        then sync False "working-key" ["--show-wk"]
+        then sync False False "working-key" ["--show-wk"]
         else putStrLn $
             unlines ["working-key"
                     ,""
                     ,"    Displays the master key with its subkeys that will be"
                     ,"    used for making signatures"]
 
-kiki "help" args = do
+-- Generic help
+kiki "help" [] = do
     putStrLn "Valid commands are:"
     let longest = maximum $ map (length . fst) commands
         pad cmd = take (longest+3) $ cmd ++ repeat ' '
     forM commands $ \(cmd,help) -> do
         putStrLn $ "   " ++ pad cmd ++ help
+    putStr . unlines $ [""
+                       ,"See 'kiki help <command>' for more information on a specific command."
+                       ]
     return ()
 
+kiki "help" args = forM_ args $ \arg -> case lookup arg commands of
+    Nothing -> putStrLn $ "No help available for commmand '" ++ arg ++ "'."
+    _       -> kiki arg ["--help"]
+
+kiki "show" args = return ()
+
 commands :: [(String,String)]
 commands =
  [ ( "help", "display usage information" )
- , ( "sync-secret", "update key files of various kinds by propogating information" )
+ --, ( "sync", "update key files of various kinds by propogating information" )
+ , ( "show", "display information from your keyrings")
+ , ( "sync-secret", "update key files of various kinds by propogating information (both secret and public)" )
+ , ( "sync-public", "update key files of various kinds by propogating public information" )
  , ( "import-secret", "import (both public and secret) information into your keyring" )
+ , ( "import-public", "import (public) information into your keyring" )
  , ( "working-key", "show the current working master key and its subkeys" )
  ]