{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : Data.PEM.Parser
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : portable
--
-- Parse PEM content.
--
-- A PEM contains contains from one to many PEM sections.
-- Each section contains an optional key-value pair header
-- and a binary content encoded in base64.
--
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 Data.PEM.Types
import Data.ByteArray.Encoding (Base(Base64), convertFromBase)
import qualified Data.ByteArray as BA

type Line = L.ByteString

parseOnePEM :: [Line] -> Either (Maybe String) (PEM, [Line])
parseOnePEM :: [Line] -> Either (Maybe [Char]) (PEM, [Line])
parseOnePEM = [Line] -> Either (Maybe [Char]) (PEM, [Line])
findPem
  where beginMarker :: Line
beginMarker = Line
"-----BEGIN "
        endMarker :: Line
endMarker   = Line
"-----END "

        findPem :: [Line] -> Either (Maybe [Char]) (PEM, [Line])
findPem []     = Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. a -> Either a b
Left Maybe [Char]
forall a. Maybe a
Nothing
        findPem (Line
l:[Line]
ls) = case Line
beginMarker Line -> Line -> Maybe Line
`prefixEat` Line
l of
                             Maybe Line
Nothing -> [Line] -> Either (Maybe [Char]) (PEM, [Line])
findPem [Line]
ls
                             Just Line
n  -> ([Char] -> [Line] -> Either (Maybe [Char]) (PEM, [Line]))
-> Line -> [Line] -> Either (Maybe [Char]) (PEM, [Line])
forall {a} {t} {b}.
IsString a =>
([Char] -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName [Char] -> [Line] -> Either (Maybe [Char]) (PEM, [Line])
getPemHeaders Line
n [Line]
ls
        getPemName :: ([Char] -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName [Char] -> t -> Either (Maybe a) b
next Line
n t
ls =
            let (Line
name, Line
r) = (Word8 -> Bool) -> Line -> (Line, Line)
L.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x2d) Line
n in
            case Line
r of
                Line
"-----" -> [Char] -> t -> Either (Maybe a) b
next (Line -> [Char]
LC.unpack Line
name) t
ls
                Line
_       -> Maybe a -> Either (Maybe a) b
forall a b. a -> Either a b
Left (Maybe a -> Either (Maybe a) b) -> Maybe a -> Either (Maybe a) b
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
"invalid PEM delimiter found"

        getPemHeaders :: [Char] -> [Line] -> Either (Maybe [Char]) (PEM, [Line])
getPemHeaders [Char]
name [Line]
lbs =
            case [Line]
-> Either (Maybe [Char]) ([([Char], StrictByteString)], [Line])
forall {a} {a} {a}.
IsString a =>
[a] -> Either (Maybe a) ([a], [a])
getPemHeaderLoop [Line]
lbs of
                Left Maybe [Char]
err           -> Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. a -> Either a b
Left Maybe [Char]
err
                Right ([([Char], StrictByteString)]
hdrs, [Line]
lbs2) -> [Char]
-> [([Char], StrictByteString)]
-> [StrictByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], StrictByteString)]
hdrs [] [Line]
lbs2
          where getPemHeaderLoop :: [a] -> Either (Maybe a) ([a], [a])
getPemHeaderLoop []     = Maybe a -> Either (Maybe a) ([a], [a])
forall a b. a -> Either a b
Left (Maybe a -> Either (Maybe a) ([a], [a]))
-> Maybe a -> Either (Maybe a) ([a], [a])
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
"invalid PEM: no more content in header context"
                getPemHeaderLoop (a
r:[a]
rs) = -- FIXME doesn't properly parse headers yet
                    ([a], [a]) -> Either (Maybe a) ([a], [a])
forall a b. b -> Either a b
Right ([], a
ra -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rs)

        getPemContent :: String -> [(String,ByteString)] -> [BC.ByteString] -> [L.ByteString] -> Either (Maybe String) (PEM, [L.ByteString])
        getPemContent :: [Char]
-> [([Char], StrictByteString)]
-> [StrictByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], StrictByteString)]
hdrs [StrictByteString]
contentLines [Line]
lbs =
            case [Line]
lbs of
                []     -> Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. a -> Either a b
Left (Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line]))
-> Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"invalid PEM: no end marker found"
                (Line
l:[Line]
ls) -> case Line
endMarker Line -> Line -> Maybe Line
`prefixEat` Line
l of
                              Maybe Line
Nothing ->
                                    case Base -> StrictByteString -> Either [Char] StrictByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either [Char] bout
convertFromBase Base
Base64 (StrictByteString -> Either [Char] StrictByteString)
-> StrictByteString -> Either [Char] StrictByteString
forall a b. (a -> b) -> a -> b
$ Line -> StrictByteString
L.toStrict Line
l of
                                        Left [Char]
err      -> Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. a -> Either a b
Left (Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line]))
-> Maybe [Char] -> Either (Maybe [Char]) (PEM, [Line])
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"invalid PEM: decoding failed: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
                                        Right StrictByteString
content -> [Char]
-> [([Char], StrictByteString)]
-> [StrictByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], StrictByteString)]
hdrs (StrictByteString
content StrictByteString -> [StrictByteString] -> [StrictByteString]
forall a. a -> [a] -> [a]
: [StrictByteString]
contentLines) [Line]
ls
                              Just Line
