Added support for importing keys from various crypto-coin networks.

1 files changed, 178 insertions, 42 deletions

diff --git a/kiki.hs b/kiki.hs
index a372c4c..6b2eb63 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -56,8 +56,9 @@ import System.Process
 import System.Posix.IO (fdToHandle,fdRead)
 import System.Posix.Files
 import System.Posix.Signals
+import System.Posix.Types (EpochTime)
 import System.Process.Internals (runGenProcess_,defaultSignal)
-import System.IO (hPutStrLn,stderr)
+import System.IO (hPutStrLn,stderr,withFile,IOMode(..))
 import System.IO.Error
 import ControlMaybe
 import Data.Char
@@ -74,6 +75,7 @@ import DotLock
 import Codec.Crypto.ECC.Base -- hecc package
 import Text.Printf
 import Math.NumberTheory.Moduli
+import qualified CryptoCoins as CryptoCoins
 
 
 -- instance Default S.ByteString where def = S.empty
@@ -82,12 +84,19 @@ import Math.NumberTheory.Moduli
 nistp256_id  = 0x2a8648ce3d030107
 secp256k1_id = 0x2b8104000a
 
-isBitCoinKey p =
+isCryptoCoinKey p =
     and [ isKey p
         , key_algorithm p == ECDSA
         , lookup 'c' (key p) == Just (MPI secp256k1_id)
         ]
 
+getCryptoCoinTag p | isSignaturePacket p = do
+    -- CryptoCoins.secret
+    let sps = hashed_subpackets p ++ unhashed_subpackets p
+    u <- listToMaybe $ mapMaybe usage sps
+    CryptoCoins.lookupNetwork CryptoCoins.network_name u
+getCryptoCoinTag _ = Nothing
+
 warn str = hPutStrLn stderr str
 
 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
@@ -508,6 +517,9 @@ listKeysFiltered grips pkts = do
                         3 -> " <-> "
                 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
                 torhash = maybe "" id $ derToBase32 <$> derRSA sub
+                (netid,kind') = maybe (0x0,"bitcoin")
+                                      (\n->(CryptoCoins.publicByteFromName n,n))
+                                      $ listToMaybe kind
             unlines $
                 concat  [ " "
                         -- , grip top
@@ -518,10 +530,10 @@ listKeysFiltered grips pkts = do
                         -- , " " ++ torhash
                         -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub))
                         ] -- ++ ppShow hashed
