summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs38
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 )
113import Data.Text.Encoding ( encodeUtf8 ) 113import Data.Text.Encoding ( encodeUtf8 )
114import qualified Data.Map as Map 114import qualified Data.Map as Map
115import qualified Data.ByteString.Lazy as L ( unpack, pack, null, readFile, writeFile 115import qualified Data.ByteString.Lazy as L ( unpack, pack, null, readFile, writeFile
116 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks ) 116 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, isSuffixOf )
117import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile) 117import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile)
118import qualified Crypto.Types.PubKey.ECC as ECC 118import qualified Crypto.Types.PubKey.ECC as ECC
119import qualified Codec.Binary.Base32 as Base32 119import qualified Codec.Binary.Base32 as Base32
@@ -1387,7 +1387,7 @@ readKeyFromFile False "PEM" fname = do
1387 let dta = extractPEM "RSA PRIVATE KEY" input 1387 let dta = extractPEM "RSA PRIVATE KEY" input
1388 -- Char8.putStrLn $ "dta = " <> dta 1388 -- Char8.putStrLn $ "dta = " <> dta
1389 let rsa = do 1389 let rsa = do
1390 e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) 1390 e <- decodeASN1 DER <$> dta
1391 asn1 <- either (const Nothing) Just e 1391 asn1 <- either (const Nothing) Just e
1392 k <- either (const Nothing) (Just . fst) (fromASN1 asn1) 1392 k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
1393 let _ = k :: RSAPrivateKey 1393 let _ = k :: RSAPrivateKey
@@ -1417,14 +1417,40 @@ readKeyFromFile False "PEM" fname = do
1417 } 1417 }
1418readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) 1418readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
1419 1419
1420extractPEM :: ByteString -> ByteString -> ByteString 1420data PEMBlob = PEMBlob { pemType :: ByteString
1421extractPEM typ pem = dta 1421 , pemBlob :: ByteString
1422 }
1423
1424extractPEM :: ByteString -> ByteString -> Maybe ByteString
1425extractPEM typ pem = if L.null blob then Nothing else Just blob
1426 where
1427 blob = pemBlob $ fst $ splitPEM (Just typ) $ Char8.lines pem
1428
1429splitPEM :: Maybe ByteString -> [ByteString] -> (PEMBlob,([ByteString],[ByteString]))
1430splitPEM mtyp [] = (PEMBlob "" "", ([],[]))
1431splitPEM mtyp pem =
1432 case mblob of
1433 Just blob -> (PEMBlob typ blob,(bs,drop 1 rs))
1434 Nothing -> let (ret,(ts,us)) = splitPEM mtyp $ drop 1 rs
1435 in (ret, (bs++ys++ts,us))
1422 where 1436 where
1437 mblob = L.pack <$> Base64.decode (Char8.unpack dta)
1423 dta = case ys of 1438 dta = case ys of
1424 _:dta_lines -> Char8.concat dta_lines 1439 _:dta_lines -> Char8.concat dta_lines
1425 [] -> "" 1440 [] -> ""
1426 xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) 1441 (typ,(bs,xs)) =
1427 ys = takeWhile (/="-----END " <> typ <> "-----") xs 1442 case mtyp of
1443 Just typ -> (typ,) $ span (/="-----BEGIN " <> typ <> "-----") pem
1444 Nothing -> (L.concat $ take 1 typs, xs0)
1445 where
1446 xs0 = span (not . ("-----BEGIN " `Char8.isPrefixOf`))
1447 pem
1448 typs = do
1449 x0 <- fmap (Char8.drop 11) $ take 1 (fst xs0)
1450 guard $ "-----" `L.isSuffixOf` x0
1451 let typ = Char8.take (Char8.length x0 - 5) x0
1452 return typ
1453 (ys,rs) = span (/="-----END " <> typ <> "-----") xs
1428 1454
1429 1455
1430doImport 1456doImport