summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs220
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
56import System.Posix.IO (fdToHandle,fdRead) 56import System.Posix.IO (fdToHandle,fdRead)
57import System.Posix.Files 57import System.Posix.Files
58import System.Posix.Signals 58import System.Posix.Signals
59import System.Posix.Types (EpochTime)
59import System.Process.Internals (runGenProcess_,defaultSignal) 60import System.Process.Internals (runGenProcess_,defaultSignal)
60import System.IO (hPutStrLn,stderr) 61import System.IO (hPutStrLn,stderr,withFile,IOMode(..))
61import System.IO.Error 62import System.IO.Error
62import ControlMaybe 63import ControlMaybe
63import Data.Char 64import Data.Char
@@ -74,6 +75,7 @@ import DotLock
74import Codec.Crypto.ECC.Base -- hecc package 75import Codec.Crypto.ECC.Base -- hecc package
75import Text.Printf 76import Text.Printf
76import Math.NumberTheory.Moduli 77import Math.NumberTheory.Moduli
78import qualified CryptoCoins as CryptoCoins
77 79
78 80
79-- instance Default S.ByteString where def = S.empty 81-- instance Default S.ByteString where def = S.empty
@@ -82,12 +84,19 @@ import Math.NumberTheory.Moduli
82nistp256_id = 0x2a8648ce3d030107 84nistp256_id = 0x2a8648ce3d030107
83secp256k1_id = 0x2b8104000a 85secp256k1_id = 0x2b8104000a
84 86
85isBitCoinKey p = 87isCryptoCoinKey p =
86 and [ isKey p 88 and [ isKey p
87 , key_algorithm p == ECDSA 89 , key_algorithm p == ECDSA
88 , lookup 'c' (key p) == Just (MPI secp256k1_id) 90 , lookup 'c' (key p) == Just (MPI secp256k1_id)
89 ] 91 ]
90 92
93getCryptoCoinTag p | isSignaturePacket p = do
94 -- CryptoCoins.secret
95 let sps = hashed_subpackets p ++ unhashed_subpackets p
96 u <- listToMaybe $ mapMaybe usage sps
97 CryptoCoins.lookupNetwork CryptoCoins.network_name u
98getCryptoCoinTag _ = Nothing
99
91warn str = hPutStrLn stderr str 100warn str = hPutStrLn stderr str
92 101
93unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) 102unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
@@ -508,6 +517,9 @@ listKeysFiltered grips pkts = do
508 3 -> " <-> " 517 3 -> " <-> "
509 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' ' 518 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
510 torhash = maybe "" id $ derToBase32 <$> derRSA sub 519 torhash = maybe "" id $ derToBase32 <$> derRSA sub
520 (netid,kind') = maybe (0x0,"bitcoin")
521 (\n->(CryptoCoins.publicByteFromName n,n))
522 $ listToMaybe kind
511 unlines $ 523 unlines $
512 concat [ " " 524 concat [ " "
513 -- , grip top 525 -- , grip top
@@ -518,10 +530,10 @@ listKeysFiltered grips pkts = do
518 -- , " " ++ torhash 530 -- , " " ++ torhash
519 -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) 531 -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub))
520 ] -- ++ ppShow hashed 532 ] -- ++ ppShow hashed
521 : if isBitCoinKey sub 533 : if isCryptoCoinKey sub
522 -- then (" " ++ "B⃦ " ++ bitcoinAddress sub) : showsigs claimants 534 -- then (" " ++ "B⃦ " ++ bitcoinAddress sub) : showsigs claimants
523 -- then (" " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants 535 -- then (" " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants
524 then (" " ++ "¢ bitcoin:" ++ bitcoinAddress 0 sub) : showsigs claimants 536 then (" " ++ "¢ "++kind'++":" ++ bitcoinAddress netid sub) : showsigs claimants
525 else showsigs claimants 537 else showsigs claimants
526 torkeys = do 538 torkeys = do
527 (code,(top,sub), kind, hashed,claimants) <- subs 539 (code,(top,sub), kind, hashed,claimants) <- subs
@@ -637,6 +649,42 @@ expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs)
637expandPath path [] = [] 649expandPath path [] = []
638 650
639 651
652-- type TimeStamp = Word32
653
654slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
655slurpWIPKeys stamp "" = ([],[])
656slurpWIPKeys stamp cs =
657 let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
658 mb = decode_btc_key stamp (Char8.unpack b58)
659 in if L.null b58
660 then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs
661 (ks,js) = slurpWIPKeys stamp xs'
662 in (ks,ys:js)
663 else let (ks,js) = slurpWIPKeys stamp xs
664 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
665
666readPacketsFromWallet ::
667 Maybe Packet
668 -> FilePath
669 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
670readPacketsFromWallet wk fname = do
671 timestamp <- handleIO_ (error $ fname++": modificaiton time?") $
672 modificationTime <$> getFileStatus fname
673 input <- L.readFile fname
674 let (ks,junk) = slurpWIPKeys timestamp input
675 when (not (null ks)) $ do
676 -- decrypt wk
677 -- create sigs
678 -- return key/sig pairs
679 return ()
680 return $ do
681 wk <- maybeToList wk
682 guard (not $ null ks)
683 let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
684 where tag = CryptoCoins.nameFromSecretByte tagbyte
685 (wk,MarkerPacket,(MarkerPacket,Map.empty))
686 :map prep ks
687
640readPacketsFromFile :: FilePath -> IO Message 688readPacketsFromFile :: FilePath -> IO Message
641readPacketsFromFile fname = do 689readPacketsFromFile fname = do
642 -- warn $ fname ++ ": reading..." 690 -- warn $ fname ++ ": reading..."
@@ -956,9 +1004,16 @@ origin p n = OriginFlags ispub n
956type OriginMap = Map.Map FilePath OriginFlags 1004type OriginMap = Map.Map FilePath OriginFlags
957data MappedPacket = MappedPacket 1005data MappedPacket = MappedPacket
958 { packet :: Packet 1006 { packet :: Packet
1007 , usage_tag :: Maybe String
959 , locations :: OriginMap 1008 , locations :: OriginMap
960 } 1009 }
961 1010
1011mappedPacket filename p = MappedPacket
1012 { packet = p
1013 , usage_tag = Nothing
1014 , locations = Map.singleton filename (origin p (-1))
1015 }
1016
962type TrustMap = Map.Map FilePath Packet 1017type TrustMap = Map.Map FilePath Packet
963type SigAndTrust = ( MappedPacket 1018type SigAndTrust = ( MappedPacket
964 , TrustMap ) -- trust packets 1019 , TrustMap ) -- trust packets
@@ -1008,10 +1063,16 @@ subcomp a b = error $ unlines ["Unable to merge subs:"
1008subcomp_m a b = subcomp (packet a) (packet b) 1063subcomp_m a b = subcomp (packet a) (packet b)
1009 1064
1010merge :: KeyDB -> FilePath -> Message -> KeyDB 1065merge :: KeyDB -> FilePath -> Message -> KeyDB
1011merge db filename (Message ps) = foldl mergeit db (zip [0..] qs) 1066merge db filename (Message ps) = merge_ db filename qs
1012 where 1067 where
1013 qs = scanPackets filename ps 1068 qs = scanPackets filename ps
1014 asMapped n p = MappedPacket p (Map.singleton filename (origin p n)) 1069
1070merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
1071 -> KeyDB
1072merge_ db filename qs = foldl mergeit db (zip [0..] qs)
1073 where
1074 asMapped n p = let m = mappedPacket filename p
1075 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
1015 asSigAndTrust n (p,tm) = (asMapped n p,tm) 1076 asSigAndTrust n (p,tm) = (asMapped n p,tm)
1016 emptyUids = Map.empty 1077 emptyUids = Map.empty
1017 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 1078 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
@@ -1030,8 +1091,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
1030 = case v of 1091 = case v of
1031 Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty 1092 Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
1032 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p 1093 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
1033 -> Just $ KeyData ( MappedPacket (minimumBy keycomp [packet key,p]) 1094 -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
1034 (Map.insert filename (origin p n) (locations key)) ) 1095 { locations = Map.insert filename (origin p n) (locations key) } )
1035 sigs 1096 sigs
1036 uids 1097 uids
1037 subkeys 1098 subkeys
@@ -1061,8 +1122,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
1061 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey 1122 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
1062 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] 1123 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
1063 mergeSubkey n p (Just (SubKey key sigs)) = Just $ 1124 mergeSubkey n p (Just (SubKey key sigs)) = Just $
1064 SubKey (MappedPacket (minimumBy subcomp [packet key,p]) 1125 SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
1065 (Map.insert filename (origin p n) (locations key))) 1126 { locations = Map.insert filename (origin p n) (locations key) })
1066 sigs 1127 sigs
1067 1128
1068 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) 1129 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)
1082 in xs ++ (mergeSameSig n sig y : ys') 1143 in xs ++ (mergeSameSig n sig y : ys')
1083 1144
1084 1145
1085 isSameSig (a,_) (MappedPacket b _,_) | isSignaturePacket a && isSignaturePacket b = 1146 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
1086 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } 1147 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
1087 isSameSig (a,_) (MappedPacket b _,_) = a==b 1148 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
1088 1149
1089 mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) 1150 mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
1090 mergeSameSig n (a,ta) (MappedPacket b locs,tb) | isSignaturePacket a && isSignaturePacket b = 1151 mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
1091 ( MappedPacket (b { unhashed_subpackets = 1152 ( m { packet = (b { unhashed_subpackets =
1092 foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) }) 1153 foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
1093 (Map.insert filename (origin a n) locs) 1154 , locations = Map.insert filename (origin a n) locs }
1094 , tb `Map.union` ta ) 1155 , tb `Map.union` ta )
1095 1156
1096 where 1157 where
@@ -1133,21 +1194,22 @@ flattenAllUids fname ispub uids =
1133 1194
1134flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] 1195flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
1135flattenUid fname ispub (str,(sigs,om)) = 1196flattenUid fname ispub (str,(sigs,om)) =
1136 MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs 1197 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
1137 1198
1138flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] 1199flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
1139flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs 1200flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
1140 1201
1141unk :: Bool -> MappedPacket -> MappedPacket 1202unk :: Bool -> MappedPacket -> MappedPacket
1142unk isPublic = if isPublic then toPacket secretToPublic else id 1203unk isPublic = if isPublic then toPacket secretToPublic else id
1143 where toPacket f (MappedPacket p m) = MappedPacket (f p) m 1204 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
1144 1205
1145unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] 1206unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
1146unsig fname isPublic (sig,trustmap) = 1207unsig fname isPublic (sig,trustmap) =
1147 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) 1208 [sig]++ map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
1148 where 1209 where
1149 f n _ = n==fname -- && trace ("fname=n="++show n) True 1210 f n _ = n==fname -- && trace ("fname=n="++show n) True
1150 asMapped n p = MappedPacket p (Map.singleton fname (origin p n)) 1211 asMapped n p = let m = mappedPacket fname p
1212 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
1151 1213
1152ifSecret (SecretKeyPacket {}) t f = t 1214ifSecret (SecretKeyPacket {}) t f = t
1153ifSecret _ t f = f 1215ifSecret _ t f = f
@@ -1205,26 +1267,78 @@ writeOutKeyrings lkmap db = do
1205 -- warn $ "writing "++f 1267 -- warn $ "writing "++f
1206 L.writeFile f (encode m) 1268 L.writeFile f (encode m)
1207 1269
1208cross_merge keyrings f = do 1270cross_merge doDecrypt grip0 keyrings wallets f = do
1209 let relock = do 1271 let relock = do
1210 (fsns,failed_locks) <- lockFiles keyrings 1272 (fsns,failed_locks) <- lockFiles keyrings
1211 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f 1273 (wsns,failed_wlocks) <- lockFiles wallets
1212 return (fsns,failed_locks) 1274 forM_ (failed_locks++failed_wlocks) $ \f -> warn $ "Failed to lock: " ++ f
1275 return (fsns,wsns,failed_locks,failed_wlocks)
1213 sec_n:_ = keyrings 1276 sec_n:_ = keyrings
1214 (fsns,failed_locks) <- relock 1277 (fsns,wsns,failed_locks,failed_wlocks) <- relock
1215 -- let (lks,fs) = unzip fsns 1278 -- let (lks,fs) = unzip fsns
1216 -- forM_ fs $ \f -> warn $ "locked: " ++ f 1279 -- forM_ fs $ \f -> warn $ "locked: " ++ f
1217 let readp n = fmap (n,) (readPacketsFromFile n) 1280 let readp n = fmap (n,) (readPacketsFromFile n)
1281 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
1218 let pass n (fsns,failed_locks) = do 1282 let pass n (fsns,failed_locks) = do
1219 ms <- mapM readp (map snd fsns++failed_locks) 1283 ms <- mapM readp (map snd fsns++failed_locks)
1220 let db = foldl' (uncurry . merge) Map.empty ms 1284 let db0 = foldl' (uncurry . merge) Map.empty ms
1221 fstkey = listToMaybe $ mapMaybe isSecringKey ms 1285 fstkey = listToMaybe $ mapMaybe isSecringKey ms
1222 where isSecringKey (fn,Message ps) 1286 where isSecringKey (fn,Message ps)
1223 | fn==sec_n = listToMaybe ps 1287 | fn==sec_n = listToMaybe ps
1224 isSecringKey _ = Nothing 1288 isSecringKey _ = Nothing
1289 grip = grip0 `mplus` (fingerprint <$> fstkey)
1290 wk = listToMaybe $ do
1291 fp <- maybeToList grip
1292 elm <- Map.toList db0
1293 guard $ matchSpec (KeyGrip fp) elm
1294 let undata (KeyData p _ _ _) = packet p
1295 return $ undata (snd elm)
1296 wms <- mapM (readw wk) (map snd wsns++failed_wlocks)
1297 let -- db1= foldl' (uncurry . merge_) db0 wms
1298 ts = do
1299 maybeToList wk
1300 (fname,xs) <- wms
1301 (_,sub,(_,m)) <- xs
1302 (tag,top) <- Map.toList m
1303 return (top,fname,sub,tag)
1304
1305 -- sig' <- makeSig doDecrypt top fname subkey_p tag mbsig
1306 importWalletKey db' (top,fname,sub,tag) = do
1307 doImportG doDecrypt
1308 db'
1309 (fmap keykey $ maybeToList wk)
1310 tag
1311 fname
1312 sub
1313 db <- foldM importWalletKey db0 ts
1314 let cs = do
1315 wk <- maybeToList wk
1316 let kk = keykey wk
1317 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
1318 (subkk,SubKey mp sigs) <- Map.toList subs
1319 let sub = packet mp
1320 guard $ isCryptoCoinKey sub
1321 tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs)
1322 return (tag,mp)
1323
1324 -- export wallet keys
1325 forM_ wsns $ \(_,n) -> do
1326 let cs' = do
1327 (nw,mp) <- cs
1328 let fns = Map.keys (locations mp)
1329 -- trace ("COIN KEY: "++show fns) $ return ()
1330 guard . not $ Map.member n (locations mp)
1331 let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
1332 return (CryptoCoins.network_name nw,wip)
1333 handleIO_ (return ()) $ do
1334 withFile n AppendMode $ \fh -> do
1335 forM_ cs' $ \(net,wip) -> do
1336 warn $ n++": new WalletKey "++net
1337 hPutStrLn fh wip
1338
1225 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings 1339 -- unlockFiles fsns ----------- Originally, I did this to enable altering the gpg keyrings
1226 ------------------------------- from external tools. 1340 ------------------------------- from external tools.
1227 (db',_) <- f (sec_n,fstkey) db 1341 (db',_) <- f (sec_n,grip) db
1228 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now. 1342 -- lk <- relock --------------- The design is not quite safe, so it is disabled for now.
1229 let lk = (fsns,failed_locks) -- 1343 let lk = (fsns,failed_locks) --
1230 ------------------------------- 1344 -------------------------------
@@ -1235,6 +1349,7 @@ cross_merge keyrings f = do
1235 let lkmap = Map.fromList $ map swap fsns 1349 let lkmap = Map.fromList $ map swap fsns
1236 writeOutKeyrings lkmap db 1350 writeOutKeyrings lkmap db
1237 unlockFiles fsns 1351 unlockFiles fsns
1352 unlockFiles wsns
1238 return () 1353 return ()
1239 1354
1240 1355
@@ -1289,7 +1404,8 @@ show_wip keyspec wkgrip db = do
1289 flip (maybe $ warn (keyspec ++ ": not found") >> return ()) 1404 flip (maybe $ warn (keyspec ++ ": not found") >> return ())
1290 (selectSecretKey s db) 1405 (selectSecretKey s db)
1291 $ \k -> do 1406 $ \k -> do
1292 putStrLn $ walletImportFormat 0x80 k 1407 let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s
1408 putStrLn $ walletImportFormat nwb k
1293 1409
1294parseSpec :: String -> String -> (KeySpec,Maybe String) 1410parseSpec :: String -> String -> (KeySpec,Maybe String)
1295parseSpec grip spec = (topspec,subspec) 1411parseSpec grip spec = (topspec,subspec)
@@ -1561,10 +1677,9 @@ bitcoinAddress network_id k = address
1561-- 0x4e*128+0x3d 10045 1677-- 0x4e*128+0x3d 10045
1562-- 1.2.840.10045.3.1.7 --> NIST P-256 1678-- 1.2.840.10045.3.1.7 --> NIST P-256
1563-- 1679--
1564decode_btc_key str = do 1680decode_btc_key timestamp str = do
1565 timestamp <- now 1681 (network_id,us) <- base58_decode str
1566 return $ Message $ do 1682 return . (network_id,) $ Message $ do
1567 (network_id,us) <- maybeToList $ base58_decode str
1568 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) 1683 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
1569 xy = secp256k1_G `pmul` d 1684 xy = secp256k1_G `pmul` d
1570 x = getx xy 1685 x = getx xy
@@ -1602,7 +1717,11 @@ decode_btc_key str = do
1602 } 1717 }
1603 1718
1604doBTCImport doDecrypt db (ms,subspec,content) = do 1719doBTCImport doDecrypt db (ms,subspec,content) = do
1605 let fetchkey = decode_btc_key content 1720 let fetchkey = do
1721 timestamp <- now
1722 let mbk = fmap discardNetworkID $ decode_btc_key timestamp content
1723 discardNetworkID = snd
1724 return $ maybe (Message []) id mbk
1606 let error s = do 1725 let error s = do
1607 warn s 1726 warn s
1608 exitFailure 1727 exitFailure
@@ -1638,10 +1757,18 @@ doImportG doDecrypt db m0 tag fname key = do
1638 let kk = head m0 1757 let kk = head m0
1639 Just (KeyData top topsigs uids subs) = Map.lookup kk db 1758 Just (KeyData top topsigs uids subs) = Map.lookup kk db
1640 subkk = keykey key 1759 subkk = keykey key
1641 (is_new, subkey) = maybe (True, SubKey (MappedPacket key (Map.singleton fname (origin key (-1)))) 1760 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1642 []) 1761 [])
1643 (False,) 1762 ( (False,) . addOrigin )
1644 (Map.lookup subkk subs) 1763 (Map.lookup subkk subs)
1764 where
1765 addOrigin (SubKey mp sigs) =
1766 let mp' = mp
1767 { locations = Map.insert fname
1768 (origin (packet mp) (-1))
1769 (locations mp) }
1770 in SubKey mp' sigs
1771 subs' = Map.insert subkk subkey subs
1645 1772
1646 istor = do 1773 istor = do
1647 guard (tag == "tor") 1774 guard (tag == "tor")
@@ -1670,7 +1797,8 @@ doImportG doDecrypt db m0 tag fname key = do
1670 $ \sig -> do 1797 $ \sig -> do
1671 let om = Map.singleton fname (origin sig (-1)) 1798 let om = Map.singleton fname (origin sig (-1))
1672 trust = Map.empty 1799 trust = Map.empty
1673 return $ Map.insert idstr ([(MappedPacket sig om,trust)],om) uids 1800 return $ Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1801 ,trust)],om) uids
1674 1802
1675 let SubKey subkey_p subsigs = subkey 1803 let SubKey subkey_p subsigs = subkey
1676 wk = packet top 1804 wk = packet top
@@ -1687,7 +1815,7 @@ doImportG doDecrypt db m0 tag fname key = do
1687 Nothing -> doInsert Nothing db -- we need to create a new sig 1815 Nothing -> doInsert Nothing db -- we need to create a new sig
1688 Just (True,sig) -> -- we can deduce is_new == False 1816 Just (True,sig) -> -- we can deduce is_new == False
1689 -- we may need to add a tor id 1817 -- we may need to add a tor id
1690 return $ Map.insert kk (KeyData top topsigs uids' subs) db 1818 return $ Map.insert kk (KeyData top topsigs uids' subs') db
1691 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag 1819 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
1692 1820
1693 1821
@@ -1700,7 +1828,7 @@ makeSig doDecrypt top fname subkey_p tag mbsig = do
1700 flip (maybe $ error "Failed to make signature.") 1828 flip (maybe $ error "Failed to make signature.")
1701 (new_sig >>= listToMaybe . signatures_over) 1829 (new_sig >>= listToMaybe . signatures_over)
1702 $ \new_sig -> do 1830 $ \new_sig -> do
1703 let mp' = MappedPacket new_sig (Map.singleton fname (origin new_sig (-1))) 1831 let mp' = mappedPacket fname new_sig
1704 return (mp', Map.empty) 1832 return (mp', Map.empty)
1705 parsedkey = [packet $ subkey_p] 1833 parsedkey = [packet $ subkey_p]
1706 hashed0 = 1834 hashed0 =
@@ -1833,7 +1961,12 @@ kiki_usage = do
1833 ," --keyrings FILE FILE..." 1961 ," --keyrings FILE FILE..."
1834 ," Provide keyring files other than the implicit secring.gpg and" 1962 ," Provide keyring files other than the implicit secring.gpg and"
1835 ," pubring.gpg in the --homedir. This option is implicit unless" 1963 ," pubring.gpg in the --homedir. This option is implicit unless"
1836 ," --keypairs is used." 1964 ," --keypairs or --wallets is used."
1965 ,""
1966 ," --wallets FILE FILE..."
1967 ," Provide wallet files with secret crypto-coin keys in Wallet"
1968 ," Import Format. The keys will be treated as subkeys of your"
1969 ," current working key (the one shown by --show-wk)."
1837 ,"" 1970 ,""
1838 ," --keypairs KEYSPEC KEYSPEC..." 1971 ," --keypairs KEYSPEC KEYSPEC..."
1839 ," Each KEYSPEC specifies that a key should match the content and" 1972 ," Each KEYSPEC specifies that a key should match the content and"
@@ -1853,6 +1986,9 @@ kiki_usage = do
1853 ," --show-pem SPEC" 1986 ," --show-pem SPEC"
1854 ," Outputs the PKCS #8 public key corresponding to SPEC." 1987 ," Outputs the PKCS #8 public key corresponding to SPEC."
1855 ,"" 1988 ,""
1989 ," --show-wip SPEC"
1990 ," Outputs the secret crypto-coin key in Wallet Input Format."
1991 ,""
1856 ," --help Shows this help screen." 1992 ," --help Shows this help screen."
1857 ] 1993 ]
1858 1994
@@ -1890,7 +2026,7 @@ main = do
1890 , ("--show-wip",1) 2026 , ("--show-wip",1)
1891 , ("--help",0) 2027 , ("--help",0)
1892 ] 2028 ]
1893 argspec = map fst sargspec ++ ["--keyrings","--keypairs","--bitcoin-keypairs"] 2029 argspec = map fst sargspec ++ ["--keyrings","--keypairs","--wallets","--bitcoin-keypairs"]
1894 args' = if map (take 1) (take 1 vargs) == ["-"] 2030 args' = if map (take 1) (take 1 vargs) == ["-"]
1895 then vargs 2031 then vargs
1896 else "--keyrings":vargs 2032 else "--keyrings":vargs
@@ -1936,6 +2072,7 @@ main = do
1936 let file= drop 1 efile 2072 let file= drop 1 efile
1937 Just (spec,file) 2073 Just (spec,file)
1938 keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs 2074 keyrings_ = maybe [] id $ Map.lookup "--keyrings" margs
2075 wallets = maybe [] id $ Map.lookup "--wallets" margs
1939 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs 2076 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1940 decrypt wk = do 2077 decrypt wk = do
1941 -- warn $ "decryptKey "++fingerprint wk 2078 -- warn $ "decryptKey "++fingerprint wk
@@ -1977,9 +2114,7 @@ main = do
1977 putStrLn $ "keyrings = "++show keyrings 2114 putStrLn $ "keyrings = "++show keyrings
1978 -} 2115 -}
1979 2116
1980 cross_merge keyrings $ \(secfile,fstkey) db -> do 2117 cross_merge decrypt grip0 keyrings wallets $ \(secfile,grip) db -> do
1981 let grip = grip0 `mplus` (fingerprint <$> fstkey)
1982
1983 let get_use_db = maybe (return db) import_db 2118 let get_use_db = maybe (return db) import_db
1984 $ Map.lookup "--import" margs 2119 $ Map.lookup "--import" margs
1985 import_db _ = do 2120 import_db _ = do
@@ -2146,9 +2281,10 @@ main = do
2146 let uidxs0 = map packet $ flattenUid "" True (str,ps) 2281 let uidxs0 = map packet $ flattenUid "" True (str,ps)
2147 -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0 2282 -- addition<- signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0
2148 additional <- signSelfAuthTorKeys' selfkey keys grip mkey uidxs0 2283 additional <- signSelfAuthTorKeys' selfkey keys grip mkey uidxs0
2149 let ps' = ( map ( (,tmap) . flip MappedPacket om) additional 2284 let ps' = ( map ( (,tmap) . toMappedPacket om) additional
2150 ++ fst ps 2285 ++ fst ps
2151 , Map.union om (snd ps) ) 2286 , Map.union om (snd ps) )
2287 toMappedPacket om p = (mappedPacket "" p) {locations=om}
2152 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str 2288 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str
2153 tmap = Map.empty 2289 tmap = Map.empty
2154 return ps' 2290 return ps'
@@ -2357,12 +2493,12 @@ main = do
2357 2493
2358 -} 2494 -}
2359 2495
2496 {-
2360 doCmd cmd@(Cross_Merge {}) = do 2497 doCmd cmd@(Cross_Merge {}) = do
2361 (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd) 2498 (homedir,secring,pubring,grip0) <- getHomeDir (homedir cmd)
2362 -- grip0 may be empty, in which case we should use the first key 2499 -- grip0 may be empty, in which case we should use the first key
2363 cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db) 2500 cross_merge (secring:pubring:files cmd) $ \_ db -> return $ (Just db,db)
2364 2501
2365 {-
2366 doCmd cmd@(CatPub {}) = do 2502 doCmd cmd@(CatPub {}) = do
2367 let spec:files = catpub_args cmd 2503 let spec:files = catpub_args cmd
2368 let (topspec,subspec) = unprefix '/' spec 2504 let (topspec,subspec) = unprefix '/' spec