language-puppet 1.3.16 → 1.3.17
raw patch · 16 files changed
+134/−113 lines, 16 filesdep ~exceptionsdep ~servantdep ~servant-client
Dependency ranges changed: exceptions, servant, servant-client
Files
- CHANGELOG +7/−0
- language-puppet.cabal +4/−4
- src/Facter.hs +14/−13
- src/Puppet/Interpreter.hs +24/−10
- src/Puppet/Language/NativeTypes/Concat.hs +0/−6
- src/Puppet/Parser.hs +2/−1
- src/Puppet/Parser/PrettyPrinter.hs +1/−0
- src/Puppet/Parser/Types.hs +3/−1
- src/Puppet/Runner/Daemon/OptionalTests.hs +2/−2
- src/Puppet/Runner/Erb.hs +1/−1
- src/Puppet/Runner/Preferences.hs +17/−4
- src/Puppet/Runner/Puppetlabs.hs +19/−19
- src/PuppetDB.hs +26/−1
- src/PuppetDB/Remote.hs +7/−1
- src/PuppetDB/TestDB.hs +5/−4
- src/XPrelude/Extra.hs +2/−46
CHANGELOG view
@@ -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 <bartavelle@gmail.com> UNRELEASED+ language-puppet (1.3.16) artful; urgency=medium [ PierreR ] * Fix #213 Hash lookup failing in erb template
language-puppet.cabal view
@@ -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
src/Facter.hs view
@@ -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
src/Puppet/Interpreter.hs view
@@ -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)"
src/Puppet/Language/NativeTypes/Concat.hs view
@@ -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]) ]
src/Puppet/Parser.hs view
@@ -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 == '-')
src/Puppet/Parser/PrettyPrinter.hs view
@@ -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)
src/Puppet/Parser/Types.hs view
@@ -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 -- ^ `+>`
src/Puppet/Runner/Daemon/OptionalTests.hs view
@@ -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)
src/Puppet/Runner/Erb.hs view
@@ -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
src/Puppet/Runner/Preferences.hs view
@@ -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
src/Puppet/Runner/Puppetlabs.hs view
@@ -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.
src/PuppetDB.hs view
@@ -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
src/PuppetDB/Remote.hs view
@@ -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"))
src/PuppetDB/TestDB.hs view
@@ -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)
src/XPrelude/Extra.hs view
@@ -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)