refactoring parseSpec, and common args, ...

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
 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
 
@@ -401,7 +459,7 @@ whoseKey rsakey db = filter matchkey (Map.elems db)
 
 
 
-kiki_usage = putStr . unlines $
+kiki_sync_help = putStr . unlines $
         {-
         ["kiki - a pgp key editing utility"
         ,""
@@ -463,14 +521,15 @@ kiki_usage = putStr . unlines $
         ,"                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."
         ,"                "
         ,"                KEYSPEC ::= SPEC=FILE{CMD} "
         ,""
         ,"                The form of SPEC is documented below. If there is only one master"
-        ,"                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"
+        ,"                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"
         ,"                information about what this key is used for, for example, any of"
         ,"                `tor', `ssh-client', `ssh-host', or `strongswan' will do."
         ,""
@@ -478,7 +537,7 @@ kiki_usage = putStr . unlines $
         ,"                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."
         ,""
@@ -503,6 +562,7 @@ kiki_usage = putStr . unlines $
         ,""
         ,"     --help     Shows this help screen."
         ,""
+ -}
         ,"Specifying keys on the kiki command line:"
         ,""
         ,"  SPEC ::= MASTER/SUBKEY"
@@ -516,7 +576,7 @@ kiki_usage = putStr . unlines $
         ,""
         ,"  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)"
         ,""
@@ -570,63 +630,76 @@ doAutosign rt kd@(KeyData k ksigs umap submap) = ops
                         = fingerprint_material a==fingerprint_material b
                    gs = groupBy sameMaster (sortBy (comparing code) bindings')
 
-
-kiki "sync" 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 ()
+kiki "sync" 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
@@ -636,16 +709,16 @@ kiki "sync" 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
-        pems = flip map keypairs 
+        pems = flip map keypairs
                 $ \(usage,path,cmd) ->
                     let cmd' = guard (not $ null cmd) >> return cmd
-                    in (ArgFile path, (MutableRef cmd', PEMFile usage)) 
+                    in (ArgFile path, (MutableRef cmd', PEMFile usage))
         walts = map (\fname -> (ArgFile fname, (MutableRef Nothing, WalletFile)))
                     wallets
         rings = map (\fname -> (ArgFile fname, (MutableRef Nothing, KeyRingFile passfd)))
@@ -674,19 +747,19 @@ kiki "sync" args_raw = do
             , homeSpec = homespec
             }
 
-    KikiResult rt report <- runKeyRing kikiOp 
+    KikiResult rt report <- runKeyRing kikiOp
 
     case rt of
       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)
-                                      ,("--help", \_ _ ->kiki_usage)]
+                                      ,("--show-wip",\[x] -> show_wip x $ fromMaybe "" grip)-}
+                                      ,("--help", \_ _ ->kiki_sync_help)]
                 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
 
             forM_ shargs $ \(cmd,args) -> cmd args (rtKeyDB rt)
@@ -698,18 +771,29 @@ kiki "sync" args_raw = do
 kiki "working-key" args = do
     kiki "sync" ["--show-wk"]
 
-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", "update key files of various kinds by propogating information" )
+ , ( "show", "display information from your keyrings")
  , ( "working-key", "show the current working master key and its subkeys" )
  ]