diff --git a/Data/PEM/Parser.hs b/Data/PEM/Parser.hs --- a/Data/PEM/Parser.hs +++ b/Data/PEM/Parser.hs @@ -13,47 +13,79 @@ -- and a binary content encoded in base64. -- module Data.PEM.Parser - ( pemParser - , pemParseBS + ( pemParseBS , pemParseLBS ) where -import Control.Applicative -import Data.Attoparsec -import qualified Data.Attoparsec.Lazy as AttoLazy -import Data.Attoparsec.Char8 (space) - -import Data.PEM.Types - +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.Base64 as Base64 +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.ByteString.Base64.Lazy as Base64 -import Prelude hiding (takeWhile) -import Data.Serialize.Builder -import Data.Monoid +import Data.PEM.Types +parseOnePEM :: [L.ByteString] -> Either (Maybe String) (PEM, [L.ByteString]) +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 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 + -- | parser to get PEM sections -pemParser :: Parser [PEM] -pemParser = many contextSection - where - beginMarker = string "-----BEGIN " >> return () - endMarker = string "-----END " >> return () - skipLine = skipWhile (/= 0xa) >> space >> return () - eatLine = takeWhile (/= 0xa) <* space - contextSection = manyTill skipLine beginMarker *> section - section = do - -- begin marker has already been eaten by contextSection - name <- takeWhile (/= 0x2d) <* (string "-----" *> space) - l <- manyTill eatLine endMarker - let content = toByteString $ mconcat $ map (fromByteString . Base64.decodeLenient) l - return $ PEM { pemName = BC.unpack name, pemHeader = [], pemContent = content } +pemParse :: [L.ByteString] -> [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 = parseOnly pemParser +pemParseBS b = pemParseLBS $ L.fromChunks [b] -- | parse a PEM content using a dynamic bytestring pemParseLBS :: L.ByteString -> Either String [PEM] -pemParseLBS = AttoLazy.eitherResult . AttoLazy.parse pemParser +pemParseLBS bs = case partitionEithers $ pemParse $ LC.lines bs of + (x:_,_ ) -> Left x + ([] ,pems) -> Right pems diff --git a/Data/PEM/Writer.hs b/Data/PEM/Writer.hs --- a/Data/PEM/Writer.hs +++ b/Data/PEM/Writer.hs @@ -7,8 +7,7 @@ -- Portability : portable -- module Data.PEM.Writer - ( pemWriteBuilder - , pemWriteLBS + ( pemWriteLBS , pemWriteBS ) where @@ -18,33 +17,32 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Base64 as Base64 -import Data.Serialize.Builder -import Data.Monoid -import Data.List -- | write a PEM structure to a builder -pemWriteBuilder :: PEM -> Builder -pemWriteBuilder pem = mconcat $ intersperse eol $ concat ([begin]:header:section:[end]:[[empty]]) - where begin = mconcat $ map fromByteString ["-----BEGIN ", sectionName, "-----" ] - end = mconcat $ map fromByteString ["-----END ", sectionName, "-----" ] - section = map fromByteString $ (splitChunks $ Base64.encode $ pemContent pem) +pemWrite :: PEM -> L.ByteString +pemWrite pem = L.fromChunks $ ([begin,header]++section++[end]) + where begin = B.concat ["-----BEGIN ", sectionName, "-----\n"] + end = B.concat ["-----END ", sectionName, "-----\n" ] + section :: [ByteString] + section = map encodeLine $ splitChunks $ pemContent pem + header :: ByteString header = if null $ pemHeader pem - then [] - else concatMap toHeader (pemHeader pem) ++ [empty] - toHeader (k,v) = [ mconcat $ map fromByteString [ bk, ":", v ] ] - where bk = BC.pack k + then B.empty + else B.concat ((concatMap toHeader (pemHeader pem)) ++ ["\n"]) + toHeader :: (String, ByteString) -> [ByteString] + toHeader (k,v) = [ BC.pack k, ":", v, "\n" ] -- expect only ASCII. need to find a type to represent it. sectionName = BC.pack $ pemName pem + encodeLine l = Base64.encode l `B.append` "\n" splitChunks b - | B.length b > 64 = let (x,y) = B.splitAt 64 b in x : splitChunks y + | B.length b > 48 = let (x,y) = B.splitAt 48 b in x : splitChunks y | otherwise = [b] - eol = fromByteString $ B.singleton 0x0a -- | convert a PEM structure to a bytestring pemWriteBS :: PEM -> ByteString -pemWriteBS = toByteString . pemWriteBuilder +pemWriteBS = B.concat . L.toChunks . pemWrite -- | convert a PEM structure to a lazy bytestring pemWriteLBS :: PEM -> L.ByteString -pemWriteLBS = toLazyByteString . pemWriteBuilder +pemWriteLBS = pemWrite diff --git a/Tests/pem.hs b/Tests/pem.hs --- a/Tests/pem.hs +++ b/Tests/pem.hs @@ -3,9 +3,12 @@ import Control.Applicative import Control.Monad +import qualified Data.ByteString.Char8 as BC import Test.QuickCheck hiding ((.&.)) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) import Data.PEM import qualified Data.ByteString as B @@ -15,9 +18,57 @@ tests :: [Test] tests = - [ testProperty "marshall" testMarshall + [ testGroup "units" $ testUnits + , testDecodingMultiple + , testUnmatchingNames + , testProperty "marshall" testMarshall ] +testUnits = map (\(i, (p,bs)) -> testCase (show i) (pemWriteBS p @=? BC.pack bs)) + $ zip [0..] [ (p1, bp1), (p2, bp2) ] + where p1 = PEM { pemName = "abc", pemHeader = [], pemContent = B.replicate 64 0 } + bp1 = unlines + [ "-----BEGIN abc-----" + , "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" + , "AAAAAAAAAAAAAAAAAAAAAA==" + , "-----END abc-----" + ] + p2 = PEM { pemName = "xxx", pemHeader = [], pemContent = B.replicate 12 3 } + bp2 = unlines + [ "-----BEGIN xxx-----" + , "AwMDAwMDAwMDAwMD" + , "-----END xxx-----" + ] + +testDecodingMultiple = testCase ("multiple pems") (pemParseBS content @=? Right expected) + where expected = [ PEM { pemName = "marker", pemHeader = [], pemContent = B.replicate 12 3 } + , PEM { pemName = "marker2", pemHeader = [], pemContent = B.replicate 64 0 } + ] + content = BC.pack $ unlines + [ "some text that is not related to PEM" + , "and is just going to be ignored by the PEM parser." + , "" + , "even empty lines should be skip until the rightful marker" + , "-----BEGIN marker-----" + , "AwMDAwMDAwMDAwMD" + , "-----END marker-----" + , "some middle text" + , "-----BEGIN marker2-----" + , "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" + , "AAAAAAAAAAAAAAAAAAAAAA==" + , "-----END marker2-----" + , "and finally some trailing text." + ] + +testUnmatchingNames = testCase "unmatching name" (let r = pemParseBS content in case r of + Left _ -> True @=? True + _ -> r @=? Left "") + where content = BC.pack $ unlines + [ "-----BEGIN marker-----" + , "AAAA" + , "-----END marker2-----" + ] + testMarshall pems = readPems == Right pems where readPems = pemParseBS writtenPems writtenPems = B.concat (map pemWriteBS pems) @@ -25,7 +76,7 @@ arbitraryName = choose (1, 30) >>= \i -> replicateM i arbitraryAscii where arbitraryAscii = elements ['A'..'Z'] -arbitraryContent = choose (1,10) >>= \i -> +arbitraryContent = choose (1,100) >>= \i -> (B.pack . map fromIntegral) `fmap` replicateM i (choose (0,255) :: Gen Int) instance Arbitrary PEM where diff --git a/pem.cabal b/pem.cabal --- a/pem.cabal +++ b/pem.cabal @@ -1,5 +1,5 @@ Name: pem -Version: 0.1.2 +Version: 0.2.0 Description: Privacy Enhanced Mail (PEM) format reader and writer. License: BSD3 License-file: LICENSE @@ -19,8 +19,6 @@ Build-Depends: base >= 3 && < 5 , mtl , bytestring - , attoparsec - , cereal , base64-bytestring Exposed-modules: Data.PEM Other-modules: Data.PEM.Parser @@ -36,6 +34,8 @@ , bytestring , test-framework >= 0.3.3 , test-framework-quickcheck2 + , test-framework-hunit + , HUnit , QuickCheck >= 2.4.0.1 , pem