{-# 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 String) (PEM, [Line])
parseOnePEM = [Line] -> Either (Maybe String) (PEM, [Line])
findPem
  where beginMarker :: Line
beginMarker = Line
"-----BEGIN "
        endMarker :: Line
endMarker   = Line
"-----END "

        findPem :: [Line] -> Either (Maybe String) (PEM, [Line])
findPem []     = Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. a -> Either a b
Left Maybe String
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 String) (PEM, [Line])
findPem [Line]
ls
                             Just Line
n  -> (String -> [Line] -> Either (Maybe String) (PEM, [Line]))
-> Line -> [Line] -> Either (Maybe String) (PEM, [Line])
forall a t b.
IsString a =>
(String -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName String -> [Line] -> Either (Maybe String) (PEM, [Line])
getPemHeaders Line
n [Line]
ls
        getPemName :: (String -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName String -> 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
"-----" -> String -> t -> Either (Maybe a) b
next (Line -> String
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 :: String -> [Line] -> Either (Maybe String) (PEM, [Line])
getPemHeaders String
name [Line]
lbs =
            case [Line] -> Either (Maybe String) ([(String, ByteString)], [Line])
forall a a a. IsString a => [a] -> Either (Maybe a) ([a], [a])
getPemHeaderLoop [Line]
lbs of
                Left Maybe String
err           -> Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. a -> Either a b
Left Maybe String
err
                Right ([(String, ByteString)]
hdrs, [Line]
lbs2) -> String
-> [(String, ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe String) (PEM, [Line])
getPemContent String
name [(String, ByteString)]
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 :: String
-> [(String, ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe String) (PEM, [Line])
getPemContent String
name [(String, ByteString)]
hdrs [ByteString]
contentLines [Line]
lbs =
            case [Line]
lbs of
                []     -> Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. a -> Either a b
Left (Maybe String -> Either (Maybe String) (PEM, [Line]))
-> Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"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 -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64 (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Line -> ByteString
L.toStrict Line
l of
                                        Left String
err      -> Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. a -> Either a b
Left (Maybe String -> Either (Maybe String) (PEM, [Line]))
-> Maybe String -> Either (Maybe String) (PEM, [Line])
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
"invalid PEM: decoding failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
                                        Right ByteString
content -> String
-> [(String, ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe String) (PEM, [Line])
getPemContent String
name [(String, ByteString)]
hdrs (ByteString
content ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
contentLines) [Line]
ls
                              Just Line
n  -> (String -> [Line] -> Either (Maybe String) (PEM, [Line]))
-> Line -> [Line] -> Either (Maybe String) (PEM, [Line])
forall a t b.
IsString a =>
(String -> t -> Either (Maybe a) b)
-> Line -> t -> Either (Maybe a) b
getPemName (String
-> [(String, ByteString)]
-> [ByteString]
-> String
-> [Line]
-> Either (Maybe String) (PEM, [Line])
forall a bin b.
(IsString a, ByteArrayAccess bin) =>
String
-> [(String, ByteString)]
-> [bin]
-> String
-> b
-> Either (Maybe a) (PEM, b)
finalizePem String
name [(String, ByteString)]
hdrs [ByteString]
contentLines) Line
n [Line]
ls
        finalizePem :: String
-> [(String, ByteString)]
-> [bin]
-> String
-> b
-> Either (Maybe a) (PEM, b)
finalizePem String
name [(String, ByteString)]
hdrs [bin]
contentLines String
nameEnd b
lbs
            | String
nameEnd String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
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 :: String -> [(String, ByteString)] -> ByteString -> PEM
PEM { pemName :: String
pemName    = String
name
                              , pemHeader :: [(String, ByteString)]
pemHeader  = [(String, ByteString)]
hdrs
                              , pemContent :: ByteString
pemContent = [bin] -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
[bin] -> bout
BA.concat ([bin] -> ByteString) -> [bin] -> ByteString
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 String PEM]
pemParse [Line]
l
    | [Line] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Line]
l    = []
    | Bool
otherwise = case [Line] -> Either (Maybe String) (PEM, [Line])
parseOnePEM [Line]
l of
                        Left Maybe String
Nothing         -> []
                        Left (Just String
err)      -> [String -> Either String PEM
forall a b. a -> Either a b
Left String
err]
                        Right (PEM
p, [Line]
remaining) -> PEM -> Either String PEM
forall a b. b -> Either a b
Right PEM
p Either String PEM -> [Either String PEM] -> [Either String PEM]
forall a. a -> [a] -> [a]
: [Line] -> [Either String PEM]
pemParse [Line]
remaining

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

-- | parse a PEM content using a dynamic bytestring
pemParseLBS :: L.ByteString -> Either String [PEM]
pemParseLBS :: Line -> Either String [PEM]
pemParseLBS Line
bs = case [Either String PEM] -> ([String], [PEM])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either String PEM] -> ([String], [PEM]))
-> [Either String PEM] -> ([String], [PEM])
forall a b. (a -> b) -> a -> b
$ [Line] -> [Either String PEM]
pemParse ([Line] -> [Either String PEM]) -> [Line] -> [Either String 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
                    (String
x:[String]
_,[PEM]
_   ) -> String -> Either String [PEM]
forall a b. a -> Either a b
Left String
x
                    ([] ,[PEM]
pems) -> [PEM] -> Either String [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
&& Line -> Word8
L.last Line
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
cr = 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'