1 files changed, 50 insertions, 41 deletions

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)]