ldif 0.0.10 → 0.0.12

raw patch · 22 files changed

+879/−551 lines, 22 filesdep +bytestringdep +rosezipperdep ~cmdargsdep ~parsecnew-component:exe:ldifdiffnew-component:exe:ldifundoPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, rosezipper

Dependency ranges changed: cmdargs, parsec

API changes (from Hackage documentation)

Files

• TODO.org +0/−28
• ldif.cabal +61/−25
• runTests.sh +22/−0
• run_tests.sh +0/−3
• src/Text/LDIF.hs +6/−1
• src/Text/LDIF/Apply.hs +16/−9
• src/Text/LDIF/Consts.hs +6/−3
• src/Text/LDIF/Diff.hs +44/−25
• src/Text/LDIF/Parser.hs +206/−207
• src/Text/LDIF/Preproc.hs +84/−0
• src/Text/LDIF/Printer.hs +34/−29
• src/Text/LDIF/Tree.hs +64/−0
• src/Text/LDIF/Types.hs +76/−26
• src/Text/LDIF/Undo.hs +40/−0
• src/Text/LDIF/Utils.hs +23/−73
• src/diffLDIF.hs +0/−33
• src/ldif2html.hs +56/−43
• src/ldifdiff.hs +34/−0
• src/ldifmodify.hs +5/−4
• src/ldifparse.hs +4/−5
• src/ldifundo.hs +36/−0
• tests/TestMain.hs +62/−37

@@ -1,28 +0,0 @@-* Tasks-** error handling, modify add: <attrX> and than <attrY>:<value>,-          need to be asserted that <attrX> and <attrY> are the same.-** Implement the base64 parsing-** Implement modifyDN parsing-** update serializers back to LDIF for base64 & all DN notations-** add module tests for versioned LDIFs-** add module tests for base64 parsing-** update the API for correct support of LDIF RFC-multiple valued attribute in RDN-binary data -** DONE update parseDNStr to parse all kind of DN notations-CLOSED: [2011-04-17 Sun 15:28]-** DONE Use getopt for input parameters on diffLDIF cmd-** DONE Implement ldifmodify (like ldapmodify)-    offline applying of Change LDIF on Content LDIF-    ldifmodify -f <contentLDIF> -o <outputLDIF> [<modifyLDIF> ... ] -* Archive-** DONE Change interface for providing parser method with expected type of LDIF-it allows parse changeldif as contentldif regardless the content.--** DONE Add ldif2html which generate hypertext LDIF representation-** DONE Update unwrap method in preprocessor for feasible resource consuption-** DONE replace error call in mkMod with parser error-    (Not needed)-** DONE create preprocessor for concat split long lines & remove comments-** DONE refactoring of packages, create Types, Parser and Proc-** DONE Implement Attribute Name case-insensitive matching at DN

@@ -1,35 +1,31 @@ Name:            ldif-Version:         0.0.10+Version:         0.0.12 License:         BSD3 License-File:    LICENSE-Synopsis:        The LDAP Data Interchange Format (LDIF) parser +Synopsis:        The LDAP Data Interchange Format (LDIF) tools  Author:          Radoslav Dorcik <radoslav.dorcik@gmail.com> Homepage:        http://rampa.sk/static/ldif.html Maintainer:      radoslav.dorcik@gmail.com Description:     - LDIF files parser implementation using Parsec and based- on RFC 2849 - The LDAP Data Interchange Format (LDIF).+ LDIF files parser implementation using Parsec.+ The LDAP Data Interchange Format (LDIF) is defined by RFC 2849.  .- Current implementation is unfinished and need to be enhanced- for base64 encoded values and various DN escaping. + Current implementation is not complete and compliant with RFC.   .- It includes following tool:+ Package includes following command line tools:  .- - diffLDIF command generates change LDIF between two -   content LDIF files.+ - ldifdiff - calculates delta LDIF between two content LDIF files.  .- - ldif2html command generates hypertext HTML browsable-   LDIF file. + - ldif2html - produces HTML/browsable LDIF file.  .- - ldifmodify commmand apply change LDIF on contenct LDIF+ - ldifmodify - replays delta LDIF operations on content LDIF (similar to ldapmodify).  . Category:        Text Stability:       experimental Build-Type:      Simple-Cabal-Version:   >= 1.6+Cabal-Version:   >= 1.8 Extra-Source-Files:-    run_tests.sh-    TODO.org+    runTests.sh     doc/rfc2253.txt     doc/rfc2849.txt     tests/TestMain.hs@@ -52,46 +48,86 @@   description: Build test program.   default:     False +flag cmd+  description: Build command line programs.+  default:     False+ Library   Build-Depends:   base         < 5,                    filepath,+                   bytestring,                    containers,-                   cmdargs      >= 0.2,+                   cmdargs,                    directory,-                   parsec       >= 2.1.0+                   rosezipper,+                   parsec       == 3.*   Hs-Source-Dirs:  src   Extensions:      CPP, PatternGuards-  Ghc-Options:      -Wall -fno-warn-orphans+  Ghc-Options:      -Wall -fno-warn-orphans -O2    Exposed-modules:         Text.LDIF         Text.LDIF.Types         Text.LDIF.Parser+        Text.LDIF.Preproc         Text.LDIF.Printer         Text.LDIF.Utils         Text.LDIF.Diff         Text.LDIF.Apply         Text.LDIF.Consts+        Text.LDIF.Tree+        Text.LDIF.Undo -Executable diffLDIF+Executable ldifdiff   Hs-Source-Dirs:  src-  Main-Is:         diffLDIF.hs+  Main-Is:         ldifdiff.hs+  if flag(cmd)+    Buildable:     True+  else+    Buildable:     False+  if flag(test)+    Buildable:     False  Executable ldif2html   Hs-Source-Dirs:  src   Main-Is:         ldif2html.hs+  if flag(cmd)+    Buildable:     True+  else+    Buildable:     False+  if flag(test)+    Buildable:     False  Executable ldifmodify   Hs-Source-Dirs:  src   Main-Is:         ldifmodify.hs+  if flag(cmd)+    Buildable:     True+  else+    Buildable:     False+  if flag(test)+    Buildable:     False +Executable ldifundo+  Hs-Source-Dirs:  src+  Main-Is:         ldifundo.hs+  if flag(cmd)+    Buildable:     True+  else+    Buildable:     False+  if flag(test)+    Buildable:     False+ Executable ldifparse   Hs-Source-Dirs:  src   Main-Is:         ldifparse.hs--Executable test-  Hs-Source-Dirs:  src, tests-  Main-Is:         TestMain.hs-  Build-Depends:   base, HUnit == 1.2.*   if !flag(test)     Buildable:     False++Test-Suite ldif-test+    type:           exitcode-stdio-1.0+    Main-Is:        TestMain.hs+    Ghc-Options:      -Wall -fno-warn-orphans -O2+    Build-Depends:  base, HUnit == 1.2.*+    Hs-Source-Dirs:  src, tests+

@@ -0,0 +1,22 @@+#!/bin/sh++function showUsage()+{+   echo "Usage: $1 [ build | rebuild | run ]"+}++if [ -z "$1" ]; then+   showUsage $0+   exit 1;+fi++if [ "$1" = "run" ]; then+    cabal test+elif [ "$1" = "build" ]; then+    cabal configure --enable-tests && cabal build && cabal test+elif [ "$1" = "rebuild" ]; then+    cabal clean+    cabal configure --enable-tests && cabal build && cabal test+else+    showUsage $0+fi

@@ -1,3 +0,0 @@-#!/bin/sh--cabal configure -ftest && cabal build && cd tests && ../dist/build/test/test

@@ -4,7 +4,9 @@   module Text.LDIF.Printer,   module Text.LDIF.Utils,   module Text.LDIF.Diff,-  module Text.LDIF.Apply+  module Text.LDIF.Apply,+  module Text.LDIF.Tree,+  module Text.LDIF.Undo ) where @@ -14,3 +16,6 @@ import Text.LDIF.Utils import Text.LDIF.Diff import Text.LDIF.Apply+import Text.LDIF.Tree+import Text.LDIF.Undo+

