diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/mains/parseTest.hs b/mains/parseTest.hs new file mode 100644 --- /dev/null +++ b/mains/parseTest.hs @@ -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 diff --git a/mains/ppTest.hs b/mains/ppTest.hs new file mode 100644 --- /dev/null +++ b/mains/ppTest.hs @@ -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 diff --git a/src/Text/LDAP/Data.hs b/src/Text/LDAP/Data.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDAP/Data.hs @@ -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') + ] diff --git a/src/Text/LDAP/InternalParser.hs b/src/Text/LDAP/InternalParser.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDAP/InternalParser.hs @@ -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)) diff --git a/src/Text/LDAP/Parser.hs b/src/Text/LDAP/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDAP/Parser.hs @@ -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" diff --git a/src/Text/LDAP/Printer.hs b/src/Text/LDAP/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDAP/Printer.hs @@ -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) diff --git a/test/PrintParse.hs b/test/PrintParse.hs new file mode 100644 --- /dev/null +++ b/test/PrintParse.hs @@ -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" + ] diff --git a/text-ldap.cabal b/text-ldap.cabal new file mode 100644 --- /dev/null +++ b/text-ldap.cabal @@ -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