diff --git a/TODO.org b/TODO.org deleted file mode 100644 --- a/TODO.org +++ /dev/null @@ -1,28 +0,0 @@ -* Tasks -** error handling, modify add: and than :, - need to be asserted that and 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 -o [ ... ] -* 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 diff --git a/ldif.cabal b/ldif.cabal --- a/ldif.cabal +++ b/ldif.cabal @@ -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 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 + diff --git a/runTests.sh b/runTests.sh new file mode 100644 --- /dev/null +++ b/runTests.sh @@ -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 diff --git a/run_tests.sh b/run_tests.sh deleted file mode 100644 --- a/run_tests.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/bin/sh - -cabal configure -ftest && cabal build && cd tests && ../dist/build/test/test diff --git a/src/Text/LDIF.hs b/src/Text/LDIF.hs --- a/src/Text/LDIF.hs +++ b/src/Text/LDIF.hs @@ -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 + diff --git a/src/Text/LDIF/Apply.hs b/src/Text/LDIF/Apply.hs --- a/src/Text/LDIF/Apply.hs +++ b/src/Text/LDIF/Apply.hs @@ -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 diff --git a/src/Text/LDIF/Consts.hs b/src/Text/LDIF/Consts.hs --- a/src/Text/LDIF/Consts.hs +++ b/src/Text/LDIF/Consts.hs @@ -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 diff --git a/src/Text/LDIF/Diff.hs b/src/Text/LDIF/Diff.hs --- a/src/Text/LDIF/Diff.hs +++ b/src/Text/LDIF/Diff.hs @@ -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) diff --git a/src/Text/LDIF/Parser.hs b/src/Text/LDIF/Parser.hs --- a/src/Text/LDIF/Parser.hs +++ b/src/Text/LDIF/Parser.hs @@ -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 diff --git a/src/Text/LDIF/Preproc.hs b/src/Text/LDIF/Preproc.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDIF/Preproc.hs @@ -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) diff --git a/src/Text/LDIF/Printer.hs b/src/Text/LDIF/Printer.hs --- a/src/Text/LDIF/Printer.hs +++ b/src/Text/LDIF/Printer.hs @@ -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) diff --git a/src/Text/LDIF/Tree.hs b/src/Text/LDIF/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDIF/Tree.hs @@ -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) diff --git a/src/Text/LDIF/Types.hs b/src/Text/LDIF/Types.hs --- a/src/Text/LDIF/Types.hs +++ b/src/Text/LDIF/Types.hs @@ -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 diff --git a/src/Text/LDIF/Undo.hs b/src/Text/LDIF/Undo.hs new file mode 100644 --- /dev/null +++ b/src/Text/LDIF/Undo.hs @@ -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] diff --git a/src/Text/LDIF/Utils.hs b/src/Text/LDIF/Utils.hs --- a/src/Text/LDIF/Utils.hs +++ b/src/Text/LDIF/Utils.hs @@ -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 diff --git a/src/diffLDIF.hs b/src/diffLDIF.hs deleted file mode 100644 --- a/src/diffLDIF.hs +++ /dev/null @@ -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] diff --git a/src/ldif2html.hs b/src/ldif2html.hs --- a/src/ldif2html.hs +++ b/src/ldif2html.hs @@ -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 [ "
dn: ", dnstr, ""] +dn2html :: DN -> BC.ByteString +dn2html ys@(DN xs) = BC.concat [ "
dn: " + , dnstr + , "" ] 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 ""++n++" : "++v++"" - else ""++n++" : "++v +attrVal2Ln :: Set.Set Value -> AttrValue -> BC.ByteString +attrVal2Ln idx ((Attribute n),v) = if Set.member v idx then BC.concat [ "" + , n + , " : " + , aVal v + , ""] + else BC.concat [ "",n," : ",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 [ ... ]" [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 [ "
"
+                                 , BC.concat $ map (ldif2html idx) (rights mls) 
+                                 , "
" ] + 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 ["
", concat $ map (ldif2html idx) (rights mls), "
" ] - xs -> mapM_ print xs -dns :: LDIF -> Set.Set String -dns (LDIF _ xs) = Set.fromList $ nub $ map (dn2last . reDN) xs diff --git a/src/ldifdiff.hs b/src/ldifdiff.hs new file mode 100644 --- /dev/null +++ b/src/ldifdiff.hs @@ -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] diff --git a/src/ldifmodify.hs b/src/ldifmodify.hs --- a/src/ldifmodify.hs +++ b/src/ldifmodify.hs @@ -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) diff --git a/src/ldifparse.hs b/src/ldifparse.hs --- a/src/ldifparse.hs +++ b/src/ldifparse.hs @@ -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 diff --git a/src/ldifundo.hs b/src/ldifundo.hs new file mode 100644 --- /dev/null +++ b/src/ldifundo.hs @@ -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) diff --git a/tests/TestMain.hs b/tests/TestMain.hs --- a/tests/TestMain.hs +++ b/tests/TestMain.hs @@ -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