Unified pgp version selection for created key packets.

5 files changed, 78 insertions, 60 deletions

diff --git a/kiki.hs b/kiki.hs
index 03ea635..d4d4084 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -335,12 +335,15 @@ show_wip keyspec wkgrip db = do
 show_torhash :: FilePath -> p -> IO ()
 show_torhash pubkey _ = do
     bs <- Char8.readFile pubkey
-    let parsekey f dta  = do
+    let -- parsekey :: ((MPI -> MPI -> Packet) -> _ -> b) -> Char8.ByteString -> Maybe b
+        parsekey f dta  = do
             let mdta = fmap L.fromStrict $ functorToMaybe $ convertFromBase Base64 (Char8.toStrict dta)
             e <- decodeASN1 DER <$> mdta
             asn1 <- either (const Nothing) (Just) e
             k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
-            return $ f (packetFromPublicRSAKey undefined) k
+            return $ f (packetFromPublicRSAKey pgpver (error "torhash timestmap?")) k
+
+        pgpver = 4 :: Word8
 
         addy :: String -> String
         addy hsh = take 16 hsh ++ ".onion " ++ hsh
@@ -348,7 +351,7 @@ show_torhash pubkey _ = do
                      $ pemParser (Just "RSA PUBLIC KEY")
         pkcs8 = fmap ( parsekey (\f (RSAKey8 n e) -> f n e) . pemBlob )
                      $ pemParser (Just "PUBLIC KEY")
-        cert = fmap (fmap pcertKey . parseCertBlob False . pemBlob)
+        cert = fmap (fmap pcertKey . parseCertBlob pgpver False . pemBlob)
                      $ pemParser (Just "CERTIFICATE")
         keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs
     mapM_ (putStrLn . addy . torhash) keys
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 554c4ad..5b51a93 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -87,7 +87,8 @@ import           KeyRing.BuildKeyDB          (allNames', Hostnames,
                                               readSecretPEMFile,
                                               secp256k1_id,
                                               selectPublicKey,
-                                              usageFromFilter)
+                                              usageFromFilter,
+                                              preferredPGPVersion)
 
 import KeyRing.Types
 import KeyDB
@@ -1025,7 +1026,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                  ExitFailure num -> return (tup,FailedExternal num)
                  ExitSuccess     -> return (tup,ExternallyGeneratedFile)
 
-           v <- foldM (importSecretKey transcode)
+           v <- foldM (importSecretKey transcode (preferredPGPVersion operation))
                       (KikiSuccess (db,[])) $ do
                     ((f,subspec,ms,stream,cmd),r) <- rs
                     guard $ case r of
@@ -1058,7 +1059,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                     internalInitializer _              = Nothing
 
            mapM_ (hPutStrLn stderr) (lefts internals)
-           v <- generateInternals transcode mwk db (rights internals)
+           v <- generateInternals transcode (preferredPGPVersion operation) mwk db (rights internals)
 
            try v $ \(db,internals_rs) -> do
 
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 57647b0..c2b2703 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -79,6 +79,9 @@ import           GnuPGAgent
 import           ByteStringUtil
 import           Text.XXD
 
+preferredPGPVersion :: KeyRingOperation -> Word8
+preferredPGPVersion _ = 4 -- TODO: v5
+
 newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr]
 -- | buildKeyDB
 --
@@ -122,7 +125,7 @@ buildKeyDB ctx grip0 keyring = do
                                     _                                -> AutoAccess
                             acc -> acc
 
-        readw wk n = fmap (n,) (readPacketsFromWallet wk n)
+        readw wk n = fmap (n,) (readPacketsFromWallet (preferredPGPVersion keyring) wk n)
 
     -- KeyRings (todo: KikiCondition reporting?)
     (spilled,mwk,grip,accs,keyqs,unspilled) <- do
@@ -232,7 +235,7 @@ buildKeyDB ctx grip0 keyring = do
     imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
                               _                   -> return True)
                        pems