@@ -1,29 +1,36 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+ module Text.LDIF.Apply (         applyLDIF ) where+import Prelude import Text.LDIF.Types import Text.LDIF.Utils import Text.LDIF.Printer import Data.List (nub, foldl')+import qualified Data.ByteString.Char8 as BC --- | Apply one LDIF to another LDIF. The destination LDIF has--- | to be Content LDIF++-- | Apply operations in second LDIF on content of first LDIF. The destination LDIF has+-- to be Content LDIF. applyLDIF :: LDIF -> LDIF -> LDIF applyLDIF dst (LDIF _ xs) = foldl' (\ld chg -> applyRecord2LDIF chg ld) dst xs  -- | Apply one LDIF Content/Change Record into LDIF and produce Changed LDIF applyRecord2LDIF :: LDIFRecord -> LDIF -> LDIF applyRecord2LDIF (ContentRecord dn vals) dst = applyRecord2LDIF (ChangeRecord dn (ChangeAdd vals)) dst-applyRecord2LDIF (ChangeRecord  dn op)   dst = applyChange2Record op dn dst (findRecordByDN dst dn)+applyRecord2LDIF (ChangeRecord  dn op)   dst = applyChange2Record op dn dst (findRecordByDN dstc dn)+  where+    dstc = createLookupTable dst  -- | Apply one LDIF Change (add/del/modf) for given DN within LDIF Content  applyChange2Record :: Change -> DN -> LDIF -> Maybe LDIFRecord -> LDIF applyChange2Record (ChangeAdd vals)   dn ld Nothing  = LDIF (lcVersion ld) ((lcEntries ld)++[ContentRecord dn vals]) -applyChange2Record (ChangeAdd _)      dn _  (Just _) = error ("ADD: Already exists: "++(dn2str dn))+applyChange2Record (ChangeAdd _)      dn _  (Just _) = error ("ADD: Already exists: "++(BC.unpack $ dn2str dn)) applyChange2Record ChangeDelete       dn ld (Just _) = LDIF (lcVersion ld) (filter (\x -> dn /= (reDN x)) (lcEntries ld))-applyChange2Record ChangeDelete       dn _  Nothing  = error ("DELETE: Entry not found: "++(dn2str dn))-applyChange2Record (ChangeModify _)   dn _  Nothing  = error ("MODIFY: Entry not found: "++(dn2str dn))+applyChange2Record ChangeDelete       dn _  Nothing  = error ("DELETE: Entry not found: "++(BC.unpack $ dn2str dn))+applyChange2Record (ChangeModify _)   dn _  Nothing  = error ("MODIFY: Entry not found: "++(BC.unpack $ dn2str dn)) applyChange2Record (ChangeModify ops) dn ld (Just r) = let pre  = takeWhile (\x -> dn /= (reDN x)) (lcEntries ld)                                                            post = filter (\x -> dn /= (reDN x)) $ dropWhile (\x -> dn /= (reDN x)) (lcEntries ld)                                                            rn   = foldr applyMod2Record r ops@@ -36,15 +43,15 @@ applyMod2Record (ModAdd      name vals) (ContentRecord dn av) = let nav = map (\v -> (name,v)) vals  -- new attr/values                                                                     mav = av ++ nav                  -- merged attr/values                                                                     verified = if (length $ nub mav) == (length mav) then mav-                                                                               else error ("ModAdd: Values already exists: "++(show av)++" vs "++(show vals)++" DN:"++(dn2str dn))+                                                                               else error ("ModAdd: Values already exists: "++(show av)++" vs "++(show vals)++" DN:"++(BC.unpack $ dn2str dn))                                                                     in ContentRecord dn verified applyMod2Record (ModDelete   name [])   (ContentRecord dn av) = let nav = filter (\(n,_) -> n /= name) av -- new attr/values                                                                     verified = if (length $ nub nav) /= (length av) then nav-                                                                               else error ("ModDel: Attribute not found: "++(show name)++" DN:"++(dn2str dn))+                                                                               else error ("ModDel: Attribute not found: "++(show name)++" DN:"++(BC.unpack $ dn2str dn))                                                                 in ContentRecord dn verified applyMod2Record (ModDelete   name vals) (ContentRecord dn av) = let mav = filter (\(n,v) -> n /= name || v `notElem` vals) av                                                                     verified = if (length av) - (length mav) == (length vals) then mav-                                                                               else error ("ModDel: Attribute/Value not found: "++(show name)++"vals"++(show vals)++" DN:"++(dn2str dn))+                                                                               else error ("ModDel: Attribute/Value not found: "++(show name)++"vals"++(show vals)++" DN:"++(BC.unpack $ dn2str dn))                                                                 in ContentRecord dn verified applyMod2Record (ModReplace  name vals) (ContentRecord dn av) = let nav = map (\v -> (name,v)) vals -- new attr/values                                                                     mav = (filter (\(n,_) -> n /= name) av) ++ nav -- merged

@@ -1,6 +1,9 @@ module Text.LDIF.Consts where --- | Chars necessary to be escaped when are within RDN values-specialDNChars, escapedDNChars :: [Char]-specialDNChars = [',','=','+','<','>','#',';']+-- | Chars with special meaning in DN+specialDNChars :: [Char]+specialDNChars = [',','=','+','<','>','#',';','/']++-- | Chars necessary to be escaped in DN when they are part of value+escapedDNChars :: [Char] escapedDNChars = ['\\', '"'] ++ specialDNChars

@@ -1,20 +1,16 @@ module Text.LDIF.Diff (         diffLDIF,-        diffRecord+        diffRecord,+        compareLDIF ) where import Text.LDIF.Types import Text.LDIF.Utils import Data.Maybe+import Data.List (foldl', sortBy) --- | Create Change LDIF between to LDIF contents. If any--- | of input argument is not LDIFContent it returns Nothing. --- | If there is not difference the Change LDIF with empty--- | change list is returned.--- |--- | Unsing following strategy: --- | 1. Iterate over L1 DN's and Modify / Remove Content --- | 2. Iterate over L2 and Add Content not in L1+-- | Calculate Change LDIF between two LDIF contents.+-- If there is not difference the empty change list is returned. diffLDIF :: LDIF -> LDIF -> Either String LDIF diffLDIF l1 l2 | getLDIFType l1 == LDIFContentType && getLDIFType l2 == LDIFContentType = Right (diffLDIF' l1 l2)                | otherwise = Left ("Diff supported only on Content LDIFs but SRC="@@ -22,24 +18,28 @@                                          ++(show $ getLDIFType l2))  diffLDIF' :: LDIF -> LDIF -> LDIF-diffLDIF' l1@(LDIF _ c1) l2@(LDIF v2 c2) = LDIF v2 (changes ++ adds)+diffLDIF' l1@(LDIF _ c1) l2@(LDIF v2 c2) = LDIF v2 (changes ++ deletes ++ adds)    where -      adds = map (content2add) $ filter (not . isEntryIn l1) c2-      changes = filter (not . isDummyRecord) $ foldl (processEntry) [] c1-      processEntry xs e1 = let me2 = findRecordByDN l2 (reDN e1) -                               change = case me2 of-					   Nothing -> ChangeRecord (reDN e1) ChangeDelete-                                           Just e2 -> fromJust $ diffRecord e1 e2-                           in xs ++ [change]-      isEntryIn ll ex = let mex = findRecordByDN ll (reDN ex)-                        in case mex of-                          Nothing -> False-                          Just _  -> True-      content2add (ContentRecord dn vals) = ChangeRecord dn (ChangeAdd vals)-      content2add (ChangeRecord _ _)      = error "Unexpected record type"+      adds = map content2add $ filter (not . isEntryIn) c2+        where+          llc = createLookupTable l1+          isEntryIn ex = case findRecordByDN llc (reDN ex) of+            Nothing                   -> False+            Just (ContentRecord _ _)  -> True+            Just (ChangeRecord _ _)   -> error "Unexpected record type"+          content2add (ContentRecord dn vals) = ChangeRecord dn (ChangeAdd vals)+          content2add (ChangeRecord _ _)      = error "Unexpected record type"+      (changes,deletes) = (reverse $ fnu changes', fnu deletes')+        where+          fnu = filter (not . isDummyRecord)+          l2c = createLookupTable l2+          (changes',deletes') = foldl' processEntry ([],[]) c1+          processEntry (cx,dx) e1 = procEntry' $ findRecordByDN l2c (reDN e1)+            where+              procEntry' Nothing   = (cx, (ChangeRecord (reDN e1) ChangeDelete):dx)+              procEntry' (Just e2) = ((fromJust $ diffRecord e1 e2):cx, dx) --- | Diff two AttrVal Records if any of provided. --- | Implementation uses inefficient algorithm for large count of attributes within ContentRecord.+-- | Calculate difference between two LDIF Records diffRecord :: LDIFRecord -> LDIFRecord -> Maybe LDIFRecord diffRecord r1 r2 | (reDN r1) /= (reDN r2) = Nothing                  | otherwise = Just (ChangeRecord (reDN r1) (ChangeModify mods))@@ -49,3 +49,22 @@       delMods = map (\x -> ModDelete (fst x) [(snd x)]) delVals       addVals = filter (\x -> not $ elem x (coAttrVals r1)) (coAttrVals r2) :: [AttrValue]       delVals = filter (\x -> not $ elem x (coAttrVals r2)) (coAttrVals r1) :: [AttrValue]++-- | Compare two LDIFs and provide list of the Records for each input LDIF,+-- which are different or not present in the other LDIF.+compareLDIF :: LDIF -> LDIF -> ([LDIFRecord], [LDIFRecord])+compareLDIF l1@(LDIF _ c1) l2@(LDIF _ c2) = (sortBy cmpByDN r1, sortBy cmpByDN $ r2 ++ adds)+   where +      cmpByDN a b = (reDN a) `compare` (reDN b)+      adds = filter (not . isEntryIn) c2+        where+          llc = createLookupTable l1+          isEntryIn ex = case findRecordByDN llc (reDN ex) of+            Nothing                   -> False+            (Just _)                  -> True+      (r1,r2) = foldl' processEntry ([],[]) c1+        where+          l2c = createLookupTable l2+          processEntry (a1,a2) e1 = case findRecordByDN l2c (reDN e1) of+            Nothing -> (e1:a1,a2)+            Just e2 -> if e1 == e2 then (a1,a2) else (e1:a1,e2:a2)

@@ -1,278 +1,277 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+ module Text.LDIF.Parser ( 	parseLDIFStr,-        parseLDIFStrAs, 	parseLDIFFile,-        parseDNStr+        parseDNStr,+        preproc,+        defaulLDIFConf,+        LDIFParserConfig(..) ) where+import Prelude import Text.LDIF.Types import Text.LDIF.Consts-import Text.ParserCombinators.Parsec+import Text.LDIF.Preproc+import Text.Parsec as PR+import Text.Parsec.ByteString+import Text.Parsec.Pos (initialPos)+import Text.Parsec.Error (Message(..), newErrorMessage)+import qualified Data.ByteString.Char8 as BC import Data.Char-import Data.List (isPrefixOf)+import Data.Maybe (fromJust, isNothing) import Numeric (readHex) --- | Parse string as LDIF content and return LDIF or ParseError-parseLDIFStr :: String -> Either ParseError LDIF-parseLDIFStr = parseLDIFStrAs Nothing ---- | Read and parse provided file and return LDIF or ParseError-parseLDIFFile :: String -> IO (Either ParseError LDIF)-parseLDIFFile name = do-	input <- readFile name-        return $ parseLDIFStrAs' name Nothing input---- | Read and parse provided string and return LDIF or ParserError--- | If LDIF type is specified than given type is expected for parsing --- | and mismatch generates ParseError-parseLDIFStrAs' :: String -> Maybe LDIFType -> String -> Either ParseError LDIF-parseLDIFStrAs' nm Nothing                = parse pLdif        nm . preproc-parseLDIFStrAs' nm (Just LDIFMixedType)   = parse pLdif        nm . preproc-parseLDIFStrAs' nm (Just LDIFContentType) = parse pLdifContent nm . preproc-parseLDIFStrAs' nm (Just LDIFChangesType) = parse pLdifChanges nm . preproc--parseLDIFStrAs :: Maybe LDIFType -> String -> Either ParseError LDIF-parseLDIFStrAs = parseLDIFStrAs' "(param)"---- | Parse string as DN and return DN type or ParseError-parseDNStr :: String -> Either ParseError DN-parseDNStr = parse pDN "(param)" ---- | Preprocessing for concat wrapped lines and remove comment lines-preproc :: String -> String-preproc = stripComments . unwrap+-- | LDIF Parser configuration+data LDIFParserConfig = LDIFParserConfig { lpExpectedType :: Maybe LDIFType  -- ^ Type of LDIF expected+                                         , lpCaseSensitive :: Bool } -- ^ Parse as Case Sensitive LDIF+                      deriving Show --- | Remove Comment Lines-stripComments :: String -> String-stripComments input = unlines $ filter (not . isPrefixOf "#") $ lines input+-- | Default configuration for parser (Any LDIF Type, Case Sensitive)+defaulLDIFConf :: LDIFParserConfig+defaulLDIFConf = LDIFParserConfig Nothing True --- | Unwrap lines, lines with space at begin is continue of previous line -unwrap :: String -> String-unwrap xs = unlines $ takeLines $ lines xs+-- | Parse LDIF content+parseLDIFStr :: LDIFParserConfig -> FilePath -> BC.ByteString -> Either ParseError LDIF+parseLDIFStr conf name xs = case eldif of +                               Left err  -> Left $ transposePos ptab err+                               Right ldf -> checkExpectedType ldf+  where +    (input, ptab) = preproc xs+    eldif = parse (pLdif conf) name input+    checkExpectedType ldf | (isNothing $ lpExpectedType conf) = Right ldf+                          | (getLDIFType ldf) == (fromJust $ lpExpectedType conf) = Right ldf+                          | otherwise = Left $ newErrorMessage (UnExpect "Invalid LDIF Type") (initialPos name)                                                                                     -takeLines :: [String] -> [String]-takeLines [] = []-takeLines xs = let (ln,ys) = takeLine xs-               in ln:takeLines ys+-- | Parse LDIF file+parseLDIFFile :: LDIFParserConfig -> FilePath -> IO (Either ParseError LDIF)+parseLDIFFile conf name = do+	input <- BC.readFile name+        return $ parseLDIFStr conf name input -takeLine :: [String] -> (String, [String])-takeLine []     = ([],[])-takeLine (x:[]) = (x,[])-takeLine (x:xs) = let isCont z = " " `isPrefixOf` z-                  in (x ++ (concat $ map (tail) $ takeWhile (isCont) xs), dropWhile (isCont) xs) +-- | Parse DN+parseDNStr :: LDIFParserConfig -> BC.ByteString -> Either ParseError DN+parseDNStr conf = parse (pDN conf) "(param)"   -- | Parsec ldif parser-pLdif :: CharParser st LDIF-pLdif = try pLdifChanges <|> try pLdifMixed--pLdifChanges :: CharParser st LDIF-pLdifChanges = do-    pSEPs-    ver <- optionMaybe pVersionSpec-    pSEPs-    recs <- sepEndBy pChangeRec pSEPs-    eof-    return $ LDIF ver recs--pLdifMixed:: CharParser st LDIF-pLdifMixed = do-    pSEPs-    ver <- optionMaybe pVersionSpec-    pSEPs-    recs <- sepEndBy pRec pSEPs-    eof-    return $ LDIF ver recs--pLdifContent :: CharParser st LDIF-pLdifContent = do-    pSEPs+pLdif :: LDIFParserConfig -> Parser LDIF+pLdif conf = do+    pSEPs conf     ver <- optionMaybe pVersionSpec-    pSEPs-    recs <- sepEndBy pAttrValRec pSEPs+    recs <- sepEndBy (pRec conf) (pSEPs1 conf)+    _ <- optionMaybe pSearchResult     eof-    return $ LDIF ver recs--pAttrValRec ::  CharParser st LDIFRecord-pAttrValRec = do-    dn <- pDNSpec-    pSEP-    attrVals <- sepEndBy1 pAttrValSpec pSEP-    return $ ContentRecord dn attrVals--pRec :: CharParser st LDIFRecord-pRec = try pChangeRec <|> pAttrValRec--pChangeRec :: CharParser st LDIFRecord-pChangeRec = try pChangeAdd-         <|> try pChangeDel-         <|> try pChangeMod-         <|> pChangeModDN+    recs `seq` return $ LDIF ver recs+  where+    pVersionSpec :: Parser BC.ByteString+    pVersionSpec = do+      _ <- string "version:"+      pFILL conf+      xs <- many1 digit+      pSEPs1 conf+      let ys = xs `seq` BC.pack xs+      ys `seq` return $ ys+    pSearchResult :: Parser ()+    pSearchResult = do+      _ <- string "search:"+      pFILL conf+      _ <- many1 digit+      pSEP conf+      _ <- string "result:"+      pFILL conf+      _ <- pSafeString conf+      pSEPs conf+      return () -pChangeAdd :: CharParser st LDIFRecord-pChangeAdd = do-    dn <- pDNSpec-    pSEP-    _ <- string "changetype:"-    pFILL+pRec :: LDIFParserConfig -> Parser LDIFRecord+pRec conf = do +  dn <- pDNSpec+  pSEP conf+  try (pChangeRec dn) <|> (pAttrValRec dn)+    where+      pDNSpec :: Parser DN+      pDNSpec = do+        _ <- string "dn:"+        pDN conf+      pAttrValRec :: DN -> Parser LDIFRecord+      pAttrValRec dn = do+        attrVals <- sepEndBy1 (pAttrValSpec conf) (pSEP conf)+        attrVals `seq` return $ ContentRecord dn attrVals+      pChangeRec :: DN -> Parser LDIFRecord+      pChangeRec dn = do+        _ <- string "changetype:"+        pFILL conf+        try (pChangeAdd conf dn)+          <|> try (pChangeDel conf dn)+          <|> try (pChangeMod conf dn)+          <|> (pChangeModDN conf dn)+                      +pChangeAdd :: LDIFParserConfig -> DN -> Parser LDIFRecord+pChangeAdd conf dn  = do     _ <- string "add"-    pSEP-    vals <- sepEndBy1 pAttrValSpec pSEP+    pSEP conf+    vals <- sepEndBy1 (pAttrValSpec conf) (pSEP conf)     return $ ChangeRecord dn (ChangeAdd vals) -pChangeDel :: CharParser st LDIFRecord-pChangeDel = do-    dn <- pDNSpec-    pSEP-    _ <- string "changetype:"-    pFILL+pChangeDel :: LDIFParserConfig -> DN -> Parser LDIFRecord+pChangeDel conf dn = do     _ <- string "delete"-    pSEP+    pSEP conf     return $ ChangeRecord dn ChangeDelete -pChangeMod :: CharParser st LDIFRecord-pChangeMod = do-    dn <- pDNSpec-    pSEP-    _ <- string "changetype:"-    pFILL+pChangeMod :: LDIFParserConfig -> DN -> Parser LDIFRecord+pChangeMod conf dn = do     _ <- string "modify"-    pSEP-    mods <- sepEndBy1 pModSpec (char '-' >> pSEP)+    pSEP conf+    mods <- sepEndBy1 (pModSpec conf) (char '-' >> pSEP conf)     return $ ChangeRecord dn (ChangeModify mods) -pChangeModDN :: CharParser st LDIFRecord-pChangeModDN = do-    dn <- pDNSpec-    pSEP-    _ <- string "changetype:"-    pFILL+pChangeModDN :: LDIFParserConfig -> DN -> Parser LDIFRecord+pChangeModDN conf dn = do     _ <- string "modrdn" -    pSEP+    pSEP conf     _ <- string "newrdn:"-    pFILL -    _ <- pRDN-    pSEP+    pFILL conf+    _ <- pRDN conf+    pSEP conf     _ <- string "deleteoldrdn:"-    pFILL+    pFILL conf     _ <- oneOf "01"-    pSEP+    pSEP conf     return $ ChangeRecord dn ChangeModDN -pRDN :: CharParser st String-pRDN = pSafeString--pDNSpec :: CharParser st DN-pDNSpec = do-    _ <- string "dn:"-    pDN+pRDN :: LDIFParserConfig -> Parser BC.ByteString+pRDN conf = pSafeString conf -pDN :: CharParser st DN-pDN = do-   pFILL-   avals <- sepEndBy pAttrEqValue (char ',')  -   return $ DN avals+pDN :: LDIFParserConfig -> Parser DN+pDN conf = do+   pFILL conf+   avals <- sepEndBy (pAttrEqValue conf) (char ',')+   avals `seq` return $ DN avals -pAttrEqValue :: CharParser st AttrValue-pAttrEqValue = do-   pFILL-   att <- pAttributeType+pAttrEqValue :: LDIFParserConfig -> Parser AttrValue+pAttrEqValue conf = do+   pFILL conf+   att <- pAttributeType conf    _ <- char '='-   val <- pAttrValueDN-   return (att,val)+   val <- pAttrValueDN conf+   att `seq` val `seq` return (att,val) -pAttrValueDN :: CharParser st Value-pAttrValueDN = do-   many allChar+pAttrValueDN :: LDIFParserConfig -> Parser Value+pAttrValueDN conf = do+   xs <- many1 allChar+   let ys = xs `seq` (mkVal conf $ BC.pack xs)+   ys `seq` return $ ys    where -     allChar = try (escChar) <|> try (hexChar) <|> (noneOf (escapedDNChars ++ "\n\r"))+     allChar = noneOf (escapedDNChars ++ "\n")+               <|> try (hexChar)+               <|> (escChar)      escChar = do        _ <- char '\\'        oneOf escapedDNChars      hexChar = do        _ <- char '\\'-       hval <- count 2 hexDigit+       hval <- PR.count 2 hexDigit        case readHex hval of          [(val,[])] -> return $ chr val          _          -> fail $ "invalid hex value: " ++ hval -pVersionSpec :: CharParser st String-pVersionSpec = do-   _ <- string "version:"-   pFILL-   many1 digit--pModSpec :: CharParser st Modify-pModSpec = do-   modType <- pModType-   pFILL-   att <- pAttributeDescription -   pSEP -   vals <- sepEndBy pAttrValSpec pSEP+pModSpec :: LDIFParserConfig -> Parser Modify+pModSpec conf = do+   modType <- pModType conf+   pFILL conf+   att <- pAttributeDescription conf+   pSEP conf+   vals <- sepEndBy (pAttrValSpec conf) (pSEP conf)    return $ mkMod modType att vals  mkMod :: String -> Attribute -> [AttrValue] -> Modify mkMod modType att vals | modType == "add:" = ModAdd att (map (snd) vals)                        | modType == "delete:" = ModDelete att (map (snd) vals)                        | modType == "replace:" = ModReplace att (map (snd) vals)-                       | otherwise = error $ "unexpected mod:" ++ modType +                       | otherwise = error $ "unexpected mod:" ++ modType                          -- error can not be reached because pModType -pModType :: CharParser st String-pModType = try (string "add:")+pModType :: LDIFParserConfig -> Parser String+pModType _ = try (string "add:")        <|> try (string "delete:")        <|> string "replace:" -pAttributeDescription :: CharParser st Attribute-pAttributeDescription = pAttributeType+pAttributeDescription :: LDIFParserConfig -> Parser Attribute+pAttributeDescription conf = pAttributeType conf -pAttributeType :: CharParser st Attribute-pAttributeType = try pLdapOid-             <|> (do { l <- letter; o <- pAttrTypeChars; return (Attribute $ l:o) } )+pAttributeType :: LDIFParserConfig -> Parser Attribute+pAttributeType _ = try pLdapOid+             <|> pCharType+   where+      pDotOid = do+         _ <- string "." +         n <- many1 digit+         let xs = n `seq` '.':n+         xs `seq` return xs+      pLdapOid = do+        num <- many1 digit+        rest <- many1 pDotOid+        let xs = num `seq` rest `seq` num ++ concat rest+        xs `seq` return (Attribute $ BC.pack xs)+      pCharType = do+         l <- letter +         o <- pAttrTypeChars+         let xs = l `seq` o `seq` l `BC.cons` o+         xs `seq` return $ Attribute xs+           where+             pAttrTypeChars :: Parser BC.ByteString+             pAttrTypeChars = do +               xs <- many (satisfy (\x -> isAlphaNum x || x == '-'))+               let ys = xs `seq` BC.pack xs+               ys `seq` return ys -pAttrValSpec :: CharParser st AttrValue-pAttrValSpec = do-   name <- pAttributeDescription-   val  <- pValueSpec-   return (name, val) -pValueSpec :: CharParser st Value-pValueSpec = try (char ':' >> char ':' >> pFILL >> pBase64String)-         <|> try (char ':' >> pFILL >> pSafeString') -         <|> (char ':' >> char '<' >> pFILL >> pURL)+pAttrValSpec :: LDIFParserConfig -> Parser AttrValue+pAttrValSpec conf = do+   name <- pAttributeDescription conf+   val  <- pValueSpec+   name `seq` val `seq` return (name, val)+     where+       pValueSpec :: Parser Value+       pValueSpec = try (char ':' >> pFILL conf >> pSafeString' conf >>= (\x -> return $ mkVal conf x))+                    <|> try (char ':' >> char ':' >> pFILL conf >> pBase64String conf >>= (\x -> return $ mkVal conf x))+                    <|> (char ':' >> char '<' >> pFILL conf >> pURL conf >>= (\x -> return $ mkVal conf x)) -pURL :: CharParser st String-pURL = pSafeString+pURL :: LDIFParserConfig -> Parser BC.ByteString+pURL conf = pSafeString conf -pSafeString :: CharParser st String-pSafeString = do-   c <- noneOf "\n\r :<"-   r <- many (noneOf "\n\r")-   return $ c:r+pSafeString :: LDIFParserConfig -> Parser BC.ByteString+pSafeString _ = do+   c <- noneOf "\n :<"+   r <- many (noneOf "\n")   +   let xs = r `seq` c:r+   let ys = xs `seq` BC.pack xs+   ys `seq` return ys -pSafeString' :: CharParser st String-pSafeString' = do-   r <- many (noneOf "\n\r")-   return r+pSafeString' :: LDIFParserConfig -> Parser BC.ByteString+pSafeString' _ = do+   r <- many (noneOf "\n")+   let ys = r `seq` BC.pack r+   ys `seq` return ys  -pBase64String :: CharParser st String-pBase64String = pSafeString--pAttrTypeChars :: CharParser st String-pAttrTypeChars = many (satisfy (\x -> isAlphaNum x || x == '-'))+pBase64String :: LDIFParserConfig -> Parser BC.ByteString+pBase64String conf = pSafeString conf -pLdapOid :: CharParser st Attribute-pLdapOid = do-   num <- many1 digit-   rest <- many (do { _ <- string "."; n <- many1 digit; return $ '.':n})-   return (Attribute $ num ++ concat rest)+pFILL :: LDIFParserConfig -> Parser ()+pFILL _ = skipMany (oneOf [' ', '\t']) -pFILL :: CharParser st ()-pFILL = skipMany (oneOf [' ', '\t'])+pSEP :: LDIFParserConfig -> Parser ()+pSEP _ = do+         _ <- newline+         return () -pSEP :: CharParser st ()-pSEP = try (char '\r' >> char '\n' >> return () )-   <|> (char '\n' >> return () )+pSEPs :: LDIFParserConfig -> Parser ()+pSEPs conf = many (pSEP conf) >> return () -pSEPs :: CharParser st ()-pSEPs = many pSEP >> return ()+pSEPs1 :: LDIFParserConfig -> Parser ()+pSEPs1 conf = many1 (pSEP conf) >> return () +mkVal :: LDIFParserConfig -> BC.ByteString -> Value+mkVal conf v | (lpCaseSensitive conf) = Value v+             | otherwise              = ValueI v

@@ -0,0 +1,84 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++module Text.LDIF.Preproc ( preproc +                         , transposePos +                         , PosTable )+where+import Text.Parsec+import Text.Parsec.Error (setErrorPos)+import qualified Data.ByteString.Char8 as BC+import Data.List (foldl', sortBy)++-- | Opaque data necessary for relation between text after preprocessing and original+type PosTable = [ PosOp ]++data PosOp = PosOpAddLine { psLine :: Int }+           | PosOpWrap    { psLine :: Int, psW :: Int, psWP :: Int } deriving Show++data LdifLine = LdifLine     { llNum :: Int, llStr :: BC.ByteString }+              | LdifLineCont { llNum :: Int, llStr :: BC.ByteString }+              | LdifComment  { llNum :: Int, llStr :: BC.ByteString }++-- | Convert error position to original text before preprocessing+transposePos :: PosTable -> ParseError -> ParseError+transposePos ptab oe = setErrorPos npos oe+  where+    opos = errorPos oe+    npos = setSourceColumn (setSourceLine opos nlin) ncol+      where+        opIdx a b = (psLine a) `compare` (psLine b)+        ocord = (sourceLine opos,sourceColumn opos)+        (nlin,ncol) = calcPos (sortBy opIdx ptab) ocord++calcPos :: PosTable -> (Int, Int) -> (Int, Int)+calcPos xs cord = foldl' updatePos cord xs+  where+    updatePos (l0,c0) (PosOpAddLine l)    | l0 >= l        = (l0+1,c0)+    updatePos (l0,c0) (PosOpWrap l _ _)  | l0 >= l        = (l0+1,c0)+    updatePos (l0,c0) (PosOpWrap l w wp)  | (l0+1) == l && c0 > w && (c0-1-w) > wp  = (l0+1,c0)+    updatePos (l0,c0) (PosOpWrap l w wp)  | (l0+1) == l && c0 > w && (c0-1-w) <= wp = (l0+1,c0-w)+    updatePos x _ = x+      +-- | Preprocessing of LDIF file, concat wrapped lines and remove comment lines+preproc :: BC.ByteString -> (BC.ByteString, PosTable)+preproc xs = (str, ptab)+  where +    str = BC.unlines $ map llStr ys    +    (ys, ptab) = lns xs+      where+        lns zs = stripComments $ unwrap $ (tokenizeLines $ specLines zs, [])++specLines :: BC.ByteString -> [BC.ByteString]+specLines xs = map cleanLine $ BC.lines xs+  where+    isCR c = c == '\r'+    cleanLine l | BC.null l        = l+                | isCR (BC.last l) = cleanLine $ BC.init l+                | otherwise        = l++tokenizeLines :: [BC.ByteString] -> [LdifLine]+tokenizeLines xs = map tokenizeLine $ zip xs [1..]+  where+    tokenizeLine (x,i) | BC.null x        = LdifLine     i BC.empty+                       | BC.head x == '#' = LdifComment  i x+                       | BC.head x == ' ' = LdifLineCont i $ BC.tail x+                       | otherwise        = LdifLine     i x+                                            +-- | Remove Comment Lines+stripComments :: ([LdifLine],PosTable) -> ([LdifLine],PosTable)+stripComments (xs,pt) = foldl' procLine ([],pt) xs+  where+    procLine (v,p) (LdifComment i _) = (v,(PosOpAddLine i):p)+    procLine (v,p) o                 = (o:v,p)++-- | Unwrap lines, lines with space at begin is continue of previous line +unwrap :: ([LdifLine],PosTable) -> ([LdifLine],PosTable)+unwrap (xs,pt) = foldl' procLine ([],pt) xs+  where+    procLine ([],p) o = (o:[],p)+    procLine (v,p) (LdifLineCont i s) = let (z,r) = splitAt 1 v+                                            o = head z+                                            o' = o { llStr = (llStr o) `BC.append` s }+                                            p' = (PosOpWrap i (BC.length $ llStr o) (BC.length s)):p+                                        in (o':r,p')+    procLine (v,p) o                  = (o:v,p)

@@ -1,54 +1,59 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+ -- | LDIF serializers module Text.LDIF.Printer ( 	ldif2str,+        ver2str,         dn2str, 	record2str ) where+import Prelude import Text.LDIF.Types import Text.LDIF.Consts-import Data.List+import qualified Data.ByteString.Char8 as BC+import Data.List as L import Data.Char import Numeric (showHex)  -- | Serialize LDIF in LDIF Format-ldif2str :: LDIF -> String-ldif2str (LDIF v xs) = unlines $ (ver2str v) ++ (map (record2str) xs)+ldif2str :: LDIF -> BC.ByteString+ldif2str (LDIF v xs) = BC.unlines $ (ver2str v) ++ (map (record2str) xs)  -- | Serialize version to LDIF Format Lines-ver2str :: Maybe String -> [String]+ver2str :: Maybe BC.ByteString -> [BC.ByteString] ver2str Nothing = []-ver2str (Just v) = ["version: "++v]+ver2str (Just v) = ["version: " `BC.append` v]  -- | Serialize DN to LDIF Format-dn2str :: DN -> String-dn2str xs = intercalate "," $ map (\((Attribute n),v) -> n++"="++(escapeDNVals v)) (dnAttrVals xs)--escapeDNVals :: String -> String-escapeDNVals vs = concat $ map escapeDNVal vs+dn2str :: DN -> BC.ByteString+dn2str xs = BC.intercalate "," $ map (\((Attribute n),v) -> n `BC.append` "="  `BC.append` (escapeDNVals $ aVal v)) (dnAttrVals xs)   where-    escapeDNVal x | not $ isPrint x          = '\\':(showHex (ord x) "")-                  | elem x escapedDNChars    = '\\':[x]-                  | otherwise                = [x]+    escapeDNVals :: BC.ByteString -> BC.ByteString+    escapeDNVals vs = BC.concat $ map escapeDNVal (BC.unpack vs)+      where+        escapeDNVal x | not $ isPrint x          = BC.pack $ '\\':(showHex (ord x) "")+                      | elem x escapedDNChars  = BC.pack $ '\\':[x]+                      | otherwise                = BC.pack $ [x]  -- | Serialize Content Record in LDIF Format-record2str :: LDIFRecord -> String-record2str (ContentRecord dn xs)                = unlines $ [ "dn: "++(dn2str dn) ] ++ (attrVals2Ln xs)-record2str (ChangeRecord dn (ChangeDelete))     = unlines   [ "dn: "++(dn2str dn), "changetype: delete" ]-record2str (ChangeRecord dn (ChangeAdd xs))     = unlines $ [ "dn: "++(dn2str dn), "changetype: add"    ] ++ (attrVals2Ln xs)-record2str (ChangeRecord dn (ChangeModify xs))  = unlines $ [ "dn: "++(dn2str dn), "changetype: modify" ] ++ (mods2Ln xs)-record2str (ChangeRecord dn (ChangeModDN))      = unlines $ [ "dn: "++(dn2str dn), "changetype: moddn"  ]+record2str :: LDIFRecord -> BC.ByteString+record2str (ContentRecord dn xs)                = BC.unlines $ [ "dn: " `BC.append` (dn2str dn) ] ++ (attrVals2Ln xs)+record2str (ChangeRecord dn (ChangeDelete))     = BC.unlines   [ "dn: " `BC.append` (dn2str dn), "changetype: delete" ]+record2str (ChangeRecord dn (ChangeAdd xs))     = BC.unlines $ [ "dn: " `BC.append` (dn2str dn), "changetype: add"    ] ++ (attrVals2Ln xs)+record2str (ChangeRecord dn (ChangeModify xs))  = BC.unlines $ [ "dn: " `BC.append` (dn2str dn), "changetype: modify" ] ++ (mods2Ln xs)+record2str (ChangeRecord dn (ChangeModDN))      = BC.unlines $ [ "dn: " `BC.append` (dn2str dn), "changetype: moddn"  ] -attrVals2Ln :: [AttrValue] -> [String]+attrVals2Ln :: [AttrValue] -> [BC.ByteString] attrVals2Ln xs = map (attrVal2Ln) xs -attrVal2Ln :: AttrValue -> String-attrVal2Ln ((Attribute n),v) = n ++ ": "++v--mods2Ln :: [Modify] -> [String]-mods2Ln xs = intercalate ["-"] $ map (mod2Ln) xs+attrVal2Ln :: AttrValue -> BC.ByteString+attrVal2Ln ((Attribute n),v) = BC.concat [ n,": ", aVal v ] -mod2Ln :: Modify -> [String]-mod2Ln (ModAdd     a@(Attribute nm) xs) = [ attrVal2Ln ((Attribute "add"),nm)     ] ++ (map (\v -> attrVal2Ln (a,v)) xs) -mod2Ln (ModDelete  a@(Attribute nm) xs) = [ attrVal2Ln ((Attribute "delete"),nm)  ] ++ (map (\v -> attrVal2Ln (a,v)) xs)-mod2Ln (ModReplace a@(Attribute nm) xs) = [ attrVal2Ln ((Attribute "replace"),nm) ] ++ (map (\v -> attrVal2Ln (a,v)) xs)+mods2Ln :: [Modify] -> [BC.ByteString]+mods2Ln xs = L.intercalate ["-"] $ map (mod2Ln) xs+  where+    mod2Ln :: Modify -> [BC.ByteString]+    mod2Ln (ModAdd     a zs) = [ attrVal2Ln ((Attribute "add"),Value $ aName a)     ] ++ (map (\v -> attrVal2Ln (a,v)) zs) +    mod2Ln (ModDelete  a zs) = [ attrVal2Ln ((Attribute "delete"),Value $ aName a)  ] ++ (map (\v -> attrVal2Ln (a,v)) zs)+    mod2Ln (ModReplace a zs) = [ attrVal2Ln ((Attribute "replace"),Value $ aName a) ] ++ (map (\v -> attrVal2Ln (a,v)) zs)

@@ -0,0 +1,64 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++-- | LDIF representation in Data.Tree structure+module Text.LDIF.Tree ( toTree, fromTree, sortTreeByName )+       where+import Prelude+import Text.LDIF.Types+import Text.LDIF.Utils+import Data.Tree+import Data.Maybe+import Data.List+import qualified Data.Set as S+import qualified Data.Tree.Zipper as Z++-- | Flatten Tree of Records to LDIF+fromTree :: Tree LDIFRecord -> LDIF+fromTree !xs = ys `seq` LDIF Nothing ys+  where+    ys = (filter (not . isFakeEntry) $ flatten xs)+      where+        isFakeEntry (ContentRecord _ []) = True+        isFakeEntry _ = False++-- | Convert LDIF to Tree of Records using their DNs. Can insert dummy parents.+toTree :: LDIF -> Bool -> Tree LDIFRecord+toTree (LDIF _ xs) False = fromRecords xs+toTree (LDIF _ xs) True  = fromRecords $ addFakeParents xs+        +addFakeParents :: [ LDIFRecord ] -> [ LDIFRecord ]        +addFakeParents entries = fakeParents ++ entries+  where +    fakeParents = map fakeParent missingDNs+      where+        fakeParent dn = ContentRecord dn []+        missingDNs = filter ((flip S.notMember) allDNs) $ S.toList parentDNs+          where+            allDNs = S.fromList $ map reDN entries+            parentDNs =  S.fromList $ map DN $ filter (not . null) $ concatMap (tails . dnAttrVals) $ S.toList allDNs+    +rootEntry :: Tree LDIFRecord    +rootEntry = Node (ContentRecord (DN []) []) []++fromRecords :: [LDIFRecord] -> Tree LDIFRecord+fromRecords xs = Z.toTree $ foldl' addEntry (Z.fromTree rootEntry) $ sortBy compareByDNLen xs+      where+        compareByDNLen a b = (lengthOfDN $ reDN a) `compare` (lengthOfDN $ reDN b)+        addEntry tree entry = Z.root $ Z.insert (Node entry []) $ findParent tree+          where+            findParent z | not $ Z.hasChildren z = Z.children z -- No children; put it here+                         | isNothing child       = Z.children z -- No matching child; put it here+                         | otherwise             = findParent $ fromJust child -- found matching child, continue+              where+                child = findChild $ Z.firstChild z -- Traverse all childs+                  where+                    findChild Nothing  = Nothing -- Nothing found+                    findChild (Just c)  | (Z.label c) `isParentRecordOf` entry = Just c  -- Found+                                        | otherwise                            = findChild $ Z.next c -- Continue++-- | Sort recursively children Records by DNs+sortTreeByName :: Tree LDIFRecord -> Tree LDIFRecord+sortTreeByName (Node n []) = Node n []+sortTreeByName (Node n xs) = let ys = sortBy cmpDN xs+                                 cmpDN a b = (reDN $ rootLabel a) `compare` (reDN $ rootLabel b)+                             in Node n (map sortTreeByName ys)

@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+ -- | LDIF related types module Text.LDIF.Types (  	LDIF(..),   @@ -6,26 +8,44 @@         Modify(..),          DN(..),          LDIFType(..),-        Attribute(..), Value, AttrValue+        Attribute(..), Value(..), AttrValue,+        isContentRecord,+        isChangeRecord,+        getLDIFType ) where+import qualified Data.ByteString.Char8 as BC import Data.Char -newtype Attribute = Attribute String deriving Show+-- | Attribute name is case-insensitive string+data Attribute = Attribute { aName :: BC.ByteString } deriving Show  instance Eq Attribute where-    (Attribute xs) == (Attribute ys)  = (map toUpper xs) == (map toUpper ys)+    (Attribute xs) == (Attribute ys)  = (BC.map toUpper xs) == (BC.map toUpper ys)  instance Ord Attribute where-    (Attribute xs) `compare` (Attribute ys)  = (map toUpper xs) `compare` (map toUpper ys)+    (Attribute xs) `compare` (Attribute ys)  = (BC.map toUpper xs) `compare` (BC.map toUpper ys) -type Value = String+-- | Attribute value is either case sensitive or insensitive string+data Value = Value  { aVal :: BC.ByteString }+           | ValueI { aVal :: BC.ByteString } deriving Show+             +instance Eq Value where+    (Value xs) == (Value ys)  = xs == ys+    xs == ys  = (BC.map toUpper $ aVal xs) == (BC.map toUpper $ aVal ys)++instance Ord Value where+    (Value xs) `compare` (Value ys)  = xs `compare` ys+    xs `compare` ys = (BC.map toUpper $ aVal xs) `compare` (BC.map toUpper $ aVal ys)++-- | Pair of Atribute and Value type AttrValue = (Attribute, Value) --- | Type of LDIF Files (Content, Changes)-data LDIFType = LDIFContentType -              | LDIFChangesType -              | LDIFMixedType deriving Eq+-- | Enumeration LDIF Types+data LDIFType = LDIFContentType -- ^ LDIF with Content Records+              | LDIFChangesType -- ^ LDIF with Changes Records+              | LDIFMixedType   -- ^ LDIF with both Content and Changes Records+              deriving Eq  instance Show LDIFType where     show LDIFChangesType = "Delta"@@ -33,30 +53,60 @@     show LDIFMixedType   = "Mixed"  -- | Represents LDIF structure, it can be either simply LDIF data dump or--- | changes LDIF with LDAP operations -data LDIF = LDIF { lcVersion :: Maybe String, lcEntries :: [LDIFRecord] } deriving (Show, Eq)+-- changes LDIF with LDAP operations +data LDIF = LDIF { lcVersion :: Maybe BC.ByteString, lcEntries :: ![LDIFRecord] } deriving (Show, Eq) --- | Represents one data record within LDIF file with DN and content--- | Represents one change record within LDIF file with DN and content-data LDIFRecord = ContentRecord { reDN :: DN, coAttrVals :: [AttrValue] } -                | ChangeRecord  { reDN :: DN, chOp :: Change } deriving (Show, Eq)+data LDIFRecord+  -- | Represents one data record within LDIF file with DN and content+  = ContentRecord { reDN :: !DN, coAttrVals :: ![AttrValue] } +  -- | Represents one change record within LDIF file with DN and content+  | ChangeRecord  { reDN :: !DN, chOp :: !Change } deriving (Show, Eq)  -- | Represents one LDAP operation within changes LDIF-data Change = ChangeAdd     { chAttrVals :: [AttrValue] }+data Change = ChangeAdd     { chAttrVals :: ![AttrValue] }             | ChangeDelete -            | ChangeModify  { chMods :: [Modify] }+            | ChangeModify  { chMods :: ![Modify] }             | ChangeModDN  deriving (Show, Eq)  -- | Represents ChangeModify operations upon one entry within given DN-data Modify = ModAdd     { modAttr :: Attribute, modAttrVals :: [Value] }-            | ModDelete  { modAttr :: Attribute, modAttrVals :: [Value] }-            | ModReplace { modAttr :: Attribute, modAttrVals :: [Value] } deriving (Show, Eq)+data Modify = ModAdd     { modAttr :: !Attribute, modAttrVals :: ![Value] }+            | ModDelete  { modAttr :: !Attribute, modAttrVals :: ![Value] }+            | ModReplace { modAttr :: !Attribute, modAttrVals :: ![Value] } deriving (Show, Eq)  -- | Represents Distinguished Name (DN)-data DN = DN { dnAttrVals :: [AttrValue] } -        | DNi { dnAttrVals :: [AttrValue] } deriving (Show)+data DN = DN { dnAttrVals :: ![AttrValue] } deriving (Eq, Show) -instance Eq DN where-    (DN xs)  == (DN ys)   = xs == ys-    (DNi xs) == (DNi ys)  = (map (\(n,v) -> (n,(map toUpper v)))  xs) == (map (\(n,v) -> (n,(map toUpper v))) ys)-    x        == y         = (DNi (dnAttrVals x)) == (DNi (dnAttrVals y))+-- | Ord Instance for DN+instance Ord DN where+  (DN xs1) `compare` (DN xs2)  = let cmpAV ((a1,v1),(a2,v2)) = let ca = a1 `compare` a2+                                                                   cv = v1 `compare` v2+                                                               in if ca == EQ then cv else ca+                                     dx = map cmpAV $ zip (reverse $ xs1) (reverse $ xs2)+                                     lx | length xs1 > length xs2 = GT+                                        | length xs1 < length xs2 = LT+                                        | otherwise = EQ+                                 in case filter (EQ /=) dx of+                                   []    -> lx+                                   (x:_) -> x++-- | Check if LDIFRecord is Content Record+isContentRecord :: LDIFRecord -> Bool+isContentRecord (ContentRecord _ _) = True+isContentRecord _ = False++-- | Check if LDIFRecord is Change Record+isChangeRecord :: LDIFRecord -> Bool+isChangeRecord (ChangeRecord _ _) = True+isChangeRecord _ = False++-- | Dettect from LDIF content the Type (Content, Changes, Mixed)+getLDIFType :: LDIF -> LDIFType+getLDIFType (LDIF _ []) = LDIFContentType+getLDIFType (LDIF _ xs) = getLDIFType' con chg+    where+      con = filter (isContentRecord) xs+      chg = filter (not . isContentRecord) xs+      getLDIFType' [] [] = LDIFContentType -- Fallback Empty LDIF as an Content LDIF+      getLDIFType' [] _  = LDIFChangesType+      getLDIFType' _  [] = LDIFContentType+      getLDIFType' _  _  = LDIFMixedType

@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}++module Text.LDIF.Undo (+        undoLDIF+)+where+import Data.Maybe+import Text.LDIF.Types++-- | Warning message when undo can not be calculated+type Warning = String++-- | Calculate undo LDIF+undoLDIF :: LDIF -> (LDIF,[[Warning]])+undoLDIF (LDIF v xs) = let (ys,w) = let zs = map undoRecord $ reverse xs+                                    in (map fst zs, map snd zs)+                       in (LDIF v ys, filter (not . null) w)++-- | Calculate undo Record with possible warnings+undoRecord :: LDIFRecord -> (LDIFRecord,[Warning])+undoRecord (ContentRecord dn _) = (ChangeRecord dn ChangeDelete,[])+undoRecord (ChangeRecord  dn (ChangeAdd _))     = (ChangeRecord dn ChangeDelete,[])+undoRecord (ChangeRecord  dn ChangeDelete)      = (ChangeRecord dn (ChangeAdd []), [wrnO dn "delete"])+undoRecord (ChangeRecord  dn (ChangeModify xs)) = let (x, w) = let ys = map undoMod $ reverse xs+                                                               in (map fst ys, map snd ys)+                                                  in (ChangeRecord dn (ChangeModify x), catMaybes w)+undoRecord x = (x, ["Unsupported operation"])++-- | Calculate undo Modification with possible warning+undoMod :: Modify -> (Modify,Maybe Warning)+undoMod (ModAdd a v)     = (ModDelete a v, Nothing)+undoMod (ModDelete a [])  = (ModAdd a [], Just $ wrnA a "delete")+undoMod (ModDelete a zs)  = (ModAdd a zs, Nothing)+undoMod (ModReplace a _) = (ModReplace a [], Just $ wrnA a "replace")++wrnA :: Attribute -> String -> String+wrnA a op = concat [show $ aName a, " ", op]++wrnO :: DN -> String -> String+wrnO dn op = concat [show dn, " ", op]

@@ -1,43 +1,32 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+ -- | LDIF related operations-module Text.LDIF.Utils (-        findRecordsByDN,-	findRecordByDN,-        isDNPrefixOf,-        sizeOfDN,-        takeDNPrefix,-        leafOfDN,-        rootOfDN,-        lookupAttr,-        filterAttr,-        isDummyRecord,-        ldif2tree,-        getLDIFType,-        isContentRecord,-        isChangeRecord,-        dn2dnI,-        ldif2ldifI-)-where+module Text.LDIF.Utils +       where+import Prelude import Text.LDIF.Types-import Data.Tree+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M +type LDIFCache = M.Map DN LDIFRecord++createLookupTable :: LDIF -> LDIFCache+createLookupTable (LDIF _ xs) = M.fromList $ map (\x -> (reDN x, x)) xs+ -- | Find all Contents with given DN findRecordsByDN :: LDIF -> DN -> [LDIFRecord] findRecordsByDN (LDIF _ entries) dn = filter (\x -> (reDN x) == dn) entries  -- | Find first Content with given DN-findRecordByDN :: LDIF -> DN -> Maybe LDIFRecord-findRecordByDN ldif dn = case findRecordsByDN ldif dn of-                                 []   -> Nothing-                                 xs   -> Just (head xs)-+findRecordByDN :: LDIFCache -> DN -> Maybe LDIFRecord+findRecordByDN cache dn = M.lookup dn cache  -- | Find fist Attribute within attributes pairs list-lookupAttr :: String -> [AttrValue] -> Maybe Value+lookupAttr :: BC.ByteString -> [AttrValue] -> Maybe Value lookupAttr attr xs = lookup (Attribute attr) xs  -- | Filter Attribute Value list according Attribute name-filterAttr :: String -> [AttrValue] -> [AttrValue]+filterAttr :: BC.ByteString -> [AttrValue] -> [AttrValue] filterAttr attr xs  = filter (\x -> (Attribute attr) == fst x) xs  -- | Change record without any impact@@ -49,66 +38,27 @@ leafOfDN xs = getDNValue xs 0  rootOfDN :: DN -> AttrValue-rootOfDN xs = getDNValue xs ((sizeOfDN xs)-1)+rootOfDN xs = getDNValue xs ((lengthOfDN xs)-1) -sizeOfDN :: DN -> Int-sizeOfDN xs = length (dnAttrVals xs)+lengthOfDN :: DN -> Int+lengthOfDN xs = length (dnAttrVals xs)  getDNValue :: DN -> Int -> AttrValue getDNValue xs idx = (dnAttrVals xs) !! idx  takeDNPrefix :: DN -> Int -> DN takeDNPrefix (DN vals) n  = (DN (reverse $ take n (reverse vals)))-takeDNPrefix (DNi vals) n = (DNi (reverse $ take n (reverse vals)))  -- | Check if the dn1 is prefix of dn2 isDNPrefixOf :: DN -> DN -> Bool-isDNPrefixOf dn1 dn2 | (sizeOfDN dn1) >= (sizeOfDN dn2) = False-                     | otherwise = let n = (sizeOfDN dn1)+isDNPrefixOf dn1 dn2 | (lengthOfDN dn1) >= (lengthOfDN dn2) = False+                     | otherwise = let n = (lengthOfDN dn1)                                    in (takeDNPrefix dn2 n) == dn1 -dummyRootDN :: DN-dummyRootDN = DN [(Attribute "dc", "root")]--ldif2tree :: LDIF -> Tree LDIFRecord-ldif2tree (LDIF _ entries) = Node (ChangeRecord dummyRootDN (ChangeAdd [])) (ldifRecs2tree entries)- isParentRecordOf :: LDIFRecord -> LDIFRecord -> Bool isParentRecordOf a b = isDNPrefixOf (reDN a) (reDN b) -ldifRoots :: [LDIFRecord] -> [LDIFRecord]-ldifRoots xs = let isRoot x = all (\y -> not $ isParentRecordOf y x) xs-               in filter (isRoot) xs -ldifRecs2tree :: [LDIFRecord] -> [Tree LDIFRecord]-ldifRecs2tree xs = let roots = (ldifRoots xs)-                       subtr x = ldifRecs2tree $ filter (isParentRecordOf x) xs-                   in map (\x -> Node x (subtr x)) roots--isContentRecord :: LDIFRecord -> Bool-isContentRecord (ContentRecord _ _) = True-isContentRecord _ = False--isChangeRecord :: LDIFRecord -> Bool-isChangeRecord (ChangeRecord _ _) = True-isChangeRecord _ = False--getLDIFType :: LDIF -> LDIFType-getLDIFType (LDIF _ []) = LDIFContentType-getLDIFType (LDIF _ xs) = getLDIFType' con chg-    where-      con = filter (isContentRecord) xs-      chg = filter (not . isContentRecord) xs-      getLDIFType' [] [] = error "Unexpected"-      getLDIFType' [] _  = LDIFChangesType-      getLDIFType' _  [] = LDIFContentType-      getLDIFType' _  _  = LDIFMixedType--dn2dnI :: DN -> DN-dn2dnI (DN xs) = (DNi xs)-dn2dnI xs = xs-+-- | Make LDIF Values case-insensitive ldif2ldifI :: LDIF -> LDIF-ldif2ldifI (LDIF v xs) = LDIF v ys-    where-      ys = map (\x -> x { reDN = dn2dnI (reDN x) } )  xs+ldif2ldifI = undefined

@@ -1,33 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--- | Make Change LDIF based on two Content LDIFs-import Data.List-import Data.Either-import Data.Maybe-import Control.Monad -import System.FilePath -import System.Environment-import Text.LDIF-import System.Console.CmdArgs--progDesc = "Create delta LDIF between Source LDIF and Target LDIF"--data DiffLdif = DiffLdif { srcFile :: FilePath-                         , dstFile :: FilePath } deriving (Show, Data, Typeable)--defaultCfg = DiffLdif { srcFile = def &= typFile &= name "s" &= help "Source LDIF File"-                      , dstFile = def &= typFile &= name "t" &= help "Target LDIF File" }--main = do-  cfg <- cmdArgs defaultCfg-  execute cfg--execute (DiffLdif []  _  ) = putStrLn "Error: -s source file is mandatory" -execute (DiffLdif _ []   ) = putStrLn "Error: -t target file is mandatory"-execute (DiffLdif src dst) = do-  ml1 <- parseLDIFFile src-  ml2 <- parseLDIFFile dst-  case rights [ml1,ml2] of -       [l1,l2] -> case diffLDIF l1 l2 of-                    Left err -> putStrLn err-                    Right delta -> putStrLn $ ldif2str delta-       _       -> print $ lefts [ml1,ml2] 

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-} -- | Make Change LDIF based on two Content LDIFs import Data.List import Data.Either@@ -7,69 +8,81 @@ import System.Environment import Text.LDIF import qualified Data.Set as Set--ldif2html :: Set.Set String -> LDIF -> String-ldif2html idx (LDIF v xs) = unlines $ (ver2str v) ++ (map (record2html idx) xs)---- | Serialize version to LDIF Format Lines-ver2str :: Maybe String -> [String]-ver2str Nothing = []-ver2str (Just v) = ["version: "++v]+import qualified Data.ByteString.Char8 as BC  -- | Serialize DN to LDIF Format-dn2html :: DN -> String-dn2html ys@(DN xs) = concat [ "<div id=\"abc"++nm++"\"></div><b>dn:</b> <font color=\"green\"><b>", dnstr, "</b></font>"]+dn2html :: DN -> BC.ByteString+dn2html ys@(DN xs) = BC.concat [ "<div id=\"abc" +                               , nm +                               , "\"></div><b>dn:</b> <font color=\"green\"><b>" +                               , dnstr +                               , "</b></font>" ]       where-        dnstr = intercalate "," $ map (\((Attribute n),v) -> n++"="++v) xs-        nm = dn2last ys--dn2last (DN xs) = snd $ head xs+        dnstr = BC.intercalate "," $ map (\((Attribute n),v) -> n `BC.append` "=" `BC.append` (aVal v)) xs+        nm = aVal $ dn2last ys  -- | Serialize Change Record in LDIF Format-record2html :: Set.Set String -> LDIFRecord -> String-record2html idx (ChangeRecord dn (ChangeDelete))     = unlines   [ (dn2str dn), "changetype: delete" ]-record2html idx (ChangeRecord dn (ChangeAdd xs))    = unlines $ [ (dn2html dn), "changetype: add"    ] ++ (attrVals2Ln idx xs)-record2html idx (ChangeRecord dn (ChangeModify xs))  = unlines $ [ (dn2str dn), "changetype: modify" ] ++ (mods2Ln idx xs)-record2html idx (ChangeRecord dn (ChangeModDN))      = unlines $ [ (dn2str dn), "changetype: moddn"  ]-record2html idx (ContentRecord dn xs) = unlines $ [ (dn2html dn) ] ++ (attrVals2Ln idx xs)+record2html :: Set.Set Value -> LDIFRecord -> BC.ByteString+record2html idx (ChangeRecord dn (ChangeDelete))     = BC.unlines   [ (dn2str dn), "changetype: delete" ]+record2html idx (ChangeRecord dn (ChangeAdd xs))     = BC.unlines $ [ (dn2html dn), "changetype: add"    ] ++ (attrVals2Ln idx xs)+record2html idx (ChangeRecord dn (ChangeModify xs))  = BC.unlines $ [ (dn2str dn), "changetype: modify" ] ++ (mods2Ln idx xs)+record2html idx (ChangeRecord dn (ChangeModDN))      = BC.unlines $ [ (dn2str dn), "changetype: moddn"  ]+record2html idx (ContentRecord dn xs) = BC.unlines $ [ (dn2html dn) ] ++ (attrVals2Ln idx xs) -attrVals2Ln :: Set.Set String -> [AttrValue] -> [String]+attrVals2Ln :: Set.Set Value -> [AttrValue] -> [BC.ByteString] attrVals2Ln idx xs = map (attrVal2Ln idx) xs -attrVal2Ln :: Set.Set String -> AttrValue -> String-attrVal2Ln idx ((Attribute n),v) = if Set.member v idx then "<b>"++n++"</b> : <a href=\"#abc"++v++"\">"++v++"</a>"-                          else "<b>"++n++"</b> : "++v+attrVal2Ln :: Set.Set Value -> AttrValue -> BC.ByteString+attrVal2Ln idx ((Attribute n),v) = if Set.member v idx then BC.concat [ "<b>"+                                                                      , n +                                                                      , "</b> : <a href=\"#abc"+                                                                      , aVal v+                                                                      , "\">" +                                                                      , aVal v+                                                                      , "</a>"]+                          else BC.concat [ "<b>",n,"</b> : ",aVal v] -mods2Ln :: Set.Set String -> [Modify] -> [String]+mods2Ln :: Set.Set Value -> [Modify] -> [BC.ByteString] mods2Ln idx xs = intercalate ["-"] $ map (mod2Ln idx) xs -mod2Ln :: Set.Set String -> Modify -> [String]-mod2Ln idx (ModAdd     a@(Attribute nm) xs) = [ attrVal2Ln idx ((Attribute "add"),nm)     ] ++ (map (\v -> attrVal2Ln idx (a,v)) xs) -mod2Ln idx (ModDelete  a@(Attribute nm) xs) = [ attrVal2Ln idx ((Attribute "delete"),nm)  ] ++ (map (\v -> attrVal2Ln idx (a,v)) xs)-mod2Ln idx (ModReplace a@(Attribute nm) xs) = [ attrVal2Ln idx ((Attribute "replace"),nm) ] ++ (map (\v -> attrVal2Ln idx (a,v)) xs)+mod2Ln :: Set.Set Value -> Modify -> [BC.ByteString]+mod2Ln idx mod = [ attrVal2Ln idx (modName,attrName) ] ++ valLst+  where+    attrName = Value $ aName $ modAttr mod+    valLst = map (\v -> attrVal2Ln idx (modAttr mod,v)) $ modAttrVals mod+    modName = case mod of +      (ModAdd _ _)     -> Attribute "add"+      (ModDelete _ _)  -> Attribute "delete"+      (ModReplace _ _) -> Attribute "replace" --- Dummy ldif2html implementation but it should--- display LDIF file as HTML with values as href to--- DN which has the value as the leaf RDN value+dns :: LDIF -> Set.Set Value+dns (LDIF _ xs) = Set.fromList $ nub $ map (dn2last . reDN) xs++dn2last (DN xs) = snd $ head xs+ main = do   args <- getArgs   case args of       []         -> putStrLn "Usage: ldif2html <input.ldif> [<input2.ldif> <input3.ldif> ... <inputN.ldif> <output.ldif>]"      [inp]      -> do-                      doLDIF2HTML [inp] (putStrLn)+                      doLDIF2HTML [inp] (BC.putStrLn)                       putStrLn "# Done."      xs         -> do-                      doLDIF2HTML (init xs) (writeFile (last xs)) +                      doLDIF2HTML (init xs) (BC.writeFile (last xs))                        putStrLn $ "## Processed : " ++ (unlines $ init xs)                       putStrLn $ "## Written   : " ++ (last xs)+  where+    doLDIF2HTML names outF = do+      mls <- mapM (parseLDIFFile defaulLDIFConf) names+      case lefts mls of +        []   -> do+                let idx = Set.unions $ map dns $ rights mls+                outF $ BC.concat [ "<html><body bgcolor=lightyellow><pre>"+                                 , BC.concat $ map (ldif2html idx) (rights mls) +                                 , "</pre></body></html>" ]+        xs  -> mapM_ print xs+      -- | Serialize LDIF to HTML+    ldif2html :: Set.Set Value -> LDIF -> BC.ByteString+    ldif2html idx (LDIF v xs) = BC.unlines $ (ver2str v) ++ (map (record2html idx) xs) -doLDIF2HTML names outF = do-  mls <- mapM (parseLDIFFile) names-  case lefts mls of -       []   -> do-                 let idx = Set.unions $ map (dns) (rights mls)-                 outF $ concat ["<html><body bgcolor=lightyellow><pre>", concat $ map (ldif2html idx) (rights mls), "</pre></body></html>" ]-       xs  -> mapM_ print xs -dns :: LDIF -> Set.Set String-dns (LDIF _ xs) = Set.fromList $ nub $ map (dn2last . reDN) xs

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | Make Change LDIF based on two Content LDIFs+import Data.List+import Data.Either+import Data.Maybe+import Control.Monad +import System.FilePath +import System.Environment+import Text.LDIF+import System.Console.CmdArgs+import qualified Data.ByteString.Char8 as BC++progDesc = "Create delta LDIF between Source LDIF and Target LDIF"++data LdifDiff = LdifDiff { srcFile :: FilePath+                         , dstFile :: FilePath } deriving (Show, Data, Typeable)++defaultCfg = LdifDiff { srcFile = def &= typFile &= name "s" &= help "Source LDIF File"+                      , dstFile = def &= typFile &= name "t" &= help "Target LDIF File" }++main = do+  cfg <- cmdArgs defaultCfg+  execute cfg++execute (LdifDiff []  _  ) = putStrLn "Error: -s source file is mandatory" +execute (LdifDiff _ []   ) = putStrLn "Error: -t target file is mandatory"+execute (LdifDiff src dst) = do+  ml1 <- parseLDIFFile defaulLDIFConf src+  ml2 <- parseLDIFFile defaulLDIFConf dst+  case rights [ml1,ml2] of +       [l1,l2] -> case diffLDIF l1 l2 of+                    Left err -> putStrLn err+                    Right delta -> BC.putStrLn $ ldif2str delta+       _       -> print $ lefts [ml1,ml2] 

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | Apply LDAP operations within LDIF on another LDIF. -- | Without schema related verification like syntax, cardinality etc. import Data.List@@ -9,6 +9,7 @@ import System.Environment import Text.LDIF import System.Console.CmdArgs+import qualified Data.ByteString.Char8 as BC  progDesc = "Apply LDAP operations from LDIF to LDIF (like ldapmodify)" @@ -32,10 +33,10 @@   modLDIFs <- mapM (safeParseLDIFFile) (modFiles cfg)   let outLDIF = foldr (flip applyLDIF) baseLDIF modLDIFs   if length (outFile cfg) == 0 then do-      putStrLn (ldif2str outLDIF)+      BC.putStrLn (ldif2str outLDIF)     else do-      writeFile (outFile cfg) (ldif2str outLDIF)+      BC.writeFile (outFile cfg) (ldif2str outLDIF)       putStrLn $ (outFile cfg) ++ " written."  safeParseLDIFFile :: FilePath -> IO LDIF-safeParseLDIFFile name = liftM (either (\e -> error $ "Can not parse: "++(show e)) (id)) (parseLDIFFile name)+safeParseLDIFFile name = liftM (either (\e -> error $ "Can not parse: "++(show e)) (id)) (parseLDIFFile defaulLDIFConf name)

@@ -6,13 +6,12 @@ import System.FilePath  import System.Environment import Text.LDIF+import qualified Data.ByteString.Char8 as BC  main = do   args <- getArgs-  ml1 <- parseLDIFFile (args !! 0)+  let name = args !! 0+  ml1 <- parseLDIFFile defaulLDIFConf name   case ml1 of -       Right l1 -> do-             print l1-             putStrLn "========================================================"-             putStrLn $ ldif2str l1+       Right l1 -> BC.putStrLn $ ldif2str l1        Left err -> print err

@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+import Data.List+import Data.Either+import Data.Maybe+import Control.Monad+import System.FilePath+import System.Environment+import Text.LDIF+import System.Console.CmdArgs+import qualified Data.ByteString.Char8 as BC++progDesc = "Calculate undo LDIF (rollback LDIF)"++data LdifUndo = LdifUndo { inFile   :: FilePath+                         , outFile  :: FilePath } deriving (Show, Data, Typeable)++defaultCfg = LdifUndo { inFile = def &= typFile &= name "f" &= help "Input LDIF File"+                      , outFile = def &= typFile &= name "o" &= help "Output LDIF File" }++main = do+  cfg <- cmdArgs defaultCfg+  execute cfg++execute (LdifUndo [] _) = putStrLn "Error: -f base LDIF File is mandatory"+execute cfg = do+  inLDIF <- safeParseLDIFFile (inFile cfg)+  let (outLDIF, wrn) = undoLDIF inLDIF+  when (not $ null wrn) (putStrLn $ "Finished with warnings: " ++ (unlines $ map unlines wrn))+  if length (outFile cfg) == 0 then do+      BC.putStrLn (ldif2str outLDIF)+    else do+      BC.writeFile (outFile cfg) (ldif2str outLDIF)+      putStrLn $ (outFile cfg) ++ " written."++safeParseLDIFFile :: FilePath -> IO LDIF+safeParseLDIFFile name = liftM (either (\e -> error $ "Can not parse: "++(show e)) (id)) (parseLDIFFile defaulLDIFConf name)

@@ -5,64 +5,89 @@ import System.Directory import System.FilePath import Control.Monad (liftM)+import qualified Data.ByteString.Char8 as BC -ldifDir = "data"+-- | Directory with input LDIF files for tests+ldifDir = "tests/data"  main = do     ls <- getLDIFs ldifDir     runTestTT (tests ls)--tests ls = TestList $ (testCasesParseOK ls) ++ testCasesDIFF ++ testCasesUtils ++ (testCasesPrintOK ls)+  where+    tests ls = TestList $ (testCasesParseOK ls) +               ++ testCasesDiff+               ++ testCasesApply+               ++ testCasesTree+               ++ testCasesUtils +               ++ (testCasesPrintOK ls)  -- -- Test Cases ---testCasesDIFF = [TestCase (assertEqual "dummy" True True)]-testCasesParseOK ls = map (\x -> TestCase (checkParsing x)) $ filter (isOK) ls+testCasesDiff  = [ TestCase (assertEqual "dummy" True True) ] -- TODO: Implement!+testCasesApply = [ TestCase (assertEqual "dummy" True True) ] -- TODO: Implement!+testCasesTree  = [ TestCase (assertEqual "dummy" True True) ] -- TODO: Implement!++-- | Parser Tests+testCasesParseOK ls = map (TestCase . checkParsing) $ filter isSuccessFile ls     where       checkParsing fname = do-        ret <- parseLDIFFile fname+        ret <- parseLDIFFile defaulLDIFConf fname         assertParsedOK fname ret "Parsing test" -testCasesPrintOK ls = map (\x -> TestCase (checkParsing x)) $ filter (isOK) ls+-- | Printer Tests+testCasesPrintOK ls = map (TestCase . checkParsing) $ filter isSuccessFile ls     where       checkParsing fname = do-        ret <- parseLDIFFile fname-        case ret of -          Left _     -> return ()-          Right ldif -> do-              let ret2 = parseLDIFStr (ldif2str ldif)+        ret <- parseLDIFFile defaulLDIFConf fname+        either (\_ -> return ()) printAndParseAgain ret+          where+            printAndParseAgain ldif = do+              let ret2 = parseLDIFStr defaulLDIFConf fname (ldif2str ldif)               assertParsedOK fname ret2 "Printing test" -testCasesUtils = [ TestCase (assertBool "DN1Root is Prefix of DN2Root" (not $ isDNPrefixOf dn1root dn2root))-                 , TestCase (assertBool "DN1Root is Prefix of DN1Child" (isDNPrefixOf dn1root dn1child))-                 , TestCase (assertBool "DN Size 1" (1 == sizeOfDN dn1root))-                 , TestCase (assertBool "DN Size 2" (2 == sizeOfDN dn1child))]+-- | Utils Tests+testCasesUtils = [ TestCase $ assertBool "DN1Root is Prefix of DN2Root"  $ not $ dn1root `isDNPrefixOf` dn2root+                 , TestCase $ assertBool "DN1Root is Prefix of DN1Child" $ dn1root `isDNPrefixOf` dn1child+                 , TestCase $ assertBool "DN Size 1" $ 1 == lengthOfDN dn1root+                 , TestCase $ assertBool "DN Size 2" $ 2 == lengthOfDN dn1child +                 ]     where-      dn1root = head $ rights [ parseDNStr "dc=sk" ]-      dn2root = head $ rights [ parseDNStr "dc=de" ]-      dn1child = head $ rights [ parseDNStr "o=green,dc=sk" ]------ Support Methods---+      dn1root  = parseRightDN "dc=sk"+      dn2root  = parseRightDN "dc=de"+      dn1child = parseRightDN "o=green,dc=sk"+      parseRightDN dstr = fromRight $ parseDNStr defaulLDIFConf $ BC.pack dstr+        where+          fromRight (Left e)  = error $ show e+          fromRight (Right d) = d++-- | Support Methods getLDIFs :: String -> IO [String] getLDIFs dr = do     liftM (map (dr </>)) $ liftM (filter isLDIF) $ getDirectoryContents dr-  -isOK x = isPrefixOf "OK" (takeFileName x)-isLDIF x = isSuffixOf ".ldif" x--assertParsedOK filename ret msg  = case ret of-  Left e -> assertFailure $ msg ++ " " ++ (show e)-  Right ldif -> assertParsedType filename ldif+      where+        isLDIF x = isSuffixOf ".ldif" x  +        +-- | Assert that file is parsed successfully and correct LDIF type+assertParsedOK name ret msg  = either onError onSuccess ret+  where+    onSuccess l = assertParsedType name l+    onError   e = assertFailure $ msg ++ " " ++ show e  -assertParsedType name ldif | (isSuffixOf ".modify.ldif" name) = assertTypeChanges name ldif-                           | (isSuffixOf ".content.ldif" name) = assertTypeContent name ldif-                           | otherwise = assertFailure $ "Unexpected filename: (not .modify.ldif or .content.ldif " ++ name+-- | Assert that file is parsed with expected LDIF type+assertParsedType name l = assertType $ contentTypeFile name+  where+    assertType t | getLDIFType l == t = assertBool "Valid Content Type" True+                 | otherwise          = let msg = name ++ " is not type of " ++ (show t) ++ " but " ++ (show $ getLDIFType l)+                                        in assertFailure msg -assertTypeContent n l  | (getLDIFType l == LDIFContentType) = assertBool "Valid Content Type" True -- >> (putStrLn $ "\n\n" ++ n ++ "\n\n" ++ (show l))-                       | otherwise          = assertFailure $ n ++ " is not type of LDIFContent"+-- | Files which names begin with "OK" are expected to be parsed Successfully+isSuccessFile x = isPrefixOf "OK" (takeFileName x) -assertTypeChanges n l | (getLDIFType l /= LDIFContentType) = assertBool "Valid Changes Type" True -- >> (putStrLn $ "\n\n" ++ n ++ "\n\n" ++ (show l))-                      | otherwise          = assertFailure $ n ++ " is not type of LDIFChanges"-  +-- | Files suffixes defines what is expected parsed content type+contentTypeFile x | isModifyFile  x = LDIFChangesType+                  | isContentFile x = LDIFContentType+                  | otherwise       = error $ "Invalid filename format in tests: " ++ x+  where+    isModifyFile x  = isSuffixOf ".modify.ldif"  x+    isContentFile x = isSuffixOf ".content.ldif" x