diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/KeyRing.hs | 22 | ||||
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 23 | ||||
-rw-r--r-- | lib/KeyRing/Types.hs | 25 | ||||
-rw-r--r-- | lib/Kiki.hs | 16 | ||||
-rw-r--r-- | lib/PacketTranscoder.hs | 8 | ||||
-rw-r--r-- | lib/Transforms.hs | 2 |
6 files changed, 54 insertions, 42 deletions
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 = | |||
425 | : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) | 425 | : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) |
426 | (Map.elems $ keySubKeys kd) | 426 | (Map.elems $ keySubKeys kd) |
427 | where | 427 | where |
428 | ismatch (p,sigs) = matchpr g p ==g | 428 | ismatch (p,sigs) = matchpr' g p |
429 | findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] | 429 | findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] |
430 | 430 | ||
431 | findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag | 431 | 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 | |||
673 | workingKey grip use_db = listToMaybe $ do | 673 | workingKey grip use_db = listToMaybe $ do |
674 | fp <- maybeToList grip | 674 | fp <- maybeToList grip |
675 | elm <- keyData use_db | 675 | elm <- keyData use_db |
676 | guard $ matchSpec (KeyGrip fp) elm | 676 | guard $ matchSpec (KeyGrip $ show fp) elm |
677 | return $ keyPacket elm | 677 | return $ keyPacket elm |
678 | 678 | ||
679 | mkarmor :: Access -> L.ByteString -> [Armor] | 679 | mkarmor :: Access -> L.ByteString -> [Armor] |
@@ -734,7 +734,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do | |||
734 | case fill stream of | 734 | case fill stream of |
735 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt | 735 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt |
736 | flattenTop f only_public | 736 | flattenTop f only_public |
737 | $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 | 737 | $ filterNewSubs f (parseSpec (Just grip) usage) d -- TODO: parseSpec3 |
738 | _ -> flattenTop f only_public d | 738 | _ -> flattenTop f only_public d |
739 | new_packets = filter isnew x | 739 | new_packets = filter isnew x |
740 | where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) | 740 | where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) |
@@ -945,7 +945,7 @@ writePEMKeys doDecrypt db exports = do | |||
945 | initializeMissingPEMFiles :: | 945 | initializeMissingPEMFiles :: |
946 | KeyRingOperation | 946 | KeyRingOperation |
947 | -> InputFileContext | 947 | -> InputFileContext |
948 | -> Maybe String | 948 | -> Maybe Fingerprint |
949 | -> Maybe MappedPacket | 949 | -> Maybe MappedPacket |
950 | -> PacketTranscoder | 950 | -> PacketTranscoder |
951 | -> KeyDB | 951 | -> KeyDB |
@@ -974,7 +974,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do | |||
974 | usage <- maybeToList mutableTag | 974 | usage <- maybeToList mutableTag |
975 | -- TODO: Use parseSpec3 | 975 | -- TODO: Use parseSpec3 |
976 | -- TODO: Report error if generating without specifying usage tag. | 976 | -- TODO: Report error if generating without specifying usage tag. |
977 | let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage | 977 | let (topspec,subspec) = parseSpec grip usage |
978 | -- ms will contain duplicates if a top key has multiple matching | 978 | -- ms will contain duplicates if a top key has multiple matching |
979 | -- subkeys. This is intentional. | 979 | -- subkeys. This is intentional. |
980 | -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db | 980 | -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db |
@@ -1026,7 +1026,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do | |||
1026 | let internals = mapMaybe getParams $ do | 1026 | let internals = mapMaybe getParams $ do |
1027 | (f,stream) <- nonexistents | 1027 | (f,stream) <- nonexistents |
1028 | usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] | 1028 | usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] |
1029 | let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage | 1029 | let (topspec,subspec) = parseSpec grip usage |
1030 | guard $ null $ do | 1030 | guard $ null $ do |
1031 | (kk,kd) <- filterMatches topspec $ kkData db | 1031 | (kk,kd) <- filterMatches topspec $ kkData db |
1032 | subkeysForExport subspec kd | 1032 | subkeysForExport subspec kd |
@@ -1071,7 +1071,7 @@ runKeyRing operation = | |||
1071 | 1071 | ||
1072 | withLockedKeyring :: Maybe FilePath | 1072 | withLockedKeyring :: Maybe FilePath |
1073 | -> Map.Map InputFile StreamInfo | 1073 | -> Map.Map InputFile StreamInfo |
1074 | -> (InputFileContext -> Maybe String -> IO (KikiResult a)) | 1074 | -> (InputFileContext -> Maybe Fingerprint -> IO (KikiResult a)) |
1075 | -> IO (KikiResult a) | 1075 | -> IO (KikiResult a) |
1076 | withLockedKeyring homespec opfiles go = do | 1076 | withLockedKeyring homespec opfiles go = do |
1077 | -- get homedir and keyring files + fingerprint for working key | 1077 | -- get homedir and keyring files + fingerprint for working key |
@@ -1099,7 +1099,7 @@ withLockedKeyring homespec opfiles go = do | |||
1099 | return ret | 1099 | return ret |
1100 | 1100 | ||
1101 | 1101 | ||
1102 | realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime) | 1102 | realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe Fingerprint -> IO (KikiResult KeyRingRuntime) |
1103 | realRunKeyRing operation ctx grip0 = do | 1103 | realRunKeyRing operation ctx grip0 = do |
1104 | bresult <- buildKeyDB ctx grip0 operation | 1104 | bresult <- buildKeyDB ctx grip0 operation |
1105 | try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do | 1105 | try' bresult $ \((db, grip, wk, hs, accs,transcode,unspilled), report_imports) -> do |
@@ -1163,7 +1163,7 @@ parseOptionFile fname = do | |||
1163 | -- , path to public ring | 1163 | -- , path to public ring |
1164 | -- , fingerprint of working key | 1164 | -- , fingerprint of working key |
1165 | -- ) | 1165 | -- ) |
1166 | getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) | 1166 | getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe Fingerprint)) |
1167 | getHomeDir protohome = do | 1167 | getHomeDir protohome = do |
1168 | homedir <- envhomedir protohome | 1168 | homedir <- envhomedir protohome |
1169 | flip (maybe (return CantFindHome)) | 1169 | flip (maybe (return CantFindHome)) |
@@ -1183,6 +1183,7 @@ getHomeDir protohome = do | |||
1183 | return $ val | 1183 | return $ val |
1184 | 1184 | ||
1185 | -- TODO: rename this to getGrip | 1185 | -- TODO: rename this to getGrip |
1186 | getWorkingKey :: String -> IO (Maybe Fingerprint) | ||
1186 | getWorkingKey homedir = do | 1187 | getWorkingKey homedir = do |
1187 | let o = Nothing | 1188 | let o = Nothing |
1188 | h = Just homedir | 1189 | h = Just homedir |
@@ -1196,5 +1197,6 @@ getHomeDir protohome = do | |||
1196 | \(forgive,fname) -> parseOptionFile fname | 1197 | \(forgive,fname) -> parseOptionFile fname |
1197 | let config = map (topair . words) args | 1198 | let config = map (topair . words) args |
1198 | where topair (x:xs) = (x,xs) | 1199 | where topair (x:xs) = (x,xs) |
1199 | return $ lookup "default-key" config >>= listToMaybe | 1200 | -- return $ lookup "default-key" config >>= listToMaybe |
1201 | return Nothing | ||
1200 | 1202 | ||
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] | |||
83 | -- | 83 | -- |
84 | -- merge all keyrings, PEM files, and wallets into process memory. | 84 | -- merge all keyrings, PEM files, and wallets into process memory. |
85 | -- | 85 | -- |
86 | buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation | 86 | buildKeyDB :: InputFileContext -> Maybe Fingerprint -> KeyRingOperation |
87 | -> IO (KikiCondition (({- db -} KeyDB | 87 | -> IO (KikiCondition (({- db -} KeyDB |
88 | ,{- grip -} Maybe String | 88 | ,{- grip -} Maybe Fingerprint |
89 | ,{- wk -} Maybe MappedPacket | 89 | ,{- wk -} Maybe MappedPacket |
90 | ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], | 90 | ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], |
91 | {- hostdbs -}[Hosts.Hosts], | 91 | {- hostdbs -}[Hosts.Hosts], |
@@ -128,7 +128,8 @@ buildKeyDB ctx grip0 keyring = do | |||
128 | ringPackets <- Map.traverseWithKey readp ringMap | 128 | ringPackets <- Map.traverseWithKey readp ringMap |
129 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) | 129 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) |
130 | 130 | ||
131 | let grip = grip0 `mplus` (show . fingerprint <$> fstkey) | 131 | let grip :: Maybe Fingerprint |
132 | grip = grip0 `mplus` (fingerprint <$> fstkey) | ||
132 | where | 133 | where |
133 | fstkey = do | 134 | fstkey = do |
134 | (_,Message ps) <- Map.lookup HomeSec ringPackets | 135 | (_,Message ps) <- Map.lookup HomeSec ringPackets |
@@ -223,7 +224,7 @@ buildKeyDB ctx grip0 keyring = do | |||
223 | guard $ all (==usage) $ drop 1 us | 224 | guard $ all (==usage) $ drop 1 us |
224 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? | 225 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? |
225 | -- TODO: parseSpec3 | 226 | -- TODO: parseSpec3 |
226 | let (topspec,subspec) = parseSpec grip usage | 227 | let (topspec,subspec) = parseSpec (Just grip) usage |
227 | ms = map fst $ filterMatches topspec (kkData db) | 228 | ms = map fst $ filterMatches topspec (kkData db) |
228 | cmd = initializer stream | 229 | cmd = initializer stream |
229 | return (n,subspec,ms,stream, cmd) | 230 | return (n,subspec,ms,stream, cmd) |
@@ -408,16 +409,16 @@ usageFromFilter _ = mzero | |||
408 | 409 | ||
409 | -- | Parse a key specification. | 410 | -- | Parse a key specification. |
410 | -- The first argument is a grip for the default working key. | 411 | -- The first argument is a grip for the default working key. |
411 | parseSpec :: Fingerprint -> String -> (KeySpec,Maybe String) | 412 | parseSpec :: Maybe Fingerprint -> String -> (KeySpec,Maybe String) |
412 | parseSpec wkgrip spec = | 413 | parseSpec wkgrip spec = |
413 | if not slashed | 414 | if not slashed |
414 | then | 415 | then |
415 | case prespec of | 416 | case prespec of |
416 | AnyMatch -> (KeyGrip "", Nothing) | 417 | AnyMatch -> (KeyGrip "", Nothing) |
417 | EmptyMatch -> error "Bad key spec." | 418 | EmptyMatch -> error "Bad key spec." |
418 | WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) | 419 | WorkingKeyMatch -> (KeyGrip $ show wkgrip, Nothing) |
419 | SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) | 420 | SubstringMatch (Just KeyTypeField) tag -> (KeyGrip $ show wkgrip, Just tag) |
420 | SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) | 421 | SubstringMatch Nothing str -> (KeyGrip $ show wkgrip, Just str) |
421 | SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) | 422 | SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) |
422 | FingerprintMatch fp -> (KeyGrip fp, Nothing) | 423 | FingerprintMatch fp -> (KeyGrip fp, Nothing) |
423 | else | 424 | else |
@@ -780,8 +781,8 @@ is40digitHex xs = ys == xs && length ys==40 | |||
780 | 781 | ||
781 | matchSpec :: KeySpec -> KeyData -> Bool | 782 | matchSpec :: KeySpec -> KeyData -> Bool |
782 | matchSpec (KeyGrip grip) (KeyData p _ _ _) | 783 | matchSpec (KeyGrip grip) (KeyData p _ _ _) |
783 | | matchpr grip (packet p)==grip = True | 784 | | matchpr' grip (packet p) = True |
784 | | otherwise = False | 785 | | otherwise = False |
785 | 786 | ||
786 | matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps | 787 | matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps |
787 | where | 788 | where |
@@ -791,7 +792,7 @@ matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps | |||
791 | && has_issuer key p | 792 | && has_issuer key p |
792 | has_issuer key p = isJust $ do | 793 | has_issuer key p = isJust $ do |
793 | issuer <- signature_issuer p | 794 | issuer <- signature_issuer p |
794 | guard $ matchpr issuer key == issuer | 795 | guard $ matchpr' issuer key |
795 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) | 796 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) |
796 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) | 797 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) |
797 | 798 | ||
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 @@ | |||
1 | {-# LANGUAGE StandaloneDeriving #-} | ||
1 | {-# LANGUAGE DeriveFunctor #-} | 2 | {-# LANGUAGE DeriveFunctor #-} |
2 | {-# LANGUAGE DeriveTraversable #-} | 3 | {-# LANGUAGE DeriveTraversable #-} |
3 | {-# LANGUAGE PatternSynonyms #-} | 4 | {-# LANGUAGE PatternSynonyms #-} |
@@ -119,7 +120,7 @@ data PassphraseSpec = PassphraseSpec | |||
119 | { passSpecRingFile :: Maybe FilePath | 120 | { passSpecRingFile :: Maybe FilePath |
120 | -- ^ If not Nothing, the passphrase is to be used for packets | 121 | -- ^ If not Nothing, the passphrase is to be used for packets |
121 | -- from this file. | 122 | -- from this file. |
122 | , passSpecKeySpec :: Maybe String | 123 | , passSpecKeySpec :: Maybe Fingerprint |
123 | -- ^ Non-Nothing value reserved for future use. | 124 | -- ^ Non-Nothing value reserved for future use. |
124 | -- (TODO: Use this to implement per-key passphrase associations). | 125 | -- (TODO: Use this to implement per-key passphrase associations). |
125 | , passSpecPassFile :: InputFile | 126 | , passSpecPassFile :: InputFile |
@@ -129,6 +130,9 @@ data PassphraseSpec = PassphraseSpec | |||
129 | | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } | 130 | | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } |
130 | | PassphraseAgent | 131 | | PassphraseAgent |
131 | 132 | ||
133 | deriving instance Ord Fingerprint | ||
134 | deriving instance Eq Fingerprint | ||
135 | |||
132 | instance Show PassphraseSpec where | 136 | instance Show PassphraseSpec where |
133 | show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) | 137 | show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) |
134 | show (PassphraseMemoizer _) = "PassphraseMemoizer" | 138 | show (PassphraseMemoizer _) = "PassphraseMemoizer" |
@@ -350,14 +354,19 @@ isTrust _ = False | |||
350 | -- matchpr fp = Data.List.Extra.takeEnd (length fp) | 354 | -- matchpr fp = Data.List.Extra.takeEnd (length fp) |
351 | -- | 355 | -- |
352 | matchpr :: Fingerprint -> Packet -> Bool | 356 | matchpr :: Fingerprint -> Packet -> Bool |
353 | matchpr fp k = p == show fp | 357 | matchpr fp k = matchpr' (show fp) k |
354 | where | ||
355 | p = reverse $ zipWith const (reverse (show $ fingerprint k)) (show fp) | ||
356 | 358 | ||
359 | matchpr' :: String -> Packet -> Bool | ||
360 | matchpr' fp k = p == fp | ||
361 | where | ||
362 | p = reverse $ zipWith const (reverse (show $ fingerprint k)) fp | ||
357 | 363 | ||
364 | matchpr'' :: String -> Packet -> String | ||
365 | matchpr'' fp k | matchpr' fp k = fp | ||
366 | matchpr'' fp k | otherwise = "" | ||
358 | 367 | ||
359 | data KeySpec = | 368 | data KeySpec = |
360 | KeyGrip Fingerprint -- fp: | 369 | KeyGrip String -- fp: |
361 | | KeyTag Packet String -- fp:????/t: | 370 | | KeyTag Packet String -- fp:????/t: |
362 | | KeyUidMatch String -- u: | 371 | | KeyUidMatch String -- u: |
363 | deriving Show | 372 | deriving Show |
@@ -428,8 +437,8 @@ seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) | |||
428 | seek_key (KeyGrip grip) sec = (pre, subs) | 437 | seek_key (KeyGrip grip) sec = (pre, subs) |
429 | where | 438 | where |
430 | (pre,subs) = break pred sec | 439 | (pre,subs) = break pred sec |
431 | pred p@(SecretKeyPacket {}) = matchpr grip p | 440 | pred p@(SecretKeyPacket {}) = matchpr' grip p |
432 | pred p@(PublicKeyPacket {}) = matchpr grip p | 441 | pred p@(PublicKeyPacket {}) = matchpr' grip p |
433 | pred _ = False | 442 | pred _ = False |
434 | 443 | ||
435 | seek_key (KeyTag key tag) ps | 444 | seek_key (KeyTag key tag) ps |
@@ -442,7 +451,7 @@ seek_key (KeyTag key tag) ps | |||
442 | (as,bs) = break (\p -> isSignaturePacket p | 451 | (as,bs) = break (\p -> isSignaturePacket p |
443 | && has_tag tag p | 452 | && has_tag tag p |
444 | && isJust (signature_issuer p) | 453 | && isJust (signature_issuer p) |
445 | && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) | 454 | && matchpr' (fromJust $ signature_issuer p) key) |
446 | ps | 455 | ps |
447 | (rs,qs) = break isKey (reverse as) | 456 | (rs,qs) = break isKey (reverse as) |
448 | 457 | ||
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 () | |||
554 | writePublicKeyFiles rt fw myId@(MyIdentity _ grip) = do | 554 | writePublicKeyFiles rt fw myId@(MyIdentity _ grip) = do |
555 | 555 | ||
556 | -- Finally, export public keys if they do not exist. | 556 | -- Finally, export public keys if they do not exist. |
557 | either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) | 557 | either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" (Just grip) (rtKeyDB rt) |
558 | either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) | 558 | either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" (Just grip) (rtKeyDB rt) |
559 | either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket | 559 | either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" (Just grip) (rtKeyDB rt) pemFromPacket |
560 | 560 | ||
561 | let cs = listPeers rt | 561 | let cs = listPeers rt |
562 | known_hosts = L.concat $ map getSshKnownHosts $ cs | 562 | known_hosts = L.concat $ map getSshKnownHosts $ cs |
@@ -615,10 +615,10 @@ pemFromPacket k = do | |||
615 | return $ | 615 | return $ |
616 | writePEM PemPublicKey qq -- ("TODO "++show keyspec) | 616 | writePEM PemPublicKey qq -- ("TODO "++show keyspec) |
617 | 617 | ||
618 | show_pem :: String -> String -> KeyDB -> IO () | 618 | show_pem :: String -> Maybe Fingerprint -> KeyDB -> IO () |
619 | show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket | 619 | show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket |
620 | 620 | ||
621 | show_pem' :: String -> String -> KeyDB -> (Packet -> Either String b) -> Either String b | 621 | show_pem' :: String -> Maybe Fingerprint -> KeyDB -> (Packet -> Either String b) -> Either String b |
622 | show_pem' keyspec wkgrip db keyfmt = do | 622 | show_pem' keyspec wkgrip db keyfmt = do |
623 | let s = parseSpec wkgrip keyspec | 623 | let s = parseSpec wkgrip keyspec |
624 | flip (maybe . Left $ keyspec ++ ": not found") | 624 | flip (maybe . Left $ keyspec ++ ": not found") |
@@ -628,17 +628,17 @@ show_pem' keyspec wkgrip db keyfmt = do | |||
628 | warn :: String -> IO () | 628 | warn :: String -> IO () |
629 | warn str = hPutStrLn stderr str | 629 | warn str = hPutStrLn stderr str |
630 | 630 | ||
631 | show_sshfp :: String -> String -> KeyDB -> IO () | 631 | show_sshfp :: String -> Maybe Fingerprint -> KeyDB -> IO () |
632 | show_sshfp keyspec wkgrip db = do | 632 | show_sshfp keyspec wkgrip db = do |
633 | let s = parseSpec wkgrip keyspec | 633 | let s = parseSpec wkgrip keyspec |
634 | case selectPublicKey s db of | 634 | case selectPublicKey s db of |
635 | Nothing -> hPutStrLn stderr $ keyspec ++ ": not found" | 635 | Nothing -> hPutStrLn stderr $ keyspec ++ ": not found" |
636 | Just k -> Char8.putStrLn $ sshKeyToHostname k | 636 | Just k -> Char8.putStrLn $ sshKeyToHostname k |
637 | 637 | ||
638 | show_ssh :: String -> String -> KeyDB -> IO () | 638 | show_ssh :: String -> Maybe Fingerprint -> KeyDB -> IO () |
639 | show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db | 639 | show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db |
640 | 640 | ||
641 | show_ssh' :: String -> Fingerprint -> KeyDB -> Either String String | 641 | show_ssh' :: String -> Maybe Fingerprint -> KeyDB -> Either String String |
642 | show_ssh' keyspec wkgrip db = do | 642 | show_ssh' keyspec wkgrip db = do |
643 | let s = parseSpec wkgrip keyspec | 643 | let s = parseSpec wkgrip keyspec |
644 | flip (maybe . Left $ keyspec ++ ": not found") | 644 | 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 | |||
113 | cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n") | 113 | cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n") |
114 | ctx | 114 | ctx |
115 | fd | 115 | fd |
116 | let matchkey fp mp = matchpr fp (packet mp) == fp | 116 | let matchkey fp mp = matchpr fp (packet mp) |
117 | matchfile file mp = Map.member file (locations mp) | 117 | matchfile file mp = Map.member file (locations mp) |
118 | specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] | 118 | specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] |
119 | specialize alg mp = | 119 | specialize alg mp = |
@@ -268,7 +268,7 @@ makeMemoizingDecrypter passwdspec ctx (workingkey,keys) = do | |||
268 | 268 | ||
269 | trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs) | 269 | trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs) |
270 | 270 | ||
271 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) | 271 | keyQueries :: Maybe Fingerprint -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) |
272 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) | 272 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) |
273 | where | 273 | where |
274 | makeQuery (maink,mp,us) = mp { packet = q } | 274 | makeQuery (maink,mp,us) = mp { packet = q } |
@@ -291,8 +291,8 @@ keyQueries grip ringPackets = (mwk, fmap makeQuery keys) | |||
291 | mwk = listToMaybe $ do | 291 | mwk = listToMaybe $ do |
292 | fp <- maybeToList grip | 292 | fp <- maybeToList grip |
293 | let matchfp mp | 293 | let matchfp mp |
294 | | not (is_subkey p) && matchpr fp p == fp = Just mp | 294 | | not (is_subkey p) && matchpr fp p = Just mp |
295 | | otherwise = Nothing | 295 | | otherwise = Nothing |
296 | where p = packet mp | 296 | where p = packet mp |
297 | Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys | 297 | Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys |
298 | 298 | ||
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) | |||
44 | data KeyRingRuntime = KeyRingRuntime | 44 | data KeyRingRuntime = KeyRingRuntime |
45 | { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' | 45 | { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' |
46 | , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec' | 46 | , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec' |
47 | , rtGrip :: Maybe String | 47 | , rtGrip :: Maybe Fingerprint |
48 | -- ^ Fingerprint or portion of a fingerprint used | 48 | -- ^ Fingerprint or portion of a fingerprint used |
49 | -- to identify the working GnuPG identity used to | 49 | -- to identify the working GnuPG identity used to |
50 | -- make signatures. | 50 | -- make signatures. |