diff options
-rw-r--r-- | KeyRing.hs | 5 | ||||
-rw-r--r-- | kiki.hs | 135 |
2 files changed, 12 insertions, 128 deletions
@@ -150,8 +150,6 @@ filesToLock k secring pubring = do | |||
150 | -- kret :: a -> KeyRingData a | 150 | -- kret :: a -> KeyRingData a |
151 | -- kret x = KeyRingData Map.empty Nothing (KeyRingAction x) | 151 | -- kret x = KeyRingData Map.empty Nothing (KeyRingAction x) |
152 | 152 | ||
153 | todo = error "unimplemented" | ||
154 | |||
155 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) | 153 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) |
156 | data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show | 154 | data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show |
157 | 155 | ||
@@ -1971,6 +1969,7 @@ fmapWithRT g (MultiPass p atn next) = MultiPass p atn next' | |||
1971 | instance Functor Kiki where | 1969 | instance Functor Kiki where |
1972 | fmap f k = fmapWithRT (return f) k | 1970 | fmap f k = fmapWithRT (return f) k |
1973 | 1971 | ||
1972 | {- | ||
1974 | instance Monad Kiki where | 1973 | instance Monad Kiki where |
1975 | return x = SinglePass todo (return x) | 1974 | return x = SinglePass todo (return x) |
1976 | k >>= f = kjoin $ fmap f k | 1975 | k >>= f = kjoin $ fmap f k |
@@ -2099,3 +2098,5 @@ keyBySpec = todo | |||
2099 | 2098 | ||
2100 | walletInputFormat :: Packet -> String | 2099 | walletInputFormat :: Packet -> String |
2101 | walletInputFormat = todo | 2100 | walletInputFormat = todo |
2101 | |||
2102 | -} | ||
@@ -82,6 +82,7 @@ import Data.Binary.Put (putWord32be,runPut,putByteString) | |||
82 | import Data.Binary.Get (runGet) | 82 | import Data.Binary.Get (runGet) |
83 | 83 | ||
84 | import KeyRing | 84 | import KeyRing |
85 | import Base58 | ||
85 | 86 | ||
86 | -- instance Default S.ByteString where def = S.empty | 87 | -- instance Default S.ByteString where def = S.empty |
87 | 88 | ||
@@ -153,8 +154,6 @@ isSubkeySignature _ = False | |||
153 | isPublicMaster k@(PublicKeyPacket {}) = not $ is_subkey k | 154 | isPublicMaster k@(PublicKeyPacket {}) = not $ is_subkey k |
154 | isPublicMaster _ = False | 155 | isPublicMaster _ = False |
155 | 156 | ||
156 | now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime | ||
157 | |||
158 | verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) | 157 | verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) |
159 | where | 158 | where |
160 | verified = do | 159 | verified = do |
@@ -623,85 +622,6 @@ writeOutKeyrings lkmap db = do | |||
623 | -- warn $ "writing "++f | 622 | -- warn $ "writing "++f |
624 | L.writeFile f (encode m) | 623 | L.writeFile f (encode m) |
625 | 624 | ||
626 | setHome spec kd = kd { homeSpec = spec | ||
627 | , kaction = const $ runKeyRing kd | ||
628 | } | ||
629 | |||
630 | |||
631 | cross_merge doDecrypt keyrings wallets kd f = do | ||
632 | |||
633 | let it = kd { filesToLock = HomeSec:HomePub:map ArgFile keyrings | ||
634 | , keyringFiles = keyrings | ||
635 | , walletFiles = wallets | ||
636 | , kaction = go doDecrypt f | ||
637 | } | ||
638 | runKeyRing it | ||
639 | where | ||
640 | go doDecrypt f rt = do | ||
641 | let readp n = fmap (n,) (readPacketsFromFile n) | ||
642 | readw wk n = fmap (n,) (readPacketsFromWallet wk n) | ||
643 | |||
644 | let pass = do | ||
645 | ms <- mapM readp (rtRings rt) | ||
646 | let grip = rtGrip rt `mplus` (fingerprint <$> fstkey) | ||
647 | where | ||
648 | fstkey = listToMaybe $ mapMaybe isSecringKey ms | ||
649 | where isSecringKey (fn,Message ps) | ||
650 | | fn== rtSecring rt = listToMaybe ps | ||
651 | isSecringKey _ = Nothing | ||
652 | wk = listToMaybe $ do | ||
653 | fp <- maybeToList grip | ||
654 | elm <- Map.toList db0 | ||
655 | guard $ matchSpec (KeyGrip fp) elm | ||
656 | return $ keyPacket (snd elm) | ||
657 | db0 = foldl' (uncurry . merge) Map.empty ms | ||
658 | wms <- mapM (readw wk) (rtWallets rt) | ||
659 | let ts = do | ||
660 | maybeToList wk | ||
661 | (fname,xs) <- wms | ||
662 | (_,sub,(_,m)) <- xs | ||
663 | (tag,top) <- Map.toList m | ||
664 | return (top,fname,sub,tag) | ||
665 | |||
666 | importWalletKey db' (top,fname,sub,tag) = do | ||
667 | doImportG doDecrypt | ||
668 | db' | ||
669 | (fmap keykey $ maybeToList wk) | ||
670 | tag | ||
671 | fname | ||
672 | sub | ||
673 | db <- foldM importWalletKey db0 ts | ||
674 | let cs = do | ||
675 | wk <- maybeToList wk | ||
676 | let kk = keykey wk | ||
677 | KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db | ||
678 | (subkk,SubKey mp sigs) <- Map.toList subs | ||
679 | let sub = packet mp | ||
680 | guard $ isCryptoCoinKey sub | ||
681 | tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs) | ||
682 | return (tag,mp) | ||
683 | |||
684 | -- export wallet keys | ||
685 | forM_ (rtWallets rt) $ \n -> do | ||
686 | let cs' = do | ||
687 | (nw,mp) <- cs | ||
688 | -- let fns = Map.keys (locations mp) | ||
689 | -- trace ("COIN KEY: "++show fns) $ return () | ||
690 | guard . not $ Map.member n (locations mp) | ||
691 | let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) | ||
692 | return (CryptoCoins.network_name nw,wip) | ||
693 | handleIO_ (return ()) $ do | ||
694 | withFile n AppendMode $ \fh -> do | ||
695 | forM_ cs' $ \(net,wip) -> do | ||
696 | warn $ n++": new WalletKey "++net | ||
697 | hPutStrLn fh wip | ||
698 | |||
699 | db' <- f (rtSecring rt,grip) db (rtPubring rt) | ||
700 | return (rtRings rt,db') | ||
701 | (fsns,db) <- pass | ||
702 | |||
703 | let lkmap = Map.fromList $ map (,()) fsns | ||
704 | writeOutKeyrings lkmap db | ||
705 | 625 | ||
706 | 626 | ||
707 | toLast f [] = [] | 627 | toLast f [] = [] |
@@ -776,47 +696,6 @@ show_wip keyspec wkgrip db = do | |||
776 | let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s | 696 | let nwb = maybe 0x80 CryptoCoins.secretByteFromName $ snd s |
777 | putStrLn $ walletImportFormat nwb k | 697 | putStrLn $ walletImportFormat nwb k |
778 | 698 | ||
779 | doExport doDecrypt (db,use_db) (fname,subspec,ms,cmd) = | ||
780 | case ms of | ||
781 | [_] -> export | ||
782 | (_:_) -> ambiguous | ||
783 | [] -> shcmd | ||
784 | where | ||
785 | ambiguous = error "Key specification is ambiguous." | ||
786 | shcmd = do | ||
787 | let noop warning = do | ||
788 | warn warning | ||
789 | return (db,use_db) | ||
790 | if null cmd then noop (fname ++ ": missing.") else do | ||
791 | let vars = [ ("file",fname) | ||
792 | , ("usage",maybe "" id subspec) ] | ||
793 | e <- systemEnv vars cmd | ||
794 | case e of | ||
795 | ExitFailure num -> noop $ fname ++ ": failed external (code="++show num++")" | ||
796 | ExitSuccess -> do | ||
797 | warn $ fname ++ ": generated" | ||
798 | db' <- doImport doDecrypt db (fname,subspec,ms,cmd) | ||
799 | return (db', use_db) | ||
800 | export = do | ||
801 | let [kk] = ms | ||
802 | Just (KeyData key _ _ subkeys) = Map.lookup kk use_db | ||
803 | p = flip (maybe (Just $ packet key)) subspec $ \tag -> do | ||
804 | let subs = Map.elems subkeys | ||
805 | doSearch (SubKey sub_mp sigtrusts) = | ||
806 | let (_,v,_) = findTag tag | ||
807 | (packet key) | ||
808 | (packet sub_mp) | ||
809 | sigtrusts | ||
810 | in fmap fst v==Just True | ||
811 | case filter doSearch subs of | ||
812 | [SubKey mp _] -> Just $ packet mp | ||
813 | [] -> Nothing | ||
814 | _ -> ambiguous | ||
815 | flip (maybe shcmd) p $ \p -> do | ||
816 | pun <- doDecrypt p | ||
817 | flip (maybe $ error "Bad passphrase?") pun $ \pun -> do | ||
818 | writeKeyToFile False "PEM" fname pun | ||
819 | return (db,use_db) | ||
820 | 699 | ||
821 | {- | 700 | {- |
822 | applyCurve curve x = x*x*x + x*a + b where (a,b)=(geta curve,getb curve) | 701 | applyCurve curve x = x*x*x + x*a + b where (a,b)=(geta curve,getb curve) |
@@ -914,6 +793,7 @@ bitcoinAddress network_id k = address | |||
914 | -- 1.2.840.10045.3.1.7 --> NIST P-256 | 793 | -- 1.2.840.10045.3.1.7 --> NIST P-256 |
915 | -- | 794 | -- |
916 | 795 | ||
796 | {- | ||
917 | doBTCImport doDecrypt db (ms,subspec,content) = do | 797 | doBTCImport doDecrypt db (ms,subspec,content) = do |
918 | let fetchkey = do | 798 | let fetchkey = do |
919 | timestamp <- now | 799 | timestamp <- now |
@@ -932,6 +812,7 @@ doBTCImport doDecrypt db (ms,subspec,content) = do | |||
932 | when (not (null tailms) || null m0) | 812 | when (not (null tailms) || null m0) |
933 | $ error "Key specification is ambiguous." | 813 | $ error "Key specification is ambiguous." |
934 | doImportG doDecrypt db m0 tag "" key | 814 | doImportG doDecrypt db m0 tag "" key |
815 | -} | ||
935 | 816 | ||
936 | -- We return into IO in case we want to make a signature here. | 817 | -- We return into IO in case we want to make a signature here. |
937 | setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData | 818 | setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData |
@@ -1358,7 +1239,7 @@ main = do | |||
1358 | -} | 1239 | -} |
1359 | 1240 | ||
1360 | let homespec = join . take 1 <$> Map.lookup "--homedir" margs | 1241 | let homespec = join . take 1 <$> Map.lookup "--homedir" margs |
1361 | cross_merge decrypt keyrings_ wallets (setHome homespec KeyRing.empty) | 1242 | todo |
1362 | $ \(secfile,grip) db pubring -> do | 1243 | $ \(secfile,grip) db pubring -> do |
1363 | 1244 | ||
1364 | use_db0 <- return db | 1245 | use_db0 <- return db |
@@ -1377,7 +1258,9 @@ main = do | |||
1377 | 1258 | ||
1378 | 1259 | ||
1379 | let (imports,exports) = partition fst fs | 1260 | let (imports,exports) = partition fst fs |
1380 | use_db <- foldM (doImport decrypt) use_db0 (map snd imports) | 1261 | -- use_db <- foldM (doImport decrypt) use_db0 (map snd imports) |
1262 | |||
1263 | let use_db = todo | ||
1381 | 1264 | ||
1382 | let (btcs,_) = partition isSupportedBTC btcpairs | 1265 | let (btcs,_) = partition isSupportedBTC btcpairs |
1383 | isSupportedBTC (spec,"base58",cnt) = True | 1266 | isSupportedBTC (spec,"base58",cnt) = True |
@@ -1391,9 +1274,9 @@ main = do | |||
1391 | in (ms,subspec,cnt) | 1274 | in (ms,subspec,cnt) |
1392 | return $ map conv btcs | 1275 | return $ map conv btcs |
1393 | 1276 | ||
1394 | use_db <- foldM (doBTCImport decrypt) use_db pbtcs | 1277 | -- use_db <- foldM (doBTCImport decrypt) use_db pbtcs |
1395 | 1278 | ||
1396 | (ret_db,_) <- foldM (doExport decrypt) (use_db,use_db) (map snd exports) | 1279 | -- (ret_db,_) <- foldM (doExport decrypt) (use_db,use_db) (map snd exports) |
1397 | 1280 | ||
1398 | use_db <- | 1281 | use_db <- |
1399 | flip (maybe $ return use_db) | 1282 | flip (maybe $ return use_db) |