From 8af08303e56fc109135e2ade91299338d03b57b0 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Tue, 16 Jul 2019 20:33:23 -0400 Subject: this compiles --- lib/KeyRing/BuildKeyDB.hs | 23 ++++++++++++----------- lib/KeyRing/Types.hs | 25 +++++++++++++++++-------- 2 files changed, 29 insertions(+), 19 deletions(-) (limited to 'lib/KeyRing') diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 461afa2..510c820 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -83,9 +83,9 @@ newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr] -- -- merge all keyrings, PEM files, and wallets into process memory. -- -buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation +buildKeyDB :: InputFileContext -> Maybe Fingerprint -> KeyRingOperation -> IO (KikiCondition (({- db -} KeyDB - ,{- grip -} Maybe String + ,{- grip -} Maybe Fingerprint ,{- wk -} Maybe MappedPacket ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], {- hostdbs -}[Hosts.Hosts], @@ -128,7 +128,8 @@ buildKeyDB ctx grip0 keyring = do ringPackets <- Map.traverseWithKey readp ringMap let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) - let grip = grip0 `mplus` (show . fingerprint <$> fstkey) + let grip :: Maybe Fingerprint + grip = grip0 `mplus` (fingerprint <$> fstkey) where fstkey = do (_,Message ps) <- Map.lookup HomeSec ringPackets @@ -223,7 +224,7 @@ buildKeyDB ctx grip0 keyring = do guard $ all (==usage) $ drop 1 us -- TODO: KikiCondition reporting for spill/fill usage mismatch? -- TODO: parseSpec3 - let (topspec,subspec) = parseSpec grip usage + let (topspec,subspec) = parseSpec (Just grip) usage ms = map fst $ filterMatches topspec (kkData db) cmd = initializer stream return (n,subspec,ms,stream, cmd) @@ -408,16 +409,16 @@ usageFromFilter _ = mzero -- | Parse a key specification. -- The first argument is a grip for the default working key. -parseSpec :: Fingerprint -> String -> (KeySpec,Maybe String) +parseSpec :: Maybe Fingerprint -> String -> (KeySpec,Maybe String) parseSpec wkgrip spec = if not slashed then case prespec of AnyMatch -> (KeyGrip "", 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 -> (KeyGrip $ show wkgrip, Nothing) + SubstringMatch (Just KeyTypeField) tag -> (KeyGrip $ show wkgrip, Just tag) + SubstringMatch Nothing str -> (KeyGrip $ show wkgrip, Just str) SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) FingerprintMatch fp -> (KeyGrip fp, Nothing) else @@ -780,8 +781,8 @@ is40digitHex xs = ys == xs && length ys==40 matchSpec :: KeySpec -> KeyData -> Bool matchSpec (KeyGrip grip) (KeyData p _ _ _) - | matchpr grip (packet p)==grip = True - | otherwise = False + | matchpr' grip (packet p) = True + | otherwise = False matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps where @@ -791,7 +792,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' issuer key has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) diff --git a/lib/KeyRing/Types.hs b/lib/KeyRing/Types.hs index 1177789..1a12a61 100644 --- a/lib/KeyRing/Types.hs +++ b/lib/KeyRing/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE PatternSynonyms #-} @@ -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 Fingerprint -- ^ Non-Nothing value reserved for future use. -- (TODO: Use this to implement per-key passphrase associations). , passSpecPassFile :: InputFile @@ -129,6 +130,9 @@ data PassphraseSpec = PassphraseSpec | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } | PassphraseAgent +deriving instance Ord Fingerprint +deriving instance Eq Fingerprint + instance Show PassphraseSpec where show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) show (PassphraseMemoizer _) = "PassphraseMemoizer" @@ -350,14 +354,19 @@ isTrust _ = False -- matchpr fp = Data.List.Extra.takeEnd (length fp) -- matchpr :: Fingerprint -> Packet -> Bool -matchpr fp k = p == show fp - where - p = reverse $ zipWith const (reverse (show $ fingerprint k)) (show fp) +matchpr fp k = matchpr' (show fp) k +matchpr' :: String -> Packet -> Bool +matchpr' fp k = p == fp + where + p = reverse $ zipWith const (reverse (show $ fingerprint k)) fp +matchpr'' :: String -> Packet -> String +matchpr'' fp k | matchpr' fp k = fp +matchpr'' fp k | otherwise = "" data KeySpec = - KeyGrip Fingerprint -- fp: + KeyGrip String -- fp: | KeyTag Packet String -- fp:????/t: | KeyUidMatch String -- u: deriving Show @@ -428,8 +437,8 @@ seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) where (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p - pred p@(PublicKeyPacket {}) = matchpr grip p + pred p@(SecretKeyPacket {}) = matchpr' grip p + pred p@(PublicKeyPacket {}) = matchpr' grip p pred _ = False seek_key (KeyTag key tag) ps @@ -442,7 +451,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' (fromJust $ signature_issuer p) key) ps (rs,qs) = break isKey (reverse as) -- cgit v1.2.3