diff --git a/dirtree.cabal b/dirtree.cabal --- a/dirtree.cabal +++ b/dirtree.cabal @@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ccecd49ad528fc24560e3ec81951861237966a7db1d26b8f8fc82c0350d392f3 +-- hash: af2392fd0d2b2978caaee80e8994f8254986e75b5c1113b4016f71255f20c7f7 name: dirtree -version: 0.0.1 +version: 0.1.0 synopsis: A small library for working with directories. -description: A small library for working with directories. +description: A small library for loading and building directories as trees. category: System homepage: https://github.com/kalhauge/dirtree#readme author: Christian Gram Kalhauge @@ -24,18 +24,22 @@ library exposed-modules: System.DirTree + System.DirTree.Zip other-modules: Paths_dirtree hs-source-dirs: src ghc-options: -Wall build-depends: - base >=4.7 && <5 + base >=4.10 && <5 + , bytestring , containers , deepseq , directory , filepath , lens + , unix + , zip-archive default-language: Haskell2010 test-suite dirtree-test @@ -43,13 +47,15 @@ main-is: Main.hs other-modules: Spec + System.DirTree.ZipSpec System.DirTreeSpec Paths_dirtree hs-source-dirs: test ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + base >=4.10 && <5 + , bytestring , containers , deepseq , directory @@ -59,4 +65,6 @@ , hspec-discover , hspec-expectations-pretty-diff , lens + , unix + , zip-archive default-language: Haskell2010 diff --git a/src/System/DirTree.hs b/src/System/DirTree.hs --- a/src/System/DirTree.hs +++ b/src/System/DirTree.hs @@ -1,695 +1,830 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-| -Module : System.DirTree -Copyright : (c) Christian Gram Kalhauge, 2019 -License : MIT -Maintainer : kalhauge@cs.ucla.edu - -A directory tree, with helper functions to do different cool stuff. - --} -module System.DirTree - ( - - -- * DirTree - DirTree (..) - - , file - , symlink - , directory - , directoryFromFiles - - -- ** Constructors - , fromFiles - , fromFiles' - , fromFile - , toFiles - - -- ** Accessors - , FileKey - , fileKeyToPath - , fileKeyFromPath - - , lookupFile - - -- ** Traversals - -- These function are used for folding over the DirTree - - , traverseDirTree - , traverseDirTree' - , itraverseDirTree - , itraverseDirTree' - - , mapDirTree' - , imapDirTree' - - , depthfirst - , foldDirTree - , foldDirTree' - , ifoldDirTree - , ifoldDirTree' - - , flatten - - -- ** Utils - , findNode - , listNodes - - -- ** IO operations - -- These functions can be used to read a DirTree from the file system. - , readDirTree - , lazyReadDirTree - - , writeDirTree - - , followLinks - , lazyFollowLinks - - -- * DirTreeNode - , Link (..) - , DirTreeNode (..) - , FileType - , fileTypeOfNode - - -- ** Folds - , mapDirTreeNode - , foldDirTreeNode - , traverseDirTreeNode - - -- ** IO operations - , getFileType - , readPath - - -- * Helpers - , DirTreeN - - -- * FileMap - , FileMap - , toFileList - , fromFileList - - , (-.>), (-|>), (-/>) - - , toDeepFileList - , fromDeepFileList - - , toFileNames - , lookupFileMap - , emptyFileMap - ) where - --- containers -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map - --- deepseq -import Control.DeepSeq - --- directory -import System.Directory hiding (findFile) - --- filepath -import System.FilePath - --- lens -import Control.Lens.Combinators --- import Control.Lens.Indexed - --- base -import Data.Foldable -import Data.Semigroup -import Data.Void -import Text.Show -import GHC.Generics -import System.IO.Unsafe --- * DirTree - --- | A dir tree is a tree of nodes. -newtype DirTree s a = DirTree - { dirTreeNode :: DirTreeN s a - } - deriving (Eq, Ord, NFData, Generic) - -instance (Show v, Show c) => Show (DirTree v c) where - showsPrec d c = showParen (d >9) $ (f $ dirTreeNode c) - where - f = \case - Directory a -> - showString "directory " . showsPrec 11 a - Symlink a -> - showString "symlink " . showsPrec 11 a - File a -> - showString "file " . showsPrec 11 a - --- | A `DirTreeN` is a `DirTreeNode` with a the directory as a recursive --- DirTree. -type DirTreeN s a = DirTreeNode (FileMap (DirTree s a)) s a - -instance Semigroup (DirTree s a) where - DirTree (Directory as) <> DirTree (Directory bs) = - DirTree (Directory (as <> bs)) - _ <> a = a - -instance Functor (DirTree s) where - fmap = mapDirTree' id - -instance Foldable (DirTree s) where - foldMap = foldDirTree' (const mempty) - -instance Traversable (DirTree s) where - traverse = traverseDirTree' pure - -instance FunctorWithIndex FileKey (DirTree v) -instance FoldableWithIndex FileKey (DirTree v) -instance TraversableWithIndex FileKey (DirTree v) where - itraverse = itraverseDirTree' (const pure) - {-# INLINE itraverse #-} - --- ** Constructors - --- | Constructs a dirtree with only a file -file :: a -> DirTree s a -file = DirTree . File - --- | Constructs a dirtree with a symlink -symlink :: s -> DirTree s a -symlink = DirTree . Symlink - --- | Constructs a dirtree with a directory -directory :: FileMap (DirTree s a) -> DirTree s a -directory = DirTree . Directory - --- | Constructs a dirtree with a directory -directoryFromFiles :: [(String, DirTree s a)] -> DirTree s a -directoryFromFiles = DirTree . Directory . fromFileList - --- ** Accessors - --- | A filekey is the filepath in reverse order -type FileKey = [String] - --- | Get a `FileKey` from a `FilePath` -fileKeyFromPath :: FilePath -> FileKey -fileKeyFromPath = - reverse . splitDirectories - --- | Get a `FilePath` from a `FileKey` -fileKeyToPath :: FileKey -> FilePath -fileKeyToPath = - joinPath . reverse - -diffFileKey :: FileKey -> FileKey -> FilePath -diffFileKey f to' = - let (n, bs) = (suffix f to') - in fileKeyToPath (bs ++ replicate n "..") - where - suffix (a:as) (b:bs) - | a /= b = - (1 + length as, b:bs) - | otherwise = - suffix as bs - suffix (_:as) [] = - (1 + length as, []) - suffix [] bs = - (0, bs) - --- | Lookup a file in a `DirTree` using a `FileKey` -lookupFile :: FileKey -> DirTree v a -> Maybe (DirTree v a) -lookupFile fk = go (reverse fk) - where - go [] tree = Just tree - go (a:rest) (DirTree (Directory x)) = - go rest =<< lookupFileMap a x - go _ _ = Nothing -{-# inline lookupFile #-} - -toFiles :: DirTree v a -> [(FileKey, Either v a)] -toFiles = - flip appEndo [] - . ifoldDirTree' (\i s -> Endo ((i, Left s):)) (\i s -> Endo ((i, Right s):)) -{-# INLINE toFiles #-} - --- | Create a dirtree from a non-empty list of files. -fromFiles :: [(FileKey, Either v a)] -> Maybe (DirTree v a) -fromFiles = - fmap fromFiles' . NonEmpty.nonEmpty -{-# INLINE fromFiles #-} - --- | Create a dirtree from a non-empty list of files. -fromFiles' :: NonEmpty.NonEmpty (FileKey, Either v a) -> DirTree v a -fromFiles' = - sconcat . fmap (uncurry fromPath) -{-# INLINE fromFiles' #-} - -fromPath :: FileKey -> Either s a -> DirTree s a -fromPath key a = - foldr (\s f -> directory (singleFile s f)) (either symlink file a) key -{-# INLINE fromPath #-} - -fromFile :: FileKey -> a -> DirTree Void a -fromFile key a = - foldr (\s f -> directory (singleFile s f)) (file a) key -{-# INLINE fromFile #-} - --- ** Helpers - --- | Traverse over the tree -itraverseDirTree :: - Applicative f - => ( FileKey -> DirTreeNode (FileMap (f (DirTree s' a'))) s a -> f (DirTreeN s' a')) - -> DirTree s a - -> f (DirTree s' a') -itraverseDirTree f = go [] - where - go x (DirTree fs) = fmap DirTree . f x $ - case fs of - Directory fm -> - Directory $ imap (\s a -> go (s:x) a) fm - Symlink a -> Symlink a - File a -> File a -{-# inline itraverseDirTree #-} - --- | Traverse over the tree with index. This method uses two functions one --- symlinks and one for files. -itraverseDirTree' :: - Applicative f - => (FileKey -> s -> f s') -> (FileKey -> a -> f a') - -> DirTree s a - -> f (DirTree s' a') -itraverseDirTree' fs fa = - itraverseDirTree - (\key -> \case - Directory fm -> - Directory <$> traverse id fm - Symlink a -> Symlink <$> fs key a - File a -> File <$> fa key a - ) -{-# inline itraverseDirTree' #-} - --- | Maps over a `DirTree` -imapDirTree' :: (FileKey -> s -> s') -> (FileKey -> a -> a') -> DirTree s a -> DirTree s' a' -imapDirTree' fs fa = - runIdentity . itraverseDirTree' (\i -> Identity . fs i) (\i -> Identity . fa i) -{-# inline imapDirTree' #-} - --- | Folds over a `DirTree`. -ifoldDirTree' :: Monoid m => (FileKey -> s -> m) -> (FileKey -> a -> m) -> DirTree s a -> m -ifoldDirTree' fs fa = - ifoldDirTree (\i -> foldDirTreeNode fold (fs i) (fa i)) -{-# inline ifoldDirTree' #-} - --- | Folds over a `DirTree` using the `DirTreeNode`. -ifoldDirTree :: (FileKey -> DirTreeNode (FileMap m) s a -> m) -> DirTree s a -> m -ifoldDirTree f = go [] - where - go x (DirTree fs) = f x $ - case fs of - Directory fm -> - Directory $ imap (\s a -> go (s:x) a) fm - Symlink a -> Symlink a - File a -> File a -{-# inline ifoldDirTree #-} - --- | Traverse a DirTree -traverseDirTree :: - Applicative f - => (DirTreeNode (FileMap (f (DirTree s' a'))) s a -> f (DirTreeN s' a')) - -> DirTree s a - -> f (DirTree s' a') -traverseDirTree fm = - itraverseDirTree (const fm) -{-# inline traverseDirTree #-} - --- | Traverse a DirTree -traverseDirTree' :: - Applicative m - => (s -> m s') -> (a -> m a') - -> DirTree s a -> m (DirTree s' a') -traverseDirTree' fs fa = - itraverseDirTree' (const fs) (const fa) -{-# inline traverseDirTree' #-} - --- | Folds over a dirtree -foldDirTree :: (DirTreeNode (FileMap m) s a -> m) -> DirTree s a -> m -foldDirTree f = - ifoldDirTree (const f) -{-# inline foldDirTree #-} - --- | Folds over a dirtree -foldDirTree' :: Monoid m => (s -> m) -> (a -> m) -> DirTree s a -> m -foldDirTree' fs fa = - ifoldDirTree' (const fs) (const fa) -{-# inline foldDirTree' #-} - --- | maps over a dirtree -mapDirTree' :: (s -> s') -> (a -> a') -> DirTree s a -> DirTree s' a' -mapDirTree' fs fa = - imapDirTree' (const fs) (const fa) -{-# inline mapDirTree' #-} - --- | Flatten a directory tree. This is usefull for following symlinks, or --- expanding zip-files. -flatten :: - (s -> DirTree s' a') - -> (a -> DirTree s' a') - -> DirTree s a - -> DirTree s' a' -flatten s a = - foldDirTree (foldDirTreeNode directory s a) -{-# inline flatten #-} - --- * Utils - --- | Recursively iterate over a folder. -depthfirst :: - Monoid m - =>(FileKey -> DirTreeNode [String] v a -> m) - -> DirTree v a - -> m -depthfirst fm = - ifoldDirTree $ \key file' -> - case file' of - Directory files -> do - fm key (Directory $ toFileNames files) <> fold files - File a -> - fm key (File a) - Symlink v -> - fm key (Symlink v) -{-# inline depthfirst #-} - --- | Find a file given a predicate that takes a `FileKey` and `DirTreeNode`. -findNode :: - (FileKey -> DirTreeNode [String] v a -> Bool) - -> DirTree v a - -> Maybe (FileKey, DirTreeNode [String] v a) -findNode f = - fmap getFirst . depthfirst - (curry $ \case - a | uncurry f a -> Just (First a) - | otherwise -> Nothing - ) -{-# inline findNode #-} - --- | List all the nodes in the `DirTree`. -listNodes :: DirTree v a -> [(FileKey, DirTreeNode [String] v a)] -listNodes = - flip appEndo [] . depthfirst (curry $ Endo . (:)) -{-# inline listNodes #-} - - --- ** IO Methods - --- | A `Link` can either be `Internal`, pointing to something in the `DirTree` or --- `External` pointing to an absolute `FilePath`. -data Link - = Internal !FileKey - | External !FilePath - deriving (Show, Eq, Generic, NFData) - --- | Reads a DirTree. All file paths are absolute to the filepath -readDirTree :: - NFData a => - (FilePath -> IO a) - -> FilePath - -> IO (DirTree Link a) -readDirTree reader' fp = do - force <$> lazyReadDirTree reader' fp - --- | Lazy read a DirTree. This function uses `unsafeInterleaveIO` to --- lazy interleave load a node. This means that it can be used to efficiently --- search of a file. All paths are absolute -lazyReadDirTree :: - (FilePath -> IO a) - -> FilePath - -> IO (DirTree Link a) -lazyReadDirTree reader' basepath = do - from' <- canonicalizePath basepath - go from' [] basepath - where - go from' key fp = unsafeInterleaveIO $ do - node <- readPath fp - foldDirTreeNode - (fmap directory . imapM (\s _ -> go from' (s:key) (fp s)) . fromFilenames) - (fmap symlink . absolute) - (const $ file <$> reader' fp) - node - where - absolute a - | isAbsolute a = - return $ External a - | otherwise = do - a' <- canonicalizePath (takeDirectory fp a) - let a'' = makeRelative from' a' - if a'' /= a' - then return $ Internal (fileKeyFromPath a'') - else return $ External a' -{-# INLINE lazyReadDirTree #-} - - --- | Reads a DirTree -writeDirTree :: - (FilePath -> a -> IO ()) - -> FilePath - -> DirTree Link a - -> IO () -writeDirTree writer fp tree = do - ifoldDirTree - ( \fk i -> - let fp' = fp fileKeyToPath fk in - case i of - Directory m -> do - createDirectory fp' - fold m - Symlink (External target) -> - createFileLink target fp' - Symlink (Internal key) -> - createFileLink - (case (fk, key) of - (_:fk', _) -> diffFileKey fk' key - ([], []) -> "." - ([], _) -> error "Fail" - ) fp' - File a -> - writer fp' a - ) - tree -{-# INLINE writeDirTree #-} - --- | Follow the links to create the tree. This function might recurse forever. -followLinks :: NFData a => (FilePath -> IO a) -> DirTree Link a -> IO (DirTree Void a) -followLinks fio dt = - force <$> lazyFollowLinks fio dt -{-# INLINE followLinks #-} - - --- | Like follow links but uses lazy io to only load the recursive folder when --- needed. -lazyFollowLinks :: (FilePath -> IO a) -> DirTree Link a -> IO (DirTree Void a) -lazyFollowLinks reader' tree = - go tree tree - where - go basetree = - unsafeInterleaveIO - . fmap (flatten id file) - . traverseDirTree' (readLink basetree) pure - - readLink basetree = \case - Internal s -> do - case lookupFile s basetree of - Just a -> go basetree a - Nothing -> - error $ "Could not find " ++ show s ++ " in the dirtree " ++ show (fmap (const ()) tree) - External s -> do - t <- lazyReadDirTree reader' s - lazyFollowLinks reader' t - - --- * DirTreeNode - --- | A directory tree node. Everything is either a file, a symbolic link, or a --- directory. -data DirTreeNode r s a - = Directory r - | Symlink s - | File a - deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic) - --- | A `FileType` is just a `DirTreeNode` with no contents. -type FileType = DirTreeNode () () () - --- ** Helpers - --- | A DirTreeNode is a weird kind of algebra. -flattenDirTreeNode :: DirTreeNode m m m -> m -flattenDirTreeNode = \case - File m -> m - Symlink m -> m - Directory m -> m - --- | We can map over a DirTreeNode -mapDirTreeNode :: - (r -> r') -> (s -> s') -> (a -> a') - -> DirTreeNode r s a - -> DirTreeNode r' s' a' -mapDirTreeNode fr fs fa = \case - File a -> File $ fa a - Symlink s -> Symlink $ fs s - Directory r -> Directory $ fr r - --- | We can fold over a DirTreeNode by providing a function for each case. -foldDirTreeNode :: (r -> m) -> (s -> m) -> (a -> m) -> DirTreeNode r s a -> m -foldDirTreeNode fr fs fa = - flattenDirTreeNode . mapDirTreeNode fr fs fa - --- | We can fold over a DirTreeNode by providing a function for each case. -traverseDirTreeNode :: - Functor m - => - (r -> m r') -> (s -> m s') -> (a -> m a') - -> DirTreeNode r s a -> m (DirTreeNode r' s' a') -traverseDirTreeNode fr fs fa = - flattenDirTreeNode . mapDirTreeNode - (fmap Directory . fr) - (fmap Symlink . fs) - (fmap File . fa) - - --- | Gets the `FileType` of a `DirTreeNode` -fileTypeOfNode :: DirTreeNode a b c -> FileType -fileTypeOfNode = mapDirTreeNode (const ()) (const ()) (const ()) - --- ** IO Methods - --- | Check a filepath for Type, throws an IOException if path does not exist. -getFileType :: FilePath -> IO FileType -getFileType fp = - pathIsSymbolicLink fp >>= \case - True -> - return $ Symlink () - False -> - doesDirectoryExist fp >>= \case - True -> - return $ Directory () - False -> - return $ File () - --- | Reads the structure of the filepath -readPath :: - FilePath - -> IO (DirTreeNode [String] FilePath ()) -readPath fp = do - node <- getFileType fp - foldDirTreeNode - (const $ Directory <$> listDirectory fp) - (const $ Symlink <$> getSymbolicLinkTarget fp) - (const . return $ File ()) - node - --- | A map from file names to -newtype FileMap a = - FileMap (Map.Map String a) - deriving (Eq, Ord, NFData, Generic, Functor, Foldable, Traversable) - - -(-.>) :: String -> a -> (String, DirTree x a) -(-.>) s a = (s, file a) - -(-|>) :: String -> a -> (String, DirTree a x) -(-|>) s a = (s, symlink a) - -(-/>) :: String -> [(String, DirTree a b)] -> (String, DirTree a b) -(-/>) s a = (s, directoryFromFiles a) - --- | Create a list of pairs of filenames and file values. -toFileList :: FileMap a -> [(String, a)] -toFileList (FileMap a) = Map.toList a - --- | Create a `FileMap` from a list of pairs of filenames a file values. -fromFileList :: [(String, a)] -> FileMap a -fromFileList = FileMap . Map.fromList - --- | Create a `FileMap` from a list of pairs of filenames a file values. -fromFilenames :: [String] -> FileMap () -fromFilenames = fromFileList . map (,()) - --- | Single File -singleFile :: String -> a -> FileMap a -singleFile s a = FileMap (Map.singleton s a) - --- | empty filemap -emptyFileMap :: FileMap a -emptyFileMap = FileMap Map.empty - --- | To a list of filenames -toFileNames :: FileMap a -> [String] -toFileNames = map fst . toFileList - --- | Lookup a file using a filename -lookupFileMap :: String -> FileMap a -> Maybe a -lookupFileMap s (FileMap a) = Map.lookup s a - --- | Returns a list of `FileMap` -toDeepFileList :: FileMap (DirTree s a) -> [(FileKey, Either s a)] -toDeepFileList fm = - toFiles $ directory fm - --- | Returns an empty `FileMap`, if the input list is empty or contains files --- that does not correspond to a `FileMap`. -fromDeepFileList :: [(FileKey, Either s a)] -> FileMap (DirTree s a) -fromDeepFileList lst = - maybe emptyFileMap - ((\case - Directory fm -> fm - _ -> emptyFileMap - ) . dirTreeNode) - $ fromFiles lst - -instance (Show a, Show b) => Show (FileMap (DirTree a b)) where - showsPrec d m = showParen (d > 9) $ showString "fromFileList " . showFileList m - where - showFileList = - showListWith (\(s, x) -> f s $ dirTreeNode x) . toFileList - - f s (Directory x) = - showsPrec (dir_prec+1) s . - showString " -/> " . - showFileList x - - f s (Symlink x) = - showsPrec (dir_prec+1) s . - showString " -|> " . - showsPrec (dir_prec+1) x - - f s (File x) = - showsPrec (dir_prec+1) s . - showString " -.> " . - showsPrec (dir_prec+1) x - dir_prec = 5 - - -instance Semigroup a => Semigroup (FileMap a) where - FileMap as <> FileMap bs = - FileMap (Map.unionWith (<>) as bs) - -instance Semigroup a => Monoid (FileMap a) where - mempty = emptyFileMap - -instance FunctorWithIndex String FileMap -instance FoldableWithIndex String FileMap -instance TraversableWithIndex String FileMap where - itraverse f (FileMap fs) = FileMap <$> itraverse f fs - {-# INLINE itraverse #-} - -data Anchored a = (:/) - { base :: FilePath - , dirTree :: a - } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic) - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-| +Module : System.DirTree +Copyright : (c) Christian Gram Kalhauge, 2019 +License : MIT +Maintainer : kalhauge@cs.ucla.edu + +A directory tree, with helper functions to do different cool stuff. Contrary to +`directory-tree`, this package does try to add as many accessors and handlers as +possible. This is alos the reason that it depends on the Lens library. + +-} +module System.DirTree + ( + -- * 'DirTreeNode' + -- $DirTreeNode + + DirTreeNode (..) + , RelativeFile (..) + + -- ** Helpers + , FileType + , fileTypeOfNode + + , AsDirTreeNode (..) + , AsRelativeFile (..) + + -- ** IO + , getFileType + , readPath + + -- * 'FileMap' + -- $FileMap + + , FileMap (..) + + -- ** Constructors + , emptyFileMap + , singletonFileMap + , toFileList + , fromFileList + , (.*), (./), (.*>), (.*.) + + -- ** Accessors + , lookupFileMap + + -- * 'DirTree' + -- $DirTree + , DirTree (..) + , RelativeDirTree + , asRelativeDirTree + + -- ** Constructors + , file + , realfile + , symlink + , directory + + , directory' + + , emptyDirectory + + , createDeepFile + , createDeepTree + + -- ** Accessors + , FileKey + + , fileKeyFromPath + , fileKeyToPath + + , diffFileKey + , diffPath + + , alterFile + + -- ** Iterators + -- Most of the iterators can be done with the 'FunctorWithIndex', + -- 'FoldableWithIndex', and 'TraversableWithIndex', but some accumilations + -- are easier. + , iflattenDirTree + , flattenDirTree + + , depthfirst + , findNode + , listNodes + + -- ** IO + + , readDirTree + , writeDirTree + , Link (..) + , toLink + , readRelativeDirTree + , followLinks + , writeRelativeDirTree + + -- * 'DirForest' + -- $DirForest + + , DirForest (..) + , RelativeDirForest + + , ForestFileKey + , fromForestFileKey + , toForestFileKey + + -- ** Constructors + , asRelativeDirForest + , emptyForest + , singletonForest + , createDeepForest + + -- ** Iterators + , alterForest + + ) where + +-- containers +import qualified Data.Map as Map + +-- deepseq +import Control.DeepSeq + +-- directory +import System.Directory hiding (findFile) + +-- filepath +import System.FilePath + +-- lens +import Control.Lens.Combinators +import Control.Lens +-- import Control.Lens.Indexed + +-- base +import Data.Functor +import Data.Foldable +import Data.Bifunctor +import Data.Maybe +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Semigroup (sconcat) +import Data.Monoid +import Data.Bitraversable +import Data.Bifoldable +import Control.Monad +import Text.Show +import GHC.Generics + +-- $DirTreeNode +-- The basic item of this library is a DirTreeNode. + +-- | A directory tree node. Everything is either a file, or a +-- directory. +data DirTreeNode r a + = Directory r + | File a + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic) + +instance Bifunctor DirTreeNode where + bimap fr fa = \case + Directory r -> Directory (fr r) + File a -> File (fa a) + +instance Bifoldable DirTreeNode where + bifoldMap fr fa = \case + Directory r -> fr r + File a -> fa a + +instance Bitraversable DirTreeNode where + bitraverse fr fa = \case + Directory r -> Directory <$> fr r + File a -> File <$> fa a + +makeClassyPrisms ''DirTreeNode + +-- | A DirTree can contain relativeFile files. This means that some files might be +-- symlinks. +data RelativeFile s a + = Symlink s + | Real a + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic) + +instance Bifunctor RelativeFile where + bimap fr fa = \case + Symlink r -> Symlink (fr r) + Real a -> Real (fa a) + +instance Bifoldable RelativeFile where + bifoldMap fr fa = \case + Symlink r -> fr r + Real a -> fa a + +instance Bitraversable RelativeFile where + bitraverse fr fa = \case + Symlink r -> Symlink <$> fr r + Real a -> Real <$> fa a + +makeClassyPrisms ''RelativeFile + +-- | It is quite offten that a node will be used as a relative file. +instance AsRelativeFile (DirTreeNode a (RelativeFile b c)) b c where + _RelativeFile = _File + +-- | A `FileType` is just a `DirTreeNode` with no contents. +type FileType = DirTreeNode () (RelativeFile () ()) + +-- | Gets the `FileType` of a `DirTreeNode` +fileTypeOfNode :: DirTreeNode a (RelativeFile b c) -> FileType +fileTypeOfNode = bimap (const ()) (bimap (const ()) (const ())) + +-- | Check a filepath for Type, throws an IOException if path does not exist. +getFileType :: FilePath -> IO FileType +getFileType fp = + pathIsSymbolicLink fp >>= \case + True -> + return $ File (Symlink ()) + False -> + doesDirectoryExist fp >>= \case + True -> + return $ Directory () + False -> + return $ File (Real ()) + +-- | Reads the structure of the filepath +readPath :: + FilePath + -> IO (DirTreeNode [String] (RelativeFile FilePath ())) +readPath fp = bitraverse + (const $ listDirectory fp) + (bitraverse + (const $ getSymbolicLinkTarget fp) + return + ) =<< getFileType fp + + +-- $FileMap +-- The 'FileMap' is used to represent the content of a directory. + +-- | A map from file names to +newtype FileMap a = + FileMap { fileMapAsMap :: Map.Map String a } + deriving (Eq, Ord, NFData, Generic, Functor, Foldable, Traversable) + +-- | Single File +singletonFileMap :: String -> a -> FileMap a +singletonFileMap s a = FileMap (Map.singleton s a) + +-- | empty filemap +emptyFileMap :: FileMap a +emptyFileMap = FileMap Map.empty + +-- | The 'FileMap' is a semigroup if the contnent is. It tries +-- to union the content under each item. +instance Semigroup a => Semigroup (FileMap a) where + FileMap as <> FileMap bs = + FileMap (Map.unionWith (<>) as bs) + +-- | The empty monoid is the emptyFileMap +instance Semigroup a => Monoid (FileMap a) where + mempty = emptyFileMap + +instance FunctorWithIndex String FileMap +instance FoldableWithIndex String FileMap +instance TraversableWithIndex String FileMap where + itraverse f (FileMap fs) = FileMap <$> itraverse f fs + {-# INLINE itraverse #-} + +instance Show a => Show (DirForest a) where + showsPrec d m = showParen (d > 9) $ showString "DirForest . fromFileList " . showFileList m + where + showFileList = + showListWith (\(s, x) -> f s $ dirTreeNode x) . toFileList . getInternalFileMap + + f s (Directory x) = + showsPrec (dir_prec+1) s . + showString " ./ " . + showFileList x + + f s (File x) = + showsPrec (dir_prec+1) s . + showString " .* " . + showsPrec (dir_prec+1) x + dir_prec = 5 + + +-- | Create a list of pairs of filenames and file values. +toFileList :: FileMap a -> [(String, a)] +toFileList (FileMap a) = Map.toList a + +-- | Create a `FileMap` from a list of pairs of filenames a file values. +fromFileList :: [(String, a)] -> FileMap a +fromFileList = FileMap . Map.fromList + +-- | Find a list of names used in the FileMap +toFileNames :: FileMap a -> [String] +toFileNames = map fst . toFileList + +-- | Lookup a file using a filename +lookupFileMap :: String -> FileMap a -> Maybe a +lookupFileMap s (FileMap a) = Map.lookup s a + +-- | The 'Map.alterF' version to the FileMap. +alterFileMap :: + Functor f + => (Maybe a -> f (Maybe a)) + -> String + -> FileMap a + -> f (FileMap a) +alterFileMap fn key (FileMap fm) = + FileMap <$> Map.alterF fn key fm + +type instance Index (FileMap a) = String +type instance IxValue (FileMap a) = a + +instance Ixed (FileMap a) where + ix k f m = FileMap <$> ix k f (fileMapAsMap m) + {-# INLINE ix #-} + +instance At (FileMap a) where + at = flip alterFileMap + {-# INLINE at #-} + +-- $DirTree +-- A 'DirTree' is a recursive difined tree. +-- + +-- | A 'FileKey' is a list of filenames to get to the final file +type FileKey = [String] + +-- | A 'DirTreeN' represents a single level in the DirTree. +type DirTreeN a = DirTreeNode (DirForest a) a + +-- | A specialized traversal of the DirTreeNode +itraverseDirTreeN :: + Applicative f + => (FileKey -> a -> f b) + -> DirTreeN a + -> f (DirTreeN b) +itraverseDirTreeN fia = \case + Directory m -> + Directory <$> itraverse (fia . fromForestFileKey) m + File a -> + File <$> fia [] a + + +-- | A dir tree is a tree of nodes. +newtype DirTree a = DirTree + { dirTreeNode :: DirTreeNode (DirForest a) a + } + deriving (Eq, Ord, NFData, Generic) + + +instance Functor DirTree where + fmap f (DirTree a) = DirTree $ bimap (fmap f) f a + +instance Foldable DirTree where + foldMap f (DirTree e) = bifoldMap (foldMap f) f e + +instance Traversable DirTree where + traverse f (DirTree e) = DirTree <$> bitraverse (traverse f) f e + +instance FunctorWithIndex FileKey DirTree +instance FoldableWithIndex FileKey DirTree +instance TraversableWithIndex FileKey DirTree where + itraverse f (DirTree fs) = DirTree <$> itraverseDirTreeN f fs + {-# INLINE itraverse #-} + +-- | A relative dir tree also exists. +type RelativeDirTree s a = DirTree (RelativeFile s a) + +-- | All 'DirTree's are also relative. +asRelativeDirTree :: DirTree a -> RelativeDirTree s a +asRelativeDirTree = fmap Real + + +instance (Show a) => Show (DirTree a) where + showsPrec d c = showParen (d >9) (f $ dirTreeNode c) + where + f = \case + Directory a -> + showString "directory " . showsPrec 11 a + File a -> + showString "file " . showsPrec 11 a + +-- | A DirTree is a semigroup, where it merges directories and take the last +-- entry if there files. +-- +-- >>> file 'a' <> file 'b' +-- file 'b' +-- +-- >>> directory' [ "a" .* 'a', "b" .* 'b'] <> directory' [ "b" .* 'd', "c" .* 'c'] +-- directory (fromFileList ["a" .* 'a',"b" .* 'd',"c" .* 'c']) +instance Semigroup (DirTree a) where + DirTree (Directory as) <> DirTree (Directory bs) = + DirTree (Directory (as <> bs)) + _ <> a = a + +-- | Constructs a dirtree with only a file +file :: a -> DirTree a +file = DirTree . File +{-# INLINE file #-} + +-- | Constructs a relative dirtree with only a real file +realfile :: a -> RelativeDirTree s a +realfile = file . Real +{-# INLINE realfile #-} + +-- | Constructs a dirtree with a symlink +symlink :: s -> RelativeDirTree s a +symlink = file . Symlink +{-# INLINE symlink #-} + +-- | Constructs a dirtree with a directory +directory :: DirForest a -> DirTree a +directory = DirTree . Directory +{-# INLINE directory #-} + +-- | Constructs a dirtree with a file list +directory' :: [(String, DirTree a)] -> DirTree a +directory' = DirTree . Directory . DirForest . fromFileList +{-# INLINE directory' #-} + +-- | Constructs a dirtree with a empty directory +emptyDirectory :: DirTree a +emptyDirectory = directory' [] +{-# INLINE emptyDirectory #-} + +-- | Create a file +(.*) :: String -> a -> (String, DirTree a) +(.*) s a = (s, file a) + +-- | Create a symbolic link +(.*>) :: String -> s -> (String, RelativeDirTree s a) +(.*>) s a = (s, symlink a) + +-- | Create a real file +(.*.) :: String -> a -> (String, RelativeDirTree s a) +(.*.) s a = (s, realfile a) + +-- | Create a directory +(./) :: String -> [(String, DirTree a)] -> (String, DirTree a) +(./) s a = (s, directory' a) + +-- | Get a `FileKey` from a `FilePath` +fileKeyFromPath :: FilePath -> FileKey +fileKeyFromPath = + splitDirectories + +-- | Get a `FilePath` from a `FileKey` +fileKeyToPath :: FileKey -> FilePath +fileKeyToPath = + joinPath + +-- | 'diffFileKey' produces a filepath which is needed to +-- navigate from one FileKey to a other. +-- +-- >>> diffFileKey ["hello", "world"] ["hello"] +-- ".." +-- +-- >>> diffFileKey ["hello"] ["hello", "world", "test"] +-- "world/test" +-- +-- >>> diffFileKey ["world", "test"] ["hello"] +-- "../../hello" +diffFileKey :: FileKey -> FileKey -> FilePath +diffFileKey f to' = + let (n, bs) = prefix f to' + in fileKeyToPath (replicate n ".." ++ bs) + where + prefix al@(a:as) bl@(b:bs) + | a == b = prefix as bs + | otherwise = + (length al, bl) + prefix (_:as) [] = + (1 + length as, []) + prefix [] bs = + (0, bs) + +-- | 'diffPath' produces a the filekey at the end of +-- a relative filepath, from one filekey. +-- +-- >>> diffPath ["hello", "world"] ".." +-- Just ["hello"] +-- +-- >>> diffPath ["hello"] "world/test" +-- Just ["hello","world","test"] +-- +-- >>> diffPath ["world", "test"] "../../hello" +-- Just ["hello"] +-- +-- >>> diffPath ["world", "test"] "/hello" +-- Nothing +-- +-- >>> diffPath ["world", "test"] "../../.." +-- Nothing +diffPath :: FileKey -> FilePath -> Maybe FileKey +diffPath f path + | isAbsolute path = Nothing + | otherwise = go (fileKeyFromPath path) (reverse f) + where + go = \case + "..":rest -> \case + _:as -> go rest as + [] -> Nothing + rest -> \m -> Just (reverse m ++ rest) + +-- | Alter File is the 'DirTree' version of 'Map.alterF'. +-- +-- >>> alterFile (\x -> [Nothing, x, Just (file 'b')]) [] (Just (file 'a')) +-- [Nothing,Just (file 'a'),Just (file 'b')] +alterFile :: + forall f a. Functor f + => (Maybe (DirTree a) -> f (Maybe (DirTree a))) + -> FileKey + -> Maybe (DirTree a) + -> f (Maybe (DirTree a)) +alterFile fn key = maybe (newFile key) (go key) where + go key' tree@(DirTree node) = + case key' of + [] -> fn (Just tree) + k : rest -> + case node of + Directory a -> Just . directory <$> alterForest fn (k :| rest) a + File _ -> newFile rest + + newFile :: FileKey -> f (Maybe (DirTree a)) + newFile key' = fmap (createDeepTree key') <$> fn Nothing +{-# INLINE alterFile #-} + +-- | Create a recursive `DirTree` from a FileKey and a value. +createDeepFile :: FileKey -> a -> DirTree a +createDeepFile key a = + createDeepTree key (file a) +{-# INLINE createDeepFile #-} + +-- | Create a recursive `DirTree` from a FileKey and a value. +createDeepTree :: FileKey -> DirTree a -> DirTree a +createDeepTree key a = + foldr (\s f -> directory (singletonForest s f)) a key +{-# INLINE createDeepTree #-} + +type instance Index (DirTree a) = FileKey +type instance IxValue (DirTree a) = DirTree a + +instance Ixed (DirTree a) where + ix key fn = go key where + go key' tree@(DirTree node) = + case nonEmpty key' of + Nothing -> fn tree + Just fk -> + case node of + Directory a -> directory <$> ix fk fn a + File _ -> pure tree + {-# INLINE ix #-} + +-- | Not a completly correct Lens, since it is implossible to +-- delete the current DirTree. To use a correct Lens, see +-- 'alterFile'. +-- +-- >>> emptyDirectory & at ["file", "path"] ?~ file 'x' +-- directory (fromFileList ["file" ./ ["path" .* 'x']]) +instance At (DirTree a) where + at k f m = fromMaybe m <$> alterFile f k (Just m) + {-# INLINE at #-} + +-- | This method enables eta reduction of a DirTree a with an index. +iflattenDirTree :: + (FileKey -> DirTreeNode (FileMap m) a -> m) + -> DirTree a + -> m +iflattenDirTree f = go id where + go fk = + f (fk []) . first (imap (\k -> go (fk . (k:))) . getInternalFileMap) . dirTreeNode +{-# inline iflattenDirTree #-} + +-- | This method enables eta reduction of a DirTree a. +flattenDirTree :: + (DirTreeNode (FileMap m) a -> m) + -> DirTree a + -> m +flattenDirTree f = go where + go = f . first (fmap go . getInternalFileMap) . dirTreeNode +{-# inline flattenDirTree #-} + +-- | Uses a semigroup to join together the results, This is slightly +-- less powerfull than 'iflattenDirTree', but more convinient for +-- summations. +depthfirst :: + (Semigroup m) + => (FileKey -> DirTreeNode [String] a -> m) + -> DirTree a + -> m +depthfirst f = iflattenDirTree $ \k -> \case + Directory fm -> sconcat $ + f k (Directory . toFileNames $ fm) :| Data.Foldable.toList fm + File a -> f k (File a) +{-# inline depthfirst #-} + +-- | Find a file given a predicate that takes a `FileKey` and `DirTreeNode`. +findNode :: + (FileKey -> DirTreeNode [String] a -> Bool) + -> DirTree a + -> Maybe (FileKey, DirTreeNode [String] a) +findNode f = + getFirst . depthfirst (\k a -> First $ guard (f k a) $> (k, a)) +{-# inline findNode #-} + +-- List all the nodes in the dirtree +listNodes :: DirTree a -> [(FileKey, DirTreeNode [String] a)] +listNodes = + (`appEndo` []) . depthfirst (\k a -> Endo ((k, a):)) +{-# inline listNodes #-} + + +-- ** IO Methods + +-- | A `Link` can either be `Internal`, pointing to something in the `DirTree` or +-- `External` pointing to an absolute `FilePath`. +data Link + = Internal !FileKey + | External !FilePath + deriving (Show, Eq, Generic, NFData) + +-- | Figure out a link from the FileKey and FilePath of Link +toLink :: FileKey -> FilePath -> Link +toLink key f = + maybe (External f) Internal (diffPath (Prelude.init key) f) + + +-- | Reads a DirTree. All file paths are absolute to the filepath +readRelativeDirTree :: + (FilePath -> IO a) + -> FilePath + -> IO (RelativeDirTree Link a) +readRelativeDirTree reader' fp = do + from' <- canonicalizePath fp + go from' fp + where + go from' fp' = do + node <- readPath fp' + DirTree <$> bimapM + ( fmap (DirForest . fromFileList) . mapM (\k -> (k,) <$> go from' (fp' k)) ) + ( bimapM absolute (const $ reader' fp') ) + node + where + absolute a + | isAbsolute a = + return $ External a + | otherwise = do + a' <- canonicalizePath (takeDirectory fp' a) + let a'' = makeRelative from' a' + return $ if a'' /= a' + then Internal (fileKeyFromPath a'') + else External a' + +-- | Reads a DirTree and follow all the relative links. Might recurse forever. +readDirTree :: + (FilePath -> IO a) + -> FilePath + -> IO (DirTree a) +readDirTree fn fp = + readRelativeDirTree fn fp >>= followLinks fn + +-- | Follow the links to create the tree. This function might recurse forever. +followLinks :: forall a. (FilePath -> IO a) -> RelativeDirTree Link a -> IO (DirTree a) +followLinks fn tree = go tree where + go = flattenDirTree $ \case + File (Symlink a) -> case a of + Internal s -> + case tree ^? ix s of + Just a' -> + go a' + Nothing -> + error $ "Could not find " ++ show s + ++ " in the dirtree " ++ show (void tree) + External s -> + readDirTree fn s + + File (Real a) -> + return $ file a + + Directory a -> + directory . DirForest <$> sequence a + +-- | Writes a Relative DirTree to a file +writeRelativeDirTree :: + (FilePath -> a -> IO ()) + -> FilePath + -> RelativeDirTree Link a + -> IO () +writeRelativeDirTree writer fp = depthfirst go where + go key = \case + Directory _ -> + createDirectory fp' + File a -> + case a of + Symlink (External target) -> + createFileLink target fp' + Symlink (Internal key') -> + createFileLink + (case (key, key') of + (_:fk', _) -> diffFileKey fk' key' + ([], []) -> "." + ([], _) -> error "Fail" + ) fp' + Real a' -> + writer fp' a' + where fp' = fp fileKeyToPath key +{-# INLINE writeRelativeDirTree #-} + +-- | Writes a Relative DirTree to a file +writeDirTree :: + (FilePath -> a -> IO ()) + -> FilePath + -> DirTree a + -> IO () +writeDirTree writer fp = writeRelativeDirTree writer fp . asRelativeDirTree +{-# INLINE writeDirTree #-} + + +-- $DirForest +-- A 'DirForest' is the content of a directory. A 'DirForest' is more +-- useful in some cases + +newtype DirForest a = DirForest + { getInternalFileMap :: FileMap (DirTree a) + } deriving (Eq, Ord, NFData, Generic) + +instance Functor DirForest where + fmap f (DirForest a) = DirForest $ fmap (fmap f) a + +instance Foldable DirForest where + foldMap f (DirForest e) = foldMap (foldMap f) e + +instance Traversable DirForest where + traverse f (DirForest e) = DirForest <$> traverse (traverse f) e + +instance FunctorWithIndex ForestFileKey DirForest +instance FoldableWithIndex ForestFileKey DirForest +instance TraversableWithIndex ForestFileKey DirForest where + itraverse f (DirForest fs) = + DirForest <$> itraverse (\k -> itraverse (f . (k:|))) fs + {-# INLINE itraverse #-} + +instance Semigroup (DirForest a) where + (DirForest a) <> (DirForest b) = DirForest (a <> b) + +instance Monoid (DirForest a) where + mempty = DirForest mempty + +-- | All entries in a DirForest has to be non-empty +type ForestFileKey = NonEmpty String + +-- | Convert a 'ForestFileKey' to a 'FileKey' +fromForestFileKey :: ForestFileKey -> FileKey +fromForestFileKey = toList + +-- | Convert a 'FileKey' to a 'ForestFileKey' +toForestFileKey :: FileKey -> Maybe ForestFileKey +toForestFileKey = nonEmpty + +-- | Creates an empty forest +emptyForest :: DirForest a +emptyForest = mempty + +-- | Creates an singleton forest +singletonForest :: String -> DirTree a -> DirForest a +singletonForest k f = + DirForest $ singletonFileMap k f + +-- | Creates an deep file in a forest +createDeepForest :: ForestFileKey -> DirTree a -> DirForest a +createDeepForest (k :| rest) f = + singletonForest k (createDeepTree rest f) + +-- | A relative dir forest also exists. +type RelativeDirForest s a = DirForest (RelativeFile s a) + +-- | All 'DirTree's are also relative. +asRelativeDirForest :: DirForest a -> RelativeDirForest s a +asRelativeDirForest = fmap Real + +type instance Index (DirForest a) = ForestFileKey +type instance IxValue (DirForest a) = DirTree a + +instance Ixed (DirForest a) where + ix (k :| key) fn a = DirForest <$> ix k (ix key fn) (getInternalFileMap a) + -- -- ix key fn . getInternalFileMap + -- go key' tree@(DirTree node) = + -- case key' of + -- [] -> fn tree + -- k : rest -> + -- case node of + -- Directory a -> directory <$> ix k (ix rest fn) a + -- File _ -> pure tree + {-# INLINE ix #-} + +alterForest :: + forall f a. Functor f + => (Maybe (DirTree a) -> f (Maybe (DirTree a))) + -> ForestFileKey + -> DirForest a + -> f (DirForest a) +alterForest fn (k :| key) a = + DirForest <$> alterFileMap (alterFile fn key) k (getInternalFileMap a) + +-- >>> emptyDirForest & at ("file" :| ["path"]) ?~ file 'x' +-- fromFileList ["file" ./ ["path" .* 'x']] +instance At (DirForest a) where + at k f = alterForest f k + {-# INLINE at #-} + +makeWrapped ''DirTree +makeWrapped ''DirForest + +instance AsDirTreeNode (DirTree a) (DirForest a) a where + _DirTreeNode = _Wrapped + {-# INLINE _DirTreeNode #-} diff --git a/src/System/DirTree/Zip.hs b/src/System/DirTree/Zip.hs new file mode 100644 --- /dev/null +++ b/src/System/DirTree/Zip.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : System.DirTree.Zip +Copyright : (c) Christian Gram Kalhauge, 2019 +License : MIT +Maintainer : kalhauge@cs.ucla.edu + +Enables reading and writeing zipfiles using dirtrees. It is +not a complete 1-1 mapping but for many usecases it gets the +job done. + +It is based of the `zip-archive` library, which can be used +if more control is needed. +-} + +module System.DirTree.Zip + ( + entriesToDirForest + , entriesFromDirForest + + -- * Helpers + , entryToDirForest + , entryFromFile + + , files + , entries + -- * Re-Exports + , toArchive + , fromArchive + ) +where + +-- base +import Data.Foldable +import Data.Maybe +import Data.Bits +import System.Posix.Files (symbolicLinkMode, stdFileMode) + +-- lens +import Control.Lens + +-- zip-archive +import Codec.Archive.Zip + +-- dirtree +import System.DirTree + +-- bytestring +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC + + +-- | Convert a entry to a single filemap, fails if the entry path is empty. +entryToDirForest :: + Entry + -> Maybe (DirForest Entry) +entryToDirForest e = + flip createDeepForest (file e) + <$> toForestFileKey (fileKeyFromPath (eRelativePath e)) + +-- | Convert entries to a 'FileMap' of 'RelativeDirTree' +entriesToDirForest :: + [Entry] + -> Maybe (RelativeDirForest Link BL.ByteString) +entriesToDirForest = + fmap (imap parseEntry . fold) + . traverse entryToDirForest + where + parseEntry key e = + case symbolicLinkEntryTarget e of + Just f -> Symlink . toLink (fromForestFileKey key) $ f + Nothing -> Real $ fromEntry e + +-- | Create a single entry from a file. This also handles symlinks, but changes +-- saves all files with the 'stdFileMode'. +entryFromFile :: Integer -> FileKey -> RelativeFile Link BL.ByteString -> Entry +entryFromFile i key = \case + Real bs -> toEntry (fileKeyToPath key) i bs + Symlink x -> + toSymlinkEntry (fileKeyToPath key) $ case x of + Internal trgt -> diffFileKey (init key) trgt + External f -> f + where + toSymlinkEntry path t = + let e = toEntry path i (BLC.pack t) + in e { eExternalFileAttributes = + eExternalFileAttributes e .|. shiftL (fromIntegral ( symbolicLinkMode .|. stdFileMode)) 16 + , eVersionMadeBy = 798 -- Random high number + } + +-- | Create a list of enties from a FileMap. +entriesFromDirForest :: + Integer + -> RelativeDirForest Link BL.ByteString + -> [Entry] +entriesFromDirForest i = + toList . imap (\k -> entryFromFile i (fromForestFileKey k)) + +-- | A simple lens into the entries of an archive. +entries :: Lens' Archive [Entry] +entries = lens zEntries (\a b -> a { zEntries = b }) + +-- | A list of entries can be seen as a FileMap of +entriesAsDirForest :: Integer -> Iso' [Entry] (RelativeDirForest Link BL.ByteString) +entriesAsDirForest i = iso from' to' where + from' = fromJust . entriesToDirForest + to' = entriesFromDirForest i + +-- | A lens to get and set the files of an archive. Uses sparingly on +-- big archvies as it will convert forth and back. +files :: Lens' Archive (RelativeDirForest Link BL.ByteString) +files = entries . entriesAsDirForest 0 diff --git a/test/System/DirTree/ZipSpec.hs b/test/System/DirTree/ZipSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/DirTree/ZipSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +module System.DirTree.ZipSpec where + +import Test.Hspec hiding (shouldBe) +import Test.Hspec.Expectations.Pretty + +import qualified Data.ByteString.Lazy as BL + +import Control.Lens + +import Codec.Archive.Zip + +import System.Directory hiding (findFile) +import System.IO.Error + +import System.DirTree +import System.DirTree.Zip + +spec :: Spec +spec = do + describe "reading a zipfile" $ do + it "can read more.zip" $ do + zipfile <- toArchive <$> BL.readFile "test/more.zip" + (zipfile ^. entries . to entriesToDirForest) + `shouldBe` Just + ( DirForest . fromFileList $ + [ "data" ./ + [ "abslink" .*> External "/dev/null" + , "deeplink" .*> Internal ["data","folder","deepfile"] + , "file" .*. "" + , "folder" ./ + [ "deepfile" .*. "" + , "revlink" .*> Internal ["data","file"] + ] + , "folderlink" .*> Internal ["data","folder"] + , "symlink" .*> Internal ["data", "file"] + ] + ] + ) + + describe "writing a zipfile" $ do + before (do _ <- tryIOError $ removeDirectoryRecursive "test/zip-output/" + createDirectory "test/zip-output" + ) $ do + it "can write more.zip" $ do + zipfile <- toArchive <$> BL.readFile "test/more.zip" + let Just forest = zipfile ^. entries . to entriesToDirForest + + let bc = fromArchive $ zipfile & entries .~ entriesFromDirForest 0 forest + BL.writeFile "test/zip-output/more.zip" bc + toArchive bc ^. entries . to entriesToDirForest `shouldBe` Just forest diff --git a/test/System/DirTreeSpec.hs b/test/System/DirTreeSpec.hs --- a/test/System/DirTreeSpec.hs +++ b/test/System/DirTreeSpec.hs @@ -1,6 +1,6 @@ module System.DirTreeSpec where -import Test.Hspec (Spec, describe, it, before, describe) +import Test.Hspec (Spec, it, before, describe) import Test.Hspec.Expectations.Pretty import System.DirTree @@ -17,10 +17,10 @@ getFileType "test/data" `shouldReturn` Directory () it "should find a file" $ do - getFileType "test/data/file" `shouldReturn` File () + getFileType "test/data/file" `shouldReturn` File (Real ()) it "should find a symbolic link" $ do - getFileType "test/data/symlink" `shouldReturn` Symlink () + getFileType "test/data/symlink" `shouldReturn` File (Symlink ()) it "should throw an IOException if nothing is found" $ do getFileType "test/data/nothing" `shouldThrow` anyException @@ -32,84 +32,85 @@ it "should find a file" $ do readPath "test/data/file" `shouldReturn` - File () + File (Real ()) it "should find a symbolic link" $ do readPath "test/data/symlink" `shouldReturn` - Symlink "file" + File (Symlink "file") it "should find a symbolic to a folder" $ do readPath "test/data/folderlink" `shouldReturn` - Symlink "folder" + File (Symlink "folder") it "should throw an IOException if nothing exists" $ do readPath "test/data/nothing" `shouldThrow` anyException - describe "readDirTree" $ do + describe "readRelativeDirTree" $ do it "should read the data directory" $ do - readDirTree (\f -> return $ makeRelative "test/data" f) "test/data" `shouldReturn` - directoryFromFiles - [ ("abslink", symlink (External "/dev/null")) - , ("file", file "file") - , ("folderlink", symlink (Internal ["folder"])) - , ("folder", directoryFromFiles - [ ("revlink", symlink (Internal ["file"])) - , ("deepfile", file "folder/deepfile") - ]) - , ("deeplink", symlink (Internal ["deepfile", "folder"])) - , ("symlink", symlink (Internal ["file"])) + readRelativeDirTree (\f -> return $ makeRelative "test/data" f) "test/data" `shouldReturn` + directory' + [ "abslink" .*> External "/dev/null" + , "file" .*. "file" + , "folderlink" .*> Internal ["folder"] + , "folder" ./ + [ "revlink" .*> Internal ["file"] + , "deepfile" .*. "folder/deepfile" + ] + , "deeplink" .*> Internal ["folder", "deepfile"] + , "symlink" .*> Internal ["file"] ] it "should read the folder in the data directory" $ do x <- makeAbsolute "test/data/file" - readDirTree (\f -> return $ makeRelative "test/data/folder" f) "test/data/folder" `shouldReturn` - directoryFromFiles - [ ("revlink", symlink (External x)) - , ("deepfile", file "deepfile") + readRelativeDirTree (\f -> return $ makeRelative "test/data/folder" f) "test/data/folder" `shouldReturn` + directory' + [ "revlink" .*> External x + , "deepfile" .*. "deepfile" ] describe "followLinks" $ do it "should read and follow the links in the data directory" $ do let relname f = return $ makeRelative "test/data" f - (readDirTree relname "test/data" >>= followLinks relname) + (readRelativeDirTree relname "test/data" >>= followLinks relname) `shouldReturn` - directoryFromFiles - [ ("symlink", file "file") - , ("file", file "file") - , ("folderlink", directoryFromFiles - [ ("revlink", file "file") - , ("deepfile", file "folder/deepfile") - ]) - , ("folder", directoryFromFiles - [ ("revlink", file "file") - , ("deepfile", file "folder/deepfile") - ]) - , ("abslink", file "/dev/null") - , ("deeplink", file "folder/deepfile") + directory' + [ "symlink" .* "file" + , "file" .* "file" + , "folderlink" ./ + [ "revlink" .* "file" + , "deepfile" .* "folder/deepfile" + ] + , "folder" ./ + [ "revlink" .* "file" + , "deepfile" .* "folder/deepfile" + ] + , "abslink" .* "/dev/null" + , "deeplink" .* "folder/deepfile" ] describe "listNodes" $ do it "should read the data directory" $ do - x <- listNodes <$> readDirTree return "test/data" + x <- listNodes <$> readRelativeDirTree return "test/data" map fst x `shouldBe` [ [] , ["abslink"] , ["deeplink"] , ["file"] , ["folder"] - , ["deepfile", "folder"] - , ["revlink", "folder"] + , ["folder", "deepfile"] + , ["folder", "revlink"] , ["folderlink"] , ["symlink"] ] describe "findNode" $ do + let isFile f fp _ = (takeBaseName (fileKeyToPath fp)) == f it "can find deepfile" $ do - x <- findNode (\fp _ -> takeBaseName (fileKeyToPath fp) == "deepfile") <$> readDirTree return "test/data" - fmap fst x `shouldBe` Just ["deepfile", "folder"] + x <- findNode (isFile "deepfile") <$> readDirTree return "test/data" + fmap fst x `shouldBe` Just ["folder", "deepfile"] it "can't find notafile" $ do - x <- findNode (\fp _ -> takeBaseName (fileKeyToPath fp) == "notafile") <$> readDirTree return "test/data" + x <- findNode (isFile "notafile") <$> readDirTree return "test/data" fmap fst x `shouldBe` Nothing describe "writeDirTree" $ do @@ -123,61 +124,53 @@ readFile "test/output/newfile" `shouldReturn` "Hello, World!" it "can write a folder" $ do - let folder = directoryFromFiles - [ ("file1", file "Hello, World!" ) - , ("file2", file "Some other file" ) - , ("file3", symlink (Internal ["file2"])) + let folder = directory' + [ "file1" .*. "Hello, World!" + , "file2" .*. "Some other file" + , "folder1" ./ + [ "file4" .*. "More files" + ] + , "symfile1" .*> Internal ["file2"] + , "symfile2" .*> Internal ["folder1", "file4"] + , "symfile3" .*> External "/dev/null" ] - writeDirTree writeFile "test/output/folder" folder - readDirTree readFile "test/output/folder" `shouldReturn` folder + writeRelativeDirTree writeFile "test/output/folder" folder + readRelativeDirTree readFile "test/output/folder" `shouldReturn` folder it "can copy a folder" $ do - datatree1 <- readDirTree return "test/data" - writeDirTree (flip copyFile) "test/output/data" datatree1 - datatree2 <- readDirTree (return . ("test/data" ) . makeRelative "test/output/data") "test/output/data" + datatree1 <- readRelativeDirTree return "test/data" + writeRelativeDirTree (flip copyFile) "test/output/data" datatree1 + datatree2 <- readRelativeDirTree (return . ("test/data" ) . makeRelative "test/output/data") "test/output/data" datatree2 `shouldBe` datatree1 describe "semigroup" $ do it "can join trees together" $ do - directoryFromFiles ["a" -.> "x"] - <> directoryFromFiles [ "b" -|> "x" ] - <> directoryFromFiles [ "x" -/> [ "a" -.> "y"]] - <> directoryFromFiles [ "x" -/> [ "b" -.> "y"]] + directory' ["a" .* "x"] + <> directory' [ "b" .* "x" ] + <> directory' [ "x" ./ [ "a" .* "y"]] + <> directory' [ "x" ./ [ "b" .* "y"]] `shouldBe` - directoryFromFiles - [ "a" -.> "x" - , "b" -|> "x" - , "x" -/> - [ "a" -.> "y" - , "b" -.> "y" + directory' + [ "a" .* "x" + , "b" .* "x" + , "x" ./ + [ "a" .* "y" + , "b" .* "y" ] ] it "joins different types to latest file" $ do - directoryFromFiles ["a" -.> "x"] - <> directoryFromFiles [ "a" -|> "y" ] + directory' ["a" .* "x"] + <> directory' [ "a" .* "y" ] `shouldBe` - directoryFromFiles - [ "a" -|> "y" - ] + directory' [ "a" .* "y"] it "can join FileMaps together" $ do - fromFileList ["a" -.> "x"] - <> fromFileList [ "b" -|> "x" ] + (DirForest . fromFileList) ["a" .* "x"] + <> (DirForest . fromFileList) [ "b" .* "x" ] `shouldBe` - fromFileList - [ "a" -.> "x" - , "b" -|> "x" + (DirForest . fromFileList) + [ "a" .* "x" + , "b" .* "x" ] - - describe "fromFiles" $ do - it "can create a DirTree from an list of files" $ do - fromFiles [(["a"], Right "x"), (["b", "c"], Left "y") ] - `shouldBe` - (Just $ directoryFromFiles - [ "a" -.> "x" - , "b" -/> - [ "c" -|> "y" - ] - ])