diff options
Diffstat (limited to 'kiki.hs')
-rw-r--r-- | kiki.hs | 40 |
1 files changed, 16 insertions, 24 deletions
@@ -41,7 +41,7 @@ import Data.Binary.Put | |||
41 | import System.Posix.User | 41 | import System.Posix.User |
42 | 42 | ||
43 | import CommandLine | 43 | import CommandLine |
44 | import Data.OpenPGP.Util (verify, fingerprint, GenerateKeyParams(..)) | 44 | import Data.OpenPGP.Util (Fingerprint, verify, fingerprint, GenerateKeyParams(..)) |
45 | import ScanningParser | 45 | import ScanningParser |
46 | import PEM | 46 | import PEM |
47 | import DotLock | 47 | import DotLock |
@@ -63,13 +63,6 @@ isCertificationSig :: SignatureOver -> Bool | |||
63 | isCertificationSig (CertificationSignature {}) = True | 63 | isCertificationSig (CertificationSignature {}) = True |
64 | isCertificationSig _ = True | 64 | isCertificationSig _ = True |
65 | 65 | ||
66 | fpmatch :: Maybe [Char] -> Packet -> Bool | ||
67 | fpmatch 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 | |||
73 | listKeys :: [Packet] -> [Char] | 66 | listKeys :: [Packet] -> [Char] |
74 | listKeys pkts = listKeysFiltered [] pkts | 67 | listKeys 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 |
82 | listKeysFiltered :: Foldable t => t [Char] -> [Packet] -> [Char] | 75 | listKeysFiltered :: Foldable t => t Fingerprint -> [Packet] -> [Char] |
83 | listKeysFiltered grips pkts = do | 76 | listKeysFiltered 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 | ||
218 | show_wk :: FilePath | 211 | show_wk :: FilePath -> Maybe Fingerprint -> KeyDB -> IO () |
219 | -> Maybe [Char] -> KeyDB -> IO () | ||
220 | show_wk secring_file grip db = do | 212 | show_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 | ||
260 | show_dns :: [Char] -> String -> KeyDB -> IO () | 252 | show_dns :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () |
261 | show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket | 253 | show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket |
262 | 254 | ||
263 | dnsPresentationFromPacket :: Monad m => Packet -> m String | 255 | dnsPresentationFromPacket :: Monad m => Packet -> m String |
@@ -282,7 +274,7 @@ dnsPresentationFromPacket k = do | |||
282 | 274 | ||
283 | show_id :: String -> p -> KeyDB -> IO () | 275 | show_id :: String -> p -> KeyDB -> IO () |
284 | show_id keyspec wkgrip db = do | 276 | show_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 | ||
293 | show_wip :: [Char] -> String -> KeyDB -> IO () | 285 | show_wip :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () |
294 | show_wip keyspec wkgrip db = do | 286 | show_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 | ||
323 | show_cert :: [Char] -> String -> KeyDB -> IO () | 315 | show_cert :: [Char] -> Maybe Fingerprint -> KeyDB -> IO () |
324 | show_cert keyspec wkgrip db = do | 316 | show_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 | ] |