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.hs | 22 ++++++++++++---------- lib/KeyRing/BuildKeyDB.hs | 23 ++++++++++++----------- lib/KeyRing/Types.hs | 25 +++++++++++++++++-------- lib/Kiki.hs | 16 ++++++++-------- lib/PacketTranscoder.hs | 8 ++++---- lib/Transforms.hs | 2 +- 6 files changed, 54 insertions(+), 42 deletions(-) (limited to 'lib') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index cd69042..8c92a81 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -425,7 +425,7 @@ selectPublicKeyAndSigs (spec,mtag) db = : 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' g p findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag @@ -673,7 +673,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 (KeyGrip $ show fp) elm return $ keyPacket elm mkarmor :: Access -> L.ByteString -> [Armor] @@ -734,7 +734,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt flattenTop f only_public - $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 + $ filterNewSubs f (parseSpec (Just grip) usage) d -- TODO: parseSpec3 _ -> flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) @@ -945,7 +945,7 @@ writePEMKeys doDecrypt db exports = do initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext - -> Maybe String + -> Maybe Fingerprint -> Maybe MappedPacket -> PacketTranscoder -> KeyDB @@ -974,7 +974,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do usage <- maybeToList mutableTag -- TODO: Use parseSpec3 -- TODO: Report error if generating without specifying usage tag. - let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage + let (topspec,subspec) = parseSpec grip usage -- ms will contain duplicates if a top key has multiple matching -- subkeys. This is intentional. -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db @@ -1026,7 +1026,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do let internals = mapMaybe getParams $ do (f,stream) <- nonexistents usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] - let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage + let (topspec,subspec) = parseSpec grip usage guard $ null $ do (kk,kd) <- filterMatches topspec $ kkData db subkeysForExport subspec kd @@ -1071,7 +1071,7 @@ runKeyRing operation = withLockedKeyring :: Maybe FilePath -> Map.Map InputFile StreamInfo - -> (InputFileContext -> Maybe String -> IO (KikiResult a)) + -> (InputFileContext -> Maybe Fingerprint -> IO (KikiResult a)) -> IO (KikiResult a) withLockedKeyring homespec opfiles go = do -- get homedir and keyring files + fingerprint for working key @@ -1099,7 +1099,7 @@ withLockedKeyring homespec opfiles go = do return ret -realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime) +realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe Fingerprint -> IO (KikiResult KeyRingRuntime) realRunKeyRing operation ctx grip0 = do bresult <- buildKeyDB ctx grip0 operation try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do @@ -1163,7 +1163,7 @@ parseOptionFile fname = do -- , path to public ring -- , fingerprint of working key -- ) -getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) +getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe Fingerprint)) getHomeDir protohome = do homedir <- envhomedir protohome flip (maybe (return CantFindHome)) @@ -1183,6 +1183,7 @@ getHomeDir protohome = do return $ val -- TODO: rename this to getGrip + getWorkingKey :: String -> IO (Maybe Fingerprint) getWorkingKey homedir = do let o = Nothing h = Just homedir @@ -1196,5 +1197,6 @@ getHomeDir protohome = do \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) - return $ lookup "default-key" config >>= listToMaybe + -- return $ lookup "default-key" config >>= listToMaybe + return Nothing 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) diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 9934aaa..523c8c4 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -554,9 +554,9 @@ writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> MyIdentity -> IO () writePublicKeyFiles rt fw myId@(MyIdentity _ grip) = do -- Finally, export public keys if they do not exist. - either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) - either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) - either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket + either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" (Just grip) (rtKeyDB rt) + either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" (Just grip) (rtKeyDB rt) + either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" (Just grip) (rtKeyDB rt) pemFromPacket let cs = listPeers rt known_hosts = L.concat $ map getSshKnownHosts $ cs @@ -615,10 +615,10 @@ pemFromPacket k = do return $ writePEM PemPublicKey qq -- ("TODO "++show keyspec) -show_pem :: String -> String -> KeyDB -> IO () +show_pem :: String -> Maybe Fingerprint -> KeyDB -> IO () show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket -show_pem' :: String -> String -> KeyDB -> (Packet -> Either String b) -> Either String b +show_pem' :: String -> Maybe Fingerprint -> KeyDB -> (Packet -> Either String b) -> Either String b show_pem' keyspec wkgrip db keyfmt = do let s = parseSpec wkgrip keyspec flip (maybe . Left $ keyspec ++ ": not found") @@ -628,17 +628,17 @@ show_pem' keyspec wkgrip db keyfmt = do warn :: String -> IO () warn str = hPutStrLn stderr str -show_sshfp :: String -> String -> KeyDB -> IO () +show_sshfp :: String -> Maybe Fingerprint -> KeyDB -> IO () show_sshfp keyspec wkgrip db = do let s = parseSpec wkgrip keyspec case selectPublicKey s db of Nothing -> hPutStrLn stderr $ keyspec ++ ": not found" Just k -> Char8.putStrLn $ sshKeyToHostname k -show_ssh :: String -> String -> KeyDB -> IO () +show_ssh :: String -> Maybe Fingerprint -> KeyDB -> IO () show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db -show_ssh' :: String -> Fingerprint -> KeyDB -> Either String String +show_ssh' :: String -> Maybe Fingerprint -> KeyDB -> Either String String show_ssh' keyspec wkgrip db = do let s = parseSpec wkgrip keyspec flip (maybe . Left $ keyspec ++ ": not found") diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index 759d83f..b24f3d2 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs @@ -113,7 +113,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 = matchpr fp (packet mp) matchfile file mp = Map.member file (locations mp) specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] specialize alg mp = @@ -268,7 +268,7 @@ makeMemoizingDecrypter passwdspec ctx (workingkey,keys) = do trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs) -keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) +keyQueries :: Maybe Fingerprint -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) keyQueries grip ringPackets = (mwk, fmap makeQuery keys) where makeQuery (maink,mp,us) = mp { packet = q } @@ -291,8 +291,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 fp p = 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 8a1da73..f55bcc5 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs @@ -44,7 +44,7 @@ import Data.Bits ((.|.), (.&.), Bits) data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec' - , rtGrip :: Maybe String + , rtGrip :: Maybe Fingerprint -- ^ Fingerprint or portion of a fingerprint used -- to identify the working GnuPG identity used to -- make signatures. -- cgit v1.2.3