1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
{-# 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 = 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) = -- FIXME doesn't properly parse headers yet
Right ([], r:rs)
getPemContent :: String -> [(String,ByteString)] -> [BC.ByteString] -> [L.ByteString] -> Either (Maybe String) (PEM, [L.ByteString])
getPemContent name hdrs contentLines lbs =
case lbs of
[] -> Left $ Just "invalid PEM: no end marker found"
(l:ls) -> case endMarker `prefixEat` l of
Nothing ->
case convertFromBase Base64 $ L.toStrict l of
Left err -> Left $ Just ("invalid PEM: decoding failed: " ++ err)
Right content -> 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 = BA.concat $ reverse contentLines }
in Right (pem, lbs)
prefixEat prefix x =
let (x1, x2) = L.splitAt (L.length prefix) x
in if x1 == prefix then Just x2 else Nothing
-- | parser to get PEM sections
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
-- | parse a PEM content using a strict bytestring
pemParseBS :: ByteString -> Either String [PEM]
pemParseBS b = pemParseLBS $ L.fromChunks [b]
-- | parse a PEM content using a dynamic bytestring
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'
|