-    db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
+    db <- foldM (importSecretKey transcode (preferredPGPVersion keyring)) (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
     -- generate keys
@@ -240,7 +243,7 @@ buildKeyDB ctx grip0 keyring = do
                 where g (Generate _ params,v) = Just (params,v)
                       g _                     = Nothing
 
-    db <- generateInternals transcode mwk db gens
+    db <- generateInternals transcode (preferredPGPVersion keyring) mwk db gens
     try db $ \(db,reportGens) -> do
 
     r <- mergeHostFiles keyring db ctx
@@ -258,7 +261,7 @@ decodePacketList :: L.ByteString -> [Packet]
 decodePacketList some =
           case decodeOrFail some of
             Right (more,_,msg ) -> msg : decodePacketList more
-            Left  (_,_,_)       -> []
+            Left  (_,_,er)      -> {- trace ("decodePacketList: " ++ er) -} []
 
 readPacketsFromFile :: InputFileContext -> InputFile -> IO (PacketsCodec, Message)
 readPacketsFromFile ctx fname = do
@@ -274,14 +277,15 @@ readPacketsFromFile ctx fname = do
                 else tryAscii
 
 readPacketsFromWallet ::
-    Maybe Packet
+    Word8
+    -> Maybe Packet
     -> InputFile
     -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
-readPacketsFromWallet wk fname = do
+readPacketsFromWallet pgpver wk fname = do
     let ctx = InputFileContext "" ""
     timestamp <- getInputFileTime ctx fname
     input <- readInputFileL ctx fname
-    let (ks,_) = slurpWIPKeys timestamp input
+    let (ks,_) = slurpWIPKeys pgpver timestamp input
     {-
     unless (null ks) $ do
         -- decrypt wk
@@ -498,13 +502,15 @@ filterMatches spec ks = filter (matchSpec spec . snd) ks
 
 importSecretKey ::
   (PacketTranscoder)
+  -> Word8
   -> KikiCondition
        (KeyDB, [(FilePath, KikiReportAction)])
   -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
   -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
-importSecretKey transcode db' tup = do
+importSecretKey transcode pgpver db' tup = do
             try db' $ \(db',report0) -> do
             r <- doImport transcode
+                      pgpver
                       db'
                       tup
             try r $ \(db'',report) -> do
@@ -512,18 +518,19 @@ importSecretKey transcode db' tup = do
 
 generateInternals ::
     PacketTranscoder
+    -> Word8
     -> Maybe MappedPacket
     -> KeyDB
     -> [(GenerateKeyParams,StreamInfo)]
     -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
-generateInternals transcode mwk db gens = do
+generateInternals transcode pgpver mwk db gens = do
     case mwk of
         Nothing -> return $ KikiSuccess (db,[])
         Just mpkt -> do
             let kk = keykey (packet mpkt)
             transmuteAt (go kk) kk db
         where
-         go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
+         go kk (Just kd0) = foldM (generateSubkey transcode pgpver) (KikiSuccess (kd0,[])) gens
          go kk Nothing    = error "generateInternals: Key not found."
 
 mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
@@ -608,16 +615,16 @@ getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
 getInputFileTime ctx arg = error $ "getInputFileTime: Invalid argument: " ++ show arg
 
 
-slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
-slurpWIPKeys stamp "" = ([],[])
-slurpWIPKeys stamp cs =
+slurpWIPKeys :: Word8 -> Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
+slurpWIPKeys pgpver stamp "" = ([],[])
+slurpWIPKeys pgpver stamp cs =
     let (b58,xs) = Char8.span (`elem` base58chars) cs
-        mb        = decode_btc_key stamp (Char8.unpack b58)
+        mb        = decode_btc_key pgpver stamp (Char8.unpack b58)
     in if L.null b58
         then let (ys,xs') = Char8.break (`elem` base58chars) cs
-                 (ks,js)  = slurpWIPKeys stamp xs'
+                 (ks,js)  = slurpWIPKeys pgpver stamp xs'
              in (ks,ys:js)
-        else let (ks,js) = slurpWIPKeys stamp xs
+        else let (ks,js) = slurpWIPKeys pgpver stamp xs
              in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
 
 merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
@@ -807,20 +814,21 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
 
 doImport
   :: PacketTranscoder
+     -> Word8
      -> KeyDB
      -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
      -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
-doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
+doImport transcode pgpver db (fname,subspec,ms,typ -> typ,_) = do
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
     (certs,keys) <- case typ of
         PEMFile -> do
-            ps <- readSecretPEMFile fname
+            ps <- readSecretPEMFile pgpver fname
             let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
                     = partition (isJust . spemCert) ps
             return (certs,keys)
         DNSPresentation -> do
-            p <- readSecretDNSFile fname
+            p <- readSecretDNSFile pgpver fname
             return ([],[p])
     -- TODO Probably we need to move to a new design where signature
     -- packets are merged into the database in one phase with null
@@ -850,23 +858,24 @@ doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
 
 generateSubkey ::
   PacketTranscoder
+  -> Word8
   -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
   -> (GenerateKeyParams, StreamInfo)
   -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
-generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
+generateSubkey transcode pgpver kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
     try kd' $ \(kd,report0) -> do
     let subs = do
             SubKey p sigs <- Map.elems $ keySubKeys kd
             filter (has_tag tag) $ map (packet . fst) sigs
     if null subs
       then do
-        newkey <- generateKey genparam
+        newkey <- fmap (\k -> k { version = pgpver }) $ generateKey genparam
         kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
         try kdr $ \(newkd,report) -> do
         return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
       else do
         return $ KikiSuccess (kd,report0)
-generateSubkey _ kd _ = return kd
+generateSubkey _ _ kd _ = return kd
 
 allNames :: Hostnames -> [Char8.ByteString]
 allNames (Hostnames _ ns os cs) = ns ++ os ++ (maybe [] return cs)
@@ -979,8 +988,8 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
             (ns,ps) = partition isName uh
 
 decode_btc_key ::
-  Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
-decode_btc_key timestamp str = do
+  Enum timestamp => Word8 -> timestamp -> String -> Maybe (Word8, Message)
+decode_btc_key pgpver timestamp str = do
     (network_id,us) <- base58_decode str
     return . (network_id,) $ Message $ do
         let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
@@ -1005,7 +1014,7 @@ decode_btc_key timestamp str = do
                                 ,"y' ="++show y'
                                 ,"y''="++show y'']) -}
             SecretKeyPacket
