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. --- kiki.hs | 11 +++++---- lib/GnuPGAgent.hs | 3 +-- lib/KeyDB.hs | 13 ++++++++--- lib/KeyRing.hs | 47 ++++++++++++++++++++++++-------------- lib/KeyRing/BuildKeyDB.hs | 57 ++++++++++++++++++++++++++-------------------- lib/KeyRing/Types.hs | 58 +++++++++++++++++++++++++++++++++++------------ lib/Kiki.hs | 1 - lib/PacketTranscoder.hs | 15 ++++++------ lib/Transforms.hs | 11 ++++----- 9 files changed, 137 insertions(+), 79 deletions(-) diff --git a/kiki.hs b/kiki.hs index 0bc7133..03ea635 100644 --- a/kiki.hs +++ b/kiki.hs @@ -188,7 +188,9 @@ listKeysFiltered style grips pkts0 = do let issuers = do sig_over <- signatures_over sig i <- maybeToList $ signature_issuer sig_over - maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i))) + let sigkeyid i | version top == 5 = take 16 i + | otherwise = reverse . take 16 . reverse $ i + maybeToList $ find_key (matchpr (auto_fp_version sig_over) i) (Message keys) (sigkeyid i) (primary,secondary) = partition (==top) issuers -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () @@ -709,13 +711,13 @@ kiki_usage ((== Export) -> bExport) ((== Import) -> bImport) ((== Secret) -> bSe ," position to indicate whether a SUBKEY or MASTER is intended." ,"" ," MASTER may be any of" - ," * The tail end of a fingerprint prefixed by 'fp:'" + ," * The tail end (or, for v5, front end) of a fingerprint prefixed by 'fp:'" ," * A sub-string of a user id (without slashes) prefixed by 'u:'" ," * 40 characters of hexidecimal (kiki will assume this to be a fingerprint)" ," * A sub-string of a user id (without slashes, the prefix 'u:' is optional)" ,"" ," SUBKEY may be any of" - ," * The tail end of a fingerprint prefixed by 'fp:'" + ," * The tail end (or, for v5, front end) of a fingerprint prefixed by 'fp:'" ," * An exact match of a usage tag prefixed by 't:'" ," * 40 characters of hexidecimal (kiki will assume this to be a fingerprint)" ," * An exact match of a usage tag (The prefix 't:' is optional)" @@ -1642,7 +1644,8 @@ kiki "tar" args | "--help" `elem` args = do ," (current working identity)" ,"" ," fp:4A39F" - ," (tail end of a fingerprint prefixed by 'fp:')" + ," (tail end of a v4 fingerprint or the front end of a v5" + ," fingerprint prefixed by 'fp:')" ,"" ," u:joe" ," (sub-string of a user id prefixed by 'u:')" diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index f1d1552..b3919dd 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs @@ -19,7 +19,6 @@ import Data.Char import Data.Maybe import Data.OpenPGP import qualified Data.OpenPGP.Util - ;import Data.OpenPGP.Util hiding (fingerprint) import Data.Word import Network.Socket import System.Directory @@ -166,7 +165,7 @@ getPassphrase agent ask (Query key uid masterkey) = do -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e return Nothing Right bs -> return $ Just $ S8.unpack bs - "ERR" -> return Nothing + _ {- "ERR" -} -> return Nothing quit :: GnuPGAgent -> IO () quit (GnuPGAgent h) = hClose h diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs index fc20b91..f785f8e 100644 --- a/lib/KeyDB.hs +++ b/lib/KeyDB.hs @@ -76,11 +76,18 @@ fingerprintGrip (Fingerprint bs) = -- -- The above was removed because Int is encoded as 8 bytes even when we are -- -- using 32-bit GHC. -- Presumably, the extra 4 bytes will be truncated. - case decode $ L.fromStrict $ S.drop (S.length bs - 8) bs of - i -> KeyInt i + case S.length bs of + -- v5 from the front + 32 -> case decode $ L.fromStrict bs of + i -> KeyInt i + -- v4 from the back + l -> case decode $ L.fromStrict $ S.drop (l - 8) bs of + i -> KeyInt i smallprGrip :: String -> Maybe KeyGrip -smallprGrip pr = KeyInt <$> readMaybe ("0x" ++ drop (length pr - 2 * sizeOf (0::Int)) pr) +smallprGrip pr = case length pr of + 64 -> KeyInt <$> readMaybe ("0x" ++ take (2 * sizeOf (0::Int)) pr) + l -> KeyInt <$> readMaybe ("0x" ++ drop (l - 2 * sizeOf (0::Int)) pr) data KeyDB = KeyDB { byKeyKey :: Map.Map KeyKey KeyData diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 07badb6..554c4ad 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -188,10 +188,12 @@ x509cert _ = Nothing +{- getStr :: SingleKeySpec -> String getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" +-} -- | Spec -- @@ -235,6 +237,8 @@ data SpecError = SpecENone String -- circ = Just GroupIDField -- | parseSpec3 - Parse a key specification. +-- +-- TODO: This is currently unused. parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$> @@ -283,7 +287,7 @@ parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0 adjustPos (SubstringMatch (Just UserIDField) _) Nothing = 1 - adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2 + -- adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2 adjustPos _ (Just i) = fromEnum i gotIndex :: Int -> SingleKeySpec -> Int @@ -296,7 +300,7 @@ parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = mismatch xs = case find (not . fst) (reverse xs) of Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n) - fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t) + fixUpSubstrMatch (g,u,t) = ({- set GroupIDField -} g, set UserIDField u, set KeyTypeField t) where set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs set _ EmptyMatch = AnyMatch @@ -313,16 +317,17 @@ parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x) applyContext (Just UserIDField) x = x - applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch) - applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x) - applyContext (Just GroupIDField) x = x + -- applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch) + -- applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x) + -- applyContext (Just GroupIDField) x = x --applyContext (Just UserIDField) (Right (g,u,x)) = Left $ -- SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField - tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $ - SpecEMissMatch str (Just GroupIDField) KeyTypeField - tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $ - SpecEMissMatch str (Just GroupIDField) UserIDField + + -- tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $ + -- SpecEMissMatch str (Just GroupIDField) KeyTypeField + -- tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $ + -- SpecEMissMatch str (Just GroupIDField) UserIDField tooBigError Nothing x = return x tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $ @@ -382,10 +387,13 @@ parseSpec grip spec = (topspec,subspec) filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' where - matchAll = KeyGrip "" + matchAll = KeyFP 0 "" + + subkeySpec (KeyFP ver grip,Nothing) = (matchAll, KeyFP ver grip) + subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) + subkeySpec (KeyTag p tag, Nothing) = (matchAll, KeyTag p tag) + subkeySpec (KeyUidMatch u, Nothing) = (KeyUidMatch u, matchAll) - subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) - subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) match spec mps = not . null @@ -420,13 +428,13 @@ selectPublicKeyAndSigs (spec,mtag) db = where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) - findbyspec (KeyGrip g) kd = do + findbyspec (KeyFP ver g) kd = do filter ismatch $ topresult kd : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) (Map.elems $ keySubKeys kd) where - ismatch (p,sigs) = matchpr g p ==g + ismatch (p,sigs) = matchpr ver g p ==g findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag @@ -674,7 +682,7 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk workingKey grip use_db = listToMaybe $ do fp <- maybeToList grip elm <- keyData use_db - guard $ matchSpec (KeyGrip fp) elm + guard $ matchSpec (KeyFP 0 fp) elm return $ keyPacket elm mkarmor :: Access -> L.ByteString -> [Armor] @@ -921,6 +929,9 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do return [(fname, ExportedSubkey)] algo -> return [(fname, UnableToExport algo $ show $ fingerprint packet)] +writeKeyToFile strm _ _ = error $ "writeKeyToFile: Unsupported file type: " ++ show (typ strm) + + writePEMKeys :: (PacketDecrypter) -> KeyDB -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] @@ -942,6 +953,9 @@ writePEMKeys doDecrypt db exports = do pun <- doDecrypt p try pun $ \pun -> do return $ KikiSuccess (fname,stream,pun) + decryptKeys (_, _, [] , _) = error "writePEMKeys: Key missing from keyring." + decryptKeys (_, _, (_:_:_), _) = error "writePEMKeys: Ambiguous key." + initializeMissingPEMFiles :: KeyRingOperation @@ -956,8 +970,6 @@ initializeMissingPEMFiles :: , StreamInfo )]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation ctx grip mwk transcode db = do - let decrypt = transcode (Unencrypted,S2K 100 "") - -- nonexistants - files missing from disk. nonexistents <- filterM (fmap not . doesFileExist . fst) @@ -1197,5 +1209,6 @@ getHomeDir protohome = do \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) + topair _ = error "parseOptionFile yeilded an empty entry?" return $ lookup "default-key" config >>= listToMaybe 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) diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 96ad9ff..f4c4a2b 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -808,7 +808,6 @@ signFile isHomeless cap keyrings keyid filename = do , content = bs } hash = SHA512 - matchkey fp mp = matchpr fp (packet mp) == fp case smallprGrip keyid of Nothing -> hPutStrLn stderr "Bad keygrip." Just grip -> do diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index 759d83f..71a2202 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs @@ -3,8 +3,6 @@ {-# LANGUAGE PatternGuards #-} module PacketTranscoder where -import Debug.Trace -import GHC.Stack import Control.Monad import Data.IORef import Data.List @@ -16,12 +14,10 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Map as Map (Map) import qualified Data.Map as Map -import qualified Data.Traversable as Traversable import System.IO ( stderr) import System.Posix.IO ( fdToHandle ) import Text.Show.Pretty as PP ( ppShow ) import KeyRing.Types -import ControlMaybe (handleIO_) -- | Merge two representations of the same key, prefering secret version -- because they have more information. @@ -113,7 +109,7 @@ interpretPassSpec ctx _ PassphraseSpec { passSpecPassFile = fd cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n") ctx fd - let matchkey fp mp = matchpr fp (packet mp) == fp + let matchkey fp mp = matchKeySpec fp (packet mp) matchfile file mp = Map.member file (locations mp) specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] specialize alg mp = @@ -142,6 +138,11 @@ interpretPassSpec ctx keys PassphraseAgent = do return $ KikiSuccess (cacheSearch, quit agent) +interpretPassSpec ctx keys (PassphraseMemoizer _) = + -- INVALID ARGUMENT: PassphraseMemoizer + return BadPassphrase + + sendQuery :: GnuPGAgent -> (QueryMode,PassphraseResponse) -> OriginMapped Query -> IO PassphraseResponse sendQuery agent (ask,failure) qry = do mbpw <- getPassphrase agent ask (packet qry) @@ -291,8 +292,8 @@ keyQueries grip ringPackets = (mwk, fmap makeQuery keys) mwk = listToMaybe $ do fp <- maybeToList grip let matchfp mp - | not (is_subkey p) && matchpr fp p == fp = Just mp - | otherwise = Nothing + | not (is_subkey p) && matchpr 0 fp p == fp = Just mp + | otherwise = Nothing where p = packet mp Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys diff --git a/lib/Transforms.hs b/lib/Transforms.hs index 118b494..473ecbc 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -151,6 +151,8 @@ signature_time ov = case (if null cs then ds else cs) of creationTime (SignatureCreationTimePacket t) = [t] creationTime _ = [] +matchingGrip :: Packet -> String -> Bool +matchingGrip topk g = matchpr 0 g topk == g -- | Given list of subpackets, a master key, one of its subkeys and a -- list of signatures on that subkey, yields: @@ -177,9 +179,8 @@ findTag tag topk subkey subsigs = (xs',minsig,ys') (sig, do sig <- Just (packet . fst $ sig) guard (isSignaturePacket sig) - guard $ flip isSuffixOf - (show $ fingerprint topk) - . fromMaybe "%bad%" + guard $ matchingGrip topk + . fromMaybe "%bad%" . signature_issuer $ sig listToMaybe $ @@ -483,9 +484,7 @@ keyFlags0 wkun uidsigs = concat , BZip2 , ZIP ] - features = filterOr isfeatures subs $ - FeaturesPacket { supports_mdc = True - } + features = filterOr isfeatures subs defaultFeatures filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs -- cgit v1.2.3