summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndrew Cady <d@jerkface.net>2019-07-16 20:33:23 -0400
committerAndrew Cady <d@jerkface.net>2019-07-16 20:33:23 -0400
commit8af08303e56fc109135e2ade91299338d03b57b0 (patch)
tree7131b086733c62c610e667638a3f7893b7304618
parent7a94f5103671011295f818bfcf30280423c44042 (diff)
this compiles
-rw-r--r--kiki.hs40
-rw-r--r--lib/KeyRing.hs22
-rw-r--r--lib/KeyRing/BuildKeyDB.hs23
-rw-r--r--lib/KeyRing/Types.hs25
-rw-r--r--lib/Kiki.hs16
-rw-r--r--lib/PacketTranscoder.hs8
-rw-r--r--lib/Transforms.hs2
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
41import System.Posix.User 41import System.Posix.User
42 42
43import CommandLine 43import CommandLine
44import Data.OpenPGP.Util (verify, fingerprint, GenerateKeyParams(..)) 44import Data.OpenPGP.Util (Fingerprint, verify, fingerprint, GenerateKeyParams(..))
45import ScanningParser 45import ScanningParser
46import PEM 46import PEM
47import DotLock 47import DotLock
@@ -63,13 +63,6 @@ isCertificationSig :: SignatureOver -> Bool
63isCertificationSig (CertificationSignature {}) = True 63isCertificationSig (CertificationSignature {}) = True
64isCertificationSig _ = True 64isCertificationSig _ = True
65 65
66fpmatch :: Maybe [Char] -> Packet -> Bool
67fpmatch grip key =
68 (==) Nothing
69 (fmap (backend (show $ fingerprint key)) grip >>= guard . not)
70 where
71 backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
72
73listKeys :: [Packet] -> [Char] 66listKeys :: [Packet] -> [Char]
74listKeys pkts = listKeysFiltered [] pkts 67listKeys pkts = listKeysFiltered [] pkts
75 68
@@ -79,7 +72,7 @@ listKeys pkts = listKeysFiltered [] pkts
79-- Build the display output 72-- Build the display output
80-- Operates in List Monad... 73-- Operates in List Monad...
81-- returns all output as a single string 74-- returns all output as a single string
82listKeysFiltered :: Foldable t => t [Char] -> [Packet] -> [Char] 75listKeysFiltered :: Foldable t => t Fingerprint -> [Packet] -> [Char]
83listKeysFiltered grips pkts = do 76listKeysFiltered grips pkts = do
84 let masterkeys = filter (\k -> isKey k && not (is_subkey k)) pkts 77 let masterkeys = filter (\k -> isKey k && not (is_subkey k)) pkts
85 (certs,bs) = getBindings pkts 78 (certs,bs) = getBindings pkts
@@ -96,7 +89,7 @@ listKeysFiltered grips pkts = do
96 ownerkey (_,(a,_),_,_,_) = a 89 ownerkey (_,(a,_),_,_,_) = a
97 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b 90 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
98 matchgrip _ | null grips = True 91 matchgrip _ | null grips = True
99 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True 92 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip matchpr top) grips = True
100 matchgrip _ = False 93 matchgrip _ = False
101 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as) 94 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
102 singles = filter (\k -> show (fingerprint k) `notElem` map (show . fingerprint) parents) masterkeys -- \\ parents 95 singles = filter (\k -> show (fingerprint k) `notElem` map (show . fingerprint) parents) masterkeys -- \\ parents
@@ -152,7 +145,7 @@ listKeysFiltered grips pkts = do
152 let issuers = do 145 let issuers = do
153 sig_over <- signatures_over sig 146 sig_over <- signatures_over sig
154 i <- maybeToList $ signature_issuer sig_over 147 i <- maybeToList $ signature_issuer sig_over
155 maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i))) 148 maybeToList $ find_key (matchpr'' i) (Message keys) (reverse (take 16 (reverse i)))
156 (primary,secondary) = partition (==top) issuers 149 (primary,secondary) = partition (==top) issuers
157 150
158 -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return () 151 -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return ()
@@ -215,8 +208,7 @@ partitionStaticArguments specs args = psa args
215 Nothing -> second (a:) $ psa as 208 Nothing -> second (a:) $ psa as
216 Just n -> first ((a:take n as):) $ psa (drop n as) 209 Just n -> first ((a:take n as):) $ psa (drop n as)
217 210
218show_wk :: FilePath 211show_wk :: FilePath -> Maybe Fingerprint -> KeyDB -> IO ()
219 -> Maybe [Char] -> KeyDB -> IO ()
220show_wk secring_file grip db = do 212show_wk secring_file grip db = do
221 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) 213 -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db)
222 let gripmatch (KeyData p _ _ _) = 214 let gripmatch (KeyData p _ _ _) =
@@ -257,7 +249,7 @@ show_whose_key input_key db =
257 (_:_) -> error "ambiguous" 249 (_:_) -> error "ambiguous"
258 [] -> return () 250 [] -> return ()
259 251
260show_dns :: [Char] -> String -> KeyDB -> IO () 252show_dns :: [Char] -> Maybe Fingerprint -> KeyDB -> IO ()
261show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket 253show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket
262 254
263dnsPresentationFromPacket :: Monad m => Packet -> m String 255dnsPresentationFromPacket :: Monad m => Packet -> m String
@@ -282,7 +274,7 @@ dnsPresentationFromPacket k = do
282 274
283show_id :: String -> p -> KeyDB -> IO () 275show_id :: String -> p -> KeyDB -> IO ()
284show_id keyspec wkgrip db = do 276show_id keyspec wkgrip db = do
285 let s = parseSpec "" keyspec 277 let s = parseSpec Nothing keyspec
286 let ps = do 278 let ps = do
287 (_,k) <- filterMatches (fst s) (kkData db) 279 (_,k) <- filterMatches (fst s) (kkData db)
288 mp <- flattenTop "" True k 280 mp <- flattenTop "" True k
@@ -290,7 +282,7 @@ show_id keyspec wkgrip db = do
290 -- putStrLn $ "show key " ++ show s 282 -- putStrLn $ "show key " ++ show s
291 putStrLn $ listKeys ps 283 putStrLn $ listKeys ps
292 284
293show_wip :: [Char] -> String -> KeyDB -> IO () 285show_wip :: [Char] -> Maybe Fingerprint -> KeyDB -> IO ()
294show_wip keyspec wkgrip db = do 286show_wip keyspec wkgrip db = do
295 let s = parseSpec wkgrip keyspec 287 let s = parseSpec wkgrip keyspec
296 flip (maybe $ void (warn (keyspec ++ ": not found"))) 288 flip (maybe $ void (warn (keyspec ++ ": not found")))
@@ -320,7 +312,7 @@ show_torhash pubkey _ = do
320 keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs 312 keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs
321 mapM_ (putStrLn . addy . torhash) keys 313 mapM_ (putStrLn . addy . torhash) keys
322 314
323show_cert :: [Char] -> String -> KeyDB -> IO () 315show_cert :: [Char] -> Maybe Fingerprint -> KeyDB -> IO ()
324show_cert keyspec wkgrip db = do 316show_cert keyspec wkgrip db = do
325 let s = parseSpec wkgrip keyspec 317 let s = parseSpec wkgrip keyspec
326 case selectPublicKeyAndSigs s db of 318 case selectPublicKeyAndSigs s db of
@@ -1235,13 +1227,13 @@ kiki "show" args = do
1235 ,("--all",const show_all) 1227 ,("--all",const show_all)
1236 ,("--whose-key", const $ show_whose_key input_key) 1228 ,("--whose-key", const $ show_whose_key input_key)
1237 ,("--packets", show_packets) 1229 ,("--packets", show_packets)
1238 ,("--key",\[x] -> show_id x $ fromMaybe "" grip) 1230 ,("--key",\[x] -> show_id x grip)
1239 ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip) 1231 ,("--pem",\[x] -> show_pem x grip)
1240 ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip) 1232 ,("--dns",\[x] -> show_dns x grip)
1241 ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip) 1233 ,("--ssh",\[x] -> show_ssh x grip)
1242 ,("--sshfp",\[x] -> show_sshfp x $ fromMaybe "" grip) 1234 ,("--sshfp",\[x] -> show_sshfp x grip)
1243 ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip) 1235 ,("--wip",\[x] -> show_wip x grip)
1244 ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip) 1236 ,("--cert",\[x] -> show_cert x grip)
1245 ,("--torhash",\[x] -> show_torhash x) 1237 ,("--torhash",\[x] -> show_torhash x)
1246 ,("--dump", const $ debug_dump (rtSecring rt) grip) 1238 ,("--dump", const $ debug_dump (rtSecring rt) grip)
1247 ] 1239 ]
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
679mkarmor :: Access -> L.ByteString -> [Armor] 679mkarmor :: 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
945initializeMissingPEMFiles :: 945initializeMissingPEMFiles ::
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
1072withLockedKeyring :: Maybe FilePath 1072withLockedKeyring :: 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)
1076withLockedKeyring homespec opfiles go = do 1076withLockedKeyring 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
1102realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe String -> IO (KikiResult KeyRingRuntime) 1102realRunKeyRing :: KeyRingOperation -> InputFileContext -> Maybe Fingerprint -> IO (KikiResult KeyRingRuntime)
1103realRunKeyRing operation ctx grip0 = do 1103realRunKeyRing 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-- )
1166getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) 1166getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe Fingerprint))
1167getHomeDir protohome = do 1167getHomeDir 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--
86buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation 86buildKeyDB :: 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.
411parseSpec :: Fingerprint -> String -> (KeySpec,Maybe String) 412parseSpec :: Maybe Fingerprint -> String -> (KeySpec,Maybe String)
412parseSpec wkgrip spec = 413parseSpec 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
781matchSpec :: KeySpec -> KeyData -> Bool 782matchSpec :: KeySpec -> KeyData -> Bool
782matchSpec (KeyGrip grip) (KeyData p _ _ _) 783matchSpec (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
786matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps 787matchSpec (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
133deriving instance Ord Fingerprint
134deriving instance Eq Fingerprint
135
132instance Show PassphraseSpec where 136instance 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--
352matchpr :: Fingerprint -> Packet -> Bool 356matchpr :: Fingerprint -> Packet -> Bool
353matchpr fp k = p == show fp 357matchpr fp k = matchpr' (show fp) k
354 where
355 p = reverse $ zipWith const (reverse (show $ fingerprint k)) (show fp)
356 358
359matchpr' :: String -> Packet -> Bool
360matchpr' fp k = p == fp
361 where
362 p = reverse $ zipWith const (reverse (show $ fingerprint k)) fp
357 363
364matchpr'' :: String -> Packet -> String
365matchpr'' fp k | matchpr' fp k = fp
366matchpr'' fp k | otherwise = ""
358 367
359data KeySpec = 368data 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])
428seek_key (KeyGrip grip) sec = (pre, subs) 437seek_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
435seek_key (KeyTag key tag) ps 444seek_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 ()
554writePublicKeyFiles rt fw myId@(MyIdentity _ grip) = do 554writePublicKeyFiles 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
618show_pem :: String -> String -> KeyDB -> IO () 618show_pem :: String -> Maybe Fingerprint -> KeyDB -> IO ()
619show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket 619show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket
620 620
621show_pem' :: String -> String -> KeyDB -> (Packet -> Either String b) -> Either String b 621show_pem' :: String -> Maybe Fingerprint -> KeyDB -> (Packet -> Either String b) -> Either String b
622show_pem' keyspec wkgrip db keyfmt = do 622show_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
628warn :: String -> IO () 628warn :: String -> IO ()
629warn str = hPutStrLn stderr str 629warn str = hPutStrLn stderr str
630 630
631show_sshfp :: String -> String -> KeyDB -> IO () 631show_sshfp :: String -> Maybe Fingerprint -> KeyDB -> IO ()
632show_sshfp keyspec wkgrip db = do 632show_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
638show_ssh :: String -> String -> KeyDB -> IO () 638show_ssh :: String -> Maybe Fingerprint -> KeyDB -> IO ()
639show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db 639show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db
640 640
641show_ssh' :: String -> Fingerprint -> KeyDB -> Either String String 641show_ssh' :: String -> Maybe Fingerprint -> KeyDB -> Either String String
642show_ssh' keyspec wkgrip db = do 642show_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
271keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) 271keyQueries :: Maybe Fingerprint -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
272keyQueries grip ringPackets = (mwk, fmap makeQuery keys) 272keyQueries 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)
44data KeyRingRuntime = KeyRingRuntime 44data 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.