-                    : if isBitCoinKey sub
+                    : if isCryptoCoinKey sub
                         -- then ("      " ++ "B⃦ " ++ bitcoinAddress sub) : showsigs claimants
                         -- then ("      " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants
-                        then ("      " ++ "¢ bitcoin:" ++ bitcoinAddress 0 sub) : showsigs claimants
+                        then ("      " ++ "¢ "++kind'++":" ++ bitcoinAddress netid sub) : showsigs claimants
                         else showsigs claimants
         torkeys = do
             (code,(top,sub), kind, hashed,claimants) <- subs
@@ -637,6 +649,42 @@ expandPath path (c:cs) | c/='/'    = path ++ "/" ++ (c:cs)
 expandPath path []                 = []
 
 
+-- type TimeStamp = Word32
+
+slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
+slurpWIPKeys stamp "" = ([],[])
+slurpWIPKeys stamp cs =
+    let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
+        mb        = decode_btc_key stamp (Char8.unpack b58)
+    in if L.null b58 
+        then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs
+                 (ks,js)  = slurpWIPKeys stamp xs'
+             in (ks,ys:js) 
+        else let (ks,js) = slurpWIPKeys stamp xs
+             in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
+
+readPacketsFromWallet :: 
+    Maybe Packet
+    -> FilePath 
+    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+readPacketsFromWallet wk fname = do
+    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
+                    modificationTime <$> getFileStatus fname
+    input <- L.readFile fname
+    let (ks,junk) = slurpWIPKeys timestamp input
+    when (not (null ks)) $ do
+        -- decrypt wk
+        -- create sigs
+        -- return key/sig pairs
+        return ()
+    return $ do
+        wk <- maybeToList wk
+        guard (not $ null ks)
+        let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
+                                where tag = CryptoCoins.nameFromSecretByte tagbyte
+        (wk,MarkerPacket,(MarkerPacket,Map.empty))
+         :map prep ks
+
 readPacketsFromFile :: FilePath -> IO Message
 readPacketsFromFile fname = do
     -- warn $ fname ++ ": reading..."
@@ -956,9 +1004,16 @@ origin p n = OriginFlags ispub n
 type OriginMap = Map.Map FilePath OriginFlags
 data MappedPacket = MappedPacket
         { packet :: Packet
+        , usage_tag :: Maybe String
         , locations :: OriginMap
         }
 
+mappedPacket filename p = MappedPacket 
+    { packet = p
+    , usage_tag = Nothing
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
 type TrustMap = Map.Map FilePath Packet
 type SigAndTrust = ( MappedPacket
                    , TrustMap     ) -- trust packets
@@ -1008,10 +1063,16 @@ subcomp a b = error $ unlines ["Unable to merge subs:"
 subcomp_m a b = subcomp (packet a) (packet b)
 
 merge :: KeyDB -> FilePath -> Message -> KeyDB
-merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
+merge db filename (Message ps) = merge_ db filename qs
  where
     qs = scanPackets filename ps
-    asMapped n p = MappedPacket p (Map.singleton filename (origin p n))
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    asMapped n p = let m = mappedPacket filename p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
     asSigAndTrust n (p,tm) = (asMapped n p,tm)
     emptyUids = Map.empty
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
@@ -1030,8 +1091,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
           = case v of
              Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
              Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
-                     -> Just $ KeyData ( MappedPacket (minimumBy keycomp [packet key,p])
-                                                      (Map.insert filename (origin p n) (locations key)) )
+                     -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
+                                          { locations = Map.insert filename (origin p n) (locations key) } )
                                        sigs
                                        uids
                                        subkeys
@@ -1061,8 +1122,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
     mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
     mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
     mergeSubkey n p (Just (SubKey key sigs)) = Just $
-        SubKey (MappedPacket (minimumBy subcomp [packet key,p])
-                             (Map.insert filename (origin p n) (locations key)))
+        SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
+                 { locations = Map.insert filename (origin p n) (locations key) })
                sigs
 
     mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
@@ -1082,15 +1143,15 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
                in xs ++ (mergeSameSig n sig y : ys')
 
 
-    isSameSig (a,_) (MappedPacket b _,_) | isSignaturePacket a && isSignaturePacket b =
+    isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
         a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
-    isSameSig (a,_) (MappedPacket b _,_) = a==b
+    isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
 
     mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
-    mergeSameSig n (a,ta) (MappedPacket b locs,tb) | isSignaturePacket a && isSignaturePacket b =
-       ( MappedPacket (b { unhashed_subpackets =
+    mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
+       ( m { packet = (b { unhashed_subpackets =
                             foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
-                      (Map.insert filename (origin a n) locs)
+           , locations = Map.insert filename (origin a n) locs }
         , tb `Map.union` ta )
 
      where
@@ -1133,21 +1194,22 @@ flattenAllUids fname ispub uids =
 
 flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
 flattenUid fname ispub (str,(sigs,om)) = 
-    MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs
+    (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
 
 flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
 flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
 
 unk :: Bool -> MappedPacket -> MappedPacket
 unk isPublic = if isPublic then toPacket secretToPublic else id
-                where toPacket f (MappedPacket p m) = MappedPacket (f p) m
+                where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
 
 unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
 unsig fname isPublic (sig,trustmap) = 
     [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
   where
     f n _ = n==fname -- && trace ("fname=n="++show n) True
-    asMapped n p = MappedPacket p (Map.singleton fname (origin p n))
+    asMapped n p = let m = mappedPacket fname p
+                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
 
 ifSecret (SecretKeyPacket {}) t f = t
 ifSecret _                    t f = f
@@ -1205,26 +1267,78 @@ writeOutKeyrings lkmap db = do
         -- warn $ "writing "++f
         L.writeFile f (encode m)
 
-cross_merge keyrings f = do
+cross_merge doDecrypt grip0 keyrings wallets f = do
         let relock = do
                 (fsns,failed_locks) <- lockFiles keyrings
-                forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
-                return (fsns,failed_locks)
+                (wsns,failed_wlocks) <- lockFiles wallets
+                forM_ (failed_locks++failed_wlocks) $ \f -> warn $ "Failed to lock: " ++ f
+                return (fsns,wsns,failed_locks,failed_wlocks)
             sec_n:_ = keyrings
-        (fsns,failed_locks) <- relock
+        (fsns,wsns,failed_locks,failed_wlocks) <- relock
         -- let (lks,fs) = unzip fsns
         -- forM_ fs $ \f -> warn $ "locked: " ++ f
         let readp n = fmap (n,) (readPacketsFromFile n)
+            readw wk n = fmap (n,) (readPacketsFromWallet wk n)
         let pass n (fsns,failed_locks) = do
                 ms <- mapM readp (map snd fsns++failed_locks)
-                let db = foldl' (uncurry . merge) Map.empty ms
+                let db0 = foldl' (uncurry . merge) Map.empty ms
                     fstkey = listToMaybe $ mapMaybe isSecringKey ms 
                               where isSecringKey (fn,Message ps)
                                         | fn==sec_n = listToMaybe ps
                                     isSecringKey _  = Nothing
+                    grip = grip0 `mplus` (fingerprint <$> fstkey)
+                    wk = listToMaybe $ do
+                            fp <- maybeToList grip
+                            elm <- Map.toList db0
+                            guard $ matchSpec (KeyGrip fp) elm
+                            let undata (KeyData p _ _ _) = packet p
+                            return $ undata (snd elm)
+                wms <- mapM (readw wk) (map snd wsns++failed_wlocks)
+                let -- db1= foldl' (uncurry . merge_) db0 wms
+                    ts = do
+                        maybeToList wk
+                        (fname,xs) <- wms
+                        (_,sub,(_,m)) <- xs
+                        (tag,top) <- Map.toList m
+                        return (top,fname,sub,tag)
+
+                -- sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
+                    importWalletKey db' (top,fname,sub,tag) = do
+                        doImportG doDecrypt 
+                                  db'
+                                  (fmap keykey $ maybeToList wk)
+                                  tag
+                                  fname
+                                  sub
+                db <- foldM importWalletKey db0 ts
+                let cs = do
+                        wk <- maybeToList wk
+                        let kk = keykey wk
+                        KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
+                        (subkk,SubKey mp sigs) <- Map.toList subs
+                        let sub = packet mp
+                        guard $ isCryptoCoinKey sub
+                        tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs)
+                        return (tag,mp)
+
+                -- export wallet keys
+                forM_ wsns $ \(_,n) -> do
+                    let cs' = do
+                        (nw,mp) <- cs
+                        let fns = Map.keys (locations mp)
+                        -- trace ("COIN KEY: "++show fns) $ return ()
+                        guard . not $ Map.member n (locations mp)
+                        let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
+                        return (CryptoCoins.network_name nw,wip)
+                    handleIO_ (return ()) $ do
+                    withFile n AppendMode $ \fh -> do
+                    forM_ cs' $ \(net,wip) -> do
+                        warn $ n++": new WalletKey "++net
+                        hPutStrLn fh wip
+
                 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
                 ------------------------------- from external tools. 
-                (db',_) <- f (sec_n,fstkey) db
+                (db',_) <- f (sec_n,grip) db
                 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
                 let lk = (fsns,failed_locks) -- 
                 -------------------------------
@@ -1235,6 +1349,7 @@ cross_merge keyrings f = do
         let lkmap = Map.fromList $ map swap fsns
         writeOutKeyrings lkmap db
         unlockFiles fsns
+        unlockFiles wsns
         return ()
 
 
@@ -1289,7 +1404,8 @@ show_wip keyspec wkgrip db = do
     flip (maybe $ warn (keyspec ++ ": not found") >> return ())
          (selectSecretKey s db)
          $ \k -> do
-    putStrLn $ walletImportFormat 0x80 k
+    let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s
+    putStrLn $ walletImportFormat nwb k
 
 parseSpec :: String -> String -> (KeySpec,Maybe String)
 parseSpec grip spec = (topspec,subspec)
@@ -1561,10 +1677,9 @@ bitcoinAddress network_id k = address
 --  0x4e*128+0x3d 10045
 -- 1.2.840.10045.3.1.7  --> NIST P-256
 --
-decode_btc_key str = do
-    timestamp <- now
-    return $ Message $ do
-        (network_id,us) <- maybeToList $ base58_decode str
+decode_btc_key timestamp str = do
+    (network_id,us) <- base58_decode str
+    return . (network_id,) $ Message $ do
         let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
             xy = secp256k1_G `pmul` d
             x = getx xy
@@ -1602,7 +1717,11 @@ decode_btc_key str = do
             }
 
 doBTCImport doDecrypt db (ms,subspec,content) = do
-    let fetchkey = decode_btc_key content
+    let fetchkey = do
+            timestamp <- now
+            let mbk = fmap discardNetworkID $ decode_btc_key timestamp content
+                discardNetworkID = snd
+            return $ maybe (Message []) id mbk
     let error s = do
                         warn s
                         exitFailure
@@ -1638,10 +1757,18 @@ doImportG doDecrypt db m0 tag fname key = do
     let kk = head m0
         Just (KeyData top topsigs uids subs) = Map.lookup kk db
         subkk = keykey key
-        (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1))))
+        (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
                                                [])
-                                 (False,)
+                                 ( (False,) . addOrigin )
                                  (Map.lookup subkk subs)
+                             where
+                                addOrigin (SubKey mp sigs) = 
+                                    let mp' = mp
+                                          { locations = Map.insert fname
+                                                             (origin (packet mp) (-1))
+                                                             (locations mp) }
+                                    in SubKey mp' sigs
+        subs' = Map.insert subkk subkey subs
 
         istor = do
             guard (tag == "tor")
@@ -1670,7 +1797,8 @@ doImportG doDecrypt db m0 tag fname key = do
                      $ \sig -> do
                 let om = Map.singleton fname (origin sig (-1))
                     trust = Map.empty
-                return $ Map.insert idstr ([(MappedPacket sig om,trust)],om) uids
+                return $ Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
+                                            ,trust)],om) uids
 
     let SubKey subkey_p subsigs = subkey
         wk = packet top
@@ -1687,7 +1815,7 @@ doImportG doDecrypt db m0 tag fname key = do
         Nothing          -> doInsert Nothing db    -- we need to create a new sig
         Just (True,sig)  -> -- we can deduce is_new == False
                             -- we may need to add a tor id
-                            return $ Map.insert kk (KeyData top topsigs uids' subs) db
+                            return $ Map.insert kk (KeyData top topsigs uids' subs') db
         Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
 
 
@@ -1700,7 +1828,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
             flip (maybe $ error "Failed to make signature.") 
                  (new_sig >>= listToMaybe . signatures_over) 
                  $ \new_sig -> do
-            let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1)))
+            let mp' = mappedPacket fname new_sig
             return (mp', Map.empty)
         parsedkey = [packet $ subkey_p]
         hashed0 =
@@ -1833,7 +1961,12 @@ kiki_usage = do
         ,"     --keyrings FILE FILE..."
         ,"                Provide keyring files other than the implicit secring.gpg and"
         ,"                pubring.gpg in the --homedir.  This option is implicit unless"
-        ,"                --keypairs is used."
+        ,"                --keypairs or --wallets is used."
+        ,""
+        ,"     --wallets  FILE FILE..."
+        ,"                Provide wallet files with secret crypto-coin keys in Wallet"
+        ,"                Import Format.  The keys will be treated as subkeys of your"
+        ,"                current working key (the one shown by --show-wk)."
         ,""
         ,"     --keypairs KEYSPEC KEYSPEC..."
         ,"                Each KEYSPEC specifies that a key should match the content and"
@@ -1853,6 +1986,9 @@ kiki_usage = do
         ,"     --show-pem SPEC"
         ,"                Outputs the PKCS #8 public key corresponding to SPEC."
         ,""
+        ,"     --show-wip SPEC"
+        ,"                Outputs the secret crypto-coin key in Wallet Input Format."
+        ,""
         ,"     --help     Shows this help screen."
         ]
 
@@ -1890,7 +2026,7 @@ main = do
                                      , ("--show-wip",1)
                                      , ("--help",0)
                                      ]
-                          argspec = map fst sargspec ++ ["--keyrings","--keypairs","--bitcoin-keypairs"]
+                          argspec = map fst sargspec ++ ["--keyrings","--keypairs","--wallets","--bitcoin-keypairs"]
                           args' = if map (take 1) (take 1 vargs) == ["-"]
                                     then vargs
                                     else "--keyrings":vargs
@@ -1936,6 +2072,7 @@ main = do
                 let file= drop 1 efile
                 Just (spec,file)
         keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
+        wallets   = maybe [] id $ Map.lookup "--wallets" margs
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
         decrypt wk = do
             -- warn $ "decryptKey "++fingerprint wk
@@ -1977,9 +2114,7 @@ main = do
     putStrLn $ "keyrings = "++show keyrings
     -}
 
