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 --- kiki.hs | 272 ---------------------------------------------------------------- 1 file changed, 272 deletions(-) (limited to 'kiki.hs') diff --git a/kiki.hs b/kiki.hs index 365562b..d7ea9c7 100644 --- a/kiki.hs +++ b/kiki.hs @@ -347,13 +347,6 @@ isPublicMaster _ = False now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime -usage (NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = u - }) = Just u -usage _ = Nothing - verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do @@ -380,10 +373,6 @@ grip k = drop 32 $ fingerprint k smallpr k = drop 24 $ fingerprint k --- 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 - disjoint_fp ks = {- concatMap group2 $ -} transpose grouped where @@ -587,58 +576,6 @@ listKeysFiltered grips pkts = do "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" -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" - - -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 modifyUID (UserIDPacket str) = UserIDPacket str' @@ -666,53 +603,6 @@ expandPath path [] = [] -- type TimeStamp = Word32 -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 - -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 - -- | Attempts to lock each file in the list. -- Returns a list of locks and a list of filenames -- that could not be locked. @@ -984,12 +874,6 @@ getPassphrase cmd = #define HOMEOPTION (def &= explicit &= name "homedir" &= typDir ) -data KeySpec = - KeyGrip String - | KeyTag Packet String - | KeyUidMatch String - deriving Show - is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs @@ -1062,7 +946,6 @@ sortByHint fname f = sortBy (comparing gethint) defnum = -1 keyMappedPacket (KeyData k _ _ _) = k -keyPacket (KeyData k _ _ _) = packet k writeOutKeyrings :: Map.Map FilePath t -> KeyDB -> IO () writeOutKeyrings lkmap db = do @@ -1417,34 +1300,6 @@ secp256k1_G = ECPa secp256k1_curve -} -} -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 - (network_id,payload) = splitAt 1 a_payload - - network_id <- listToMaybe network_id - guard (hash_result==expected_hash) - return (network_id,payload) - walletImportFormat idbyte k = secret_base58_foo where -- isSecret (SecretKeyPacket {}) = True @@ -1530,48 +1385,6 @@ bitcoinAddress network_id k = address -- 0x4e*128+0x3d 10045 -- 1.2.840.10045.3.1.7 --> NIST P-256 -- -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 - } doBTCImport doDecrypt db (ms,subspec,content) = do let fetchkey = do @@ -2494,26 +2307,6 @@ selectKey0 wantPublic (spec,mtag) db = do zs = snd $ seek_key subspec ys1 listToMaybe zs -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 - seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) where @@ -2614,68 +2407,3 @@ sigpackets typ hashed unhashed = return $ 0 -- Word16 -- Left 16 bits of the signed hash value [] -- [MPI] -keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) - {- - where - vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids))) - ws = map signatures_over vs - xs = filter null ws - -} - -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 - -- cgit v1.2.3