{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}

{- |
Module      : Data.PEM.Parser
License     : BSD-style
Copyright   : (c) 2010-2018 Vincent Hanquez <vincent@snarc.org>
Stability   : experimental
Portability : portable

Parse PEM content.

A PEM contains contains one or more PEM sections. Each section contains an
optional key-value pair header and binary content encoded in base64.
-}

module Data.PEM.Parser
  ( pemParseBS
  , pemParseLBS
  ) where

import           Data.ByteString ( ByteString )
import qualified Data.ByteString as B
#if MIN_VERSION_base64(1,0,0)
import           Data.ByteString.Base64 ( decodeBase64Untyped )
#else
import           Data.ByteString.Base64 ( decodeBase64 )
#endif
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
import           Data.Either ( partitionEithers )
import           Data.PEM.Types ( PEM (..) )
import qualified Data.Text as T

type Line = L.ByteString

-- | A helper function while base64 < 1.0 is supported.

#if !MIN_VERSION_base64(1,0,0)
decodeBase64Untyped :: ByteString -> Either T.Text ByteString
decodeBase64Untyped = decodeBase64
#endif

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], ByteString)], [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], ByteString)]
hdrs, [Line]
lbs2) -> [Char]
-> [([Char], ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], 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 :: [Char]
-> [([Char], ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], ByteString)]
hdrs [ByteString]
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 ByteString -> Either Text ByteString
decodeBase64Untyped (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ Line -> ByteString
L.toStrict Line
l of
            Left Text
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]
++ Text -> [Char]
T.unpack Text
err)
            Right ByteString
content -> [Char]
-> [([Char], ByteString)]
-> [ByteString]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
getPemContent [Char]
name [([Char], ByteString)]
hdrs (ByteString
content ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
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], ByteString)]
-> [ByteString]
-> [Char]
-> [Line]
-> Either (Maybe [Char]) (PEM, [Line])
forall {a} {b}.
IsString a =>
[Char]
-> [([Char], ByteString)]
-> [ByteString]
-> [Char]
-> b
-> Either (Maybe a) (PEM, b)
finalizePem [Char]
name [([Char], ByteString)]
hdrs [ByteString]
contentLines) Line
n [Line]
ls

  finalizePem :: [Char]
-> [([Char], ByteString)]
-> [ByteString]
-> [Char]
-> b
-> Either (Maybe a) (PEM, b)
finalizePem [Char]
name [([Char], ByteString)]
hdrs [ByteString]
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], ByteString)]
pemHeader  = [([Char], ByteString)]
hdrs
                      , pemContent :: ByteString
pemContent = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
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 PEM content from a strict 'ByteString'.

pemParseBS :: ByteString -> Either String [PEM]
pemParseBS :: ByteString -> Either [Char] [PEM]
pemParseBS ByteString
b = Line -> Either [Char] [PEM]
pemParseLBS (Line -> Either [Char] [PEM]) -> Line -> Either [Char] [PEM]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Line
L.fromChunks [ByteString
b]

-- | Parse PEM content from a lazy 'Data.ByteString.Lazy.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'