packages feed

directory-contents (empty) → 0.1.0.0

raw patch · 8 files changed

+647/−0 lines, 8 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, directory-contents, filepath, text, transformers, witherable

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for directory-contents++## 0.1.0.0++* Build recursive directory trees and try to avoid symlink cycles. Includes functions to walk a directory tree, filter it, and display it.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Obsidian Systems LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Obsidian Systems LLC nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.lhs view
@@ -0,0 +1,49 @@+directory-contents+==================+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/directory-contents.svg)](https://hackage.haskell.org/package/directory-contents) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/directory-contents/badge)](https://matrix.hackage.haskell.org/#/package/directory-contents) [![Github CI](https://github.com/obsidiansystems/directory-contents/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/directory-contents/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/obsidiansystems/directory-contents/blob/master/LICENSE)++Recursively list the contents of a directory while avoiding symlink loops.++Description+-----------++Modeled after the linux `tree` command (when invoked with the follow-symlinks+option), this module recursively lists the contents of a directory while+avoiding symlink loops. In particular, `tree -l` and `buildDirTree` should+provide the same result. See the documentation of `buildDirTree` for an+example.++In addition to building the directory-contents tree, this module provides+facilities for filtering, displaying, and navigating the directory hierarchy.++Example+-------++```haskell++>+> import Data.Foldable as F+> import Data.List+> import qualified Data.Text as T+> import System.Directory.Contents+> import System.FilePath+>+> main :: IO ()+> main = do+>   mp <- buildDirTree "."+>   case mp of+>     Nothing -> putStrLn "Couldn't find that path."+>     Just p -> do+>       let f = pruneDirTree =<< filterDirTree ((`elem` [".hs", ".lhs"]) . takeExtension) p+>       putStrLn $ case f of+>         Nothing -> "No haskell source files found."+>         Just hs -> unlines+>           [ "Paths that contain haskell source files:"+>           , T.unpack $ drawDirTree hs+>           , ""+>           , "Haskell source files:"+>           , intercalate ", " $ F.toList hs+>           ]+>++```
+ README.md view
@@ -0,0 +1,49 @@+directory-contents+==================+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/directory-contents.svg)](https://hackage.haskell.org/package/directory-contents) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/directory-contents/badge)](https://matrix.hackage.haskell.org/#/package/directory-contents) [![Github CI](https://github.com/obsidiansystems/directory-contents/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/directory-contents/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/obsidiansystems/directory-contents/blob/master/LICENSE)++Recursively list the contents of a directory while avoiding symlink loops.++Description+-----------++Modeled after the linux `tree` command (when invoked with the follow-symlinks+option), this module recursively lists the contents of a directory while+avoiding symlink loops. In particular, `tree -l` and `buildDirTree` should+provide the same result. See the documentation of `buildDirTree` for an+example.++In addition to building the directory-contents tree, this module provides+facilities for filtering, displaying, and navigating the directory hierarchy.++Example+-------++```haskell++>+> import Data.Foldable as F+> import Data.List+> import qualified Data.Text as T+> import System.Directory.Contents+> import System.FilePath+>+> main :: IO ()+> main = do+>   mp <- buildDirTree "."+>   case mp of+>     Nothing -> putStrLn "Couldn't find that path."+>     Just p -> do+>       let f = pruneDirTree =<< filterDirTree ((`elem` [".hs", ".lhs"]) . takeExtension) p+>       putStrLn $ case f of+>         Nothing -> "No haskell source files found."+>         Just hs -> unlines+>           [ "Paths that contain haskell source files:"+>           , T.unpack $ drawDirTree hs+>           , ""+>           , "Haskell source files:"+>           , intercalate ", " $ F.toList hs+>           ]+>++```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ directory-contents.cabal view
@@ -0,0 +1,61 @@+cabal-version:      >=1.10+name:               directory-contents+version:            0.1.0.0+synopsis:           Recursively build a tree of directory contents.+description:+  Like the linux tree command, this library recursively constructs a tree of directory contents while detecting and avoiding symlink cycles.++bug-reports:+  https://github.com/obsidiansystems/directory-contents/issues++license:            BSD3+license-file:       LICENSE+author:             Obsidian Systems+maintainer:         maintainer@obsidian.systems+copyright:          2020 Obsidian Systems LLC+category:           System+build-type:         Simple+extra-source-files:+  CHANGELOG.md+  README.md++library+  exposed-modules:  System.Directory.Contents+  build-depends:+      base          >=4.12 && <4.15+    , containers    >=0.6  && <0.7+    , directory     >=1.3  && <1.4+    , filepath      >=1.4  && <1.5+    , text          >=1.2  && <1.3+    , transformers  >=0.5  && <0.6+    , witherable    >=0.3  && <0.4++  hs-source-dirs:   src+  default-language: Haskell2010+  ghc-options:      -Wall++executable readme+  build-depends:+      base+    , directory-contents+    , filepath+    , text++  main-is:          README.lhs+  default-language: Haskell2010+  ghc-options:      -Wall -optL -q++test-suite directory-contents-test+  type:             exitcode-stdio-1.0+  build-depends:+      base+    , directory-contents+    , filepath++  default-language: Haskell2010+  hs-source-dirs:   test+  main-is:          Test.hs++source-repository head+  type:     git+  location: git://github.com/obsidiansystems/directory-contents.git
+ src/System/Directory/Contents.hs view
@@ -0,0 +1,407 @@+{-# language DeriveFoldable #-}+{-# language DeriveFunctor #-}+{-# language DeriveGeneric #-}+{-# language DeriveTraversable #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}+{-# language ScopedTypeVariables #-}++{-|+Description:+  Recursively list the contents of a directory while avoiding+  symlink loops.++Modeled after the linux @tree@ command (when invoked with the follow-symlinks+option), this module recursively lists the contents of a directory while+avoiding symlink loops. See the documentation of 'buildDirTree' for an example.++In addition to building the directory-contents tree, this module provides+facilities for filtering, displaying, and navigating the directory hierarchy.++-}+module System.Directory.Contents where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Writer+import Data.List+import qualified Data.Map as Map+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Tree as DataTree+import Data.Witherable+import GHC.Generics+import System.Directory+import System.FilePath++-- | The contents of a directory, represented as a tree. See 'Symlink' for+-- special handling of symlinks.+data DirTree a+  = DirTree_Dir FilePath [DirTree a]+  | DirTree_File FilePath a+  | DirTree_Symlink FilePath (Symlink a)+  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Generic)++-- | Symlink cycles are prevented by separating symlinks into two categories:+-- those that point to paths already within the directory hierarchy being+-- recursively listed, and those that are not. In the former case, rather than+-- following the symlink and listing the target redundantly, we simply store+-- the symlink reference itself. In the latter case, we treat the symlink as we+-- would any other folder and produce a list of its contents.+--+-- The 'String' argument represents the symlink reference (e.g., "../somefile").+-- In the 'Symlink_Internal' case, the second ('FilePath') argument is the path+-- to the symlink target.+-- In the 'Symlink_External' case, the second (@[DirTree a]@) argument contains+-- the contents of the symlink target.+data Symlink a+  = Symlink_Internal String FilePath+  | Symlink_External String [DirTree a]+  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Generic)++-- * Constructing a tree+-- | Recursively list the contents of a 'FilePath', representing the results as+-- a hierarchical 'DirTree'. This function should produce results similar to+-- the linux command @tree -l@.+--+-- For example, given this directory and symlink structure+-- (as shown by @tree -l@):+--+-- > test+-- > ├── A+-- > │   ├── a+-- > │   ├── A -> ../A  [recursive, not followed]+-- > │   └── B -> ../B+-- > │       ├── A -> ../A  [recursive, not followed]+-- > │       └── b+-- > ├── B+-- > │   ├── A -> ../A  [recursive, not followed]+-- > │   └── b+-- > └── C -> ../C+-- >     └── c+--+-- this function will produce the following (as rendererd by 'drawDirTree'):+--+-- > test+-- > |+-- > +- A+-- > |  |+-- > |  +- A -> ../A+-- > |  |+-- > |  +- B -> ../B+-- > |  |+-- > |  `- a+-- > |+-- > +- B+-- > |  |+-- > |  +- A -> ../A+-- > |  |+-- > |  `- b+-- > |+-- > `- C -> ../C+-- >    |+-- >    `- c+--+buildDirTree :: FilePath -> IO (Maybe (DirTree FilePath))+buildDirTree root = build Map.empty root+  where+    build seen path = do+      canon <- canonicalizePath path+      isPath <- doesPathExist path+      isDir <- doesDirectoryExist path+      isSym <- pathIsSymbolicLink path+      subpaths <- if isDir then listDirectory path else pure []+      subcanons <- mapM canonicalizePath <=<+        filterM (fmap not . pathIsSymbolicLink) $ (path </>) <$> subpaths+      let seen' = Map.union seen $ Map.fromList $ zip subcanons subpaths+          buildSubpaths = catMaybes <$> mapM+            (build (Map.insert canon path seen') . (path </>)) subpaths+      if | not isPath -> pure Nothing+         | isSym -> case Map.lookup canon seen' of+             Nothing -> do+               s <- getSymbolicLinkTarget path+               Just . DirTree_Symlink path . Symlink_External s <$> buildSubpaths+             Just _ -> do+               target <- getSymbolicLinkTarget path+               canonRoot <- canonicalizePath root+               let startingPoint = takeFileName root+               canonSym <- canonicalizePath $ takeDirectory path </> target+               pure $ Just $ DirTree_Symlink path $ Symlink_Internal target $+                startingPoint </> mkRelative canonRoot canonSym+         | isDir -> Just . DirTree_Dir path <$> buildSubpaths+         | otherwise -> pure $ Just $ DirTree_File path path++-- | De-reference one layer of symlinks+{- |+==== __Example__++Given:++> tmp+> |+> +- A+> |  |+> |  `- a+> |+> +- a -> A/a+> |+> `- C+>    |+>    `- A -> ../A++This function will follow one level of symlinks, producing:++> tmp+> |+> +- A+> |  |+> |  `- a+> |+> +- a+> |+> `- C+>    |+>    `- A+>       |+>       `- a++-}+dereferenceSymlinks :: DirTree FilePath -> IO (DirTree FilePath)+dereferenceSymlinks toppath = deref toppath toppath+  where+    deref top cur = case cur of+      DirTree_Dir p xs -> DirTree_Dir p <$> mapM (deref top) xs+      DirTree_File p x -> pure $ DirTree_File p x+      DirTree_Symlink p sym -> case sym of+        Symlink_External _ paths -> case paths of+          [] -> do+            isDir <- doesDirectoryExist p+            pure $ if isDir+              then DirTree_Dir p []+              else DirTree_File p p+          ps -> pure $ DirTree_Dir p ps+        Symlink_Internal _ r -> do+          let startingPoint = takeFileName $ filePath top+          let target = walkDirTree (startingPoint </> r) top+          pure $ case target of+            Nothing -> DirTree_Symlink p sym+            Just t -> t++-- * Navigate+-- | Starting from the root directory, try to walk the given filepath and return+-- the 'DirTree' at the end of the route. For example, given the following tree:+--+-- > src+-- > └── System+-- >     └── Directory+-- >             └── Contents.hs+--+-- @walkDirTree "src/System"@ should produce+--+-- > Directory+-- > |+-- > `- Contents.hs+--+-- This function does not dereference symlinks, nor does it handle the special+-- paths @.@ and @..@.+walkDirTree :: FilePath -> DirTree a -> Maybe (DirTree a)+walkDirTree target p =+  let pathSegments = splitDirectories target+      walk :: [FilePath] -> DirTree a -> Maybe (DirTree a)+      walk [] path = Just path+      walk (c : gc) path = case path of+        DirTree_Dir a xs+          | takeFileName a == c -> alternative $ walk gc <$> xs+        DirTree_File a f+          | takeFileName a == c && null gc -> Just $ DirTree_File a f+        DirTree_Symlink a (Symlink_Internal s t)+          | takeFileName a == c && null gc -> Just $ DirTree_Symlink a+            (Symlink_Internal s t)+        DirTree_Symlink a (Symlink_External _ xs)+          | takeFileName a == c -> alternative $ walk gc <$> xs+        _ -> Nothing+  in walk pathSegments p++-- | Like 'walkDirTree' but skips the outermost containing directory. Useful for+-- walking paths relative from the root directory passed to 'buildDirTree'.+--+-- Given the following 'DirTree':+--+-- > src+-- > └── System+-- >     └── Directory+-- >             └── Contents.hs+--+-- @walkContents "System"@ should produce+--+-- > Directory+-- > |+-- > `- Contents.hs+walkContents :: FilePath -> DirTree a -> Maybe (DirTree a)+walkContents p = \case+  DirTree_Dir _ xs -> walkSub xs+  DirTree_File _ _ -> Nothing+  DirTree_Symlink _ (Symlink_External _ xs) -> walkSub xs+  DirTree_Symlink _ (Symlink_Internal _ _) -> Nothing+  where+    walkSub :: [DirTree a] -> Maybe (DirTree a)+    walkSub xs = getAlt $ mconcat $ Alt . walkDirTree p <$> xs++-- * Filter+-- | This wrapper really just represents the no-path/empty case so that+-- filtering works+newtype DirTreeMaybe a = DirTreeMaybe { unDirTreeMaybe :: Maybe (DirTree a) }+  deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)++instance Filterable DirTreeMaybe where+  catMaybes (DirTreeMaybe Nothing) = DirTreeMaybe Nothing+  catMaybes (DirTreeMaybe (Just x)) = DirTreeMaybe $ do+    let go :: DirTree (Maybe a) -> Writer [FilePath] (Maybe (DirTree a))+        go = \case+          DirTree_Dir p xs -> do+            out <- mapM go xs+            pure $ Just $ DirTree_Dir p $ catMaybes out+          DirTree_File p f -> case f of+            Nothing -> tell [p] >> pure Nothing+            Just f' -> pure $ Just $ DirTree_File p f'+          DirTree_Symlink p (Symlink_External s xs) -> do+            out <- mapM go xs+            pure $ Just $ DirTree_Symlink p (Symlink_External s $ catMaybes out)+          DirTree_Symlink p (Symlink_Internal s r) -> pure $+             Just $ DirTree_Symlink p (Symlink_Internal s r)+        removeStaleSymlinks :: [FilePath] -> DirTree a -> Maybe (DirTree a)+        removeStaleSymlinks xs = \case+          DirTree_Symlink p (Symlink_Internal s r) ->+            let startingPoint = takeDirectory $ filePath x+            in+              if (startingPoint </> r) `elem` xs+              then Nothing+              else Just $ DirTree_Symlink p (Symlink_Internal s r)+          DirTree_Symlink p s -> Just $ DirTree_Symlink p s+          DirTree_File p f -> Just $ DirTree_File p f+          DirTree_Dir p fs -> Just $ DirTree_Dir p $+            catMaybes $ removeStaleSymlinks xs <$> fs+    let (out, removals) = runWriter $ go x+    removeStaleSymlinks removals =<< out++instance Witherable DirTreeMaybe++-- | Map a function that could produce an empty result over a 'DirTree'+withDirTreeMaybe+  :: (DirTreeMaybe a -> DirTreeMaybe b)+  -> DirTree a+  -> Maybe (DirTree b)+withDirTreeMaybe f = unDirTreeMaybe . f . DirTreeMaybe . Just++-- | Map a function that could produce an empty result in the given functor+withDirTreeMaybeF+  :: Functor f+  => (DirTreeMaybe a -> f (DirTreeMaybe b))+  -> DirTree a+  -> f (Maybe (DirTree b))+withDirTreeMaybeF f = fmap unDirTreeMaybe . f . DirTreeMaybe . Just++-- | 'wither' for 'DirTree'. This represents the case of no paths left after+-- filtering with 'Nothing' (something that the 'DirTree' type can't represent on+-- its own).  NB: Filtering does not remove directories, only files. The+-- directory structure remains intact. To remove empty directories, see+-- 'pruneDirTree'.+witherDirTree+  :: Applicative f+  => (a -> f (Maybe b))+  -> DirTree a+  -> f (Maybe (DirTree b))+witherDirTree = withDirTreeMaybeF . wither++-- | 'filterA' for 'DirTree'. See 'witherDirTree'.+filterADirTree+  :: Applicative f+  => (a -> f Bool)+  -> DirTree a+  -> f (Maybe (DirTree a))+filterADirTree = withDirTreeMaybeF . filterA++-- | 'mapMaybe' for 'DirTree'. See 'witherDirTree'.+mapMaybeDirTree :: (a -> Maybe b) -> DirTree a -> Maybe (DirTree b)+mapMaybeDirTree = withDirTreeMaybe . mapMaybe++-- | 'catMaybes' for 'DirTree'. See 'witherDirTree'.+catMaybesDirTree :: DirTree (Maybe a) -> Maybe (DirTree a)+catMaybesDirTree = withDirTreeMaybe catMaybes++-- | 'Data.Witherable.filter' for 'DirTree'. See 'witherDirTree'.+filterDirTree :: (a -> Bool) -> DirTree a -> Maybe (DirTree a)+filterDirTree = withDirTreeMaybe . Data.Witherable.filter++-- | Remove empty directories from the 'DirTree'+pruneDirTree :: DirTree a -> Maybe (DirTree a)+pruneDirTree = \case+  DirTree_Dir a xs ->+    sub (DirTree_Dir a) xs+  DirTree_File a f ->+    Just $ DirTree_File a f+  DirTree_Symlink a (Symlink_External s xs) ->+    sub (DirTree_Symlink a . Symlink_External s) xs+  DirTree_Symlink a (Symlink_Internal s t) ->+    Just $ DirTree_Symlink a (Symlink_Internal s t)+  where+    sub c xs = case mapMaybe pruneDirTree xs of+      [] -> Nothing+      ys -> Just $ c ys++-- * Display+-- | Produces a tree drawing (using only text) of a 'DirTree' hierarchy.+drawDirTree :: DirTree a -> Text+drawDirTree = T.pack . drawDirTreeWith const++-- | Apply a rendering function to each file when drawing the directory hierarchy+drawDirTreeWith :: (String -> a -> String) -> DirTree a -> String+drawDirTreeWith f = DataTree.drawTree . pathToTree+  where+    pathToTree = \case+      DirTree_File p a ->+        DataTree.Node (f (takeFileName p) a) []+      DirTree_Dir p ps ->+        DataTree.Node (takeFileName p) $ pathToTree <$> ps+      DirTree_Symlink p (Symlink_Internal s _) ->+        DataTree.Node (showSym p s) []+      DirTree_Symlink p (Symlink_External s xs) ->+        DataTree.Node (showSym p s) $ pathToTree <$> xs+    showSym p s = takeFileName p <> " -> " <> s++-- | Print the 'DirTree' as a tree. For example:+--+-- @+--+-- System+-- |+-- `- Directory+--    |+--    `- Contents.hs+--+-- @+printDirTree :: DirTree a -> IO ()+printDirTree = putStrLn . T.unpack . drawDirTree++-- * Utilities++-- | Make one filepath relative to another+mkRelative :: FilePath -> FilePath -> FilePath+mkRelative root fp = case stripPrefix (dropTrailingPathSeparator root) fp of+  Nothing -> []+  Just r ->+    -- Remove the leading slash - we know it'll be there because+    -- we removed the trailing slash (if it was there) from the root+    drop 1 r++-- | Get the first 'Alternative'+alternative :: Alternative f => [f a] -> f a+alternative = getAlt . mconcat . fmap Alt++-- | Extract the 'FilePath' from a 'DirTree' node+filePath :: DirTree a -> FilePath+filePath = \case+  DirTree_Dir f _ -> f+  DirTree_File f _ -> f+  DirTree_Symlink f _ -> f
+ test/Test.hs view
@@ -0,0 +1,44 @@+import Data.Maybe+import System.Directory.Contents+import System.Exit+import System.FilePath++main :: IO ()+main = do+  p <- test+    "Build DirTree in the presence of recursive symlinks"+    (buildDirTree "test/fixtures/test-1")+  test+    "Navigate to a directory that should exist"+    (pure $ walkContents "C" p)+  filtered <- test "Filter contents based on a predicate" $+    pure (filterDirTree ((/="README.md") . takeFileName) p)+  test "Check that filtering didn't prune directories" $+    pure $ walkContents "C" p+  test "Check that pruneDirTree does prune empty directories" $+    pure $ expectNothing $ walkContents "C" =<< pruneDirTree filtered+  rocket <- test "Check that symlink can be traversed" $+    pure (walkContents "D/rocket" filtered)+  let filterRockets = filterDirTree ((/="rocket") . takeFileName)+  test "Check that filtering removes symlinks to filtered files" $+    pure $ expectNothing $+      walkContents "d_rocket" =<< filterRockets p+  test "Check that dereferenced symlinks to filtered files are not removed" $ do+    deref <- dereferenceSymlinks p+    pure $ walkContents "d_rocket" =<< filterRockets deref+  readFile (filePath rocket) >>=+    putStr >> putStrLn " All systems go!"++test :: String -> IO (Maybe a) -> IO a+test describe run = do+  putStr describe+  putStr " ... "+  result <- run+  case result of+    Nothing -> putStrLn "FAILED" >> exitWith (ExitFailure 1)+    Just r -> putStrLn "passed" >> return r++expectNothing :: Maybe a -> Maybe ()+expectNothing x = case x of+  Nothing -> Just ()+  Just _ -> Nothing