1 files changed, 303 insertions, 10 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index cdfcd34..2a80930 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
 module KeyRing where
 
 import System.Environment
@@ -11,17 +12,32 @@ import Data.Char
 import Data.List
 import Data.OpenPGP
 import Data.Functor
-import Control.Applicative    ( (<$>) )
+import Data.Bits              ( (.|.) )
+-- import Control.Applicative    ( (<$>) )
 import System.Directory       ( getHomeDirectory, doesFileExist )
 import Control.Arrow          ( first, second )
 import Data.OpenPGP.Util      ( fingerprint )
 import Data.ByteString.Lazy   ( ByteString )
 import Text.Show.Pretty as PP ( ppShow )
+import Data.Word ( Word8 )
+import Data.Binary ( decode )
+import ControlMaybe ( handleIO_ )
 import qualified Data.Map as Map
-
+import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString )
+import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 
+import qualified Crypto.Types.PubKey.ECC as ECC
+import System.Posix.Types (EpochTime)
+import System.Posix.Files ( modificationTime, getFileStatus )
+
+import qualified CryptoCoins as CryptoCoins
+import Base58
 import FunctorToMaybe
 import DotLock
 
+-- DER-encoded elliptic curve ids
+nistp256_id  = 0x2a8648ce3d030107
+secp256k1_id = 0x2b8104000a
+
 data HomeDir =
     HomeDir { homevar :: String
             , appdir :: String
@@ -51,6 +67,7 @@ data KeyRingRuntime = KeyRingRuntime
                         , rtRings :: [FilePath]
                         , rtWallets :: [FilePath]
                         , rtGrip :: Maybe String
+                        , rtKeyDB :: KeyDB
                         }
 
 data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)
@@ -61,17 +78,19 @@ data KeyRingData = KeyRingData
     , homeSpec :: Maybe String
     }
 
-filesToLock k secring pubring = do
-    (f,(rtyp,ftyp)) <- Map.toList (kFiles k)
-    case rtyp of
-        ConstRef -> []
-        MutableRef {} -> resolve f
+resolveInputFile secring pubring = resolve
  where
     resolve HomeSec = return secring
     resolve HomePub = return pubring
     resolve (ArgFile f) = return f
     resolve _ = []
 
+filesToLock k secring pubring = do
+    (f,(rtyp,ftyp)) <- Map.toList (kFiles k)
+    case rtyp of
+        ConstRef -> []
+        MutableRef {} -> resolveInputFile secring pubring f
+
 
 -- kret :: a -> KeyRingData a
 -- kret x = KeyRingData Map.empty Nothing (KeyRingAction x)
@@ -102,6 +121,188 @@ data KikiResult a = KikiResult
     , kikiReport :: [ (FilePath, KikiReportAction) ]
     }
 
