diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +language-puppet (1.3.17) artful; urgency=medium + * Loose upperbound for servant to include 0.13 + * Loose upperbound for exceptions to include 0.10.0 + * Fix #241 + + -- Simon Marechal UNRELEASED + language-puppet (1.3.16) artful; urgency=medium [ PierreR ] * Fix #213 Hash lookup failing in erb template diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.3.16 +version: 1.3.17 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -103,7 +103,7 @@ , containers == 0.5.* , cryptonite >= 0.6 , directory >= 1.2 && < 1.4 - , exceptions >= 0.8 && < 0.10 + , exceptions >= 0.8 && < 0.11 , filecache >= 0.2.9 && < 0.4 , filepath >= 1.4 , formatting @@ -126,8 +126,8 @@ , random , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 - , servant >= 0.9 && < 0.13 - , servant-client >= 0.9 && < 0.13 + , servant >= 0.9 && < 0.14 + , servant-client >= 0.9 && < 0.14 , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3 diff --git a/src/Facter.hs b/src/Facter.hs --- a/src/Facter.hs +++ b/src/Facter.hs @@ -8,11 +8,12 @@ import Data.Char import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS -import Data.List (intercalate, stripPrefix) -import Data.List.Split (splitOn) +import qualified Data.List as List +import qualified Data.List.Split as List import Data.Maybe (mapMaybe) +import Data.Semigroup import qualified Data.Text as T -import System.Directory (doesFileExist) +import qualified System.Directory as Directory import System.Environment import System.Posix.Unistd (SystemID (..), getSystemID) import System.Posix.User @@ -40,12 +41,12 @@ storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ] getPrefix :: Int -> String -getPrefix n | null fltr = error $ "Could not get unit prefix for order " ++ show n +getPrefix n | null fltr = error $ "Could not get unit prefix for order " <> show n | otherwise = fst $ head fltr where fltr = filter (\(_, x) -> x == n) storageunits getOrder :: String -> Int -getOrder n | null fltr = error $ "Could not get order for unit prefix " ++ show n +getOrder n | null fltr = error $ "Could not get order for unit prefix " <> show n | otherwise = snd $ head fltr where nu = map toUpper n @@ -81,8 +82,8 @@ factOS :: IO [(String, String)] factOS = do - islsb <- doesFileExist "/etc/lsb-release" - isdeb <- doesFileExist "/etc/debian_version" + islsb <- Directory.doesFileExist "/etc/lsb-release" + isdeb <- Directory.doesFileExist "/etc/debian_version" case (islsb, isdeb) of (True, _) -> factOSLSB (_, True) -> factOSDebian @@ -98,7 +99,7 @@ , ("lsbmajdistrelease" , takeWhile (/='.') v) , ("osfamily" , "Debian") , ("lsbdistcodename" , codename v) - , ("lsbdistdescription" , "Debian GNU/Linux " ++ v ++ " (" ++ codename v ++ ")") + , ("lsbdistdescription" , "Debian GNU/Linux " <> v <> " (" <> codename v <> ")") ] codename v | null v = "unknown" | h '7' = "wheezy" @@ -165,11 +166,11 @@ factUName :: IO [(String, String)] factUName = do SystemID sn nn rl _ mc <- getSystemID - let vparts = splitOn "." (takeWhile (/='-') rl) + let vparts = List.splitOn "." (takeWhile (/='-') rl) return [ ("kernel" , sn) -- Linux - , ("kernelmajversion" , intercalate "." (take 2 vparts)) -- 3.5 + , ("kernelmajversion" , List.intercalate "." (take 2 vparts)) -- 3.5 , ("kernelrelease" , rl) -- 3.5.0-45-generic - , ("kernelversion" , intercalate "." (take 3 vparts)) -- 3.5.0 + , ("kernelversion" , List.intercalate "." (take 3 vparts)) -- 3.5.0 , ("hardwareisa" , mc) -- x86_64 , ("hardwaremodel" , mc) -- x86_64 , ("hostname" , nn) @@ -183,6 +184,6 @@ factProcessor :: IO [(String,String)] factProcessor = do cpuinfo <- readFile "/proc/cpuinfo" - let cpuinfos = zip [ "processor" ++ show (n :: Int) | n <- [0..]] modelnames - modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) + let cpuinfos = zip [ "processor" <> show (n :: Int) | n <- [0..]] modelnames + modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . List.stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs --- a/src/Puppet/Interpreter.hs +++ b/src/Puppet/Interpreter.hs @@ -382,12 +382,18 @@ fromAttributeDecls = foldM resolve mempty where - resolve acc (AttributeDecl k _ v) = + resolve acc adcl = + case adcl of + AttributeWildcard v -> do + pv <- resolveExpression v + case pv of + PHash h -> foldM (\curacc (attrname, attrvalue) -> go curacc attrname attrvalue) acc (itoList h) + _ -> throwPosError ("A hash was expected, not" <+> pretty pv) + AttributeDecl k _ v -> resolveExpression v >>= go acc k + go acc k pv = case acc ^. at k of Just _ -> throwPosError ("Parameter" <+> dullyellow (ppline k) <+> "already defined!") - Nothing -> do - pv <- resolveExpression v - return (acc & at k ?~ pv) + Nothing -> return (acc & at k ?~ pv) saveCaptureVariables :: InterpreterMonad (HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc)) saveCaptureVariables = do @@ -778,12 +784,20 @@ Just _ -> res modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource -modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do - value <- resolveExpression expr - let optype = case arrowop of - AppendArrow -> AppendAttribute - AssignArrow -> Replace - addAttribute optype attributename res value +modifyCollectedAttribute res adecl + = case adecl of + AttributeDecl attributename arrowop expr -> do + value <- resolveExpression expr + let optype = case arrowop of + AppendArrow -> AppendAttribute + AssignArrow -> Replace + addAttribute optype attributename res value + AttributeWildcard expr -> do + resolved <- resolveExpression expr + case resolved of + PHash hash -> + foldM (\curres (attrname, attrval) -> addAttribute Replace attrname curres attrval) res (itoList hash) + _ -> throwPosError ("A hash was expected, not" <+> pretty resolved) registerResource :: Text -> Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" diff --git a/src/Puppet/Language/NativeTypes/Concat.hs b/src/Puppet/Language/NativeTypes/Concat.hs --- a/src/Puppet/Language/NativeTypes/Concat.hs +++ b/src/Puppet/Language/NativeTypes/Concat.hs @@ -37,10 +37,4 @@ ,("source" , [string]) -- order should be an int or a string ,("order" , [defaultvalue "10", string]) - ,("ensure" , [string, values ["present","absent"]]) - -- deprecated field - -- ,("mode" , [string]) - -- ,("owner" , [string]) - -- ,("group" , [string]) - -- ,("backup" , [string]) ] diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -475,7 +475,8 @@ <|> (operator "~>" *> pure RNotify) assignment :: Parser AttributeDecl -assignment = AttributeDecl <$> key <*> arrowOp <*> expression +assignment = (AttributeDecl <$> key <*> arrowOp <*> expression) + <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression)) where key = identl (satisfy Char.isAsciiLower) (satisfy acceptable) "Assignment key" acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-') diff --git a/src/Puppet/Parser/PrettyPrinter.hs b/src/Puppet/Parser/PrettyPrinter.hs --- a/src/Puppet/Parser/PrettyPrinter.hs +++ b/src/Puppet/Parser/PrettyPrinter.hs @@ -154,6 +154,7 @@ folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs) maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx) prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ppline k)) <+> pretty op <+> pretty v + prettyDecl (AttributeWildcard v) = dullblue "*" <+> pretty AssignArrow <+> pretty v showArgs :: Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst) diff --git a/src/Puppet/Parser/Types.hs b/src/Puppet/Parser/Types.hs --- a/src/Puppet/Parser/Types.hs +++ b/src/Puppet/Parser/Types.hs @@ -91,7 +91,9 @@ | ChainResRefr !Text [Expression] !PPosition deriving (Show, Eq) -data AttributeDecl = AttributeDecl !Text !ArrowOp !Expression +data AttributeDecl + = AttributeDecl !Text !ArrowOp !Expression + | AttributeWildcard !Expression deriving (Show, Eq) data ArrowOp = AppendArrow -- ^ `+>` diff --git a/src/Puppet/Runner/Daemon/OptionalTests.hs b/src/Puppet/Runner/Daemon/OptionalTests.hs --- a/src/Puppet/Runner/Daemon/OptionalTests.hs +++ b/src/Puppet/Runner/Daemon/OptionalTests.hs @@ -5,7 +5,7 @@ import qualified Data.HashSet as Set import qualified Data.Text as Text -import System.Posix.Files (fileExist) +import qualified System.Directory as Directory import Puppet.Language import Puppet.Runner.Preferences @@ -84,7 +84,7 @@ testFile :: FilePath -> ExceptT PrettyError IO () testFile fp = do - p <- liftIO (fileExist fp) + p <- liftIO (Directory.doesFileExist fp) unless p (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp)) -- | Only test the `puppet:///` protocol (files managed by the puppet server) diff --git a/src/Puppet/Runner/Erb.hs b/src/Puppet/Runner/Erb.hs --- a/src/Puppet/Runner/Erb.hs +++ b/src/Puppet/Runner/Erb.hs @@ -175,7 +175,7 @@ rubyerr err = fmap (either snd identity) (FR.toRuby (Text.pack err) >>= FR.safeMethodCall "MyError" "new" . (:[])) case (,) <$> efname <*> eargs of Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do - logError $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !" + logWarning $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !" getSymbol "undef" | otherwise -> do let args = case varray of diff --git a/src/Puppet/Runner/Preferences.hs b/src/Puppet/Runner/Preferences.hs --- a/src/Puppet/Runner/Preferences.hs +++ b/src/Puppet/Runner/Preferences.hs @@ -29,10 +29,12 @@ import Data.Aeson import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS +import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Yaml as Yaml +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath import qualified System.Log.Logger as LOG -import System.Posix (fileExist) import Puppet.Interpreter import qualified Puppet.Runner.Puppetlabs as Puppetlabs @@ -97,8 +99,8 @@ testdir = dirpaths ^. testPath hierafile = basedir <> "/hiera.yaml" defaultfile = testdir <> "/defaults.yaml" - defaults <- ifM (fileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing) - hieradir <- ifM (fileExist hierafile) (pure $ Just hierafile) (pure Nothing) + defaults <- ifM (Directory.doesFileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing) + hieradir <- ifM (Directory.doesFileExist hierafile) (pure $ Just hierafile) (pure Nothing) loadedtypes <- loadedTypes modulesdir labsFunctions <- Puppetlabs.extFunctions modulesdir return $ Preferences dirpaths @@ -120,8 +122,19 @@ loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods) loadedTypes modulesdir = do - typenames <- fmap (map takeBaseName) (getFiles (Text.pack modulesdir) "lib/puppet/type" ".rb") + typenames <- map (Text.pack . FilePath.takeBaseName) <$> (getFiles modulesdir "lib/puppet/type" ".rb") pure $ HM.fromList (map defaulttype typenames) + where + getFiles :: FilePath -> FilePath -> FilePath -> IO [FilePath] + getFiles moduledir subdir extension = + fmap concat + $ Directory.listDirectory moduledir + >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) + checkForSubFiles :: FilePath -> FilePath -> IO [FilePath] + checkForSubFiles extension dir = + catch (fmap Right (Directory.listDirectory dir)) (\e -> return $ Left (e :: IOException)) >>= \case + Right o -> return ((map (\x -> dir <> "/" <> x) . filter (List.isSuffixOf extension)) o ) + Left _ -> return [] -- Utilities for getting default values from the yaml file -- It provides (the same) static defaults (see the 'Nothing' case) when diff --git a/src/Puppet/Runner/Puppetlabs.hs b/src/Puppet/Runner/Puppetlabs.hs --- a/src/Puppet/Runner/Puppetlabs.hs +++ b/src/Puppet/Runner/Puppetlabs.hs @@ -3,18 +3,18 @@ import XPrelude -import Crypto.Hash as Crypto -import Data.ByteString (ByteString) -import Data.Foldable (foldlM) -import qualified Data.HashMap.Strict as HM -import Data.Scientific as Sci -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Vector (Vector) -import Formatting (scifmt, sformat, (%), (%.)) -import qualified Formatting as FMT -import System.Posix.Files (fileExist) -import System.Random (mkStdGen, randomRs) +import Crypto.Hash as Crypto +import Data.ByteString (ByteString) +import Data.Foldable (foldlM) +import qualified Data.HashMap.Strict as HM +import Data.Scientific as Sci +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Vector (Vector) +import Formatting (scifmt, sformat, (%), (%.)) +import qualified Formatting as FMT +import qualified System.Directory as Directory +import System.Random (mkStdGen, randomRs) import Puppet.Interpreter @@ -43,13 +43,13 @@ if test then return $ HM.insert fname fn acc else return acc - testFile modname fname = fileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb") + testFile modname fname = Directory.doesFileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb") apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue -apacheBool2httpd [PBoolean True] = return $ PString "On" +apacheBool2httpd [PBoolean True] = return $ PString "On" apacheBool2httpd [PString "true"] = return $ PString "On" -apacheBool2httpd [_] = return $ PString "Off" -apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg +apacheBool2httpd [_] = return $ PString "Off" +apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg pgPassword :: MonadThrowPos m => [PValue] -> m PValue pgPassword [PString username, PString pwd] = @@ -68,17 +68,17 @@ -- To be implemented if needed. mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue -mockJenkinsPrefix [] = return $ PString "" +mockJenkinsPrefix [] = return $ PString "" mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg -- To be implemented if needed. mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue -mockJenkinsPort [] = return $ PString "8080" +mockJenkinsPort [] = return $ PString "8080" mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg mockCacheData :: MonadThrowPos m => [PValue] -> m PValue mockCacheData [_, _, b] = return b -mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg +mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg -- | Simple implemenation that does not handle all cases. -- For instance 'auth_option' is currently not implemented. diff --git a/src/PuppetDB.hs b/src/PuppetDB.hs --- a/src/PuppetDB.hs +++ b/src/PuppetDB.hs @@ -85,4 +85,29 @@ ] allfacts = nfacts `Map.union` ofacts genFacts = Map.fromList - return (allfacts & traverse %~ PString) + return (allfacts & traverse %~ PString & buildOSHash) + +buildOSHash :: Facts -> Facts +buildOSHash facts = case buildObject topLevel of + Nothing -> facts + Just os -> facts & at "os" ?~ os + where + buildObject keys = + let nobject = foldl' addKey mempty keys + in if nobject == mempty + then Nothing + else Just (PHash nobject) + g k = facts ^? ix k + topLevel = [ ("name", g "operatingsystem") + , ("family", g "osfamily") + , ("release", buildObject [("major", g "lsbdistrelease"), ("full", g "lsbdistrelease")]) + , ("lsb", buildObject [ ("distcodename", g "lsbdistcodename") + , ("distid", g "lsbdistid") + , ("distdescription", g "lsbdistdescription") + , ("distrelease", g "lsbdistrelease") + , ("majdistrelease", g "lsbmajdistrelease") + ]) + ] + addKey hash (k, mv) = case mv of + Nothing -> hash + Just v -> hash & at k ?~ v diff --git a/src/PuppetDB/Remote.hs b/src/PuppetDB/Remote.hs --- a/src/PuppetDB/Remote.hs +++ b/src/PuppetDB/Remote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} @@ -26,11 +27,16 @@ api :: Proxy PDBAPI api = Proxy +#if !MIN_VERSION_servant(0,13,0) +mkClientEnv :: Manager -> BaseUrl -> ClientEnv +mkClientEnv = ClientEnv +#endif + -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'. pdbConnect :: Manager -> String -> IO (Either PrettyError (PuppetDBAPI IO)) pdbConnect mgr url = do url' <- parseBaseUrl url - let env = ClientEnv mgr url' + let env = mkClientEnv mgr url' pure $ Right $ PuppetDBAPI (return (ppline $ fromString url)) (const (throwError "operation not supported")) diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs --- a/src/PuppetDB/TestDB.hs +++ b/src/PuppetDB/TestDB.hs @@ -19,7 +19,8 @@ import qualified Data.Maybe.Strict as S import qualified Data.Text as Text import qualified Data.Vector as V -import Data.Yaml +import Data.Yaml (ParseException (..), YamlException (..), YamlMark(..)) +import qualified Data.Yaml as Yaml import Text.Megaparsec.Pos import Facter @@ -38,7 +39,7 @@ instance FromJSON DBContent where parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing - parseJSON _ = mempty + parseJSON _ = mempty instance ToJSON DBContent where toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] @@ -46,7 +47,7 @@ -- | Initializes the test DB using a file to back its content loadTestDB :: FilePath -> IO (Either PrettyError (PuppetDBAPI IO)) loadTestDB fp = - decodeFileEither fp >>= \case + Yaml.decodeFileEither fp >>= \case Left (OtherParseException rr) -> return (Left (PrettyError (pplines (show rr)))) Left (InvalidYaml Nothing) -> baseError "Unknown error" Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: " @@ -176,7 +177,7 @@ dbc <- liftIO $ atomically $ readTVar db case dbc ^. backingFile of Nothing -> throwError "No backing file defined" - Just bf -> liftIO (encodeFile bf dbc `catches` [ ]) + Just bf -> liftIO (Yaml.encodeFile bf dbc `catches` [ ]) getNds :: DB -> Query NodeField -> ExceptT PrettyError IO [NodeInfo] getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db) diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs --- a/src/XPrelude/Extra.hs +++ b/src/XPrelude/Extra.hs @@ -7,12 +7,9 @@ , unwrapError , isEmpty , dropInitialColons - , getDirectoryContents - , takeBaseName , strictifyEither , scientific2text , text2Scientific - , getFiles , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith -- * Logger , loggerName @@ -51,30 +48,23 @@ import Text.Regex.PCRE.ByteString.Utils as Exports (Regex) import Data.Attoparsec.Text (parseOnly, rational) -import qualified Data.ByteString as BS import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as HS -import qualified Data.List as List import qualified Data.Scientific as Scientific import Data.String (String) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified System.Log.Logger as Log -import System.Posix.Directory.ByteString import XPrelude.PP type Container = Map.HashMap Text text2Scientific :: Text -> Maybe Scientific -text2Scientific t = - case parseOnly rational t of - Left _ -> Nothing - Right s -> Just s +text2Scientific t = rightToMaybe (parseOnly rational t) scientific2text :: Scientific -> Text scientific2text n = - Text.pack $ case Scientific.floatingOrInteger n of + case Scientific.floatingOrInteger n of Left r -> show (r :: Double) Right i -> show (i :: Integer) @@ -82,13 +72,6 @@ strictifyEither (Left x) = S.Left x strictifyEither (Right x) = S.Right x --- | See "System.FilePath.Posix" -takeBaseName :: Text -> Text -takeBaseName fullname = - let afterLastSlash = List.last $ Text.splitOn "/" fullname - splitExtension = List.init $ Text.splitOn "." afterLastSlash - in Text.intercalate "." splitExtension - -- | Helper for hashmap, in case we want another kind of map. ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m {-# INLINABLE ifromList #-} @@ -117,33 +100,6 @@ iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v {-# INLINABLE iunionWith #-} iunionWith = Map.unionWith - -getFiles :: Text -> Text -> Text -> IO [Text] -getFiles moduledir subdir extension = - fmap concat - $ getDirContents moduledir - >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) - -checkForSubFiles :: Text -> Text -> IO [Text] -checkForSubFiles extension dir = - catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case - Right o -> return ((map (\x -> dir <> "/" <> x) . filter (Text.isSuffixOf extension)) o ) - Left _ -> return [] - -getDirContents :: Text -> IO [Text] -getDirContents x = fmap (filter (not . Text.all (=='.'))) (getDirectoryContents x) - -getDirectoryContents :: Text -> IO [Text] -getDirectoryContents fpath = do - h <- openDirStream (Text.encodeUtf8 fpath) - let readHandle = do - fp <- readDirStream h - if BS.null fp - then return [] - else fmap (Text.decodeUtf8 fp :) readHandle - out <- readHandle - closeDirStream h - pure out isEmpty :: (Eq x, Monoid x) => x -> Bool isEmpty = (== mempty)