text-ldap (empty) → 0.1.0.0
raw patch · 10 files changed
+924/−0 lines, 10 filesdep +Cabaldep +QuickCheckdep +attoparsecsetup-changed
Dependencies added: Cabal, QuickCheck, attoparsec, base, base64-bytestring, bytestring, containers, dlist, random, semigroups, text-ldap, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- mains/parseTest.hs +21/−0
- mains/ppTest.hs +29/−0
- src/Text/LDAP/Data.hs +162/−0
- src/Text/LDAP/InternalParser.hs +37/−0
- src/Text/LDAP/Parser.hs +260/−0
- src/Text/LDAP/Printer.hs +174/−0
- test/PrintParse.hs +133/−0
- text-ldap.cabal +76/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ mains/parseTest.hs view
@@ -0,0 +1,21 @@++import System.Environment (getArgs)+import Control.Applicative+import Text.LDAP.Parser+import qualified Data.ByteString.Lazy.Char8 as LB+++matchTest :: Show a => LdapParser a -> LB.ByteString -> String+matchTest d b = case runLdapParser (openLdapEntry d) b of+ Right r -> show r+ Left e -> "Failed: " ++ show e ++ ": " ++ show b++main :: IO ()+main = do+ as <- getArgs+ let test = case as of+ "raw":_ -> matchTest ldifAttrValue+ _ -> matchTest ldifDecodeAttrValue++ bs <- map LB.unlines . openLdapDataBlocks . LB.lines <$> LB.getContents+ mapM_ (putStrLn . test) $ bs
+ mains/ppTest.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import Text.LDAP.Parser+import qualified Text.LDAP.Parser as Parser+import Text.LDAP.Printer+import qualified Text.LDAP.Printer as Printer+import Data.Monoid ((<>))+import qualified Data.ByteString.Lazy.Char8 as LB+import Data.Either+++appendErr :: String -> Either String a -> Either String a+appendErr s = either (Left . (++ (": " ++ s))) Right++isoTest :: LB.ByteString -> Either String LB.ByteString+isoTest b = do+ let entParser = Parser.openLdapEntry Parser.ldifDecodeAttrValue+ ent0 <- appendErr "parse0" $ runLdapParser entParser b+ let out = runLdapPrinter (Printer.openLdapEntry Printer.ldifEncodeAttrValue) ent0+ ent1 <- appendErr ("parse1: " ++ LB.unpack out) $ runLdapParser entParser out+ if ent0 == ent1+ then Right $ "Isomorphic: " <> out+ else Left $ "Not isomorphic: " ++ LB.unpack out++main :: IO ()+main = do+ bs <- map LB.unlines . openLdapDataBlocks . LB.lines <$> LB.getContents+ mapM_ putStrLn . lefts . map isoTest $ bs
+ src/Text/LDAP/Data.hs view
@@ -0,0 +1,162 @@+-- |+-- Module : Text.LDAP.Data+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+module Text.LDAP.Data+ ( Attribute+ , AttrType (..), attrOid+ , AttrValue (..)++ , Component (..), component++ , DN, consDN, unconsDN++ , List1+ , Bound, exact, boundsElems, inBounds, elem', notElem', inSBounds++ , ordW8+ , quotation, specialChars++ , LdifAttrValue (..)+ , ldifSafeBounds+ , ldifSafeInitBounds+ ) where++import Prelude hiding (reverse)+import Data.Ord (comparing)+import Data.List (sortBy)+import Data.Char (ord)+import Data.Word (Word8)+import Data.ByteString (ByteString)+import Data.Set (fromList, member)+import Data.List.NonEmpty (NonEmpty ((:|)), reverse)+++-- | Not empty list type+type List1 = NonEmpty++-- | Type to express value bound+type Bound a = (a, a)++-- | Bound value to express exact value+exact :: a -> Bound a+exact a = (a, a)++{-# SPECIALIZE bexpand :: (Char, Char) -> [Char] #-}+bexpand :: Enum a => (a, a) -> [a]+bexpand (x, y) = [x .. y]++-- | Element list in value bounds+{-# SPECIALIZE boundsElems :: [(Char, Char)] -> [Char] #-}+boundsElems :: Enum a => [(a, a)] -> [a]+boundsElems = (>>= bexpand)++{-# SPECIALIZE widerFirst :: [(Char, Char)] -> [(Char, Char)] #-}+widerFirst :: (Enum a, Ord a) => [(a, a)] -> [(a, a)]+widerFirst = sortBy (flip $ comparing $ length . bexpand)++-- | Test element in value bounds.+{-# SPECIALIZE inBounds :: Char -> [(Char, Char)] -> Bool #-}+inBounds :: (Enum a, Ord a) => a -> [(a, a)] -> Bool+inBounds a = or . map (\(x, y) -> (x <= a && a <= y)) . widerFirst++-- | Test element using ordered set.+{-# SPECIALIZE elem' :: Char -> [Char] -> Bool #-}+elem' :: Ord a => a -> [a] -> Bool+elem' a = (a `member`) . fromList++-- | Test not element using ordered set.+{-# SPECIALIZE notElem' :: Char -> [Char] -> Bool #-}+notElem' :: Ord a => a -> [a] -> Bool+notElem' a = not . (a `elem'`)++-- | Test element in value bounds using ordered set.+{-# SPECIALIZE inSBounds :: Char -> [(Char, Char)] -> Bool #-}+inSBounds :: (Enum a, Ord a) => a -> [(a, a)] -> Bool+inSBounds a = (a `elem'`) . boundsElems++infix 4 `inBounds`, `elem'`, `notElem'`, `inSBounds`++-- | Type of dn attribute type+data AttrType+ = AttrType ByteString+ | AttrOid (List1 ByteString)+ deriving (Eq, Ord, Show)++-- | Construct OID attribute type+attrOid :: ByteString -> [ByteString] -> AttrType+attrOid hd tl = AttrOid $ hd :| tl++-- | Type of dn attribute value+newtype AttrValue = AttrValue ByteString+ deriving (Eq, Ord, Show)++-- | Type of dn attribute+type Attribute = (AttrType, AttrValue)++-- | Type of dn component (rdn)+data Component+ = S Attribute+ | L (List1 Attribute)+ deriving (Eq, Ord, Show)++-- | Construct dn component (rdn)+component :: Attribute -> [Attribute] -> Component+component = d where+ d x [] = S x+ d x xs@(_:_) = L $ x :| xs++-- | Type of dn+type DN = List1 Component++-- | Construct dn+consDN :: Component -> [Component] -> DN+consDN h tl = reverse $ h :| tl++-- | Deconstruct dn+unconsDN :: DN -> (Component, [Component])+unconsDN dn = (h, tl) where (h :| tl) = reverse dn++-- | Word8 value of Char+ordW8 :: Char -> Word8+ordW8 = fromIntegral . ord++-- | Quotation word8 code of dn+quotation :: Word8+quotation = ordW8 '"'++-- | Secial word8 codes of dn+specialChars :: [Word8]+specialChars = map ordW8 [',', '=', '+', '<', '>', '#', ';']+++-- LDIF+-- | Type of LDIF attribute value+data LdifAttrValue+ = LAttrValRaw ByteString+ | LAttrValBase64 ByteString+ deriving (Eq, Ord, Show)++-- | Char bounds LDIF safe string+ldifSafeBounds :: [(Char, Char)]+ldifSafeBounds =+ [ ('\x01', '\x09')+ , ('\x0B', '\x0C')+ , ('\x0E', '\x7F')+ ]++-- | Char bounds LDIF safe string first char+ldifSafeInitBounds :: [(Char, Char)]+ldifSafeInitBounds =+ [ ('\x01', '\x09')+ , ('\x0B', '\x0C')+ , ('\x0E', '\x1F')+ , ('\x21', '\x39')+ , exact '\x3B'+ , ('\x3D', '\x7F')+ ]
+ src/Text/LDAP/InternalParser.hs view
@@ -0,0 +1,37 @@+-- |+-- Module : Text.LDAP.InternalParser+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Module of internal share parsers.+module Text.LDAP.InternalParser+ ( LdapParser+ , satisfyW8++ , ldifSafeString+ ) where++import Control.Applicative ((<$>), (<*>), many)+import Data.Word (Word8)+import Data.ByteString (ByteString, pack)+import Data.Attoparsec.ByteString.Char8 (Parser, satisfy)++import Text.LDAP.Data (ordW8, inBounds)+import qualified Text.LDAP.Data as Data++type LdapParser = Parser+++satisfyW8 :: (Char -> Bool) -> LdapParser Word8+satisfyW8 = (ordW8 <$>) . satisfy++ldifSafeString :: LdapParser ByteString+ldifSafeString =+ (pack <$>)+ $ (:)+ <$> satisfyW8 (`inBounds` Data.ldifSafeInitBounds)+ <*> many (satisfyW8 (`inBounds` Data.ldifSafeBounds))
+ src/Text/LDAP/Parser.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Text.LDAP.Parser+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+module Text.LDAP.Parser+ ( LdapParser, runLdapParser++ , dn, component, attribute++ , ldifDN, ldifAttr++ , openLdapEntry, openLdapData+ , openLdapDataBlocks++ , ldifDecodeAttrValue, ldifAttrValue++ , ldifDecodeB64Value+ ) where++import Control.Applicative+ ((<$>), pure, (<*>), (*>), (<*), (<|>), some, many)+import Numeric (readHex)+import Data.Monoid ((<>))+import Data.Word (Word8)+import Data.ByteString (ByteString, pack)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LB+import Data.Attoparsec.ByteString.Char8+ (Parser, satisfy, isAlpha_ascii, char, char8, digit)+import qualified Data.Attoparsec.ByteString.Char8 as AP+import qualified Data.Attoparsec.ByteString as APW+import Data.Attoparsec.ByteString.Lazy (parse, eitherResult)+import qualified Data.ByteString.Base64 as Base64++import Text.LDAP.Data+ (AttrType (..), AttrValue (..), Attribute, Component, DN, LdifAttrValue (..),+ ordW8, exact, inBounds, elem', notElem')+import qualified Text.LDAP.Data as Data+import Text.LDAP.InternalParser (satisfyW8, ldifSafeString)+import qualified Text.LDAP.InternalParser as Internal+++-- | Parser context type for LDAP data stream+type LdapParser = Internal.LdapParser++-- | Run 'LdapParser' context.+runLdapParser :: Parser a -> LB.ByteString -> Either String a+runLdapParser p = eitherResult . parse (p <* AP.endOfInput)+++spaces :: LdapParser ()+spaces = many (char ' ') *> pure ()++alpha :: LdapParser Char+alpha = satisfy isAlpha_ascii++alphaW8 :: LdapParser Word8+alphaW8 = ordW8 <$> alpha++digitW8 :: LdapParser Word8+digitW8 = ordW8 <$> digit++quotation :: LdapParser Word8+quotation = APW.word8 Data.quotation++digits1' :: LdapParser ByteString+digits1' = pack <$> some digitW8+++-- DN+keychar :: LdapParser Word8+keychar = alphaW8 <|> digitW8 <|> char8 '-'++quotechar :: LdapParser Word8+quotechar = APW.satisfy (`notElem'` [ordW8 '\\', Data.quotation])++special :: LdapParser Word8+special = APW.satisfy (`elem'` Data.specialChars)++stringchar :: LdapParser Word8+stringchar = APW.satisfy (`notElem'` map ordW8 ['\r', '\n', '\\'] ++ Data.quotation : Data.specialChars)++hexchar :: LdapParser Char+hexchar = digit <|> satisfy (`inBounds` [('a', 'f'), ('A', 'F')])+++hexpair :: LdapParser Word8+hexpair = (rh <$>) $ (:) <$> hexchar <*> ((:) <$> hexchar <*> pure []) where+ rh s+ | rs == [] = error $ "hexpair: BUG!: fail to read hex: " ++ s+ | otherwise = fst $ head rs+ where rs = readHex s++pair :: LdapParser Word8+pair = char '\\' *> (+ special <|>+ char8 '\\' <|>+ quotation <|>+ hexpair )+++hexstring :: LdapParser ByteString+hexstring = pack <$> some hexpair++string :: LdapParser ByteString+string = pack <$> some (stringchar <|> pair) <|>+ char '#' *> hexstring <|>+ pack <$> (quotation *> many (quotechar <|> pair) <* quotation) {- Only for v2 -} <|>+ pure ""++_testString :: Either String ByteString+_testString = runLdapParser string "\",\""++attrOid :: LdapParser AttrType+attrOid = Data.attrOid <$> digits1' <*> many (char '.' *> digits1')++attrTypeStr :: LdapParser AttrType+attrTypeStr = (Data.AttrType . pack <$>) $ (:) <$> alphaW8 <*> many keychar++attrType :: LdapParser AttrType+attrType = attrTypeStr <|> attrOid++_testAT :: Either String AttrType+_testAT = runLdapParser attrType "dc"++attrValueString :: LdapParser AttrValue+attrValueString = AttrValue <$> string++_testAV :: Either String AttrValue+_testAV = runLdapParser attrValueString "com"++-- | Parser of attribute pair string in RDN.+attribute :: LdapParser Attribute+attribute = (,)+ <$> (attrType <* char '=')+ <*> attrValueString++_testAttr :: Either String Attribute+_testAttr = runLdapParser attribute "dc=com"++-- | Parser of RDN string.+component :: LdapParser Component+component = Data.component <$> attribute <*> many (char '+' *> attribute)++comma :: LdapParser Char+comma = spaces *> (char ',' <|> char ';') <* spaces++-- | Parser of DN string.+dn :: LdapParser DN+dn = Data.consDN <$> component <*> many (comma *> component)++++-- LDIF+fill :: LdapParser ()+fill = spaces++base64Bounds :: [(Char, Char)]+base64Bounds = [('A', 'Z'), ('a', 'z'), ('0', '9'), exact '+', exact '/', exact '=']++base64String :: LdapParser ByteString+base64String = pack <$> many (satisfyW8 (`inBounds` base64Bounds))++padDecodeB64 :: ByteString -> Either String ByteString+padDecodeB64 s = Base64.decode (s <> pad) where+ pad = BS8.replicate ((- BS8.length s) `mod` 4) '='++eitherParser :: String -> Either String a -> LdapParser a+eitherParser s = either (fail . ((s ++ ": ") ++)) pure++decodeBase64 :: ByteString -> LdapParser ByteString+decodeBase64 = eitherParser "internal decodeBase64" . padDecodeB64++parseDN :: ByteString -> LdapParser DN+parseDN s =+ eitherParser "internal parseDN"+ . runLdapParser dn $ LB.fromChunks [s]++-- | Parser of LDIF DN line.+ldifDN :: LdapParser DN+ldifDN = AP.string "dn:" *> (+ fill *> dn <|>+ char ':' *> fill *> (parseDN =<< decodeBase64 =<< base64String)+ )++-- | Parser of LDIF attribute value which may be base64 encoded.+-- Available combinator parser to pass 'ldifAttr' or 'openLdapEntry', etc ...+ldifAttrValue :: Parser LdifAttrValue+ldifAttrValue =+ fill *> (LAttrValRaw <$> ldifSafeString) <|>+ char ':' *> fill *> (LAttrValBase64 <$> base64String) <|>+ fill *> pure (LAttrValRaw "")++-- | Decode value string of attribute pair after stream parsing.+ldifDecodeB64Value :: LdifAttrValue -> Either String AttrValue+ldifDecodeB64Value a = case a of+ LAttrValRaw s -> Right $ AttrValue s+ LAttrValBase64 b -> AttrValue <$> padDecodeB64 b++-- | Parser of LDIF attribute value. This parser decodes base64 string.+-- Available combinator parser to pass 'ldifAttr' or 'openLdapEntry', etc ...+ldifDecodeAttrValue :: LdapParser AttrValue+ldifDecodeAttrValue =+ ldifAttrValue >>=+ eitherParser "internal ldifDecodeAttrValue" . ldifDecodeB64Value++-- | Parser of LDIF attribute pair line.+-- Use with 'ldifDecodeAttrValue' or 'ldifAttrValue' parser, like @ldifAttr ldifDecodeAttrValue@.+ldifAttr :: LdapParser a -> LdapParser (AttrType, a)+ldifAttr vp =+ (,)+ <$> (attrType <* char ':')+ <*> vp++newline :: LdapParser ByteString+newline = AP.string "\n" <|> AP.string "\r\n"++-- | OpenLDAP data-stream block parser.+-- Use with 'ldifDecodeAttrValue' or 'ldifAttrValue' parser, like @openLdapEntry ldifDecodeAttrValue@.+openLdapEntry :: LdapParser a+ -> LdapParser (DN, [(AttrType, a)])+openLdapEntry dp =+ (,)+ <$> (ldifDN <* newline)+ <*> many (ldifAttr dp <* newline)++-- | OpenLDAP data-stream block list parser.+-- Use with 'ldifDecodeAttrValue' or 'ldifAttrValue' parser, like @openLdapData ldifDecodeAttrValue@.+openLdapData :: LdapParser a+ -> LdapParser [(DN, [(AttrType, a)])]+openLdapData dp = many (openLdapEntry dp <* newline)++contLines :: [LB.ByteString] -> [LB.ByteString]+contLines = d where+ d [] = []+ d (x:xs) = rec' x xs where+ rec' a [] = [a]+ rec' a (y:ys)+ | hd == " " = rec' (a <> tl) ys+ | otherwise = a : rec' y ys+ where (hd, tl) = LB.splitAt 1 y++blocks :: [LB.ByteString] -> [[LB.ByteString]]+blocks = d where+ d [] = []+ d ls@(_:_) = hd : blocks (drop 1 tl)+ where (hd,tl) = break (== "") ls++-- | Chunking lines of OpenLDAP data stream.+openLdapDataBlocks :: [LB.ByteString] -> [[LB.ByteString]]+openLdapDataBlocks = map contLines . blocks++_test0 :: Either String DN+_test0 = runLdapParser ldifDN "dn: cn=Slash\\\\The Post\\,ma\\=ster\\+\\<\\>\\#\\;,dc=example.sk,dc=com"
+ src/Text/LDAP/Printer.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Text.LDAP.Printer+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+module Text.LDAP.Printer+ ( LdapPrinter, runLdapPrinter, LdapPutM++ , dn+ , component+ , attribute++ , ldifDN, ldifAttr++ , ldifAttrValue, ldifEncodeAttrValue++ , openLdapEntry, openLdapData+ ) where++import Prelude hiding (reverse)+import Data.DList (DList, toList)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Char (chr, isAscii, isPrint)+import Data.Word (Word8)+import qualified Data.ByteString as BS+import Data.ByteString.Char8 (ByteString, singleton)+import qualified Data.ByteString.Lazy as LB+import Control.Applicative (pure, (<*))+import Control.Monad.Trans.Writer (Writer, tell, execWriter)+import Text.Printf (printf)+import qualified Data.ByteString.Base64 as Base64+import Data.Attoparsec.ByteString (parseOnly, endOfInput)++import Text.LDAP.Data+ (AttrType (..), AttrValue (..), Attribute,+ Component (..), DN, unconsDN,+ LdifAttrValue (..),+ elem', ordW8)+import qualified Text.LDAP.Data as Data+import Text.LDAP.InternalParser (ldifSafeString)+++-- | Printer context type for LDAP data stream+type LdapPutM = Writer (DList ByteString)++-- | 'LdapPrinter' 'a' print type 'a' into context+type LdapPrinter a = a -> LdapPutM ()++-- | Run 'LdapPrinter'+runLdapPrinter :: LdapPrinter a -> a -> LB.ByteString+runLdapPrinter p = LB.fromChunks . toList . execWriter . p++string :: LdapPrinter ByteString+string = tell . pure++bslash :: Word8+bslash = ordW8 '\\'++chrW8 :: Word8 -> Char+chrW8 = chr . fromIntegral++escapeValueChar :: Word8 -> [Word8]+escapeValueChar w+ | not $ isAscii c = hex+ | w `elem'` echars = [bslash, w]+ | c == '\r' || c == '\n' = hex+ | isPrint c = [w]+ | otherwise = hex+ where c = chrW8 w+ echars = bslash : Data.quotation : Data.specialChars+ hex = (bslash :) . map ordW8 $ printf "%02x" w++_testEscape :: IO ()+_testEscape =+ putStr $ unlines [ show (w, map chrW8 $ escapeValueChar w) | w <- [0 .. 255 ] ]++escapeValueBS :: ByteString -> ByteString+escapeValueBS = BS.pack . concatMap escapeValueChar . BS.unpack++char :: LdapPrinter Char+char = string . singleton++newline :: LdapPutM ()+newline = char '\n'++-- DN+attrType :: LdapPrinter AttrType+attrType = d where+ d (AttrType s) = string s+ d (AttrOid (x :| xs)) = do+ string x+ mapM_ (\x' -> char '.' >> string x') xs++attrValue :: LdapPrinter AttrValue+attrValue (AttrValue s) = string . escapeValueBS $ s++-- | Printer of attribute pair string in RDN.+attribute :: LdapPrinter Attribute+attribute (t, v) = do+ attrType t+ char '='+ attrValue v++-- | Printer of RDN string.+component :: LdapPrinter Component+component = d where+ d (S a) = attribute a+ d (L (a :| as)) = do+ attribute a+ mapM_ (\a' -> char '+' >> attribute a') as++-- | Printer of DN string.+dn :: LdapPrinter DN+dn = d . unconsDN where+ d (c, cs) = do+ component c+ mapM_ (\c' -> char ',' >> component c') cs+++-- LDIF++-- | Printer of LDIF DN line.+ldifDN :: LdapPrinter DN+ldifDN x = do+ string "dn: "+ dn x++-- | Printer of LDIF attribute value already encoded.+-- Available printer combinator to pass 'ldifAttr' or 'openLdapEntry', etc ...+ldifAttrValue :: LdapPrinter LdifAttrValue+ldifAttrValue = d where+ d (LAttrValRaw s) = do+ char ' '+ string s+ d (LAttrValBase64 s) = do+ string ": "+ string s++ldifToSafeAttrValue :: AttrValue -> LdifAttrValue+ldifToSafeAttrValue (AttrValue s) = do+ case parseOnly (ldifSafeString <* endOfInput) $ s of+ Right _ -> LAttrValRaw s+ Left _ -> LAttrValBase64 $ Base64.encode s++-- | Printer of LDIF attribute value with encode not safe string.+-- Available printer combinator to pass 'ldifAttr' or 'openLdapEntry', etc ...+ldifEncodeAttrValue :: LdapPrinter AttrValue+ldifEncodeAttrValue = ldifAttrValue . ldifToSafeAttrValue++-- | Printer of LDIF attribute pair line.+-- Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @ldifAttr ldifEncodeAttrValue@.+ldifAttr :: LdapPrinter v -> LdapPrinter (AttrType, v)+ldifAttr vp (a, v) = do+ attrType a+ char ':'+ vp v++-- | OpenLDAP data-stream block printer.+-- Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @openLdapEntry ldifEncodeAttrValue@.+openLdapEntry :: LdapPrinter v -> LdapPrinter (DN, [(AttrType, v)])+openLdapEntry vp (x, as) = do+ ldifDN x+ newline+ mapM_ ((>> newline) . ldifAttr vp) as++-- | OpenLDAP data-stream block list printer.+-- Use with 'ldifAttrValue' or 'ldifEncodeAttrValue' printer, like @openLdapData ldifEncodeAttrValue@.+openLdapData :: LdapPrinter v -> LdapPrinter [(DN, [(AttrType, v)])]+openLdapData vp = mapM_ ((>> newline) . openLdapEntry vp)
+ test/PrintParse.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}++module PrintParse (tests) where++import Distribution.TestSuite+ (Test (Test), TestInstance (TestInstance), Result (Pass, Fail), Progress (Finished))+import Test.QuickCheck+ (Testable, Gen, Arbitrary (..),+ choose, oneof, frequency, elements, quickCheck)++import Control.Exception (try)+import Control.Applicative ((<$>), (<*>))+import Data.ByteString.Char8 (ByteString, pack)+import Text.LDAP.Data+ (AttrType (..), AttrValue (..), Attribute, Component (..),+ DN, List1)+import Text.LDAP.Printer (LdapPrinter, runLdapPrinter)+import qualified Text.LDAP.Printer as Printer+import Text.LDAP.Parser (LdapParser, runLdapParser)+import qualified Text.LDAP.Parser as Parser+import Data.List.NonEmpty (NonEmpty ((:|)))+++simpleInstance :: IO Progress -> String -> Test+simpleInstance p name = Test this where+ this = TestInstance p name [] [] (\_ _ -> Right this)++testSuite :: Testable prop => prop -> String -> Test+testSuite t = simpleInstance $ do+ e <- try $ quickCheck t+ return . Finished $ either (Fail . show) (const Pass) (e :: Either IOError ())+++list :: Gen a -> Int -> Gen [a]+list g n = sequence [ g | _i <- [1..n] ]++sequence1 :: Monad m => NonEmpty (m a) -> m (NonEmpty a)+sequence1 (ma :| ms) = do+ x <- ma+ xs <- sequence ms+ return $ x :| xs++list1 :: Gen a -> Int -> Gen (List1 a)+list1 g n = sequence1 $ do+ _i <- 1 :| [2..n]+ return g++digit :: Gen Char+digit = choose ('0', '9')++oidpe :: Gen ByteString+oidpe = (pack <$>) $ choose (1, 10) >>= list digit++alpha :: Gen Char+alpha = oneof [choose ('A', 'Z'), choose ('a', 'z')]++keychar :: Gen Char+keychar = elements $ '-' : ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z']++keystr :: Gen ByteString+keystr = (pack <$>) $ (:) <$> alpha <*> (choose (0, 40) >>= list keychar)++bstring' :: Int -> Int -> Gen ByteString+bstring' n m = (pack <$>) $ choose (n, m) >>= list (elements ['\0'..'\255'])++bstring :: Int -> Gen ByteString+bstring = bstring' 0+++attrType :: Gen AttrType+attrType =+ oneof+ [ AttrType <$> keystr+ , AttrOid <$> (choose (1, 8) >>= list1 oidpe)+ ]++attrValue :: Gen AttrValue+attrValue = AttrValue <$> bstring 0x200++component :: Gen Component+component =+ frequency+ [ (1, S <$> arbitrary)+ , (3, L <$> (choose (2, 5) >>= list1 arbitrary))+ ]+++isoProp :: Eq a => LdapPrinter a -> LdapParser a -> a -> Bool+isoProp pr ps a = Right a == (runLdapParser ps . runLdapPrinter pr $ a)++instance Arbitrary AttrType where+ arbitrary = attrType++instance Arbitrary AttrValue where+ arbitrary = attrValue++instance Arbitrary Component where+ arbitrary = component++instance Arbitrary DN where+ arbitrary = choose (1, 30) >>= list1 arbitrary++prop_attributeIso :: Attribute -> Bool+prop_attributeIso = isoProp Printer.attribute Parser.attribute++prop_componentIso :: Component -> Bool+prop_componentIso = isoProp Printer.component Parser.component++prop_dnIso :: DN -> Bool+prop_dnIso = isoProp Printer.dn Parser.dn++prop_ldifAttrIso :: (AttrType, AttrValue) -> Bool+prop_ldifAttrIso =+ isoProp+ (Printer.ldifAttr Printer.ldifEncodeAttrValue)+ (Parser.ldifAttr Parser.ldifDecodeAttrValue)++prop_openLdapEntryIso :: (DN, [(AttrType, AttrValue)]) -> Bool+prop_openLdapEntryIso =+ isoProp+ (Printer.openLdapEntry Printer.ldifEncodeAttrValue)+ (Parser.openLdapEntry Parser.ldifDecodeAttrValue)++tests :: IO [Test]+tests =+ return+ [ testSuite prop_attributeIso "attribute iso - print parse"+ , testSuite prop_componentIso "component iso - print parse"+ , testSuite prop_dnIso "dn iso - print parse"+ , testSuite prop_ldifAttrIso "ldifAttr iso - print parse"+ , testSuite prop_openLdapEntryIso "openLdapEntry iso - print parse"+ ]
+ text-ldap.cabal view
@@ -0,0 +1,76 @@++name: text-ldap+version: 0.1.0.0+synopsis: Parser and Printer for LDAP text data stream+description: This package contains Parser and Printer for+ LDAP text data stream like OpenLDAP backup LDIF.+license: BSD3+license-file: LICENSE+author: Kei Hibino+maintainer: ex8k.hibino@gmail.com+copyright: Copyright (c) 2014 Kei Hibino+category: Text+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules:+ Text.LDAP.Data+ Text.LDAP.Parser+ Text.LDAP.Printer+ other-modules:+ Text.LDAP.InternalParser++ build-depends: base <5+ , bytestring+ , containers+ , transformers+ , attoparsec+ , dlist+ , semigroups+ , base64-bytestring+ hs-source-dirs: src+ ghc-options: -Wall+ ghc-prof-options: -prof -fprof-auto+++executable parseTest+ main-is: parseTest.hs+ build-depends: base <5+ , bytestring+ , text-ldap+ hs-source-dirs: mains+ ghc-options: -Wall -rtsopts+ ghc-prof-options: -prof -fprof-auto++executable ppTest+ main-is: ppTest.hs+ build-depends: base <5+ , bytestring+ , text-ldap+ hs-source-dirs: mains+ ghc-options: -Wall -rtsopts+ ghc-prof-options: -prof -fprof-auto+++Test-suite pp+ build-depends: base <5+ , bytestring+ , random+ , semigroups+ , text-ldap+ , QuickCheck >=2+ , Cabal++ type: detailed-0.9+ test-module: PrintParse+ hs-source-dirs: test+ ghc-options: -Wall++source-repository head+ type: git+ location: https://github.com/khibino/haskell-text-ldap++source-repository head+ type: mercurial+ location: https://bitbucket.org/khibino/haskell-text-ldap