{-# Language DeriveFoldable #-}
{-# Language DeriveFunctor #-}
{-# Language DeriveTraversable #-}
{-# Language FlexibleContexts #-}
{-# Language LambdaCase #-}
{-# Language MultiWayIf #-}
module System.Directory.Contents
(
DirTree(..)
, Symlink(..)
, FileName
, buildDirTree
, dereferenceSymlinks
, filePath
, fileName
, fileNameMap
, insertSibling
, removeSibling
, withFirstChild
, walkDirTree
, walkContents
, pruneDirTree
, DirTreeMaybe(..)
, withDirTreeMaybe
, withDirTreeMaybeF
, witherDirTree
, filterADirTree
, mapMaybeDirTree
, catMaybesDirTree
, filterDirTree
, drawDirTree
, drawDirTreeWith
, printDirTree
, mkRelative
, alternative
) 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.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Tree as DataTree
import Data.Witherable
import System.Directory
import System.FilePath
import System.Directory.Contents.Types
import System.Directory.Contents.Zipper
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 . fileNameMap <$> 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 . fileNameMap <$> buildSubpaths
| otherwise -> pure $ Just $ DirTree_File path path
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 ->
if Map.null paths
then do
isDir <- doesDirectoryExist p
pure $ if isDir
then DirTree_Dir p Map.empty
else DirTree_File p p
else pure $ DirTree_Dir p paths
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
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 <$> Map.elems 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 <$> Map.elems xs
_ -> Nothing
in walk pathSegments p
walkContents :: FilePath -> DirTree a -> Maybe (DirTree a)
walkContents p = fmap focused . followRelative p . zipped
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 (Set 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 (Set.singleton 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 :: Set FilePath -> DirTree a -> Maybe (DirTree a)
removeStaleSymlinks xs d = case d of
DirTree_Symlink p (Symlink_Internal s r) ->
let startingPoint = case takeDirectory $ filePath x of
"." -> ""
a -> a
in
if (startingPoint </> r) `Set.member` xs
then Nothing
else Just $ DirTree_Symlink p (Symlink_Internal s r)
DirTree_Symlink p (Symlink_External s cs) ->
if Map.null cs && Set.member (filePath x </> s) xs
then Nothing
else Just $ DirTree_Symlink p (Symlink_External s cs)
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
withDirTreeMaybe
:: (DirTreeMaybe a -> DirTreeMaybe b)
-> DirTree a
-> Maybe (DirTree b)
withDirTreeMaybe f = unDirTreeMaybe . f . DirTreeMaybe . Just
withDirTreeMaybeF
:: Functor f
=> (DirTreeMaybe a -> f (DirTreeMaybe b))
-> DirTree a
-> f (Maybe (DirTree b))
withDirTreeMaybeF f = fmap unDirTreeMaybe . f . DirTreeMaybe . Just
witherDirTree
:: Applicative f
=> (a -> f (Maybe b))
-> DirTree a
-> f (Maybe (DirTree b))
witherDirTree = withDirTreeMaybeF . wither
filterADirTree
:: Applicative f
=> (a -> f Bool)
-> DirTree a
-> f (Maybe (DirTree a))
filterADirTree = withDirTreeMaybeF . filterA
mapMaybeDirTree :: (a -> Maybe b) -> DirTree a -> Maybe (DirTree b)
mapMaybeDirTree = withDirTreeMaybe . mapMaybe
catMaybesDirTree :: DirTree (Maybe a) -> Maybe (DirTree a)
catMaybesDirTree = withDirTreeMaybe catMaybes
filterDirTree :: (a -> Bool) -> DirTree a -> Maybe (DirTree a)
filterDirTree = withDirTreeMaybe . Data.Witherable.filter
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 =
let ys = mapMaybe pruneDirTree xs
in if Map.null ys then Nothing else Just $ c ys
drawDirTree :: DirTree a -> Text
drawDirTree = T.pack . drawDirTreeWith const
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 <$> Map.elems 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 <$> Map.elems xs
showSym p s = takeFileName p <> " -> " <> s
printDirTree :: DirTree a -> IO ()
printDirTree = putStrLn . T.unpack . drawDirTree
mkRelative :: FilePath -> FilePath -> FilePath
mkRelative root fp = case stripPrefix (dropTrailingPathSeparator root) fp of
Nothing -> []
Just r ->
drop 1 r
alternative :: Alternative f => [f a] -> f a
alternative = getAlt . mconcat . fmap Alt