From 99ff0f49d3f668acf4a7d9e7f4da275a1cb327c2 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 16 May 2020 10:04:13 -0400 Subject: Match v5 partial fingerprints from front rather than back. --- lib/KeyRing/BuildKeyDB.hs | 57 ++++++++++++++++++++++++++-------------------- lib/KeyRing/Types.hs | 58 +++++++++++++++++++++++++++++++++++------------ 2 files changed, 76 insertions(+), 39 deletions(-) (limited to 'lib/KeyRing') diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 44952de..57647b0 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -36,6 +36,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.OpenPGP import Data.OpenPGP.Util (GenerateKeyParams (..), fingerprint, generateKey, pgpSign, verify) +import GHC.Stack import Data.Time.Clock (UTCTime) @@ -171,7 +172,7 @@ buildKeyDB ctx grip0 keyring = do trans f (info,ps) = do let manip = combineTransforms (transforms info) rt1 = rt0 { rtKeyDB = merge emptyKeyDB f ps } - acc = Just Sec /= Map.lookup f accs + -- acc = Just Sec /= Map.lookup f accs r <- performManipulations doDecrypt rt1 mwk manip try r $ \(rt2,report) -> do return $ KikiSuccess (report,rtKeyDB rt2) @@ -390,6 +391,7 @@ doImportG transcode db m0 tags fname key = do , rrs ) -} let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key + go Nothing = pure NoWorkingKey transmuteAt go kk db @@ -413,27 +415,27 @@ parseSpec wkgrip spec = if not slashed then case prespec of - AnyMatch -> (KeyGrip "", Nothing) + AnyMatch -> (KeyFP 0 "", Nothing) EmptyMatch -> error "Bad key spec." - WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) - SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) - SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) + WorkingKeyMatch -> (KeyFP 0 wkgrip, Nothing) + SubstringMatch (Just KeyTypeField) tag -> (KeyFP 0 wkgrip, Just tag) + SubstringMatch Nothing str -> (KeyFP 0 wkgrip, Just str) SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) - FingerprintMatch fp -> (KeyGrip fp, Nothing) + FingerprintMatch ver fp -> (KeyFP ver fp, Nothing) else case (prespec,postspec) of - (FingerprintMatch fp, SubstringMatch st t) - | st /= Just UserIDField -> (KeyGrip fp, Just t) + (FingerprintMatch ver fp, SubstringMatch st t) + | st /= Just UserIDField -> (KeyFP ver fp, Just t) (SubstringMatch mt u, _) | postspec `elem` [AnyMatch,EmptyMatch] && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) (SubstringMatch mt u, SubstringMatch st t) | mt /= Just KeyTypeField && st /= Just UserIDField -> (KeyUidMatch u, Just t) - (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" - (_,FingerprintMatch fp) -> error "todo: support /fp: spec" - (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" - _ -> error "Bad key spec." + (FingerprintMatch _ _,FingerprintMatch _ _) -> error "todo: support fp:/fp: spec" + (_,FingerprintMatch _ fp) -> error "todo: support /fp: spec" + (FingerprintMatch _ fp,_) -> error "todo: support fp:/ spec" + _ -> error "Bad key spec." where (preslash,slashon) = break (=='/') spec slashed = not $ null $ take 1 slashon @@ -522,6 +524,7 @@ generateInternals transcode mwk db gens = do transmuteAt (go kk) kk db where go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens + go kk Nothing = error "generateInternals: Key not found." mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext -> IO @@ -588,7 +591,7 @@ readInputFileL ctx inp = do hs <- mapM (`openFile` ReadMode) fname fmap L.concat $ mapM (hGetContentsN oneMeg) hs -getInputFileTime :: InputFileContext -> InputFile -> IO CTime +getInputFileTime :: HasCallStack => InputFileContext -> InputFile -> IO CTime getInputFileTime ctx (Pipe fdr fdw) = do mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr maybe tryw return mt @@ -602,6 +605,8 @@ getInputFileTime ctx (FileDesc fd) = do getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname +getInputFileTime ctx arg = error $ "getInputFileTime: Invalid argument: " ++ show arg + slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) slurpWIPKeys stamp "" = ([],[]) @@ -763,14 +768,15 @@ parseSingleSpec "-" = WorkingKeyMatch parseSingleSpec "" = EmptyMatch parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag -parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag -parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp +-- parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag +parseSingleSpec ('f':'p':':':fp) = FingerprintMatch 0 fp parseSingleSpec str - | is40digitHex str = FingerprintMatch str - | otherwise = SubstringMatch Nothing str + | Just 40 <- isHexDigits str = FingerprintMatch 4 str + | Just 64 <- isHexDigits str = FingerprintMatch 5 str + | otherwise = SubstringMatch Nothing str -is40digitHex :: [Char] -> Bool -is40digitHex xs = ys == xs && length ys==40 +isHexDigits :: [Char] -> Maybe Int +isHexDigits xs = guard (ys == xs) >> Just (length ys) where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True @@ -779,9 +785,9 @@ is40digitHex xs = ys == xs && length ys==40 ishex c = False matchSpec :: KeySpec -> KeyData -> Bool -matchSpec (KeyGrip grip) (KeyData p _ _ _) - | matchpr grip (packet p)==grip = True - | otherwise = False +matchSpec (KeyFP ver grip) (KeyData p _ _ _) + = let mg = matchpr ver grip (packet p) + in mg == grip matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps where @@ -791,7 +797,7 @@ matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps && has_issuer key p has_issuer key p = isJust $ do issuer <- signature_issuer p - guard $ matchpr issuer key == issuer + guard $ matchpr 0 issuer key == issuer has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) @@ -907,7 +913,7 @@ getHostnames (KeyData topmp _ uids subs) = Hostnames addr onames othernames Noth hasFingerDress :: KeyDB -> SockAddr -> Bool hasFingerDress db addr | socketFamily addr/=AF_INET6 = False -hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) +hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyFP 0 g',Nothing) db) where (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr g' = map toUpper g @@ -1012,6 +1018,7 @@ decode_btc_key timestamp str = do ] , s2k_useage = 0 , s2k = S2K 100 "" + , aead_algorithm = Nothing , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True @@ -1205,6 +1212,7 @@ readSecretDNSFile fname = do _ -> RSA case alg of RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs + _ -> return $ error $ "readSecretDNSFile: " ++ show alg ++ " unimplemented." spemPacket :: SecretPEMData -> Maybe Packet spemPacket (PEMPacket p) = Just p @@ -1310,6 +1318,7 @@ rsaToPGP stamp rsa = SecretKeyPacket -- , ecc_curve = def , s2k_useage = 0 , s2k = S2K 100 "" + , aead_algorithm = Nothing , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs index af213ce..dbcc22c 100644 --- a/lib/KeyRing/Types.hs +++ b/lib/KeyRing/Types.hs @@ -13,6 +13,7 @@ import Data.Maybe (maybeToList,isJust,fromJust,mapMaybe) import Data.OpenPGP import Data.OpenPGP.Util import Data.Time.Clock +import Data.Word import FunctorToMaybe import qualified Data.ByteString.Lazy as L import qualified System.Posix.Types as Posix @@ -119,7 +120,7 @@ data PassphraseSpec = PassphraseSpec { passSpecRingFile :: Maybe FilePath -- ^ If not Nothing, the passphrase is to be used for packets -- from this file. - , passSpecKeySpec :: Maybe String + , passSpecKeySpec :: Maybe KeySpec -- ^ Non-Nothing value reserved for future use. -- (TODO: Use this to implement per-key passphrase associations). , passSpecPassFile :: InputFile @@ -132,9 +133,12 @@ data PassphraseSpec = PassphraseSpec instance Show PassphraseSpec where show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) show (PassphraseMemoizer _) = "PassphraseMemoizer" + show PassphraseAgent = "PassphraseAgent" instance Eq PassphraseSpec where PassphraseSpec a b c == PassphraseSpec d e f = and [a==d,b==e,c==f] + PassphraseAgent == PassphraseAgent + = True _ == _ = False @@ -152,10 +156,13 @@ instance Ord PassphraseSpec where compare (PassphraseSpec a b c) (PassphraseSpec d e f) | fmap (const ()) a == fmap (const ()) d && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f) - compare (PassphraseSpec (Just _) (Just _) _) _ = LT - compare (PassphraseSpec Nothing (Just _) _) _ = LT - compare (PassphraseSpec (Just _) _ _) _ = LT - compare PassphraseAgent _ = GT + compare (PassphraseSpec (Just _) (Just _) _) _ = LT + compare (PassphraseSpec Nothing (Just _) _) _ = LT + compare (PassphraseSpec (Just _) _ _) _ = LT + compare PassphraseAgent _ = GT + compare (PassphraseSpec Nothing Nothing _) (PassphraseSpec _ _ _) = GT + compare (PassphraseSpec Nothing Nothing _) (PassphraseMemoizer _) = GT + compare (PassphraseSpec Nothing Nothing _) PassphraseAgent = LT data Transform = Autosign @@ -349,17 +356,35 @@ isTrust _ = False -- -- matchpr fp = Data.List.Extra.takeEnd (length fp) -- -matchpr :: String -> Packet -> String -matchpr fp k = reverse $ zipWith const (reverse (show $ fingerprint k)) fp +matchpr :: Word8 -> String -> Packet -> String +matchpr ver fp k = + let (rev,v) = case ver of + 4 -> (reverse, 4) + 5 -> (id, 5) + _ -> case auto_fp_version k of + 5 -> (id, 5) + v -> (reverse, v) + in rev $ zipWith const (rev (show $ fingerprintv v k)) fp data KeySpec = - KeyGrip String -- fp: + KeyFP { fpVer :: Word8 -- 5 or 4 to select fingerprint style, 0 to match either. + , fpPartial :: String -- partial fingerprint, matches trailing for 4, or leading for 5 + } -- fp: | KeyTag Packet String -- fp:????/t: | KeyUidMatch String -- u: - deriving Show + deriving (Show,Eq) + +instance Ord KeySpec where + compare (KeyFP av af) (KeyFP bv bf) = compare (av,af) (bv,bf) + compare (KeyTag ap a) (KeyTag bp b) = compare (fingerprint ap,a) (fingerprint bp,b) + compare (KeyUidMatch a) (KeyUidMatch b) = compare a b + compare (KeyFP {}) _ = LT + compare (KeyTag {}) _ = LT + compare _ _ = GT + {- RSAPrivateKey ::= SEQUENCE { @@ -400,9 +425,9 @@ data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert deriving (Show,Eq) -data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum) +data MatchingField = KeyTypeField | UserIDField deriving (Show,Eq,Ord,Enum) -data SingleKeySpec = FingerprintMatch String +data SingleKeySpec = FingerprintMatch Word8 String | SubstringMatch (Maybe MatchingField) String | EmptyMatch | AnyMatch @@ -423,12 +448,15 @@ secretToPublic pkt@(SecretKeyPacket {}) = } secretToPublic pkt = pkt +matchKeySpec :: KeySpec -> Packet -> Bool +matchKeySpec spec pkt = not $ null $ snd $ seek_key spec [pkt] + seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) +seek_key (KeyFP ver grip) sec = (pre, subs) where (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip + pred p@(SecretKeyPacket {}) = matchpr ver grip p == grip + pred p@(PublicKeyPacket {}) = matchpr ver grip p == grip pred _ = False seek_key (KeyTag key tag) ps @@ -441,7 +469,7 @@ seek_key (KeyTag key tag) ps (as,bs) = break (\p -> isSignaturePacket p && has_tag tag p && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) + && matchpr (version p) (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) ps (rs,qs) = break isKey (reverse as) -- cgit v1.2.3