From b57248ba0189f9d91be08e02fc8e23dd29a99687 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 14 Apr 2016 22:34:28 -0400 Subject: Import DNS keys. --- KeyRing.hs | 171 +++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 121 insertions(+), 50 deletions(-) (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs index 50702ae..0bf3e32 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -131,7 +131,7 @@ import Data.Text.Encoding ( encodeUtf8 ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt - , index ) + , index, break, pack ) import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr ) import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 @@ -249,6 +249,7 @@ type Initializer = String data FileType = KeyRingFile | PEMFile | WalletFile + | DNSPresentation | Hosts -- | Use this type to indicate whether a file of type 'KeyRingFile' is expected @@ -335,9 +336,10 @@ isring :: FileType -> Bool isring (KeyRingFile {}) = True isring _ = False -ispem :: FileType -> Bool -ispem (PEMFile {}) = True -ispem _ = False +isSecretKeyFile :: FileType -> Bool +isSecretKeyFile PEMFile = True +isSecretKeyFile DNSPresentation = True +isSecretKeyFile _ = False {- pwfile :: FileType -> Maybe InputFile @@ -1183,13 +1185,13 @@ cachedContents maybePrompt ctx fd = do writeIORef ref (Just pw) return pw -importPEMKey :: +importSecretKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) - -> (FilePath, Maybe [Char], [KeyKey], t) + -> (FilePath, Maybe [Char], [KeyKey], FileType, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importPEMKey doDecrypt db' tup = do +importSecretKey doDecrypt db' tup = do try db' $ \(db',report0) -> do r <- doImport doDecrypt db' @@ -1423,7 +1425,7 @@ buildKeyDB ctx grip0 keyring = do (n,stream) <- Map.toList $ opFiles keyring grip <- maybeToList grip n <- resolveInputFile ctx n - guard $ spillable stream && ispem (typ stream) + guard $ spillable stream && isSecretKeyFile (typ stream) let us = mapMaybe usageFromFilter [fill stream,spill stream] usage <- take 1 us guard $ all (==usage) $ drop 1 us @@ -1431,9 +1433,9 @@ buildKeyDB ctx grip0 keyring = do let (topspec,subspec) = parseSpec grip usage ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer stream - return (n,subspec,ms,cmd) - imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems - db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports + return (n,subspec,ms,typ stream, cmd) + imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems + db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do r <- mergeHostFiles keyring db ctx @@ -1551,26 +1553,43 @@ decodeBlob cert = bs = pcertBlob cert key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert +extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey +extractRSAKeyFields kvs = do + let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs + n <- lookup "Modulus" kvs' + e <- lookup "PublicExponent" kvs' + d <- lookup "PrivateExponent" kvs' + p <- lookup "Prime1" kvs' -- p + q <- lookup "Prime2" kvs' -- q + dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) + dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) + u <- lookup "Coefficient" kvs' + {- + case (d,p,dmodp1) of + (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () + _ -> error "dmodp fail!" + case (d,q,dmodqminus1) of + (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () + _ -> error "dmodq fail!" + -} + return $ RSAPrivateKey + { rsaN = n + , rsaE = e + , rsaD = d + , rsaP = p + , rsaQ = q + , rsaDmodP1 = dmodp1 + , rsaDmodQminus1 = dmodqminus1 + , rsaCoefficient = u } + where + parseField blob = MPI <$> m + where m = bigendian <$> Base64.decode (Char8.unpack blob) -readSecretPEMFile :: InputFile -> IO [SecretPEMData] -readSecretPEMFile fname = do - -- warn $ fname ++ ": reading ..." - let ctx = InputFileContext "" "" - -- Note: The key's timestamp is included in it's fingerprint. - -- Therefore, we should attempt to preserve it. - stamp <- getInputFileTime ctx fname - input <- readInputFileL ctx fname - 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) - $ 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 $ SecretKeyPacket + bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs + where + nlen = length bs + +rsaToPGP stamp rsa = SecretKeyPacket { version = 4 , timestamp = fromTime stamp -- toEnum (fromEnum stamp) , key_algorithm = RSA @@ -1590,6 +1609,52 @@ readSecretPEMFile fname = do , encrypted_data = "" , is_subkey = True } + +readSecretDNSFile :: InputFile -> IO Packet +readSecretDNSFile fname = do + let ctx = InputFileContext "" "" + stamp <- getInputFileTime ctx fname + input <- readInputFileL ctx fname + let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) + . Char8.break (==':')) + $ Char8.lines input + alg = maybe RSA parseAlg $ lookup "Algorithm" kvs + parseAlg spec = case Char8.words spec of + nstr:_ -> case read (Char8.unpack nstr) :: Int of + 2 -> DH + 3 -> DSA -- SHA1 + 5 -> RSA -- SHA1 + 6 -> DSA -- NSEC3-SHA1 (RFC5155) + 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) + 8 -> RSA -- SHA256 + 10 -> RSA -- SHA512 (RFC5702) + -- 12 -> GOST + 13 -> ECDSA -- P-256 SHA256 (RFC6605) + 14 -> ECDSA -- P-384 SHA384 (RFC6605) + _ -> RSA + case alg of + RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs + + +readSecretPEMFile :: InputFile -> IO [SecretPEMData] +readSecretPEMFile fname = do + -- warn $ fname ++ ": reading ..." + let ctx = InputFileContext "" "" + -- Note: The key's timestamp is included in it's fingerprint. + -- Therefore, we should attempt to preserve it. + stamp <- getInputFileTime ctx fname + input <- readInputFileL ctx fname + 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) + $ 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 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') @@ -1603,22 +1668,28 @@ doImport :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData - -> (FilePath, Maybe [Char], [k], t) + -> (FilePath, Maybe [Char], [k], FileType, t) -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) -doImport doDecrypt db (fname,subspec,ms,_) = do +doImport doDecrypt db (fname,subspec,ms,typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do - ps <- readSecretPEMFile (ArgFile fname) - let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) - = partition (isJust . spemCert) ps + (certs,keys) <- case typ of + PEMFile -> do + ps <- readSecretPEMFile (ArgFile fname) + let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) + = partition (isJust . spemCert) ps + return (certs,keys) + DNSPresentation -> do + p <- readSecretDNSFile (ArgFile 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 -- signatures, and then the signatures are made in the next phase. -- This would let us merge annotations (like certificates) from -- seperate files. - foldM (importPEMKey tag certs) (KikiSuccess (db,[])) keys + foldM (importKey tag certs) (KikiSuccess (db,[])) keys where - importPEMKey tag certs prior key = do + importKey tag certs prior key = do try prior $ \(db,report) -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) @@ -2187,10 +2258,10 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do f <- resolveInputFile ctx f return (f,t) - let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do + let (missing,notmissing) = partition (\(_,_,ns,_,_)->null (ns >>= snd)) $ do (fname,stream) <- nonexistents guard $ isMutable stream - guard $ ispem (typ stream) + guard $ isSecretKeyFile (typ stream) usage <- usageFromFilter (fill stream) -- TODO: Error if no result? let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage -- ms will contain duplicates if a top key has multiple matching @@ -2200,12 +2271,12 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do ns = do (kk,kd) <- filterMatches topspec $ Map.toList db return (kk , subkeysForExport subspec kd) - return (fname,subspec,ns,initializer stream) - (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) + return (fname,subspec,ns,(typ stream),initializer stream) + (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd)) notmissing - exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 + exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 - ambiguity (f,topspec,subspec,_) = do + ambiguity (f,topspec,subspec,_,_) = do return $ AmbiguousKeySpec f ifnotnull (x:xs) f g = f x @@ -2217,10 +2288,10 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do do let cmds = mapMaybe getcmd missing where - getcmd (fname,subspec,ms,mcmd) = do + getcmd (fname,subspec,ms,typ,mcmd) = do cmd <- mcmd - return (fname,subspec,ms,cmd) - rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do + return (fname,subspec,ms,typ,cmd) + rs <- forM cmds $ \tup@(fname,subspec,ms,typ,cmd) -> do e <- systemEnv [ ("file",fname) , ("usage",fromMaybe "" subspec) ] cmd @@ -2228,16 +2299,16 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do ExitFailure num -> return (tup,FailedExternal num) ExitSuccess -> return (tup,ExternallyGeneratedFile) - v <- foldM (importPEMKey decrypt) + v <- foldM (importSecretKey decrypt) (KikiSuccess (db,[])) $ do - ((f,subspec,ms,cmd),r) <- rs + ((f,subspec,ms,typ,cmd),r) <- rs guard $ case r of ExternallyGeneratedFile -> True _ -> False - return (f,subspec,map fst ms,cmd) + return (f,subspec,map fst ms,typ,cmd) try v $ \(db,import_rs) -> do - return $ KikiSuccess ((db,exports), map (\((f,_,_,_),r)->(f,r)) rs + return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs) {- interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData -- cgit v1.2.3