1 files changed, 121 insertions, 50 deletions

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