splitPEM function

1 files changed, 32 insertions, 6 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index b359dab..b87b76c 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -113,7 +113,7 @@ import Data.Bits ( Bits )
 import Data.Text.Encoding ( encodeUtf8 )
 import qualified Data.Map as Map
 import qualified Data.ByteString.Lazy as L ( unpack, pack, null, readFile, writeFile
-        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks )
+        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, isSuffixOf )
 import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile)
 import qualified Crypto.Types.PubKey.ECC as ECC
 import qualified Codec.Binary.Base32 as Base32
@@ -1387,7 +1387,7 @@ readKeyFromFile False "PEM" fname = do
     let dta = extractPEM "RSA PRIVATE KEY" input
     -- Char8.putStrLn $ "dta = " <> dta
     let rsa = do
-           e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta)
+           e <- decodeASN1 DER <$> dta
            asn1 <- either (const Nothing) Just e
            k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
            let _ = k :: RSAPrivateKey
@@ -1417,14 +1417,40 @@ readKeyFromFile False "PEM" fname = do
             }
 readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
 
-extractPEM :: ByteString -> ByteString -> ByteString
-extractPEM typ pem = dta
+data PEMBlob = PEMBlob { pemType :: ByteString
+                       , pemBlob :: ByteString
+                       }
+
+extractPEM :: ByteString -> ByteString -> Maybe ByteString
+extractPEM typ pem = if L.null blob then Nothing else Just blob
+ where
+    blob = pemBlob $ fst $ splitPEM (Just typ) $ Char8.lines pem
+
+splitPEM :: Maybe ByteString -> [ByteString] -> (PEMBlob,([ByteString],[ByteString]))
+splitPEM mtyp []  = (PEMBlob "" "", ([],[]))
+splitPEM mtyp pem =
+    case mblob of
+        Just blob -> (PEMBlob typ blob,(bs,drop 1 rs))
+        Nothing -> let (ret,(ts,us)) = splitPEM mtyp $ drop 1 rs
+                   in (ret, (bs++ys++ts,us))
  where
+    mblob = L.pack <$> Base64.decode (Char8.unpack dta)
     dta = case ys of
             _:dta_lines -> Char8.concat dta_lines
             []          -> ""
-    xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem)
-    ys = takeWhile (/="-----END " <> typ <> "-----") xs
+    (typ,(bs,xs)) =
+        case mtyp of
+            Just typ -> (typ,) $ span (/="-----BEGIN " <> typ <> "-----") pem
+            Nothing  -> (L.concat $ take 1 typs, xs0)
+                         where
+                            xs0 = span (not . ("-----BEGIN " `Char8.isPrefixOf`))
+                                       pem
+                            typs = do
+                                x0 <- fmap (Char8.drop 11) $ take 1 (fst xs0)
+                                guard $ "-----" `L.isSuffixOf` x0
+                                let typ = Char8.take (Char8.length x0 - 5) x0
+                                return typ
+    (ys,rs) = span (/="-----END " <> typ <> "-----") xs
 
 
 doImport