diff options
author | Joe Crayne <joe@jerkface.net> | 2020-05-17 16:37:45 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-05-19 12:52:08 -0400 |
commit | a3a517892426b0fb2cffbfcca5f749f06d710842 (patch) | |
tree | 094dce3373b4b4ce1abbc2b0db85135771b8169f /lib | |
parent | 99ff0f49d3f668acf4a7d9e7f4da275a1cb327c2 (diff) |
Unified pgp version selection for created key packets.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/KeyRing.hs | 7 | ||||
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 91 | ||||
-rw-r--r-- | lib/Kiki.hs | 10 | ||||
-rw-r--r-- | lib/Transforms.hs | 21 |
4 files changed, 72 insertions, 57 deletions
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, | |||
87 | readSecretPEMFile, | 87 | readSecretPEMFile, |
88 | secp256k1_id, | 88 | secp256k1_id, |
89 | selectPublicKey, | 89 | selectPublicKey, |
90 | usageFromFilter) | 90 | usageFromFilter, |
91 | preferredPGPVersion) | ||
91 | 92 | ||
92 | import KeyRing.Types | 93 | import KeyRing.Types |
93 | import KeyDB | 94 | import KeyDB |
@@ -1025,7 +1026,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do | |||
1025 | ExitFailure num -> return (tup,FailedExternal num) | 1026 | ExitFailure num -> return (tup,FailedExternal num) |
1026 | ExitSuccess -> return (tup,ExternallyGeneratedFile) | 1027 | ExitSuccess -> return (tup,ExternallyGeneratedFile) |
1027 | 1028 | ||
1028 | v <- foldM (importSecretKey transcode) | 1029 | v <- foldM (importSecretKey transcode (preferredPGPVersion operation)) |
1029 | (KikiSuccess (db,[])) $ do | 1030 | (KikiSuccess (db,[])) $ do |
1030 | ((f,subspec,ms,stream,cmd),r) <- rs | 1031 | ((f,subspec,ms,stream,cmd),r) <- rs |
1031 | guard $ case r of | 1032 | guard $ case r of |
@@ -1058,7 +1059,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do | |||
1058 | internalInitializer _ = Nothing | 1059 | internalInitializer _ = Nothing |
1059 | 1060 | ||
1060 | mapM_ (hPutStrLn stderr) (lefts internals) | 1061 | mapM_ (hPutStrLn stderr) (lefts internals) |
1061 | v <- generateInternals transcode mwk db (rights internals) | 1062 | v <- generateInternals transcode (preferredPGPVersion operation) mwk db (rights internals) |
1062 | 1063 | ||
1063 | try v $ \(db,internals_rs) -> do | 1064 | try v $ \(db,internals_rs) -> do |
1064 | 1065 | ||
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 | |||
79 | import ByteStringUtil | 79 | import ByteStringUtil |
80 | import Text.XXD | 80 | import Text.XXD |
81 | 81 | ||
82 | preferredPGPVersion :: KeyRingOperation -> Word8 | ||
83 | preferredPGPVersion _ = 4 -- TODO: v5 | ||
84 | |||
82 | newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr] | 85 | newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr] |
83 | -- | buildKeyDB | 86 | -- | buildKeyDB |
84 | -- | 87 | -- |
@@ -122,7 +125,7 @@ buildKeyDB ctx grip0 keyring = do | |||
122 | _ -> AutoAccess | 125 | _ -> AutoAccess |
123 | acc -> acc | 126 | acc -> acc |
124 | 127 | ||
125 | readw wk n = fmap (n,) (readPacketsFromWallet wk n) | 128 | readw wk n = fmap (n,) (readPacketsFromWallet (preferredPGPVersion keyring) wk n) |
126 | 129 | ||
127 | -- KeyRings (todo: KikiCondition reporting?) | 130 | -- KeyRings (todo: KikiCondition reporting?) |
128 | (spilled,mwk,grip,accs,keyqs,unspilled) <- do | 131 | (spilled,mwk,grip,accs,keyqs,unspilled) <- do |
@@ -232,7 +235,7 @@ buildKeyDB ctx grip0 keyring = do | |||
232 | imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n | 235 | imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n |
233 | _ -> return True) | 236 | _ -> return True) |
234 | pems | 237 | pems |
235 | db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports | 238 | db <- foldM (importSecretKey transcode (preferredPGPVersion keyring)) (KikiSuccess (db,[])) imports |
236 | try db $ \(db,reportPEMs) -> do | 239 | try db $ \(db,reportPEMs) -> do |
237 | 240 | ||
238 | -- generate keys | 241 | -- generate keys |
@@ -240,7 +243,7 @@ buildKeyDB ctx grip0 keyring = do | |||
240 | where g (Generate _ params,v) = Just (params,v) | 243 | where g (Generate _ params,v) = Just (params,v) |
241 | g _ = Nothing | 244 | g _ = Nothing |
242 | 245 | ||
243 | db <- generateInternals transcode mwk db gens | 246 | db <- generateInternals transcode (preferredPGPVersion keyring) mwk db gens |
244 | try db $ \(db,reportGens) -> do | 247 | try db $ \(db,reportGens) -> do |
245 | 248 | ||
246 | r <- mergeHostFiles keyring db ctx | 249 | r <- mergeHostFiles keyring db ctx |
@@ -258,7 +261,7 @@ decodePacketList :: L.ByteString -> [Packet] | |||
258 | decodePacketList some = | 261 | decodePacketList some = |
259 | case decodeOrFail some of | 262 | case decodeOrFail some of |
260 | Right (more,_,msg ) -> msg : decodePacketList more | 263 | Right (more,_,msg ) -> msg : decodePacketList more |
261 | Left (_,_,_) -> [] | 264 | Left (_,_,er) -> {- trace ("decodePacketList: " ++ er) -} [] |
262 | 265 | ||
263 | readPacketsFromFile :: InputFileContext -> InputFile -> IO (PacketsCodec, Message) | 266 | readPacketsFromFile :: InputFileContext -> InputFile -> IO (PacketsCodec, Message) |
264 | readPacketsFromFile ctx fname = do | 267 | readPacketsFromFile ctx fname = do |
@@ -274,14 +277,15 @@ readPacketsFromFile ctx fname = do | |||
274 | else tryAscii | 277 | else tryAscii |
275 | 278 | ||
276 | readPacketsFromWallet :: | 279 | readPacketsFromWallet :: |
277 | Maybe Packet | 280 | Word8 |
281 | -> Maybe Packet | ||
278 | -> InputFile | 282 | -> InputFile |
279 | -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] | 283 | -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] |
280 | readPacketsFromWallet wk fname = do | 284 | readPacketsFromWallet pgpver wk fname = do |
281 | let ctx = InputFileContext "" "" | 285 | let ctx = InputFileContext "" "" |
282 | timestamp <- getInputFileTime ctx fname | 286 | timestamp <- getInputFileTime ctx fname |
283 | input <- readInputFileL ctx fname | 287 | input <- readInputFileL ctx fname |
284 | let (ks,_) = slurpWIPKeys timestamp input | 288 | let (ks,_) = slurpWIPKeys pgpver timestamp input |
285 | {- | 289 | {- |
286 | unless (null ks) $ do | 290 | unless (null ks) $ do |
287 | -- decrypt wk | 291 | -- decrypt wk |
@@ -498,13 +502,15 @@ filterMatches spec ks = filter (matchSpec spec . snd) ks | |||
498 | 502 | ||
499 | importSecretKey :: | 503 | importSecretKey :: |
500 | (PacketTranscoder) | 504 | (PacketTranscoder) |
505 | -> Word8 | ||
501 | -> KikiCondition | 506 | -> KikiCondition |
502 | (KeyDB, [(FilePath, KikiReportAction)]) | 507 | (KeyDB, [(FilePath, KikiReportAction)]) |
503 | -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) | 508 | -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) |
504 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) | 509 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) |
505 | importSecretKey transcode db' tup = do | 510 | importSecretKey transcode pgpver db' tup = do |
506 | try db' $ \(db',report0) -> do | 511 | try db' $ \(db',report0) -> do |
507 | r <- doImport transcode | 512 | r <- doImport transcode |
513 | pgpver | ||
508 | db' | 514 | db' |
509 | tup | 515 | tup |
510 | try r $ \(db'',report) -> do | 516 | try r $ \(db'',report) -> do |
@@ -512,18 +518,19 @@ importSecretKey transcode db' tup = do | |||
512 | 518 | ||
513 | generateInternals :: | 519 | generateInternals :: |
514 | PacketTranscoder | 520 | PacketTranscoder |
521 | -> Word8 | ||
515 | -> Maybe MappedPacket | 522 | -> Maybe MappedPacket |
516 | -> KeyDB | 523 | -> KeyDB |
517 | -> [(GenerateKeyParams,StreamInfo)] | 524 | -> [(GenerateKeyParams,StreamInfo)] |
518 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) | 525 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) |
519 | generateInternals transcode mwk db gens = do | 526 | generateInternals transcode pgpver mwk db gens = do |
520 | case mwk of | 527 | case mwk of |
521 | Nothing -> return $ KikiSuccess (db,[]) | 528 | Nothing -> return $ KikiSuccess (db,[]) |
522 | Just mpkt -> do | 529 | Just mpkt -> do |
523 | let kk = keykey (packet mpkt) | 530 | let kk = keykey (packet mpkt) |
524 | transmuteAt (go kk) kk db | 531 | transmuteAt (go kk) kk db |
525 | where | 532 | where |
526 | go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens | 533 | go kk (Just kd0) = foldM (generateSubkey transcode pgpver) (KikiSuccess (kd0,[])) gens |
527 | go kk Nothing = error "generateInternals: Key not found." | 534 | go kk Nothing = error "generateInternals: Key not found." |
528 | 535 | ||
529 | mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext | 536 | mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext |
@@ -608,16 +615,16 @@ getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do | |||
608 | getInputFileTime ctx arg = error $ "getInputFileTime: Invalid argument: " ++ show arg | 615 | getInputFileTime ctx arg = error $ "getInputFileTime: Invalid argument: " ++ show arg |
609 | 616 | ||
610 | 617 | ||
611 | slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) | 618 | slurpWIPKeys :: Word8 -> Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) |
612 | slurpWIPKeys stamp "" = ([],[]) | 619 | slurpWIPKeys pgpver stamp "" = ([],[]) |
613 | slurpWIPKeys stamp cs = | 620 | slurpWIPKeys pgpver stamp cs = |
614 | let (b58,xs) = Char8.span (`elem` base58chars) cs | 621 | let (b58,xs) = Char8.span (`elem` base58chars) cs |
615 | mb = decode_btc_key stamp (Char8.unpack b58) | 622 | mb = decode_btc_key pgpver stamp (Char8.unpack b58) |
616 | in if L.null b58 | 623 | in if L.null b58 |
617 | then let (ys,xs') = Char8.break (`elem` base58chars) cs | 624 | then let (ys,xs') = Char8.break (`elem` base58chars) cs |
618 | (ks,js) = slurpWIPKeys stamp xs' | 625 | (ks,js) = slurpWIPKeys pgpver stamp xs' |
619 | in (ks,ys:js) | 626 | in (ks,ys:js) |
620 | else let (ks,js) = slurpWIPKeys stamp xs | 627 | else let (ks,js) = slurpWIPKeys pgpver stamp xs |
621 | in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb | 628 | in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb |
622 | 629 | ||
623 | merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] | 630 | merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] |
@@ -807,20 +814,21 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us | |||
807 | 814 | ||
808 | doImport | 815 | doImport |
809 | :: PacketTranscoder | 816 | :: PacketTranscoder |
817 | -> Word8 | ||
810 | -> KeyDB | 818 | -> KeyDB |
811 | -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) | 819 | -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) |
812 | -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) | 820 | -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) |
813 | doImport transcode db (fname,subspec,ms,typ -> typ,_) = do | 821 | doImport transcode pgpver db (fname,subspec,ms,typ -> typ,_) = do |
814 | flip (maybe $ return CannotImportMasterKey) | 822 | flip (maybe $ return CannotImportMasterKey) |
815 | subspec $ \tag -> do | 823 | subspec $ \tag -> do |
816 | (certs,keys) <- case typ of | 824 | (certs,keys) <- case typ of |
817 | PEMFile -> do | 825 | PEMFile -> do |
818 | ps <- readSecretPEMFile fname | 826 | ps <- readSecretPEMFile pgpver fname |
819 | let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) | 827 | let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) |
820 | = partition (isJust . spemCert) ps | 828 | = partition (isJust . spemCert) ps |
821 | return (certs,keys) | 829 | return (certs,keys) |
822 | DNSPresentation -> do | 830 | DNSPresentation -> do |
823 | p <- readSecretDNSFile fname | 831 | p <- readSecretDNSFile pgpver fname |
824 | return ([],[p]) | 832 | return ([],[p]) |
825 | -- TODO Probably we need to move to a new design where signature | 833 | -- TODO Probably we need to move to a new design where signature |
826 | -- packets are merged into the database in one phase with null | 834 | -- packets are merged into the database in one phase with null |
@@ -850,23 +858,24 @@ doImport transcode db (fname,subspec,ms,typ -> typ,_) = do | |||
850 | 858 | ||
851 | generateSubkey :: | 859 | generateSubkey :: |
852 | PacketTranscoder | 860 | PacketTranscoder |
861 | -> Word8 | ||
853 | -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db | 862 | -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db |
854 | -> (GenerateKeyParams, StreamInfo) | 863 | -> (GenerateKeyParams, StreamInfo) |
855 | -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) | 864 | -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) |
856 | generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do | 865 | generateSubkey transcode pgpver kd' (genparam,StreamInfo { spill = KF_Match tag }) = do |
857 | try kd' $ \(kd,report0) -> do | 866 | try kd' $ \(kd,report0) -> do |
858 | let subs = do | 867 | let subs = do |
859 | SubKey p sigs <- Map.elems $ keySubKeys kd | 868 | SubKey p sigs <- Map.elems $ keySubKeys kd |
860 | filter (has_tag tag) $ map (packet . fst) sigs | 869 | filter (has_tag tag) $ map (packet . fst) sigs |
861 | if null subs | 870 | if null subs |
862 | then do | 871 | then do |
863 | newkey <- generateKey genparam | 872 | newkey <- fmap (\k -> k { version = pgpver }) $ generateKey genparam |
864 | kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey | 873 | kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey |
865 | try kdr $ \(newkd,report) -> do | 874 | try kdr $ \(newkd,report) -> do |
866 | return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) | 875 | return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) |
867 | else do | 876 | else do |
868 | return $ KikiSuccess (kd,report0) | 877 | return $ KikiSuccess (kd,report0) |
869 | generateSubkey _ kd _ = return kd | 878 | generateSubkey _ _ kd _ = return kd |
870 | 879 | ||
871 | allNames :: Hostnames -> [Char8.ByteString] | 880 | allNames :: Hostnames -> [Char8.ByteString] |
872 | allNames (Hostnames _ ns os cs) = ns ++ os ++ (maybe [] return cs) | 881 | allNames (Hostnames _ ns os cs) = ns ++ os ++ (maybe [] return cs) |
@@ -979,8 +988,8 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops | |||
979 | (ns,ps) = partition isName uh | 988 | (ns,ps) = partition isName uh |
980 | 989 | ||
981 | decode_btc_key :: | 990 | decode_btc_key :: |
982 | Enum timestamp => timestamp -> String -> Maybe (Word8, Message) | 991 | Enum timestamp => Word8 -> timestamp -> String -> Maybe (Word8, Message) |
983 | decode_btc_key timestamp str = do | 992 | decode_btc_key pgpver timestamp str = do |
984 | (network_id,us) <- base58_decode str | 993 | (network_id,us) <- base58_decode str |
985 | return . (network_id,) $ Message $ do | 994 | return . (network_id,) $ Message $ do |
986 | let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) | 995 | let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) |
@@ -1005,7 +1014,7 @@ decode_btc_key timestamp str = do | |||
1005 | ,"y' ="++show y' | 1014 | ,"y' ="++show y' |
1006 | ,"y''="++show y'']) -} | 1015 | ,"y''="++show y'']) -} |
1007 | SecretKeyPacket | 1016 | SecretKeyPacket |
1008 | { version = 4 | 1017 | { version = pgpver |
1009 | , timestamp = toEnum (fromEnum timestamp) | 1018 | , timestamp = toEnum (fromEnum timestamp) |
1010 | , key_algorithm = ECDSA | 1019 | , key_algorithm = ECDSA |
1011 | , key = [ -- public fields... | 1020 | , key = [ -- public fields... |
@@ -1159,8 +1168,8 @@ instance ASN1Object RSAPrivateKey where | |||
1159 | Left "fromASN1: RSAPrivateKey: unexpected format" | 1168 | Left "fromASN1: RSAPrivateKey: unexpected format" |
1160 | 1169 | ||
1161 | 1170 | ||
1162 | readSecretPEMFile :: InputFile -> IO [SecretPEMData] | 1171 | readSecretPEMFile :: Word8 -> InputFile -> IO [SecretPEMData] |
1163 | readSecretPEMFile fname = do | 1172 | readSecretPEMFile pgpver fname = do |
1164 | -- warn $ fname ++ ": reading ..." | 1173 | -- warn $ fname ++ ": reading ..." |
1165 | let ctx = InputFileContext "" "" | 1174 | let ctx = InputFileContext "" "" |
1166 | -- Note: The key's timestamp is included in it's fingerprint. | 1175 | -- Note: The key's timestamp is included in it's fingerprint. |
@@ -1170,14 +1179,14 @@ readSecretPEMFile fname = do | |||
1170 | let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input | 1179 | let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input |
1171 | pkcs1 = fmap (parseRSAPrivateKey . pemBlob) | 1180 | pkcs1 = fmap (parseRSAPrivateKey . pemBlob) |
1172 | $ pemParser $ Just "RSA PRIVATE KEY" | 1181 | $ pemParser $ Just "RSA PRIVATE KEY" |
1173 | cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) | 1182 | cert = fmap (fmap PEMCertificate . parseCertBlob pgpver False . pemBlob) |
1174 | $ pemParser $ Just "CERTIFICATE" | 1183 | $ pemParser $ Just "CERTIFICATE" |
1175 | parseRSAPrivateKey dta = do | 1184 | parseRSAPrivateKey dta = do |
1176 | let e = decodeASN1 DER dta | 1185 | let e = decodeASN1 DER dta |
1177 | asn1 <- either (const $ mzero) return e | 1186 | asn1 <- either (const $ mzero) return e |
1178 | rsa <- either (const mzero) (return . fst) (fromASN1 asn1) | 1187 | rsa <- either (const mzero) (return . fst) (fromASN1 asn1) |
1179 | let _ = rsa :: RSAPrivateKey | 1188 | let _ = rsa :: RSAPrivateKey |
1180 | return $ PEMPacket $ rsaToPGP stamp rsa | 1189 | return $ PEMPacket $ rsaToPGP pgpver stamp rsa |
1181 | dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta | 1190 | dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta |
1182 | mergeDate (_,obj) (Left tm) = (fromTime tm,obj) | 1191 | mergeDate (_,obj) (Left tm) = (fromTime tm,obj) |
1183 | mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') | 1192 | mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') |
@@ -1188,8 +1197,8 @@ readSecretPEMFile fname = do | |||
1188 | return $ dta | 1197 | return $ dta |
1189 | 1198 | ||
1190 | 1199 | ||
1191 | readSecretDNSFile :: InputFile -> IO Packet | 1200 | readSecretDNSFile :: Word8 -> InputFile -> IO Packet |
1192 | readSecretDNSFile fname = do | 1201 | readSecretDNSFile pgpver fname = do |
1193 | let ctx = InputFileContext "" "" | 1202 | let ctx = InputFileContext "" "" |
1194 | stamp <- getInputFileTime ctx fname | 1203 | stamp <- getInputFileTime ctx fname |
1195 | input <- readInputFileL ctx fname | 1204 | input <- readInputFileL ctx fname |
@@ -1211,7 +1220,7 @@ readSecretDNSFile fname = do | |||
1211 | 14 -> ECDSA -- P-384 SHA384 (RFC6605) | 1220 | 14 -> ECDSA -- P-384 SHA384 (RFC6605) |
1212 | _ -> RSA | 1221 | _ -> RSA |
1213 | case alg of | 1222 | case alg of |
1214 | RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs | 1223 | RSA -> return $ rsaToPGP pgpver stamp $ fromJust $ extractRSAKeyFields kvs |
1215 | _ -> return $ error $ "readSecretDNSFile: " ++ show alg ++ " unimplemented." | 1224 | _ -> return $ error $ "readSecretDNSFile: " ++ show alg ++ " unimplemented." |
1216 | 1225 | ||
1217 | spemPacket :: SecretPEMData -> Maybe Packet | 1226 | spemPacket :: SecretPEMData -> Maybe Packet |
@@ -1269,8 +1278,8 @@ socketFamily (SockAddrUnix _) = AF_UNIX | |||
1269 | selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet | 1278 | selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet |
1270 | selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db | 1279 | selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db |
1271 | 1280 | ||
1272 | parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert | 1281 | parseCertBlob :: Word8 -> Bool -> ByteString -> Maybe ParsedCert |
1273 | parseCertBlob comp bs = do | 1282 | parseCertBlob pgpver comp bs = do |
1274 | asn1 <- either (const Nothing) Just | 1283 | asn1 <- either (const Nothing) Just |
1275 | $ decodeASN1 DER bs | 1284 | $ decodeASN1 DER bs |
1276 | let asn1' = drop 2 asn1 | 1285 | let asn1' = drop 2 asn1 |
@@ -1292,7 +1301,7 @@ parseCertBlob comp bs = do | |||
1292 | then encode len <> GZip.compress (Char8.fromChunks [pre,post']) | 1301 | then encode len <> GZip.compress (Char8.fromChunks [pre,post']) |
1293 | else bs | 1302 | else bs |
1294 | return | 1303 | return |
1295 | ParsedCert { pcertKey = packetFromPublicRSAKey notBefore | 1304 | ParsedCert { pcertKey = packetFromPublicRSAKey pgpver notBefore |
1296 | (MPI $ RSA.public_n key) | 1305 | (MPI $ RSA.public_n key) |
1297 | (MPI $ RSA.public_e key) | 1306 | (MPI $ RSA.public_e key) |
1298 | , pcertTimestamp = notBefore | 1307 | , pcertTimestamp = notBefore |
@@ -1301,9 +1310,9 @@ parseCertBlob comp bs = do | |||
1301 | } | 1310 | } |
1302 | _ -> Nothing | 1311 | _ -> Nothing |
1303 | 1312 | ||
1304 | rsaToPGP :: TimeUtil.IsUTC a => a -> RSAPrivateKey -> Packet | 1313 | rsaToPGP :: TimeUtil.IsUTC a => Word8 -> a -> RSAPrivateKey -> Packet |
1305 | rsaToPGP stamp rsa = SecretKeyPacket | 1314 | rsaToPGP pgpver stamp rsa = SecretKeyPacket |
1306 | { version = 4 | 1315 | { version = pgpver |
1307 | , timestamp = fromTime stamp -- toEnum (fromEnum stamp) | 1316 | , timestamp = fromTime stamp -- toEnum (fromEnum stamp) |
1308 | , key_algorithm = RSA | 1317 | , key_algorithm = RSA |
1309 | , key = [ -- public fields... | 1318 | , key = [ -- public fields... |
@@ -1364,9 +1373,9 @@ extractRSAKeyFields kvs = do | |||
1364 | toStrict :: L.ByteString -> S.ByteString | 1373 | toStrict :: L.ByteString -> S.ByteString |
1365 | toStrict = foldr1 (<>) . L.toChunks | 1374 | toStrict = foldr1 (<>) . L.toChunks |
1366 | 1375 | ||
1367 | packetFromPublicRSAKey :: UTCTime -> MPI -> MPI -> Packet | 1376 | packetFromPublicRSAKey :: Word8 -> UTCTime -> MPI -> MPI -> Packet |
1368 | packetFromPublicRSAKey notBefore n e = | 1377 | packetFromPublicRSAKey pgpver notBefore n e = |
1369 | PublicKeyPacket { version = 4 | 1378 | PublicKeyPacket { version = pgpver |
1370 | , timestamp = round $ utcTimeToPOSIXSeconds notBefore | 1379 | , timestamp = round $ utcTimeToPOSIXSeconds notBefore |
1371 | , key_algorithm = RSA | 1380 | , key_algorithm = RSA |
1372 | , key = [('n',n),('e',e)] | 1381 | , 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 | |||
214 | let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn) | 214 | let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn) |
215 | (fmap (++"/root/.gnupg") rootdir) | 215 | (fmap (++"/root/.gnupg") rootdir) |
216 | passfd = cap_passfd cmn | 216 | passfd = cap_passfd cmn |
217 | pgpver = preferredPGPVersion $ minimalOp False cmn | ||
217 | (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec | 218 | (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec |
218 | osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root" | 219 | osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root" |
219 | 220 | ||
@@ -224,13 +225,14 @@ importAndRefresh root cmn cipher = do | |||
224 | -- Since 'runKeyRing' cannot currently cope with this situation, we will | 225 | -- Since 'runKeyRing' cannot currently cope with this situation, we will |
225 | -- generate a master-key and very minimal secring.gpg file. | 226 | -- generate a master-key and very minimal secring.gpg file. |
226 | master_un <- generateKey (GenRSA $ 4096 `div` 8 ) | 227 | master_un <- generateKey (GenRSA $ 4096 `div` 8 ) |
227 | <&> \k -> MappedPacket (k { is_subkey = False }) -- Set as master-key. | 228 | <&> \k -> MappedPacket (k { is_subkey = False -- Set as master-key. |
229 | , version = pgpver }) -- Set pgp packet version. | ||
228 | Map.empty -- Packet occurs in no files. | 230 | Map.empty -- Packet occurs in no files. |
229 | -- The user may desire the master key is encrypted on disk but this | 231 | -- The user may desire the master key is encrypted on disk but this |
230 | -- requires a password prompt. In order to have a decent prompt, it'd | 232 | -- requires a password prompt. In order to have a decent prompt, it'd |
231 | -- be nice if we could display the .onion hostname for the key. | 233 | -- be nice if we could display the .onion hostname for the key. |
232 | -- Therefore, we generate the tor key early. | 234 | -- Therefore, we generate the tor key early. |
233 | tor_un <- generateKey (GenRSA $ 1024 `div` 8 ) | 235 | tor_un <- fmap (\k -> k { version = pgpver }) $ generateKey (GenRSA $ 1024 `div` 8 ) |
234 | -- However, we'll postpone writing the tor key to the keyring and | 236 | -- However, we'll postpone writing the tor key to the keyring and |
235 | -- instead have the later all-in-one call to runKeyRing take care of | 237 | -- instead have the later all-in-one call to runKeyRing take care of |
236 | -- it. That interface does not currently provide a way to accept | 238 | -- it. That interface does not currently provide a way to accept |
@@ -270,7 +272,7 @@ importAndRefresh root cmn cipher = do | |||
270 | writeInputFileL ctx | 272 | writeInputFileL ctx |
271 | HomeSec | 273 | HomeSec |
272 | $ encode $ Message [master] | 274 | $ encode $ Message [master] |
273 | putStrLn "Wrote master key" | 275 | putStrLn $ "Wrote master key." |
274 | return (FileDesc read_tor, [PassphraseMemoizer transcoder]) | 276 | return (FileDesc read_tor, [PassphraseMemoizer transcoder]) |
275 | er -> do | 277 | er -> do |
276 | hPutStrLn stderr ("warning: " ++ errorString er) | 278 | hPutStrLn stderr ("warning: " ++ errorString er) |
@@ -279,7 +281,7 @@ importAndRefresh root cmn cipher = do | |||
279 | writeInputFileL ctx | 281 | writeInputFileL ctx |
280 | HomeSec | 282 | HomeSec |
281 | $ encode $ Message [packet master_un] | 283 | $ encode $ Message [packet master_un] |
282 | putStrLn "Wrote master key" | 284 | putStrLn $ "Wrote unencrypted master key." |
283 | return (FileDesc read_tor, []) | 285 | return (FileDesc read_tor, []) |
284 | 286 | ||
285 | -- If the public ring does not exist, then creating an empty file is | 287 | -- 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 | |||
341 | 341 | ||
342 | sigpackets :: | 342 | sigpackets :: |
343 | Monad m => | 343 | Monad m => |
344 | Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet | 344 | Word8 -> Word8 -> KeyAlgorithm -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet |
345 | sigpackets typ alg hashed unhashed = return $ | 345 | sigpackets pgpver typ alg hashed unhashed = return $ |
346 | signaturePacket | 346 | signaturePacket |
347 | 4 -- version | 347 | pgpver -- version |
348 | typ -- 0x18 subkey binding sig, or 0x19 back-signature | 348 | typ -- 0x18 subkey binding sig, or 0x19 back-signature |
349 | alg | 349 | alg |
350 | SHA256 | 350 | SHA256 |
@@ -409,7 +409,8 @@ makeInducerSig | |||
409 | makeInducerSig topk wkun uid extras | 409 | makeInducerSig topk wkun uid extras |
410 | = CertificationSignature (secretToPublic topk) | 410 | = CertificationSignature (secretToPublic topk) |
411 | uid | 411 | uid |
412 | (sigpackets 0x13 | 412 | (sigpackets (version wkun) |
413 | 0x13 | ||
413 | (key_algorithm wkun) | 414 | (key_algorithm wkun) |
414 | subpackets | 415 | subpackets |
415 | subpackets_unh) | 416 | subpackets_unh) |
@@ -577,7 +578,8 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
577 | back_sig <- pgpSign (Message parsedkey) | 578 | back_sig <- pgpSign (Message parsedkey) |
578 | (SubkeySignature wk | 579 | (SubkeySignature wk |
579 | (head parsedkey) | 580 | (head parsedkey) |
580 | (sigpackets 0x19 | 581 | (sigpackets (version $ head parsedkey) |
582 | 0x19 | ||
581 | (key_algorithm $ head parsedkey) | 583 | (key_algorithm $ head parsedkey) |
582 | hashed0 | 584 | hashed0 |
583 | [IssuerPacket subgrip])) | 585 | [IssuerPacket subgrip])) |
@@ -590,10 +592,11 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
590 | new_sig <- pgpSign (Message [wkun]) | 592 | new_sig <- pgpSign (Message [wkun]) |
591 | (SubkeySignature wk | 593 | (SubkeySignature wk |
592 | (head parsedkey) | 594 | (head parsedkey) |
593 | (sigpackets 0x18 | 595 | (sigpackets (version wkun) |
594 | (key_algorithm wkun) | 596 | 0x18 |
595 | hashed0 | 597 | (key_algorithm wkun) |
596 | unhashed0)) | 598 | hashed0 |
599 | unhashed0)) | ||
597 | SHA256 | 600 | SHA256 |
598 | grip | 601 | grip |
599 | let newSig = do | 602 | let newSig = do |