From 832e580497558deccca59622e2c2fc395a854130 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 14 Apr 2014 19:54:21 -0400 Subject: work in progress: buildKeyDB --- KeyRing.hs | 313 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 303 insertions(+), 10 deletions(-) (limited to 'KeyRing.hs') 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, -- cgit v1.2.3