Option to render SHA256 based fingerprints.

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