diff --git a/Data/PEM.hs b/Data/PEM.hs new file mode 100644 --- /dev/null +++ b/Data/PEM.hs @@ -0,0 +1,18 @@ +-- | +-- Module : Data.PEM +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +-- Read and write PEM files +-- +module Data.PEM + ( module Data.PEM.Types + , module Data.PEM.Writer + , module Data.PEM.Parser + ) where + +import Data.PEM.Types +import Data.PEM.Writer +import Data.PEM.Parser diff --git a/Data/PEM/Parser.hs b/Data/PEM/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/PEM/Parser.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.PEM.Parser +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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' diff --git a/Data/PEM/Types.hs b/Data/PEM/Types.hs new file mode 100644 --- /dev/null +++ b/Data/PEM/Types.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Data.PEM.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Data.PEM.Types where + +import Data.ByteString (ByteString) +import Basement.NormalForm + +-- | Represent one PEM section +-- +-- for now headers are not serialized at all. +-- this is just available here as a placeholder for a later implementation. +data PEM = PEM + { pemName :: String -- ^ the name of the section, found after the dash BEGIN tag. + , pemHeader :: [(String, ByteString)] -- ^ optionals key value pair header + , pemContent :: ByteString -- ^ binary content of the section + } deriving (Show,Eq) + +instance NormalForm PEM where + toNormalForm pem = + toNormalForm (pemName pem) `seq` nfLbs (pemHeader pem) `seq` pemContent pem `seq` () + where + nfLbs [] = () + nfLbs ((s,bs):l) = toNormalForm s `seq` bs `seq` nfLbs l diff --git a/Data/PEM/Writer.hs b/Data/PEM/Writer.hs new file mode 100644 --- /dev/null +++ b/Data/PEM/Writer.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.PEM.Writer +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : portable +-- +module Data.PEM.Writer + ( pemWriteLBS + , pemWriteBS + ) where + +import Data.PEM.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import Data.ByteArray.Encoding (Base(Base64), convertToBase) + +-- | write a PEM structure to a builder +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 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 = convertToBase Base64 l `B.append` "\n" + + splitChunks b + | B.length b > 48 = let (x,y) = B.splitAt 48 b in x : splitChunks y + | otherwise = [b] + +-- | convert a PEM structure to a bytestring +pemWriteBS :: PEM -> ByteString +pemWriteBS = B.concat . L.toChunks . pemWrite + +-- | convert a PEM structure to a lazy bytestring +pemWriteLBS :: PEM -> L.ByteString +pemWriteLBS = pemWrite diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010-2018 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests/pem.hs b/Tests/pem.hs new file mode 100644 --- /dev/null +++ b/Tests/pem.hs @@ -0,0 +1,83 @@ +module Main where + +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 + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ 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) + +arbitraryName = choose (1, 30) >>= \i -> replicateM i arbitraryAscii + where arbitraryAscii = elements ['A'..'Z'] + +arbitraryContent = choose (1,100) >>= \i -> + (B.pack . map fromIntegral) `fmap` replicateM i (choose (0,255) :: Gen Int) + +instance Arbitrary PEM where + arbitrary = PEM <$> arbitraryName <*> pure [] <*> arbitraryContent diff --git a/crypton-pem.cabal b/crypton-pem.cabal new file mode 100644 --- /dev/null +++ b/crypton-pem.cabal @@ -0,0 +1,58 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.38.1. +-- +-- see: https://github.com/sol/hpack + +name: crypton-pem +version: 0.2.4 +synopsis: Privacy Enhanced Mail (PEM) format reader and writer. +description: Privacy Enhanced Mail (PEM) format reader and writer. long description +category: Data +stability: experimental +homepage: http://github.com/mpilgrem/crypton-pem +bug-reports: https://github.com/mpilgrem/crypton-pem/issues +author: Vincent Hanquez +maintainer: Mike Pilgrem , + Kazu Yamamoto +copyright: Vincent Hanquez +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + Tests/pem.hs + +source-repository head + type: git + location: https://github.com/mpilgrem/crypton-pem + +library + exposed-modules: + Data.PEM + other-modules: + Data.PEM.Parser + Data.PEM.Writer + Data.PEM.Types + ghc-options: -Wall + build-depends: + base >=3 && <5 + , basement + , bytestring + , memory + default-language: Haskell98 + +test-suite test-pem + type: exitcode-stdio-1.0 + main-is: pem.hs + hs-source-dirs: + Tests + build-depends: + HUnit + , QuickCheck >=2.4.0.1 + , base + , bytestring + , crypton-pem + , test-framework >=0.3.3 + , test-framework-hunit + , test-framework-quickcheck2 + default-language: Haskell98