From a3a517892426b0fb2cffbfcca5f749f06d710842 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 17 May 2020 16:37:45 -0400 Subject: Unified pgp version selection for created key packets. --- kiki.hs | 9 +++-- lib/KeyRing.hs | 7 ++-- lib/KeyRing/BuildKeyDB.hs | 91 ++++++++++++++++++++++++++--------------------- lib/Kiki.hs | 10 +++--- lib/Transforms.hs | 21 ++++++----- 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 -- cgit v1.2.3