-            { version = 4
+            { version = pgpver
             , timestamp = toEnum (fromEnum timestamp)
             , key_algorithm = ECDSA
             , key = [ -- public fields...
@@ -1159,8 +1168,8 @@ instance ASN1Object RSAPrivateKey where
         Left "fromASN1: RSAPrivateKey: unexpected format"
 
 
-readSecretPEMFile :: InputFile -> IO [SecretPEMData]
-readSecretPEMFile fname = do
+readSecretPEMFile :: Word8 -> InputFile -> IO [SecretPEMData]
+readSecretPEMFile pgpver fname = do
     -- warn $ fname ++ ": reading ..."
     let ctx = InputFileContext "" ""
     -- Note: The key's timestamp is included in it's fingerprint.
@@ -1170,14 +1179,14 @@ readSecretPEMFile fname = do
     let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
         pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
                     $ pemParser $ Just "RSA PRIVATE KEY"
-        cert  = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
+        cert  = fmap (fmap PEMCertificate . parseCertBlob pgpver False . pemBlob)
                     $ pemParser $ Just "CERTIFICATE"
         parseRSAPrivateKey dta = do
            let e = decodeASN1 DER dta
            asn1 <- either (const $ mzero) return e
            rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
            let _ = rsa :: RSAPrivateKey
-           return $ PEMPacket $ rsaToPGP stamp rsa
+           return $ PEMPacket $ rsaToPGP pgpver stamp rsa
         dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
         mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
         mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
@@ -1188,8 +1197,8 @@ readSecretPEMFile fname = do
     return $ dta
 
 
-readSecretDNSFile :: InputFile -> IO Packet
-readSecretDNSFile fname = do
+readSecretDNSFile :: Word8 -> InputFile -> IO Packet
+readSecretDNSFile pgpver fname = do
     let ctx = InputFileContext "" ""
     stamp <- getInputFileTime ctx fname
     input <- readInputFileL ctx fname
@@ -1211,7 +1220,7 @@ readSecretDNSFile fname = do
                                             14 -> ECDSA -- P-384 SHA384 (RFC6605)
                             _ -> RSA
     case alg of
-        RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
+        RSA -> return $ rsaToPGP pgpver stamp $ fromJust $ extractRSAKeyFields kvs
         _ -> return $ error $ "readSecretDNSFile: " ++ show alg ++ " unimplemented."
 
 spemPacket :: SecretPEMData -> Maybe Packet
@@ -1269,8 +1278,8 @@ socketFamily (SockAddrUnix _)   = AF_UNIX
 selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
 
-parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert
-parseCertBlob comp bs = do
+parseCertBlob :: Word8 -> Bool -> ByteString -> Maybe ParsedCert
+parseCertBlob pgpver comp bs = do
     asn1 <- either (const Nothing) Just
                 $ decodeASN1 DER bs
     let asn1' = drop 2 asn1
@@ -1292,7 +1301,7 @@ parseCertBlob comp bs = do
                         then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
                         else bs
             return
-                ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
+                ParsedCert { pcertKey = packetFromPublicRSAKey pgpver notBefore
                                                                (MPI $ RSA.public_n key)
                                                                (MPI $ RSA.public_e key)
                            , pcertTimestamp = notBefore
@@ -1301,9 +1310,9 @@ parseCertBlob comp bs = do
                            }
         _ -> Nothing
 
-rsaToPGP :: TimeUtil.IsUTC a => a -> RSAPrivateKey -> Packet
-rsaToPGP stamp rsa = SecretKeyPacket
-                { version = 4
+rsaToPGP :: TimeUtil.IsUTC a => Word8 -> a -> RSAPrivateKey -> Packet
+rsaToPGP pgpver stamp rsa = SecretKeyPacket
+                { version = pgpver
                 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
                 , key_algorithm = RSA
                 , key = [ -- public fields...
@@ -1364,9 +1373,9 @@ extractRSAKeyFields kvs = do
 toStrict :: L.ByteString -> S.ByteString
 toStrict = foldr1 (<>) . L.toChunks
 
-packetFromPublicRSAKey :: UTCTime -> MPI -> MPI -> Packet
-packetFromPublicRSAKey notBefore n e =
-    PublicKeyPacket { version = 4
+packetFromPublicRSAKey :: Word8 -> UTCTime -> MPI -> MPI -> Packet
+packetFromPublicRSAKey pgpver notBefore n e =
+    PublicKeyPacket { version = pgpver
                     , timestamp = round $ utcTimeToPOSIXSeconds notBefore
                     , key_algorithm = RSA
                     , key = [('n',n),('e',e)]
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index f4c4a2b..222c1bb 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -214,6 +214,7 @@ importAndRefresh root cmn cipher = do
     let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn)
                          (fmap (++"/root/.gnupg") rootdir)
         passfd = cap_passfd cmn
+        pgpver = preferredPGPVersion $ minimalOp False cmn
     (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec
     osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root"
 
@@ -224,13 +225,14 @@ importAndRefresh root cmn cipher = do
         -- Since 'runKeyRing' cannot currently cope with this situation, we will
         -- generate a master-key and very minimal secring.gpg file.
         master_un <- generateKey (GenRSA $ 4096 `div` 8 )
-            <&> \k -> MappedPacket (k { is_subkey = False }) -- Set as master-key.
+            <&> \k -> MappedPacket (k { is_subkey = False     -- Set as master-key.
+                                      , version   = pgpver }) -- Set pgp packet version.
                                    Map.empty                 -- Packet occurs in no files.
         -- The user may desire the master key is encrypted on disk but this
         -- requires a password prompt.  In order to have a decent prompt, it'd
         -- be nice if we could display the .onion hostname for the key.
         -- Therefore, we generate the tor key early.
-        tor_un <- generateKey (GenRSA $ 1024 `div` 8 )
+        tor_un <- fmap (\k -> k { version = pgpver }) $ generateKey (GenRSA $ 1024 `div` 8 )
         -- However, we'll postpone writing the tor key to the keyring and
         -- instead have the later all-in-one call to runKeyRing take care of
         -- it.  That interface does not currently provide a way to accept
@@ -270,7 +272,7 @@ importAndRefresh root cmn cipher = do
                 writeInputFileL ctx
                                 HomeSec
                                 $ encode $ Message [master]
-                putStrLn "Wrote master key"
+                putStrLn $ "Wrote master key."
                 return (FileDesc read_tor, [PassphraseMemoizer transcoder])
             er -> do
                 hPutStrLn stderr ("warning: " ++ errorString er)
@@ -279,7 +281,7 @@ importAndRefresh root cmn cipher = do
                 writeInputFileL ctx
                                 HomeSec
                                 $ encode $ Message [packet master_un]
-                putStrLn "Wrote master key"
+                putStrLn $ "Wrote unencrypted master key."
                 return (FileDesc read_tor, [])
 
     -- If the public ring does not exist, then creating an empty file is
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 473ecbc..261d7f0 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -341,10 +341,10 @@ accBindings bs = as
 
 sigpackets ::
   Monad m =>
-  Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
-sigpackets typ alg hashed unhashed = return $
+  Word8 -> Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
+sigpackets pgpver typ alg hashed unhashed = return $
     signaturePacket
-        4 -- version
+        pgpver -- version
         typ -- 0x18 subkey binding sig, or 0x19 back-signature
         alg
         SHA256
@@ -409,7 +409,8 @@ makeInducerSig
 makeInducerSig topk wkun uid extras
     = CertificationSignature (secretToPublic topk)
                              uid
-                             (sigpackets 0x13
+                             (sigpackets (version wkun)
+                                         0x13
                                          (key_algorithm wkun)
                                          subpackets
                                          subpackets_unh)
@@ -577,7 +578,8 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
     back_sig <- pgpSign (Message parsedkey)
                         (SubkeySignature wk
                                          (head parsedkey)
-                                         (sigpackets 0x19
+                                         (sigpackets (version $ head parsedkey)
+                                                     0x19
                                                      (key_algorithm $ head parsedkey)
                                                      hashed0
                                                      [IssuerPacket subgrip]))
@@ -590,10 +592,11 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
     new_sig <- pgpSign (Message [wkun])
                        (SubkeySignature wk
                                         (head parsedkey)
-                                        (sigpackets 0x18
-                                                   (key_algorithm wkun)
-                                                   hashed0
-                                                   unhashed0))
+                                        (sigpackets (version wkun)
+                                                    0x18
+                                                    (key_algorithm wkun)
+                                                    hashed0
+                                                    unhashed0))
                       SHA256
                       grip
     let newSig = do