From a3b9c59b4c2839a2f31a060082624937fa4e32dc Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 10 May 2020 20:58:07 -0400 Subject: Option to render SHA256 based fingerprints. --- kiki.hs | 109 ++++++++++++++++++++++++++++++++++++++---------------------- lib/Kiki.hs | 23 +++++++++++-- stack.yaml | 2 +- 3 files changed, 91 insertions(+), 43 deletions(-) diff --git a/kiki.hs b/kiki.hs index fe9a979..a4857f0 100644 --- a/kiki.hs +++ b/kiki.hs @@ -22,6 +22,7 @@ import Data.Maybe import Data.OpenPGP import Data.Ord import Data.String +import Text.Read import Text.Show.Pretty as PP ( ppShow ) import Data.Text.Encoding import System.Posix.Files @@ -45,7 +46,7 @@ import Data.Monoid ( (<>) ) import Data.Binary.Put import CommandLine -import Data.OpenPGP.Util (verify, fingerprint, GenerateKeyParams(..)) +import Data.OpenPGP.Util (verify, fingerprint, fingerprintv, GenerateKeyParams(..)) import ScanningParser import PEM import DotLock @@ -99,8 +100,8 @@ checkSelfAuthenticating parsed subs = do guard (len >= 16) listToMaybe $ filter match $ subkeysForDomain (uid_topdomain parsed) subs -listKeys :: [Packet] -> [Char] -listKeys pkts = listKeysFiltered [] pkts +listKeys :: FingerprintStyle -> [Packet] -> [Char] +listKeys style pkts = listKeysFiltered style [] pkts -- | listKeysFiltered -- @grips fingerprints of keys to show @@ -108,9 +109,12 @@ 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 grips pkts = do - let masterkeys = filter (\k -> isKey k && not (is_subkey k)) pkts +listKeysFiltered :: Foldable t => FingerprintStyle -> t [Char] -> [Packet] -> [Char] +listKeysFiltered style grips pkts = do + let fp = case style of + FingerprintAuto -> \p -> show (fingerprint p) + Fingerprint5 -> \p -> show (fingerprintv 5 p) + masterkeys = filter (\k -> isKey k && not (is_subkey k)) pkts (certs,bs) = getBindings pkts as = accBindings bs defaultkind (k:_) hs = k @@ -128,11 +132,11 @@ listKeysFiltered grips pkts = do matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) 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 + singles = filter (\k -> fp k `notElem` map fp parents) masterkeys -- \\ parents where parents = do subs@((_,(top,_),_,_,_):_) <- gs return top - showsigs claimants = map (\k -> " " ++ "^ signed: " ++ show (fingerprint k)) claimants + showsigs claimants = map (\k -> " " ++ "^ signed: " ++ fp k) claimants subs0 <- map Left gs ++ map Right singles let (top,subs) = case subs0 of Left subs1@((_,(top0,_),_,_,_):_) -> (top0,subs1) Right top0 -> (top0,[]) @@ -156,7 +160,7 @@ listKeysFiltered grips pkts = do , ar , formkind , " " - , show $ fingerprint sub + , fp sub , kcipher sub -- , " " ++ (torhash sub) -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) @@ -191,7 +195,7 @@ listKeysFiltered grips pkts = do checkSelfAuthenticating parsed subs unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary -- (_,sigs) = unzip certs - "master-key " ++ show (fingerprint top) ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" + "master-key " ++ fp top ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" {- @@ -219,8 +223,8 @@ toLast f [x] = [f x] toLast f (x:xs) = x : toLast f xs -- partitionStaticArguments :: Ord a => [(a, Int)] -> [a] -> ([[a]], [a]) -partitionStaticArguments :: [([Char], Int)] - -> [[Char]] -> ([[[Char]]], [[Char]]) +partitionStaticArguments :: [(String, Int)] + -> [String] -> ([[String]], [String]) partitionStaticArguments specs args = psa args where smap = Map.fromList specs @@ -233,15 +237,16 @@ partitionStaticArguments specs args = psa args Nothing -> second (a:) $ psa as Just n -> first ((a:take n as):) $ psa (drop n as) -show_wk :: FilePath +show_wk :: FingerprintStyle + -> FilePath -> Maybe [Char] -> KeyDB -> IO () -show_wk secring_file grip db = do +show_wk style secring_file grip db = do -- printf "show_wk(%s,%s,%s)\n" (show secring_file) (show grip) (show db) let gripmatch (KeyData p _ _ _) = Map.member secring_file (locations p) || Map.member "&secret" (locations p) Message sec = flattenFiltered False gripmatch db - putStrLn $ listKeysFiltered (maybeToList grip) sec + putStrLn $ listKeysFiltered style (maybeToList grip) sec debug_dump :: FilePath -> p -> KeyDB -> IO () debug_dump secring_file grip db = do @@ -251,10 +256,10 @@ debug_dump secring_file grip db = do Message sec = flattenFiltered False gripmatch db mapM_ print sec -show_all :: KeyDB -> IO () -show_all db = do +show_all :: FingerprintStyle -> KeyDB -> IO () +show_all style db = do let Message packets = flattenFiltered True (const True) db - putStrLn $ listKeys packets + putStrLn $ listKeys style packets show_packets :: (Eq a, IsString a) => [a] -> KeyDB -> IO () @@ -298,15 +303,15 @@ dnsPresentationFromPacket k = do ,qq ] -show_id :: String -> p -> KeyDB -> IO () -show_id keyspec wkgrip db = do +show_id :: FingerprintStyle -> String -> p -> KeyDB -> IO () +show_id style keyspec wkgrip db = do let s = parseSpec "" keyspec let ps = do (_,k) <- filterMatches (fst s) (kkData db) mp <- flattenTop "" True k return $ packet mp -- putStrLn $ "show key " ++ show s - putStrLn $ listKeys ps + putStrLn $ listKeys style ps show_wip :: [Char] -> String -> KeyDB -> IO () show_wip keyspec wkgrip db = do @@ -655,6 +660,9 @@ kiki_usage ((== Export) -> bExport) ((== Import) -> bImport) ((== Secret) -> bSe ," --trace-verify" ," For debugging, stderr traces for every signature verification." ,"" + ," --fingerprint=5" + ," Use SHA256-based (PGP v5) fingerprints even for PGP v4 key packets." + ,"" ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag bExport bImport bSecret showwk :: [String] @@ -941,6 +949,12 @@ documentHostsOption bExport bImport bSecret = ,""] +commonArgSpec :: [(String,Int)] +commonArgSpec = [ ("--homedir",1) + , ("--passphrase-fd",1) + , ("--fingerprint",1) + , ("--help",0) + ] -- | -- Arguments: @@ -964,10 +978,6 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) where (args,trail1) = break (=="--") args_raw trail = drop 1 trail1 - commonArgSpec = [ ("--homedir",1) - , ("--passphrase-fd",1) - , ("--help",0) - ] sargspec' = commonArgSpec ++ sargspec (sargs,margs) = (sargs, foldl' (\m (k:xs)->Map.alter (appendArgs k xs) k m) @@ -991,10 +1001,14 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) parseCommonArgs :: (Ord k, IsString k) => Map.Map k [[Char]] -> CommonArgsParsed -parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd } +parseCommonArgs margs = CommonArgsParsed + { cap_homespec = homespec + , cap_passfd = passfd + , cap_fpstyle = style } where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs homespec = join . take 1 <$> Map.lookup "--homedir" margs + style = maybe FingerprintAuto read $ join . take 1 <$> Map.lookup "--fingerprint" margs passfd = fmap (FileDesc . read) passphrase_fd parseKeySpecs :: [String] -> [Maybe (String,String,String)] @@ -1060,6 +1074,9 @@ moreSync :: [Maybe (String, String, String)] -> Map.Map String [FilePath] -> May moreSync keypairs0 margs passphrase_fd bExport bImport bSecret cmdarg keyrings_ wallets sargs = do let keypairs = catMaybes keypairs0 homespec = join . take 1 <$> Map.lookup "--homedir" margs + style = fromMaybe FingerprintAuto $ do + fs <- Map.lookup "--fingerprint" margs + readMaybe $ concat $ take 1 fs passfd = fmap (FileDesc . read) passphrase_fd -- reftyp is used as value for 'fill field' in StreamInfo, walts and rings reftyp | bExport == Export = KF_Subkeys -- export to rings when they have master present @@ -1111,16 +1128,16 @@ moreSync keypairs0 margs passphrase_fd bExport bImport bSecret cmdarg keyrings_ , opHome = homespec } let usage f = maybe f (const $ kiki_usage bExport bImport bSecret cmdarg) $ Map.lookup "--help" margs - usage $ moreMoreSync kikiOp sargs + usage $ moreMoreSync style kikiOp sargs -moreMoreSync :: KeyRingOperation -> [[String]] -> IO () -moreMoreSync kikiOp sargs = do +moreMoreSync :: FingerprintStyle -> KeyRingOperation -> [[String]] -> IO () +moreMoreSync style kikiOp sargs = do KikiResult rt report <- runKeyRing kikiOp case rt of KikiSuccess rt -> do -- interpret --show-* commands. let grip = rtGrip rt - let shspec = Map.fromList [("--show-wk", const $ show_wk (rtSecring rt) grip) + let shspec = Map.fromList [("--show-wk", const $ show_wk style (rtSecring rt) grip) {-,("--show-all",const show_all) ,("--show-whose-key", const $ show_whose_key input_key) ,("--show-key",\[x] -> show_id x $ fromMaybe "" grip) @@ -1192,9 +1209,12 @@ kiki "help" args = forM_ args $ \arg -> case lookup arg commands of Nothing -> putStrLn $ "No help available for commmand '" ++ arg ++ "'." _ -> kiki arg ["--help"] -kiki "show" [] = kiki "show" ["--working"] kiki "show" args = do - let (sargs,margs) = processArgs sargspec polyVariadicArgs "--show" args + let (sargs0,margs) = processArgs sargspec polyVariadicArgs "--show" args + notCommon xss = concat (take 1 xss) `notElem` map fst commonArgSpec + sargs = case filter notCommon sargs0 of + [] -> ["--working"] : sargs0 + _ -> sargs0 sargspec = [ ("--working",0) --("--show-wk",0) , ("--dump",0) --("--show-all",0) , ("--all",0) --("--show-all",0) @@ -1249,11 +1269,11 @@ kiki "show" args = do case rt of KikiSuccess rt -> do -- interpret --show-* commands. let grip = rtGrip rt - let shspec = Map.fromList [("--working", const $ show_wk (rtSecring rt) grip) - ,("--all",const show_all) + let shspec = Map.fromList [("--working", const $ show_wk (cap_fpstyle cap) (rtSecring rt) grip) + ,("--all",const (show_all (cap_fpstyle cap))) ,("--whose-key", const $ show_whose_key input_key) ,("--packets", show_packets) - ,("--key",\[x] -> show_id x $ fromMaybe "" grip) + ,("--key",\[x] -> show_id (cap_fpstyle cap) x $ fromMaybe "" grip) ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip) ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip) ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip) @@ -1343,15 +1363,15 @@ kiki "merge" args = do case rt of KikiSuccess rt -> do let db = rtKeyDB rt if bShowAll - then show_all db + then show_all style db else forM_ keyspecs $ \keyspec -> do - show_id keyspec (error "show_id wkgrip") db + show_id style keyspec (error "show_id wkgrip") db when bPackets $ show_packets [] db err -> putStrLn $ errorString err forM_ report $ \(fname,act) -> do putStrLn $ fname ++ ": " ++ reportString act where - (_,((_,keyspecs),op)) = foldl' buildOp (True,((flow0,[]),noop)) args3 + (_,((_,keyspecs),op)) = foldl' buildOp (True,((flow0,[]),noop)) args4 (args',mbAgent) = case break (=="--agent") args of (as,[]) -> (as, id) (as,_:bs) -> ( as++bs @@ -1362,6 +1382,10 @@ kiki "merge" args = do (args3,bPackets) = case break (=="--packets") args'' of (as,[]) -> (as, False) (as,_:bs) -> (as++bs, True) + (args4,style) = case break (=="--fingerprint") args3 of + (as,b:bs) | Just s <- readMaybe b + -> (as++bs, s) + (as,[]) -> (as, FingerprintAuto) noop = KeyRingOperation { opFiles = Map.empty , opTransforms = [] @@ -1712,7 +1736,14 @@ main = do return $ as ++ bs case args_raw of - [] -> kiki "show" ["--working"] + [] -> kiki "show" args_raw + + ["--help"] -> do + putStrLn "Showing help for the default \"show\" command." + putStrLn "Use \"help\" without leading hyphens to see other available commands." + putStrLn "\n" + kiki "show" args_raw + ('-':_):_ -> kiki "show" args_raw cmd : args | cmd `elem` map fst commands -> kiki cmd args diff --git a/lib/Kiki.hs b/lib/Kiki.hs index f89aad2..96ad9ff 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -49,7 +49,7 @@ import qualified SSHKey as SSH import CommandLine import DotLock import GnuPGAgent (Query (..)) -import qualified IntMapClass as I +-- import qualified IntMapClass as I import KeyRing hiding (pemFromPacket) import KeyDB import KeyRing.BuildKeyDB (gpgipv6addr, Hostnames, allNames) @@ -104,7 +104,22 @@ refresh root homepass = do KikiSuccess rt -> refreshCache rt mroot _ -> return () -- XXX: silent fail? -data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile } +data CommonArgsParsed = CommonArgsParsed + { cap_homespec :: Maybe String + , cap_passfd :: Maybe InputFile + , cap_fpstyle :: FingerprintStyle + } + +data FingerprintStyle + = FingerprintAuto + | Fingerprint5 + deriving (Eq,Ord,Show) + +instance Read FingerprintStyle where + readsPrec _ s = case break isSpace s of + ("auto",t) -> [(FingerprintAuto, drop 1 t)] + ("5",t) -> [(Fingerprint5, drop 1 t)] + _ -> [] streaminfo :: StreamInfo streaminfo = StreamInfo @@ -519,7 +534,8 @@ refreshCache rt rootdir = do let exportOp = passphrases <> pemSecrets <> minimalOp False (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) - Nothing) + Nothing + FingerprintAuto) where passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } pemSecrets = mempty { opFiles = Map.fromList @@ -712,6 +728,7 @@ dashdashHomedir :: Args CommonArgsParsed dashdashHomedir = CommonArgsParsed <$> optional (arg "--homedir") <*> optional (FileDesc <$> read <$> arg "--passphrase-fd") + <*> (fromMaybe FingerprintAuto <$> optional (read <$> arg "--fingerprint")) dashdashCipher :: Args SymmetricAlgorithm dashdashCipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher") diff --git a/stack.yaml b/stack.yaml index 358866d..576bc86 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,7 +4,7 @@ packages: extra-deps: # - ../openpgp-util - git: d@cryptonomic.net:public_git/openpgp-util.git - commit: 02680b1ed3b37c0cc16e04e51e613d53ff9dbab8 + commit: 47fdd273f68e0af73595daa1f3a9cdff2c8a9320 - git: d@cryptonomic.net:public_git/openpgp-asciiarmor.git commit: 9694b1b6ae3763c44d3b1361b5faa0a7b27e77a9 - modular-arithmetic-1.2.1.5 -- cgit v1.2.3