n  -> ([Char] -> [Line] -> Either (Maybe [Char]) (PEM, [Line]))
-> Line -> [Line] -> Either (Maybe [Char]) (PEM, [Line])
forall {a} {t} {b}.
IsString a =>
([Char] -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName ([Char]
-> [([Char], StrictByteString)]
-> [StrictByteString]
-> [Char]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
forall {a} {bin} {b}.
(IsString a, ByteArrayAccess bin) =>
[Char]
-> [([Char], StrictByteString)]
-> [bin]
-> [Char]
-> b
-> Either (Maybe a) (PEM, b)
finalizePem [Char]
name [([Char], StrictByteString)]
hdrs [StrictByteString]
contentLines) Line
n [Line]
ls
        finalizePem :: [Char]
-> [([Char], StrictByteString)]
-> [bin]
-> [Char]
-> b
-> Either (Maybe a) (PEM, b)
finalizePem [Char]
name [([Char], StrictByteString)]
hdrs [bin]
contentLines [Char]
nameEnd b
lbs
            | [Char]
nameEnd [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
name = Maybe a -> Either (Maybe a) (PEM, b)
forall a b. a -> Either a b
Left (Maybe a -> Either (Maybe a) (PEM, b))
-> Maybe a -> Either (Maybe a) (PEM, b)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
"invalid PEM: end name doesn't match start name"
            | Bool
otherwise       =
                let pem :: PEM
pem = PEM { pemName :: [Char]
pemName    = [Char]
name
                              , pemHeader :: [([Char], StrictByteString)]
pemHeader  = [([Char], StrictByteString)]
hdrs
                              , pemContent :: StrictByteString
pemContent = [bin] -> StrictByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
BA.concat ([bin] -> StrictByteString) -> [bin] -> StrictByteString
forall a b. (a -> b) -> a -> b
$ [bin] -> [bin]
forall a. [a] -> [a]
reverse [bin]
contentLines }
                 in (PEM, b) -> Either (Maybe a) (PEM, b)
forall a b. b -> Either a b
Right (PEM
pem, b
lbs)

        prefixEat :: Line -> Line -> Maybe Line
prefixEat Line
prefix Line
x =
            let (Line
x1, Line
x2) = Int64 -> Line -> (Line, Line)
L.splitAt (Line -> Int64
L.length Line
prefix) Line
x
             in if Line
x1 Line -> Line -> Bool
forall a. Eq a => a -> a -> Bool
== Line
prefix then Line -> Maybe Line
forall a. a -> Maybe a
Just Line
x2 else Maybe Line
forall a. Maybe a
Nothing

-- | parser to get PEM sections
pemParse :: [Line] -> [Either String PEM]
pemParse :: [Line] -> [Either [Char] PEM]
pemParse [Line]
l
    | [Line] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Line]
l    = []
    | Bool
otherwise = case [Line] -> Either (Maybe [Char]) (PEM, [Line])
parseOnePEM [Line]
l of
                        Left Maybe [Char]
Nothing         -> []
                        Left (Just [Char]
err)      -> [[Char] -> Either [Char] PEM
forall a b. a -> Either a b
Left [Char]
err]
                        Right (PEM
p, [Line]
remaining) -> PEM -> Either [Char] PEM
forall a b. b -> Either a b
Right PEM
p Either [Char] PEM -> [Either [Char] PEM] -> [Either [Char] PEM]
forall a. a -> [a] -> [a]
: [Line] -> [Either [Char] PEM]
pemParse [Line]
remaining

-- | parse a PEM content using a strict bytestring
pemParseBS :: ByteString -> Either String [PEM]
pemParseBS :: StrictByteString -> Either [Char] [PEM]
pemParseBS StrictByteString
b = Line -> Either [Char] [PEM]
pemParseLBS (Line -> Either [Char] [PEM]) -> Line -> Either [Char] [PEM]
forall a b. (a -> b) -> a -> b
$ [StrictByteString] -> Line
L.fromChunks [StrictByteString
b]

-- | parse a PEM content using a dynamic bytestring
pemParseLBS :: L.ByteString -> Either String [PEM]
pemParseLBS :: Line -> Either [Char] [PEM]
pemParseLBS Line
bs = case [Either [Char] PEM] -> ([[Char]], [PEM])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either [Char] PEM] -> ([[Char]], [PEM]))
-> [Either [Char] PEM] -> ([[Char]], [PEM])
forall a b. (a -> b) -> a -> b
$ [Line] -> [Either [Char] PEM]
pemParse ([Line] -> [Either [Char] PEM]) -> [Line] -> [Either [Char] PEM]
forall a b. (a -> b) -> a -> b
$ (Line -> Line) -> [Line] -> [Line]
forall a b. (a -> b) -> [a] -> [b]
map Line -> Line
unCR ([Line] -> [Line]) -> [Line] -> [Line]
forall a b. (a -> b) -> a -> b
$ Line -> [Line]
LC.lines Line
bs of
                    ([Char]
x:[[Char]]
_,[PEM]
_   ) -> [Char] -> Either [Char] [PEM]
forall a b. a -> Either a b
Left [Char]
x
                    ([] ,[PEM]
pems) -> [PEM] -> Either [Char] [PEM]
forall a b. b -> Either a b
Right [PEM]
pems
  where unCR :: Line -> Line
unCR Line
b | Line -> Int64
L.length Line
b Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0 Bool -> Bool -> Bool
&& HasCallStack => Line -> Word8
Line -> Word8
L.last Line
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cr = HasCallStack => Line -> Line
Line -> Line
L.init Line
b
               | Bool
otherwise                        = Line
b
        cr :: Word8
cr = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'\r'