{-# LANGUAGE OverloadedStrings #-}
module Data.PEM.Parser
( pemParseBS
, pemParseLBS
) where
import Data.Either (partitionEithers)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Base64.Lazy as Base64
import Data.PEM.Types
type Line = L.ByteString
parseOnePEM :: [Line] -> Either (Maybe String) (PEM, [Line])
parseOnePEM = findPem
where beginMarker = "-----BEGIN "
endMarker = "-----END "
findPem [] = Left Nothing
findPem (l:ls) = case beginMarker `prefixEat` l of
Nothing -> findPem ls
Just n -> getPemName getPemHeaders n ls
getPemName next n ls =
let (name, r) = L.break (== 0x2d) n in
case r of
"-----" -> next (LC.unpack name) ls
_ -> Left $ Just "invalid PEM delimiter found"
getPemHeaders name lbs =
case getPemHeaderLoop lbs of
Left err -> Left err
Right (hdrs, lbs2) -> getPemContent name hdrs [] lbs2
where getPemHeaderLoop [] = Left $ Just "invalid PEM: no more content in header context"
getPemHeaderLoop (r:rs) =
Right ([], r:rs)
getPemContent name hdrs contentLines lbs =
case lbs of
[] -> Left $ Just "invalid PEM: no end marker found"
(l:ls) -> case endMarker `prefixEat` l of
Nothing ->
let content = Base64.decodeLenient l
in getPemContent name hdrs (content : contentLines) ls
Just n -> getPemName (finalizePem name hdrs contentLines) n ls
finalizePem name hdrs contentLines nameEnd lbs
| nameEnd /= name = Left $ Just "invalid PEM: end name doesn't match start name"
| otherwise =
let pem = PEM { pemName = name
, pemHeader = hdrs
, pemContent = toSBS $ L.concat $ reverse contentLines }
in Right (pem, lbs)
toSBS = BC.concat . L.toChunks
prefixEat prefix x =
let (x1, x2) = L.splitAt (L.length prefix) x
in if x1 == prefix then Just x2 else Nothing
pemParse :: [Line] -> [Either String PEM]
pemParse l
| null l = []
| otherwise = case parseOnePEM l of
Left Nothing -> []
Left (Just err) -> [Left err]
Right (p, remaining) -> Right p : pemParse remaining
pemParseBS :: ByteString -> Either String [PEM]
pemParseBS b = pemParseLBS $ L.fromChunks [b]
pemParseLBS :: L.ByteString -> Either String [PEM]
pemParseLBS bs = case partitionEithers $ pemParse $ map unCR $ LC.lines bs of
(x:_,_ ) -> Left x
([] ,pems) -> Right pems
where unCR b | L.length b > 0 && L.last b == cr = L.init b
| otherwise = b
cr = fromIntegral $ fromEnum '\r'