WIP: support for importing bitcoin keys.

2 files changed, 300 insertions, 12 deletions

diff --git a/kiki.cabal b/kiki.cabal
index 0a517f0..8ce59a6 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -15,11 +15,13 @@ Executable kiki
     Main-is: kiki.hs
     Build-Depends:   base -any, cmdargs -any, directory -any,
                      openpgp-crypto-api -any,
-                     crypto-pubkey -any, cryptohash -any,
+                     crypto-pubkey (>=0.2.3), cryptohash -any,
+                     crypto-pubkey-types -any,
                      asn1-types -any, asn1-encoding -any,
                      dataenc -any, text -any, pretty -any, pretty-show -any,
                      bytestring -any, openpgp (==0.6.1), binary -any,
                      unix, time, crypto-api, cryptocipher (>=0.3.7),
-                     containers -any, process -any, filepath -any
+                     containers -any, process -any, filepath -any,
+                     hecc -any
     ghc-options:     -O2
     c-sources: dotlock.c
diff --git a/kiki.hs b/kiki.hs
index 22000d0..6c8ef10 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -14,7 +14,7 @@ import GHC.IO.Exception ( ioException, IOErrorType(..) )
 import Data.IORef
 import Data.Tuple
 import Data.Binary
-import Data.OpenPGP
+import Data.OpenPGP as OpenPGP
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.ByteString      as S
@@ -23,7 +23,8 @@ import Control.Monad
 import qualified Text.Show.Pretty as PP
 import Text.PrettyPrint as PP hiding ((<>))
 import Data.List
-import Data.OpenPGP.CryptoAPI
+import Data.OpenPGP.CryptoAPI hiding (sign)
+import qualified Data.OpenPGP.CryptoAPI as Stephen (sign)
 import Data.Ord
 import Data.Maybe
 import Data.Bits
@@ -32,6 +33,12 @@ import Data.Text.Encoding
 import qualified Codec.Binary.Base32 as Base32
 import qualified Codec.Binary.Base64 as Base64
 import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
+import qualified Crypto.Types.PubKey.ECC as ECC
+-- import qualified Crypto.Types.PubKey.ECDSA as ECDSA
+-- import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
+
 import Data.Char (toLower)
 import qualified Crypto.PubKey.RSA as RSA
 import Crypto.Random (newGenIO,SystemRandom)
@@ -39,6 +46,8 @@ import Data.ASN1.Types
 import Data.ASN1.Encoding
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.BitArray
+import qualified Data.Foldable as Foldable
+import qualified Data.Sequence as Sequence
 import Control.Applicative
 import System.Environment
 import System.Directory
@@ -54,7 +63,7 @@ import System.IO.Error
 import ControlMaybe
 import Data.Char
 import Control.Arrow (first,second)
-import Data.Traversable hiding (mapM,forM)
+-- import Data.Traversable hiding (mapM,forM)
 import System.Console.CmdArgs
 -- import System.Posix.Time
 import Data.Time.Clock.POSIX
@@ -62,6 +71,101 @@ import Data.Monoid ((<>))
 -- import Data.X509
 import qualified Data.Map as Map
 import DotLock