-    cross_merge keyrings $ \(secfile,fstkey) db -> do
-        let grip = grip0 `mplus` (fingerprint <$> fstkey)
-
+    cross_merge decrypt grip0 keyrings wallets $ \(secfile,grip) db -> do
         let get_use_db = maybe (return db) import_db 
                             $ Map.lookup "--import" margs
             import_db _ = do
@@ -2146,9 +2281,10 @@ main = do
                     let uidxs0 = map packet $ flattenUid "" True (str,ps)
                     -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0
                     additional <- signSelfAuthTorKeys' selfkey   keys grip           mkey uidxs0
-                    let ps' = ( map ( (,tmap) . flip MappedPacket om) additional 
+                    let ps' = ( map ( (,tmap) . toMappedPacket om) additional 
                                  ++ fst ps
                               , Map.union om (snd ps) )
+                        toMappedPacket om p = (mappedPacket "" p) {locations=om}
                         om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str
                         tmap = Map.empty
                     return ps'
@@ -2357,12 +2493,12 @@ main = do
 
     -}
 
+    {-
     doCmd cmd@(Cross_Merge {}) = do
         (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd)
         -- grip0 may be empty, in which case we should use the first key
         cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db)
 
-    {-
     doCmd cmd@(CatPub {}) = do
         let spec:files = catpub_args cmd
         let (topspec,subspec) = unprefix '/' spec