readKeyFile "PEM" now accepts multiple keys and certs.

1 files changed, 114 insertions, 37 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index fe0f3cd..ad3e2ae 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -80,6 +80,10 @@ module KeyRing
     , accBindings
     , isSubkeySignature
     , torhash
+    , ParsedCert(..)
+    , parseCertBlob
+    , packetFromPublicRSAKey
+    , decodeBlob
     ) where
 
 import System.Environment
@@ -93,7 +97,7 @@ import Data.OpenPGP
 import Data.Functor
 import Data.Monoid
 import Data.Tuple             ( swap )
-import Data.Bits              ( (.|.) )
+import Data.Bits              ( (.|.), (.&.) )
 import Control.Applicative    ( Applicative, pure, liftA2, (<*>) )
 import System.Directory       ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
 import Control.Arrow          ( first, second )
@@ -107,17 +111,22 @@ import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
 import Data.ASN1.BitArray ( BitArray(..), toBitArray )
 import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
 import Data.ASN1.BinaryEncoding ( DER(..) )
-import Data.Time.Clock.POSIX ( POSIXTime )
+import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
+import Data.Time.Clock ( UTCTime )
 import Data.Bits ( Bits )
 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 )
-import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile)
+        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
+        , index )
+import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null )
 import qualified Crypto.Types.PubKey.ECC as ECC
 import qualified Codec.Binary.Base32 as Base32
 import qualified Codec.Binary.Base64 as Base64
 import qualified Crypto.Hash.SHA1 as SHA1
+import qualified Data.X509 as X509
+import qualified Crypto.PubKey.RSA as RSA
+import qualified Codec.Compression.GZip as GZip
 import qualified Data.Text as T ( Text, unpack, pack,
         strip, reverse, drop, break, dropAround, length )
 import qualified System.Posix.Types as Posix
@@ -1378,7 +1387,74 @@ try x body =
            Left e -> return e
            Right x -> body x
 
-readKeyFromFile :: Bool -> String -> InputFile -> IO Message
+
+data ParsedCert = ParsedCert
+    { pcertKey :: Packet
+    , pcertTimestamp :: UTCTime
+    , pcertBlob :: L.ByteString
+    }
+ deriving (Show,Eq)
+data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
+
+spemPacket (PEMPacket p) = Just p
+spemPacket _ = Nothing
+
+spemCert (PEMCertificate p) = Just p
+spemCert _ = Nothing
+
+parseCertBlob comp bs = do
+    asn1 <- either (const Nothing) Just
+                $ decodeASN1 DER bs
+    let asn1' = drop 2 asn1
+    cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
+    let _ = cert :: X509.Certificate
+        (notBefore,_) = X509.certValidity cert
+    case X509.certPubKey cert of
+        X509.PubKeyRSA key -> do
+            let withoutkey =
+                    let ekey = Char8.toStrict $ encodeASN1 DER (toASN1 key [])
+                        (pre,post) = S.breakSubstring ekey $ Char8.toStrict bs
+                        post' = S.drop (S.length ekey) post
+                        len :: Word16
+                        len = if S.null post then maxBound
+                                             else fromIntegral $ S.length pre
+                    in if len < 4096
+                        then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
+                        else bs
+            return
+                ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
+                                                               (MPI $ RSA.public_n key)
+                                                               (MPI $ RSA.public_e key)
+                           , pcertTimestamp = notBefore
+                           , pcertBlob = if comp then withoutkey
+                                                 else bs
+                           }
+        _ -> Nothing
+
+packetFromPublicRSAKey notBefore n e =
+    PublicKeyPacket { version = 4
+                    , timestamp = round $ utcTimeToPOSIXSeconds notBefore
+                    , key_algorithm = RSA
+                    , key = [('n',n),('e',e)]
+                    , is_subkey = True
+                    , v3_days_of_validity = Nothing
+                    }
+
+decodeBlob cert =
+    if 0 /= (bs `L.index` 0) .&. 0x10
+     then bs
+     else let (keypos0,bs') = L.splitAt 2 bs
+              keypos :: Word16
+              keypos = decode keypos0
+              ds = GZip.decompress bs'
+              (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
+           in prekey <> key <> postkey
+ where
+    bs = pcertBlob cert
+    key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
+
+
+readKeyFromFile :: Bool -> String -> InputFile -> IO [SecretPEMData]
 readKeyFromFile False "PEM" fname = do
     -- warn $ fname ++ ": reading ..."
     let ctx = InputFileContext "" ""
@@ -1386,37 +1462,37 @@ readKeyFromFile False "PEM" fname = do
     --       Therefore, we should attempt to preserve it.
     timestamp <- getInputFileTime ctx fname
     input <- readInputFileL ctx fname
-    let dta = fmap pemBlob $ listToMaybe $ scanAndParse (pemParser $ Just "RSA PRIVATE KEY") $ Char8.lines input
-    -- Char8.putStrLn $ "dta = " <> dta
-    let rsa = do
-           e <- decodeASN1 DER <$> dta
-           asn1 <- either (const Nothing) Just e
-           k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
-           let _ = k :: RSAPrivateKey
-           return k
-    -- putStrLn $ "rsa = "++ show rsa
-    return . Message $ do
-        rsa <- maybeToList rsa
-        return $ SecretKeyPacket
-            { version = 4
-            , timestamp = toEnum (fromEnum timestamp)
-            , key_algorithm = RSA
-            , key = [ -- public fields...
-                     ('n',rsaN rsa)
-                    ,('e',rsaE rsa)
-                    -- secret fields
-                    ,('d',rsaD rsa)
-                    ,('p',rsaQ rsa) -- Note: p & q swapped
-                    ,('q',rsaP rsa) -- Note: p & q swapped
-                    ,('u',rsaCoefficient rsa)
-                    ]
-            -- , ecc_curve = def
-            , s2k_useage = 0
-            , s2k = S2K 100 ""
-            , symmetric_algorithm = Unencrypted
-            , encrypted_data = ""
-            , is_subkey = True
-            }
+    let dta = catMaybes $ scanAndParse pkcs1 $ Char8.lines input
+        pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
+                    $ pemParser $ Just "RSA PRIVATE KEY"
+        cert  = fmap (fmap (PEMPacket . pcertKey) . 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
+                { version = 4
+                , timestamp = toEnum (fromEnum timestamp)
+                , key_algorithm = RSA
+                , key = [ -- public fields...
+                         ('n',rsaN rsa)
+                        ,('e',rsaE rsa)
+                        -- secret fields
+                        ,('d',rsaD rsa)
+                        ,('p',rsaQ rsa) -- Note: p & q swapped
+                        ,('q',rsaP rsa) -- Note: p & q swapped
+                        ,('u',rsaCoefficient rsa)
+                        ]
+                -- , ecc_curve = def
+                , s2k_useage = 0
+                , s2k = S2K 100 ""
+                , symmetric_algorithm = Unencrypted
+                , encrypted_data = ""
+                , is_subkey = True
+                }
+    return dta
 readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
 
 doImport
@@ -1429,7 +1505,8 @@ doImport doDecrypt db (fname,subspec,ms,_) = do
     let fetchkey = readKeyFromFile False "PEM" (ArgFile fname)
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
-    Message parsedkey <- fetchkey
+    ps <- fetchkey
+    let parsedkey = mapMaybe spemPacket ps
     flip (maybe $ return $ KikiSuccess (db,[]))
          (listToMaybe parsedkey) $ \key -> do
     let (m0,tailms) = splitAt 1 ms