diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -103,7 +103,6 @@ import System.Environment import Data.List -import System.IO import qualified Data.Map as Map import Data.Algorithm.Diff import qualified System.Log.Logger as LOG @@ -112,6 +111,10 @@ import Control.Monad.Error (runErrorT) import Data.Char (toLower) import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Monoid hiding (First) +import Data.Maybe (isNothing) import Facter @@ -123,11 +126,15 @@ import Puppet.DSL.Printer import Puppet.DSL.Loader import Puppet.JsonCatalog +import PuppetDB.Rest +tshow :: Show a => a -> T.Text +tshow = T.pack . show + usage = error "Usage: puppetresource puppetdir nodename [filename]" addRequire :: FinalCatalog -> ((ResIdentifier, ResIdentifier), LinkInfo) -> FinalCatalog -addRequire curcat ((src, dst), (ltype, _, _)) = +addRequire curcat ((src, dst), (ltype, _, _, _)) = case Map.lookup src curcat of Nothing -> curcat Just res -> Map.insert src (res { rrelations = (ltype, dst) : rrelations res }) curcat @@ -137,38 +144,50 @@ hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: Maybe String -> String -> IO ([Char] -> IO (FinalCatalog, EdgeMap, FinalCatalog)) +initializedaemonWithPuppet :: Maybe T.Text -> T.Text -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog)) initializedaemonWithPuppet purl puppetdir = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) prefs <- genPrefs puppetdir - (queryfunc, _, _, _) <- initDaemon (prefs { puppetDBurl = purl }) + let nprefs = case purl of + Nothing -> prefs + Just ur -> prefs { puppetDBquery = pdbRequest ur } + queryfunc <- if isNothing purl + then testingDaemon Nothing puppetdir allFacts + else do + (q, _, _, _) <- initDaemon nprefs + return (\nodename -> allFacts nodename >>= q nodename) return (\nodename -> do - o <- allFacts nodename >>= queryfunc nodename + o <- queryfunc nodename case o of Left err -> error err - Right (c,m,e) -> do - return $ (foldl' addRequire c (Map.toList m), m, e) + Right (c,m,e) -> return (foldl' addRequire c (Map.toList m), m, e) ) {-| A helper for when you don't want to use PuppetDB -} -initializedaemon :: String -> IO ([Char] -> IO (FinalCatalog, EdgeMap, FinalCatalog)) +initializedaemon :: T.Text -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog)) initializedaemon = initializedaemonWithPuppet Nothing -showparam (k,v) = k ++ " => " ++ show v +showparam :: (T.Text, ResolvedValue) -> T.Text +showparam (k,v) = k <> " => " <> tshow v -showtdiff :: (DI, String) -> String -showtdiff (F, s) = "- " ++ s -showtdiff (S, s) = "+ " ++ s +showtdiff :: Diff T.Text -> T.Text +showtdiff (First s) = "- " <> s +showtdiff (Second s) = "+ " <> s +showtdiff (Both _ _) = "" -textdiff :: ResolvedValue -> ResolvedValue -> [String] -textdiff (ResolvedString s1) (ResolvedString s2) = map showtdiff $ filter (\(x,_) -> x /= B) $ getDiff (lines s1) (lines s2) +textdiff :: ResolvedValue -> ResolvedValue -> [T.Text] +textdiff (ResolvedString s1) (ResolvedString s2) = map showtdiff $ filter (not . isBoth) $ getDiff (T.lines s1) (T.lines s2) + where + isBoth Both{} = True + isBoth _ = False +textdiff a b = error ("hum? " ++ show a ++ " " ++ show b) -showpdiff :: String -> ResolvedValue -> ResolvedValue -> [String] +showpdiff :: T.Text -> ResolvedValue -> ResolvedValue -> [T.Text] showpdiff pname pval1 pval2 - | pname == "content" = ["# content\n"] ++ textdiff pval1 pval2 - | otherwise = ["- " ++ showparam (pname, pval1), "+ " ++ showparam (pname, pval2)] + | pname == "content" = "# content\n" : textdiff pval1 pval2 + | otherwise = ["- " <> showparam (pname, pval1), "+ " <> showparam (pname, pval2)] -paramdiff :: Map.Map String ResolvedValue -> String -> ResolvedValue -> [String] -> [String] +paramdiff :: Map.Map T.Text ResolvedValue -> T.Text -> ResolvedValue -> [T.Text] -> [T.Text] paramdiff lpmap rpname rpval curdiff = curdiff ++ newdiff where mlpval = Map.lookup rpname lpmap @@ -179,8 +198,8 @@ then [] else showpdiff rpname lpval rpval -getdiff :: ResIdentifier -> RResource -> RResource -> String -getdiff (rtype,rname) r1 r2 = rtype ++ "[" ++ rname ++ "]" ++ " {\n" ++ (concatMap (\x -> x ++"\n") difflist) ++ "}" +getdiff :: ResIdentifier -> RResource -> RResource -> T.Text +getdiff (rtype,rname) r1 r2 = rtype <> "[" <> rname <> "] {\n" <> T.intercalate "\n" difflist <> "\n}" where difflist = diffrelations ++ diffparams diffrelations = [] @@ -188,15 +207,15 @@ p2 = rrparams r2 onlyleft = Map.difference p1 p2 onlyright = Map.difference p2 p1 - diffparams = ol ++ or ++ distincts - ol = map (\x -> "- " ++ showparam x) $ Map.toList onlyleft - or = map (\x -> "+ " ++ showparam x) $ Map.toList onlyright + diffparams = ole ++ ori ++ distincts + ole = map (\x -> "- " <> showparam x) $ Map.toList onlyleft + ori = map (\x -> "+ " <> showparam x) $ Map.toList onlyright distincts = Map.foldrWithKey (paramdiff p1) [] p2 rescompare :: RResource -> RResource -> Bool -rescompare (RResource _ a1 b1 c1 d1 _) (RResource _ a2 b2 c2 d2 _) = (a1==a2) && (b1==b2) && (c1==c2) && (d1==d2) +rescompare (RResource _ a1 b1 c1 d1 _ _) (RResource _ a2 b2 c2 d2 _ _) = (a1==a2) && (b1==b2) && (c1==c2) && (d1==d2) -checkdiff :: FinalCatalog -> ResIdentifier -> RResource -> (FinalCatalog, [String]) -> (FinalCatalog, [String]) +checkdiff :: FinalCatalog -> ResIdentifier -> RResource -> (FinalCatalog, [T.Text]) -> (FinalCatalog, [T.Text]) checkdiff refmap resid res (curseconds, curdiffs) = (newseconds, newdiffs) where myres = Map.lookup resid refmap @@ -208,7 +227,7 @@ Just x -> if rescompare x res then curdiffs - else (getdiff resid x res) : curdiffs + else getdiff resid x res : curdiffs {-| The diffing function, will output what is only in the first catalog, then what is only in the second, and will end with a diff between common resources. @@ -219,13 +238,9 @@ diff c1 c2 = do let onlyfirsts = Map.difference c1 c2 (onlyseconds, differences) = Map.foldrWithKey (checkdiff c1) (Map.empty, []) c2 - if Map.null onlyfirsts - then return () - else putStrLn $ "Only in the first catalog:\n" ++ showFCatalog onlyfirsts - if Map.null onlyseconds - then return () - else putStrLn $ "Only in the second catalog:\n" ++ showFCatalog onlyseconds - mapM_ putStrLn differences + unless (Map.null onlyfirsts) $ T.putStrLn $ "Only in the first catalog:\n" <> showFCatalog onlyfirsts + unless (Map.null onlyseconds) $ T.putStrLn $ "Only in the second catalog:\n" <> showFCatalog onlyseconds + mapM_ T.putStrLn differences doparse :: FilePath -> IO () doparse fp = do @@ -236,66 +251,67 @@ exitWith ExitSuccess -- prints the content of a file -printContent :: String -> FinalCatalog -> IO () +printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog = - case (Map.lookup ("file", filename) catalog) of + case Map.lookup ("file", filename) catalog of Nothing -> error "File not found" - Just r -> case (Map.lookup "content" (rrparams r)) of + Just r -> case Map.lookup "content" (rrparams r) of Nothing -> error "This file has no content" - Just (ResolvedString c) -> putStrLn c + Just (ResolvedString c) -> T.putStrLn c Just x -> print x -- pretty print a resource -- if this resource has content, works like printContent -printResource :: String -> String -> FinalCatalog -> IO () +printResource :: T.Text -> T.Text -> FinalCatalog -> IO () printResource restype resname catalog = - case (Map.lookup (restype, resname) catalog) of - Nothing -> error $ "Resource " ++ restype ++ "[" ++ resname ++ "] does not exists." - Just r -> putStrLn $ showFCatalog $ Map.singleton (restype, resname) r + case Map.lookup (restype, resname) catalog of + Nothing -> error $ T.unpack $ "Resource " <> restype <> "[" <> resname <> "] does not exists." + Just r -> T.putStrLn $ showFCatalog $ Map.singleton (restype, resname) r -r2s :: ResolvedValue -> String +r2s :: ResolvedValue -> T.Text r2s (ResolvedString x) = x -r2s x = show x +r2s x = tshow x -- filters resources by type name -getResourcesOfType :: String -> FinalCatalog -> FinalCatalog +getResourcesOfType :: T.Text -> FinalCatalog -> FinalCatalog getResourcesOfType rtype = Map.filter (\r -> rrtype r == rtype) -- just extract the names of the resources -getResourceNames :: FinalCatalog -> [String] +getResourceNames :: FinalCatalog -> [T.Text] getResourceNames cat = map snd $ Map.keys cat main :: IO () main = do - args <- getArgs + args <- fmap (map T.pack) getArgs let (rargs, puppeturl) = case args of ("-r":pu:xs) -> (xs, Just pu) _ -> (args, Nothing) - when (length rargs == 1) (doparse (head rargs)) + when (length rargs == 1) (doparse (T.unpack $ head rargs)) let (puppetdir, nodename) | (length rargs /= 2) && (length rargs /= 3) = usage | otherwise = (rargs !! 0, rargs !! 1) - getresname :: String -> Maybe (String, String) + getresname :: T.Text -> Maybe (T.Text, T.Text) getresname r = - let isresname = ((head $ reverse r) == ']') && ('[' `elem` r) - (rtype, rname) = break (== '[') r + let isresname = T.last r == ']' && T.isInfixOf "[" r + (rtype, rname) = T.break (== '[') r in if isresname - then Just (map toLower rtype, tail $ reverse $ (tail $ reverse rname)) + then Just (T.map toLower rtype, T.tail $ T.init rname) else Nothing handlePrintResource resname cat - = case (getresname resname) of + = case getresname resname of Just (t,n) -> printResource t n cat Nothing -> printContent resname cat queryfunc <- initializedaemonWithPuppet puppeturl puppetdir (x,m,e) <- queryfunc nodename - tests <- testCatalog puppetdir x [] - case tests of - Right _ -> return () - Left rr -> error rr if length rargs == 3 then if (rargs !! 2) == "JSON" then do let json = catalog2JSon nodename 1 x e m BSL.putStrLn json else handlePrintResource (rargs !! 2) x - else putStrLn $ showFCatalog x + else do + (tests,_) <- testCatalog puppetdir x [] + case tests of + Right _ -> return () + Left rr -> error rr + T.putStrLn $ showFCatalog x diff --git a/puppetresources.cabal b/puppetresources.cabal --- a/puppetresources.cabal +++ b/puppetresources.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: puppetresources -version: 0.4.1 +version: 0.4.2 synopsis: A program that displays the puppet resources associated to a node given .pp files. -- description: license: GPL-3 @@ -22,13 +22,15 @@ executable puppetresources extensions: BangPatterns main-is: Main.hs - ghc-options: -rtsopts + ghc-options: -rtsopts -Wall -O2 + extensions: OverloadedStrings -- other-modules: build-depends: base >=3 && <5, - language-puppet >= 0.3.1.0, - hsfacter >= 0.2.0.0, + language-puppet >= 0.4.0, + hsfacter >= 0.2.1, containers, hslogger, - Diff, + Diff >= 0.2.0, mtl, - bytestring + bytestring, + text