+import Codec.Crypto.ECC.Base
+import Text.Printf
+
+
+isBitCoinKey p =
+    isKey p && key_algorithm p == ECDSA && ecc_curve p == oidToDER secp256k1_oid
+
+sign seckeys dta hashalgo keyid timestamp g = r
+ where
+    Message ks = seckeys
+    ks' = catMaybes $ map (\k->find_key fingerprint (Message [k]) keyid) ks
+    r = case ks' of
+         [k] | isBitCoinKey k -> btc_sign (Message [k]) dta hashalgo keyid timestamp g
+         [k] -> Stephen.sign (Message [k]) dta hashalgo keyid timestamp g
+         ks  -> error $ "cannot determine a key to sign with"
+
+{-
+btc_sign :: (CryptoRandomGen g) =>
+    OpenPGP.Message          -- ^ SecretKeys, one of which will be used
+    -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet
+    -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature
+    -> String                -- ^ KeyID of key to choose
+    -> Integer               -- ^ Timestamp for signature (unless sig supplied)
+    -> g                     -- ^ Random number generator
+    -> (OpenPGP.SignatureOver, g)
+-}
+btc_sign keys over hsh keyid timestamp g = (over {OpenPGP.signatures_over = [sig]}, g')
+    where
+    (final, g') = case OpenPGP.key_algorithm sig of
+        -- OpenPGP.DSA -> ([dsaR, dsaS], dsaG)
+        OpenPGP.ECDSA -> ([ecdsaR,ecdsaS],ecdsaG)
+        kalgo -- | kalgo `elem` [OpenPGP.RSA,OpenPGP.RSA_S] -> ([toNum rsaFinal], g)
+              | otherwise ->
+            error ("Unsupported key algorithm " ++ show kalgo ++ "in sign")
+    Right ((ecdsaR,ecdsaS),ecdsaG) = todo
+    sig = todo
+      where
+        _ = todo -- ECDSA.sign g 
+    {-
+    Right ((dsaR,dsaS),dsaG) = let k' = privateDSAkey k in
+        DSA.sign g (dsaTruncate k' . bhash) k' dta
+    Right rsaFinal = RSA.sign bhash padding (privateRSAkey k) dta
+    dsaTruncate (DSA.PrivateKey (_,_,q) _) = BS.take (integerBytesize q)
+    dta     = toStrictBS $ encode over `LZ.append` OpenPGP.trailer sig
+    sig     = findSigOrDefault (listToMaybe $ OpenPGP.signatures_over over)
+    padding = emsa_pkcs1_v1_5_hash_padding hsh
+    bhash   = fst . pgpHash hsh . toLazyBS
+    toNum   = BS.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0
+    Just k  = find_key keys keyid
+
+    -- Either a SignaturePacket was found, or we need to make one
+    findSigOrDefault (Just s) = OpenPGP.signaturePacket
+        (OpenPGP.version s)
+        (OpenPGP.signature_type s)
+        (OpenPGP.key_algorithm k) -- force to algo of key
+        hsh -- force hash algorithm
+        (OpenPGP.hashed_subpackets s)
+        (OpenPGP.unhashed_subpackets s)
+        (OpenPGP.hash_head s)
+        (map OpenPGP.MPI final)
+    findSigOrDefault Nothing  = OpenPGP.signaturePacket
+        4
+        defaultStype
+        (OpenPGP.key_algorithm k) -- force to algo of key
+        hsh
+        ([
+            -- Do we really need to pass in timestamp just for the default?
+            OpenPGP.SignatureCreationTimePacket $ fromIntegral timestamp,
+            OpenPGP.IssuerPacket $ fingerprint k
+        ] ++ (case over of
+            OpenPGP.KeySignature  {} -> [OpenPGP.KeyFlagsPacket {
+                    OpenPGP.certify_keys = True,
+                    OpenPGP.sign_data = True,
+                    OpenPGP.encrypt_communication = False,
+                    OpenPGP.encrypt_storage = False,
+                    OpenPGP.split_key = False,
+                    OpenPGP.authentication = False,
+                    OpenPGP.group_key = False
+                }]
+            _ -> []
+        ))
+        []
+        0 -- TODO
+        (map OpenPGP.MPI final)
+
+    defaultStype = case over of
+        OpenPGP.DataSignature ld _
+            | OpenPGP.format ld == 'b'     -> 0x00
+            | otherwise                    -> 0x01
+        OpenPGP.KeySignature {}           -> 0x1F
+        OpenPGP.SubkeySignature {}        -> 0x18
+        OpenPGP.CertificationSignature {} -> 0x13
+    -}
+
+
 
 
 warn str = hPutStrLn stderr str
@@ -240,6 +344,7 @@ secretToPublic pkt@(SecretKeyPacket {}) =
     PublicKeyPacket { version = version pkt
                     , timestamp = timestamp pkt
                     , key_algorithm = key_algorithm pkt
+                    , ecc_curve = ecc_curve pkt
                     , key = let seckey = key pkt
                                 pubs = public_key_fields (key_algorithm pkt)
                             in filter (\(k,v) -> k `elem` pubs) seckey
@@ -604,7 +709,7 @@ expandPath path []                 = []
 
 readPacketsFromFile :: FilePath -> IO Message
 readPacketsFromFile fname = do
-    -- warn $ fname ++ ": reading..."
+    warn $ fname ++ ": reading..."
     input <- L.readFile fname
     return $
       case decodeOrFail input of
@@ -853,6 +958,7 @@ readKeyFromFile False "PEM" fname = do
                     ,('q',rsaP rsa) -- Note: p & q swapped
                     ,('u',rsaCoefficient rsa)
                     ]
+            , ecc_curve = []
             , s2k_useage = 0
             , s2k = S2K 100 ""
             , symmetric_algorithm = Unencrypted
@@ -948,7 +1054,7 @@ uidkey (UserIDPacket str) = str
 -- Compare master keys, LT is prefered for merging
 keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
 keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
-keycomp a b | a==b = EQ
+keycomp a b | keykey a==keykey b = EQ
 keycomp a b = error $ unlines ["Unable to merge keys:"
                               , fingerprint a
                               , PP.ppShow a
@@ -959,7 +1065,7 @@ keycomp a b = error $ unlines ["Unable to merge keys:"
 -- Compare subkeys, LT is prefered for merging
 subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
 subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
-subcomp a b | a==b = EQ
+subcomp a b | keykey a==keykey b = EQ
 subcomp a b = error $ unlines ["Unable to merge subs:"
                               , fingerprint a
                               , PP.ppShow a
@@ -1368,18 +1474,170 @@ findTag tag wk subkey subsigs = (xs',minsig,ys')
                     isNotation _ = False
                 return (tag `elem` ks, sig)
 
+secp256k1_oid = [1,3,132,0,10]
+secp256k1_curve = ECi l a b p r
+ where
+    -- y² = x³ + 7 (mod p)
+    p = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEFFFFFC2F 
+    a = 0
+    b = 7
+    -- group order  (also order of base point G)
+    r = n
+    n = 0x0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141 
+    -- cofactor
+    h = 1 
+    -- bit length
+    l = 256
+
+secp256k1_G = ECPa secp256k1_curve 
+                0x79BE667EF9DCBBAC55A06295CE870B07029BFCDB2DCE28D959F2815B16F81798
+                0x483ADA7726A3C4655DA4FBFC0E1108A8FD17B448A68554199C47D08FFB10D4B8 
+    {-
+    The base point G in compressed form is:
+
+        G = 02 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798 
+
+    and in uncompressed form is:
+
+        G = 04 79BE667E F9DCBBAC 55A06295 CE870B07 029BFCDB 2DCE28D9 59F2815B 16F81798
+               483ADA77 26A3C465 5DA4FBFC 0E1108A8 FD17B448 A6855419 9C47D08F FB10D4B8 
+    -}
+
+base58chars = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
+
+base58digits :: [Char] -> Maybe [Int]
+base58digits str = sequence mbs
+ where
+    mbs = map (flip elemIndex base58chars) str
+    
+-- 5HueCGU8rMjxEXxiPuD5BDku4MkFqeZyd4dZ1jvhTVqvbTLvyTJ
+base58_decode :: [Char] -> Maybe (Word8,[Word8])
+base58_decode str = do
+    ds <- base58digits str
+    let n = foldl' (\a b-> a*58 + b) 0 $ ( map fromIntegral ds :: [Integer] )
+        rbytes = unfoldr getbyte n
+        getbyte d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 256
+            return (fromIntegral b,q)
+    
+    let (rcksum,rpayload) = splitAt 4 $ rbytes
+        a_payload = reverse rpayload
+        hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload
+        expected_hash = S.pack $ reverse rcksum
+        (app,payload) = splitAt 1 a_payload
+    
+    app <- listToMaybe app
+    guard (hash_result==expected_hash)
+    return (app,payload)
+
+base58_encode :: S.ByteString -> String
+base58_encode hash = replicate zcount '1' ++ map (base58chars !!) (reverse rdigits)
+  where
+    zcount = S.length . S.takeWhile (==0) $ hash
+    cksum = S.take 4 . SHA256.hash . SHA256.hash $ hash
+    n = foldl' (\a b->a*256+b) 0 . map asInteger $ concatMap S.unpack [hash, cksum]
+    asInteger x = fromIntegral x :: Integer
+    rdigits = unfoldr getdigit n
+     where
+        getdigit d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 58
+            return (fromIntegral b,q)
+
+cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
+ where
+  numToBytes n = reverse $ unfoldr getbyte n
+    where
+        getbyte d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 256
+            return (fromIntegral b,q)
+  pad32 xs = replicate zlen 0 ++ xs
+    where
+        zlen = 32 - length xs
+    
+oidToDER ns = b1 : concatMap encode ys :: [Word8]
+ where
+    (xs,ys) = splitAt 2 ns
+    b1 = fromIntegral $ foldl' (\a b->a*40+b) 0 xs
+    encode x | x <= 127  = [fromIntegral x]
+             | otherwise = map (0x80 .|.) (base128 x)
+    base128 n = reverse $ unfoldr getbyte n
+     where
+        getbyte d = do
+            guard (d/=0)
+            let (q,b) = d `divMod` 128
+            return (fromIntegral b,q)
+
+
+decode_btc_key str = do
+    timestamp <- now
+    return $ Message $ do
+        (a,us) <- maybeToList $ base58_decode str
+        let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
+            xy = secp256k1_G `pmul` d
+            x = getx xy
+            y = gety xy
+            pub = cannonical_eckey x y
+            network_id = 0 -- main network
+            hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
+            address = base58_encode hash
+            pubstr = concatMap (printf "%02x") $ pub
+            _ = pubstr :: String
+        return $ trace (unlines ["pub="++show pubstr
+                                ,"add="++show address])  SecretKeyPacket
+            { version = 4
+            , timestamp = toEnum (fromEnum timestamp)
+            , key_algorithm = ECDSA
+            , ecc_curve = oidToDER secp256k1_oid
+            , key = [ -- public fields...
+                     ('x',MPI x)
+                    ,('y',MPI y) -- OPTIONAL CACHED y
+                    -- secret fields
+                    ,('d',MPI d)
+                    ]
+            , s2k_useage = 0
+            , s2k = S2K 100 ""
+            , symmetric_algorithm = Unencrypted
+            , encrypted_data = ""
+            , is_subkey = True
+            }
+
+doBTCImport doDecrypt db (ms,subspec,content) = do
+    let fetchkey = decode_btc_key content
+    let error s = do
+                        warn s
+                        exitFailure
+    flip (maybe $ error "Cannot import master key.")
+         subspec $ \tag -> do
+    Message parsedkey <- fetchkey
+    flip (maybe $ return db)
+         (listToMaybe parsedkey) $ \key -> do
+    let (m0,tailms) = splitAt 1 ms
+    when (not (null tailms) || null m0)
+        $ error "Key specification is ambiguous."
+    doImportG doDecrypt db m0 tag "" key
+
 doImport doDecrypt db (fname,subspec,ms,_) = do
+    let fetchkey = readKeyFromFile False "PEM" fname
     let error s = do
                         warn s
                         exitFailure
     flip (maybe $ error "Cannot import master key.")
          subspec $ \tag -> do
-    Message parsedkey <- readKeyFromFile False "PEM" fname
+    Message parsedkey <- fetchkey
     flip (maybe $ return db)
          (listToMaybe parsedkey) $ \key -> do
     let (m0,tailms) = splitAt 1 ms
     when (not (null tailms) || null m0)
         $ error "Key specification is ambiguous."
+    doImportG doDecrypt db m0 tag fname key
+
+doImportG doDecrypt db m0 tag fname key = do
+    let error s = do
+                        warn s
+                        exitFailure
     let kk = head m0
         Just (KeyData top topsigs uids subs) = Map.lookup kk db
         subkk = keykey key
@@ -1635,7 +1893,7 @@ main = do
                                      , ("--show-pem",1)
                                      , ("--help",0)
                                      ]
-                          argspec = map fst sargspec ++ ["--keyrings","--keypairs"]
+                          argspec = map fst sargspec ++ ["--keyrings","--keypairs","--bitcoin-keypairs"]
                           args' = if map (take 1) (take 1 vargs) == ["-"]
                                     then vargs
                                     else "--keyrings":vargs
@@ -1663,6 +1921,17 @@ main = do
                 guard $ take 1 bdmcb == "}"
                 let cmd = (drop 1 . reverse . drop 1) bdmcb
                 Just (spec,file,cmd)
+        btcpairs0 =
+            flip map (maybe [] id $ Map.lookup "--bitcoin-keypairs" margs) $ \specfile -> do
+                let (spec,efilecmd) = break (=='=') specfile
+                (spec,protocnt) <- do
+                    return $ if take 1 efilecmd=="=" then (spec,drop 1 efilecmd)
+                                                     else ("",spec)
+                let (proto,content) = break (==':') protocnt
+                spec <- return $ if null spec then "bitcoin" else spec
+                return $ 
+                    if take 1 content =="=" then (spec,proto,drop 1 content)
+                                            else (spec,"base58",proto)
         publics =
             flip map (maybe [] id $ Map.lookup "--public" margs) $ \specfile -> do
                 let (spec,efile) = break (=='=') specfile
@@ -1699,6 +1968,7 @@ main = do
         exitFailure
 
     let keypairs = catMaybes keypairs0
+        btcpairs = catMaybes btcpairs0
 
     (homedir,secring,pubring,grip0) <- getHomeDir ( concat <$> Map.lookup "--homedir" margs)
 
@@ -1734,8 +2004,8 @@ main = do
         use_db0 <- get_use_db
 
         let pkeypairs = maybe [] id $ do
-                            g <- grip
-                            return $ map (\(spec,f,cmd)-> (parseSpec g spec,f,cmd)) keypairs
+                            keygrip <- grip
+                            return $ map (\(spec,f,cmd)-> (parseSpec keygrip spec,f,cmd)) keypairs
         fs <- forM pkeypairs $ \((topspec,subspec),f,cmd) -> do
             -- Note that it's important to discard the KeyData objects
             -- returned by filterMatches and retain only the keys.
@@ -1745,8 +2015,24 @@ main = do
             f_found <- doesFileExist f
             return (f_found,(f,subspec,ms,cmd))
 
+
         let (imports,exports) = partition fst fs
         use_db <- foldM (doImport decrypt) use_db0 (map snd imports)
+
+        let (btcs,bad_btcs) = partition isSupportedBTC btcpairs
+            isSupportedBTC (spec,"base58",cnt) = True
+            isSupportedBTC _                   = False
+            dblist = Map.toList use_db
+            pbtcs = maybe [] id $ do
+                        keygrip <- grip
+                        let conv (spec,proto,cnt) = 
+                                    let (topspec,subspec) = parseSpec keygrip spec
+                                        ms = map fst $ filterMatches topspec dblist
+                                    in (ms,subspec,cnt)
+                        return $ map conv btcs
+
+        use_db <- foldM (doBTCImport decrypt) use_db pbtcs
+
         (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports)
 
         use_db <-