+keyPacket (KeyData k _ _ _) = packet k
+
+usage (NotationDataPacket
+        { human_readable = True
+        , notation_name  = "usage@"
+        , notation_value = u
+        }) = Just u
+usage _    = Nothing
+
+keyflags flgs@(KeyFlagsPacket {}) =
+    Just . toEnum $
+        (   bit 0x1 certify_keys
+        .|. bit 0x2 sign_data
+        .|. bit 0x4 encrypt_communication
+        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
+    -- other flags:
+    --  split_key
+    --  authentication (ssh-client)
+    --  group_key
+ where
+    bit v f = if f flgs then v else 0
+keyflags _ = Nothing
+
+
+data PGPKeyFlags =
+    Special
+    | Vouch -- Signkey
+    | Sign
+    | VouchSign
+    | Communication
+    | VouchCommunication
+    | SignCommunication
+    | VouchSignCommunication
+    | Storage
+    | VouchStorage
+    | SignStorage
+    | VouchSignStorage
+    | Encrypt
+    | VouchEncrypt
+    | SignEncrypt
+    | VouchSignEncrypt
+ deriving (Eq,Show,Read,Enum)
+usageString flgs =
+ case flgs of
+    Special -> "special"
+    Vouch -> "vouch" -- signkey
+    Sign -> "sign"
+    VouchSign -> "vouch-sign"
+    Communication -> "communication"
+    VouchCommunication -> "vouch-communication"
+    SignCommunication -> "sign-communication"
+    VouchSignCommunication -> "vouch-sign-communication"
+    Storage -> "storage"
+    VouchStorage -> "vouch-storage"
+    SignStorage -> "sign-storage"
+    VouchSignStorage -> "vouch-sign-storage"
+    Encrypt -> "encrypt"
+    VouchEncrypt -> "vouch-encrypt"
+    SignEncrypt -> "sign-encrypt"
+    VouchSignEncrypt -> "vouch-sign-encrypt"
+
+
+
+
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+
+keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
+keyFlags0 wkun uidsigs = concat
+                      [ keyflags
+                      , preferredsym
+                      , preferredhash
+                      , preferredcomp
+                      , features ]
+
+ where
+    subs = concatMap hashed_subpackets uidsigs
+    keyflags = filterOr isflags subs $
+               KeyFlagsPacket { certify_keys = True
+                              , sign_data = True
+                              , encrypt_communication = False
+                              , encrypt_storage = False
+                              , split_key = False
+                              , authentication = False
+                              , group_key = False
+                              }
+    preferredsym = filterOr ispreferedsym subs $
+               PreferredSymmetricAlgorithmsPacket
+                              [ AES256
+                              , AES192
+                              , AES128
+                              , CAST5
+                              , TripleDES
+                              ]
+    preferredhash = filterOr ispreferedhash subs $
+               PreferredHashAlgorithmsPacket
+                              [ SHA256
+                              , SHA1
+                              , SHA384
+                              , SHA512
+                              , SHA224
+                              ]
+    preferredcomp = filterOr ispreferedcomp subs $
+               PreferredCompressionAlgorithmsPacket
+                              [ ZLIB
+                              , BZip2
+                              , ZIP
+                              ]
+    features = filterOr isfeatures subs $
+               FeaturesPacket { supports_mdc = True
+                              }
+
+    filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
+
+    isflags (KeyFlagsPacket {}) = True
+    isflags _ = False
+    ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
+    ispreferedsym _ = False
+    ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
+    ispreferedhash _ = False
+    ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
+    ispreferedcomp _ = False
+    isfeatures (FeaturesPacket {}) = True
+    isfeatures _ = False
+
+
+matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 
+    | matchpr grip (packet p)==grip = True
+    | otherwise                     = False
+
+matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
+ where
+    ps = map (packet .fst) sigs
+    match p = isSignaturePacket p
+                && has_tag tag p
+                && has_issuer key p
+    has_issuer key p = isJust $ do
+        issuer <- signature_issuer p
+        guard $ matchpr issuer key == issuer
+    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
+                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
+
+matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
+  where
+    us = filter (isInfixOf pat) $ Map.keys uids
+
+
+data KeySpec =
+      KeyGrip String
+    | KeyTag Packet String
+    | KeyUidMatch String
+ deriving Show
+
+
+buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
+              -> IO ((KeyDB,String),[(FilePath,KikiReportAction)])
+buildKeyDB secring pubring grip0 keyring = do
+    let rings = do
+            (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
+            let isring (KeyRingFile {}) = True
+                isring _                = False
+            guard (isring ftyp)
+            resolveInputFile secring pubring f
+        readp n = fmap (n,) (readPacketsFromFile n)
+        readw wk n = fmap (n,) (readPacketsFromWallet wk n)
+    ms <- mapM readp rings
+    let grip = grip0 `mplus` (fingerprint <$> fstkey)
+          where
+            fstkey = listToMaybe $ mapMaybe isSecringKey ms 
+                      where isSecringKey (fn,Message ps)
+                                | fn==secring = listToMaybe ps
+                            isSecringKey _  = Nothing
+        wk = listToMaybe $ do
+                fp <- maybeToList grip
+                elm <- Map.toList db0
+                guard $ matchSpec (KeyGrip fp) elm
+                return $ keyPacket (snd elm)
+        db0 = foldl' (uncurry . merge) Map.empty ms
+    db <- return db0 -- todo
+    return ( (db, todo), todo )
+
 runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a)
 runKeyRing keyring op = do
     (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
@@ -117,7 +318,7 @@ runKeyRing keyring op = do
         ret = if null failed then KikiSuccess () else FailedToLock failed
     ret <- case functorToEither ret of
       Right {} -> do
-         report <- todo -- build db
+         ((db,grip), report1) <- buildKeyDB secring pubring grip0 keyring -- build db
 
          a <- return $ op KeyRingRuntime
                         { rtPubring = pubring
@@ -125,10 +326,11 @@ runKeyRing keyring op = do
                         , rtRings = [] -- todo secring:pubring:keyringFiles keyring
                         , rtWallets = [] -- todo walletFiles keyring
                         , rtGrip = grip0
+                        , rtKeyDB = db
                         }
-         report <- todo report -- write files
+         report2 <- todo -- write files
         
-         return $ KikiResult (KikiSuccess a) report
+         return $ KikiResult (KikiSuccess a) (report1 ++ report2)
       Left err -> return $ KikiResult err []
 
     forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
@@ -196,6 +398,97 @@ isUserID _                 = False
 isTrust (TrustPacket {}) = True
 isTrust _                = False
 
+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
+
+
+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
+            y = gety xy
+            -- y² = x³ + 7 (mod p)
+            y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
+            -}
+            secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
+            ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
+            -- pub = cannonical_eckey x y
+            -- 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
+                                ,"y  ="++show y
+                                ,"y' ="++show y'
+                                ,"y''="++show y'']) -}
+            SecretKeyPacket 
+            { version = 4
+            , timestamp = toEnum (fromEnum timestamp)
+            , key_algorithm = ECDSA
+            , key = [ -- public fields...
+                     ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
+                    ,('l',MPI 256)
+                    ,('x',MPI x)
+                    ,('y',MPI y)
+                    -- secret fields
+                    ,('d',MPI d)
+                    ]
+            , s2k_useage = 0
+            , s2k = S2K 100 ""
+            , symmetric_algorithm = Unencrypted
+            , encrypted_data = ""
+            , is_subkey = True
+            }
+
+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,_) = 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..."
+    input <- L.readFile fname
+#if MIN_VERSION_binary(0,6,4)
+    return $
+      case decodeOrFail input of
+        Right (_,_,msg ) -> msg
+        Left  (_,_,_)    -> trace (fname++": read fail") $ Message []
+#else
+    return $ decode input
+#endif
+
 
 data OriginFlags = OriginFlags {
         originallyPublic :: Bool,