From 8af08303e56fc109135e2ade91299338d03b57b0 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Tue, 16 Jul 2019 20:33:23 -0400 Subject: this compiles --- kiki.hs | 40 ++++++++++++++++------------------------ 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 +- 7 files changed, 70 insertions(+), 66 deletions(-) diff --git a/kiki.hs b/kiki.hs index 9b78e8f..d7099b6 100644 --- a/kiki.hs +++ b/kiki.hs @@ -41,7 +41,7 @@ import Data.Binary.Put import System.Posix.User import CommandLine -import Data.OpenPGP.Util (verify, fingerprint, GenerateKeyParams(..)) +import Data.OpenPGP.Util (Fingerprint, verify, fingerprint, GenerateKeyParams(..)) import ScanningParser import PEM import DotLock @@ -63,13 +63,6 @@ isCertificationSig :: SignatureOver -> Bool isCertificationSig (CertificationSignature {}) = True isCertificationSig _ = True -fpmatch :: Maybe [Char] -> Packet -> Bool -fpmatch grip key = - (==) Nothing - (fmap (backend (show $ fingerprint key)) grip >>= guard . not) - where - backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys) - listKeys :: [Packet] -> [Char] listKeys pkts = listKeysFiltered [] pkts @@ -79,7 +72,7 @@ listKeys pkts = listKeysFiltered [] pkts -- Build the display output -- Operates in List Monad... -- returns all output as a single string -listKeysFiltered :: Foldable t => t [Char] -> [Packet] -> [Char] +listKeysFiltered :: Foldable t => t Fingerprint -> [Packet] -> [Char] listKeysFiltered grips pkts = do let masterkeys = filter (\k -> isKey k && not (is_subkey k)) pkts (certs,bs) = getBindings pkts @@ -96,7 +89,7 @@ listKeysFiltered grips pkts = do ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b matchgrip _ | null grips = True - matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True + matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip matchpr top) grips = True matchgrip _ = False gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) singles = filter (\k -> show (fingerprint k) `notElem` map (show . fingerprint) parents) masterkeys -- \\ parents @@ -152,7 +145,7 @@ listKeysFiltered grips pkts = 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))) + maybeToList $ find_key (matchpr'' i) (Message keys) (reverse (take 16 (reverse i))) (primary,secondary) = partition (==top) issuers -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () @@ -215,8 +208,7 @@ partitionStaticArguments specs args = psa args Nothing -> second (a:) $ psa as Just n -> first ((a:take n as):) $ psa (drop n as) -show_wk :: FilePath - -> Maybe [Char] -> KeyDB -> IO () +show_wk :: FilePath -> Maybe Fingerprint -> KeyDB -> IO () show_wk secring_file grip db = do -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) let gripmatch (KeyData p _ _ _) = @@ -257,7 +249,7 @@ show_whose_key input_key db = (_:_) -> error "ambiguous" [] -> return () -show_dns :: [Char] -> String -> KeyDB -> IO () +show_dns :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket dnsPresentationFromPacket :: Monad m => Packet -> m String @@ -282,7 +274,7 @@ dnsPresentationFromPacket k = do show_id :: String -> p -> KeyDB -> IO () show_id keyspec wkgrip db = do - let s = parseSpec "" keyspec + let s = parseSpec Nothing keyspec let ps = do (_,k) <- filterMatches (fst s) (kkData db) mp <- flattenTop "" True k @@ -290,7 +282,7 @@ show_id keyspec wkgrip db = do -- putStrLn $ "show key " ++ show s putStrLn $ listKeys ps -show_wip :: [Char] -> String -> KeyDB -> IO () +show_wip :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () show_wip keyspec wkgrip db = do let s = parseSpec wkgrip keyspec flip (maybe $ void (warn (keyspec ++ ": not found"))) @@ -320,7 +312,7 @@ show_torhash pubkey _ = do keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs mapM_ (putStrLn . addy . torhash) keys -show_cert :: [Char] -> String -> KeyDB -> IO () +show_cert :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () show_cert keyspec wkgrip db = do let s = parseSpec wkgrip keyspec case selectPublicKeyAndSigs s db of @@ -1235,13 +1227,13 @@ kiki "show" args = do ,("--all",const show_all) ,("--whose-key", const $ show_whose_key input_key) ,("--packets", show_packets) - ,("--key",\[x] -> show_id x $ fromMaybe "" grip) - ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip) - ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip) - ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip) - ,("--sshfp",\[x] -> show_sshfp x $ fromMaybe "" grip) - ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip) - ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip) + ,("--key",\[x] -> show_id x grip) + ,("--pem",\[x] -> show_pem x grip) + ,("--dns",\[x] -> show_dns x grip) + ,("--ssh",\[x] -> show_ssh x grip) + ,("--sshfp",\[x] -> show_sshfp x grip) + ,("--wip",\[x] -> show_wip x grip) + ,("--cert",\[x] -> show_cert x grip) ,("--torhash",\[x] -> show_torhash x) ,("--dump", const $ debug_dump (rtSecring rt) grip) ] 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