diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for lens-fs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2019 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +# lens-filesystem + +[HACKAGE](https://hackage.haskell.org/package/lens-filesystem) + +A lensy style interface to your filesystem. + +This is pretty experimental; I wouldn't recommend using it in production code at the moment; +Using the read-only operations should be fine, but I'd strongly recommend doing lots of testing +with `print` before you run destructive filesystem operations. + +This library is meant to be used in conjunction with the `lens-action` library. + +The interface to this package could change at any time. + +Examples: + +```haskell +Many of the combinators you see here come from `lens-action`. + +-- Find all files in ~ or ~/config with a .vim or .conf extension +>>> "/Users/chris" ^!! including (path "config") . ls . traversed . exts ["vim", "conf"] +["/Users/chris/.vim","/Users/chris/tmux.conf","/Users/chris/config/plugins.vim"] + +-- Check whether a filename is a dotfile +>>> let isDotfile = has (filename . _head . only '.') +-- Crawl a filetree according to a given fold, +-- e.g. crawl all dirs that aren't dotfiles (a.k.a. .git, .stack-work) +>>> "." ^!! crawling (ls'ed . dirs . filtered (not . isDotfile)) +[ "." , "./app" , "./test" , "./src" , "./src/Control" +, "./src/Control/Lens", "./src/Control/Lens/FileSystem"] + +-- Crawl ALL files in "src" collecting "*.hs" files, then make file paths absolute +>>> "src" ^!! crawled . exts ["hs"] . absolute +[ "/Users/chris/dev/lens-fs/src/Control/Lens/FileSystem/Combinators.hs" +, "/Users/chris/dev/lens-fs/src/Control/Lens/FileSystem.hs" ] + +-- Find all executables in the 'scripts' directory and copy them to bin +>>> "scripts" ^! crawled . withPerms [executable] . act (`copyFile` "/Users/chris/bin") + +-- Read all markdown files and get their contents with filename +>>> "./test" ^!! crawled . exts ["md"] . contents . withIndex +[("./test/data/flat/file.md","markdown\n")] +``` + +See more examples in the [tests](./test/Spec.hs) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lens-filesystem.cabal b/lens-filesystem.cabal new file mode 100644 --- /dev/null +++ b/lens-filesystem.cabal @@ -0,0 +1,61 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9ca81ad924a9ad21b7413d6c5eabf70ce7b386acbbb1e630c907cd5e58d9531e + +name: lens-filesystem +version: 0.0.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/ChrisPenner/lens-filesystem#readme +bug-reports: https://github.com/ChrisPenner/lens-filesystem/issues +author: Chris Penner +maintainer: example@example.com +copyright: 2019 Chris Penner +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/ChrisPenner/lens-filesystem + +library + exposed-modules: + Control.Lens.FileSystem + Control.Lens.FileSystem.Internal.Combinators + other-modules: + Paths_lens_filesystem + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , directory + , filepath + , lens + , lens-action + default-language: Haskell2010 + +test-suite lens-filesystem-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_lens_filesystem + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , directory + , filepath + , hspec + , lens + , lens-action + , lens-filesystem + default-language: Haskell2010 diff --git a/src/Control/Lens/FileSystem.hs b/src/Control/Lens/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/FileSystem.hs @@ -0,0 +1,197 @@ +{-| +Module : Control.Lens.FileSystem +Description : Lensy File system combinators +Copyright : (c) Chris Penner, 2019 +License : BSD3 + +Note that this package is experimental, test things carefully before performing destructive +operations. I'm not responsible if things go wrong. + +This package is meant to be used alongside combinators from 'lens-action'; for example +'^!', '^!!' and 'act'. +-} + + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +module Control.Lens.FileSystem + ( + -- * File System Helpers + ls + , ls'ed + , path + , pathL + , branching + , dirs + , files + , contents + , exts + , crawled + , crawling + , absolute + , withPerms + , symLinksFollowed + + -- * Combinators + , filteredM + , merging + , including + + -- ** Exception Handling + , recovering + , tryOrContinue + , tryCatch + + -- * Re-exports + , () + + , readable + , writable + , executable + , module System.FilePath.Lens + ) where + +import Control.Lens +import Control.Lens.Action +import Control.Lens.FileSystem.Internal.Combinators +import System.Directory +import System.FilePath.Posix +import System.FilePath.Lens + +-- | List the files at a given directory +-- If the focused path isn't a directory this fold will return 0 results +-- +-- >>> "./test/data" ^! ls +-- ["./test/data/flat","./test/data/symlinked","./test/data/.dotfile","./test/data/permissions","./test/data/nested"] +ls :: Monoid r => Acting IO r FilePath [FilePath] +ls = recovering $ act (\fp -> (fmap (fp )) <$> listDirectory fp) + +-- | Fold over all files in the given directory. +-- If the focused path isn't a directory this fold will return 0 results +-- This is an alias for @@ls . traversed@@ +-- +-- >>> "./test/data" ^!! ls'ed +-- ["./test/data/flat","./test/data/symlinked","./test/data/.dotfile","./test/data/permissions","./test/data/nested"] +ls'ed :: Monoid r => Acting IO r FilePath FilePath +ls'ed = ls . traversed + + +-- | Append a path the end of the current path. +-- This uses `` for cross platform compatibility so +-- you don't need leading/trailing slashes here +-- +-- >>> "./src" ^! path "Control" +-- "./src/Control" +path :: FilePath -> Getter FilePath FilePath +path filePath = to ( filePath) + +-- | Create a filepath from a list of path segments, then append it to the focused path. +-- +-- >>> "." ^! pathL ["a", "b", "c"] +-- "./a/b/c" +pathL :: [FilePath] -> Getter FilePath FilePath +pathL filePaths = to ( joinPath filePaths) + +-- | "Branch" a fold into many sub-paths. +-- E.g. if we want to crawl into BOTH of @src@ and @test@ directories we can do: +-- +-- >>> "." ^!! branching ["src", "test"] . ls +-- [["./src/Control"],["./test/Spec.hs","./test/data"]] +branching :: [FilePath] -> Fold FilePath FilePath +branching filePaths = folding (\fp -> (fp ) <$> filePaths) + +-- | Filter for only paths which point to a valid directory +-- +-- >>> "./test" ^!! ls'ed +-- ["./test/Spec.hs","./test/data"] +-- +-- >>> "./test" ^!! ls'ed . dirs +-- ["./test/data"] +dirs :: (Monoid r) => Acting IO r FilePath FilePath +dirs = filteredM doesDirectoryExist + +-- | Filter for only paths which point to a valid file +-- +-- >>> "./test" ^!! ls'ed +-- ["./test/Spec.hs","./test/data"] +-- +-- >>> "./test" ^!! ls'ed . files +-- ["./test/Spec.hs"] +files :: (Monoid r) => Acting IO r FilePath FilePath +files = filteredM doesFileExist + +-- | Get the contents of a file +-- This fold will return 0 results if the path does not exist, if it isn't a file, or if +-- reading the file causes any exceptions. +-- +-- This fold lifts the path of the current file into the index of the fold in case you need it +-- downstream. +-- +-- >>> "./test/data/flat/file.md" ^! contents +-- "markdown\n" +-- +-- >>> "./test/data/flat/file.md" ^! contents . withIndex +-- ("./test/data/flat/file.md","markdown\n") +contents :: (Indexable FilePath p, Effective IO r f, Monoid r) => Over' p f FilePath String +contents = recovering (iact go) + where + go fp = do + contents' <- readFile fp + return (fp, contents') + +-- | Filter the fold for only files which have ANY of the given file extensions. +-- E.g. to find all Haskell or Markdown files in the current directory: +-- +-- >>> "./test/" ^!! crawled . exts ["hs", "md"] +-- ["./test/Spec.hs","./test/data/flat/file.md","./test/data/symlinked/file.md"] +exts :: [String] -> Traversal' FilePath FilePath +exts extList = filtered check + where + check fp = drop 1 (takeExtension fp) `elem` extList + +-- | Crawl over every file AND directory in the given path. +-- +-- >>> "./test/data/nested/top" ^!! crawled +-- ["./test/data/nested/top","./test/data/nested/top/mid","./test/data/nested/top/mid/bottom","./test/data/nested/top/mid/bottom/floor.txt"] +crawled :: Monoid r => Acting IO r FilePath FilePath +crawled = including (dirs . ls . traversed . crawled) + +-- | Continually run the given fold until all branches hit dead ends, +-- yielding over all elements encountered the way. +-- +-- >>> "./test/data" ^!! crawling (ls'ed . filtered ((== "flat") . view filename)) +-- ["./test/data","./test/data/flat"] +crawling :: Monoid r => Acting IO r FilePath FilePath -> Acting IO r FilePath FilePath +crawling fld = including (recovering (fld . crawling fld)) + +-- | Make filepaths absolute in reference to the current working directory +-- +-- > >>> "./test/data" ^! absolute +-- > "/Users/chris/dev/lens-filesystem/test/data" +absolute :: MonadicFold IO FilePath FilePath +absolute = act makeAbsolute + +-- | Filter for only paths which have ALL of the given file-permissions +-- See 'readable', 'writable', 'executable' +-- +-- >>> "./test/data" ^!! crawled . withPerms [readable, executable] +-- ["./test/data/permissions/exe"] +withPerms :: Monoid r => [Permissions -> Bool] -> Acting IO r FilePath FilePath +withPerms permChecks = filteredM checkAll + where + checkAll fp = do + perms <- getPermissions fp + return $ all ($ perms) permChecks + +-- | If the path is a symlink, rewrite the path to its destination and keep folding +-- If it's not a symlink; pass the path onwards as is. +-- +-- >>> "./test/data/symlinked" ^! symLinksFollowed +-- "flat" +symLinksFollowed :: Monoid r => Acting IO r FilePath FilePath +symLinksFollowed = tryOrContinue (act getSymbolicLinkTarget) diff --git a/src/Control/Lens/FileSystem/Internal/Combinators.hs b/src/Control/Lens/FileSystem/Internal/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Control/Lens/FileSystem/Internal/Combinators.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +module Control.Lens.FileSystem.Internal.Combinators where + +import Control.Lens +import Control.Lens.Action +import Control.Lens.Action.Internal +import Control.Applicative + +-- | If a given fold fails (e.g. with an exception), recover and simply return 0 elements +-- rather than crashing. +recovering :: (Monad m, Alternative m, Monoid r, Effective m r f) => Over' p f s a -> Over' p f s a +recovering fld f s = effective (ineffective (fld f s) <|> pure mempty) + +-- | Try the given fold, if it throws an exception then return the input as the output instead +tryOrContinue :: (Monad m, Alternative m) => Acting m r a a -> Acting m r a a +tryOrContinue = flip tryCatch pure + +-- | Try the given fold, if it throws an exception then use the given handler to compute a +-- replacement value and continue with that. +tryCatch :: (Monad m, Alternative m) => Acting m r s b -> (s -> m b) -> Acting m r s b +tryCatch fld handler f a = effective (ineffective (fld f a) <|> (handler a >>= ineffective . f)) + +-- | Filter a fold using a monadic action +filteredM :: (Monad m, Monoid r) => (a -> m Bool) -> Acting m r a a +filteredM predicate f a = effective go + where + go = do + predicate a >>= \case + True -> ineffective (f a) + False -> pure mempty + +-- | Merge two folds +merging :: (Applicative f, Contravariant f) => LensLike' f s a -> LensLike' f s a -> LensLike' f s a +merging fold1 fold2 nextFold s = fold1 nextFold s *> fold2 nextFold s + +-- | Include the results of an additional fold alongside the original values +including :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a +including = merging id diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE LambdaCase #-} +import Control.Lens +import Control.Lens.Action +import Control.Lens.FileSystem +import System.Directory +import Test.Hspec + +baseDir :: FilePath +baseDir = "test" "data" + +main :: IO () +main = do + absRoot <- makeAbsolute baseDir + setCurrentDirectory baseDir + hspec $ do + describe "ls" $ do + it "should return files and dirs with full path" $ do + "flat" ^! ls `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"] + it "should allow traversing deeper" $ do + "flat" ^!! ls . traversed `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"] + describe "ls'ed" $ do + it "should behave like 'ls' but with traversal" $ do + "flat" ^!! ls'ed `shouldReturn` ["flat/file.txt","flat/file.md","flat/dir"] + describe "path" $ do + it "should add to path" $ do + "nested" ^! path "top" `shouldReturn` "nested/top" + it "should add deep paths to path" $ do + "nested" ^! path ("top" "mid" "bottom") `shouldReturn` "nested/top/mid/bottom" + describe "pathL" $ do + it "should add to path" $ do + "nested" ^! pathL ["top"] `shouldReturn` "nested/top" + it "should add deep pathL to path" $ do + "nested" ^! pathL ["top", "mid", "bottom"] `shouldReturn` "nested/top/mid/bottom" + describe "branching" $ do + it "should follow many paths" $ do + "nested" ^! branching ["top", "peak"] . ls `shouldReturn` + ["nested/top/mid","nested/peak/trees.txt","nested/peak/base"] + describe "dirs" $ do + it "should filter to only dirs" $ do + "flat" ^!! ls . traversed . dirs `shouldReturn` ["flat/dir"] + describe "files" $ do + it "should filter to only files" $ do + "flat" ^!! ls . traversed . files `shouldReturn` ["flat/file.txt", "flat/file.md"] + describe "contents" $ do + it "should get file contents" $ do + "flat" ^!! ls . traversed . files . contents `shouldReturn` ["text\n", "markdown\n"] + describe "exts" $ do + it "should filter by extension" $ do + "flat" ^!! ls . traversed . exts ["", "txt"] `shouldReturn` ["flat/file.txt", "flat/dir"] + describe "crawled" $ do + it "should find ALL files and dirs under root including root" $ do + "nested" ^!! crawled `shouldReturn` + [ "nested", "nested/top", "nested/top/mid", "nested/top/mid/bottom" + , "nested/top/mid/bottom/floor.txt", "nested/peak", "nested/peak/trees.txt" + , "nested/peak/base", "nested/peak/base/basecamp.txt"] + describe "absoluted" $ do + it "should make paths absolute" $ do + "flat" ^!! ls . traversed . absolute `shouldReturn` + [ absRoot "flat" "file.txt" + , absRoot "flat" "file.md" + , absRoot "flat" "dir" + ] + describe "withPerms" $ do + it "should filter based on permissions" $ do + "permissions" ^!! ls . traversed . withPerms [executable] `shouldReturn` + ["permissions/exe" ] + "permissions" ^!! ls . traversed . withPerms [readable] `shouldReturn` + ["permissions/readonly", "permissions/exe" ] + it "should 'and' permissions together" $ do + "permissions" ^!! ls . traversed . withPerms [executable, readable, writable] `shouldReturn` + ["permissions/exe" ] + describe "symLinksFollowed" $ do + it "should rewrite symlinks" $ do + "symLinked" ^!! symLinksFollowed `shouldReturn` ["flat"] + + describe "recovering" $ do + it "should recover from exceptions with an empty fold" $ do + [1 :: Int, 2, 3] ^!! traversed . recovering (act (\case 2 -> fail "nope"; n -> pure n)) + `shouldReturn` [1, 3] + + describe "tryOrContinue" $ do + it "should return input when fold fails" $ do + [1 :: Int, 2, 3] ^!! traversed . tryOrContinue (act (\case 2 -> fail "nope"; n -> pure (10*n))) + `shouldReturn` [10, 2, 30] + + describe "tryCatch" $ do + it "should recover from failure using handler" $ do + [1 :: Int, 2, 3] ^!! traversed . tryCatch (act (\case 2 -> fail "nope"; n -> pure (10*n))) (pure . (*100)) + `shouldReturn` [10, 200, 30] + + describe "filteredM" $ do + it "should filter out failing elements" $ do + [1 :: Int, 2, 3] ^!! traversed . filteredM (pure . odd) + `shouldReturn` [1, 3] + + describe "merging" $ do + it "should combine elements from multiple folds" $ do + [1 :: Int, 2, 3] ^!! traversed . merging (to (*10)) (to (*100)) + `shouldReturn` [10, 100, 20, 200, 30, 300] + + describe "including" $ do + it "should add new elements while keeping old ones" $ do + [1 :: Int, 2, 3] ^!! traversed . including (to (*10)) + `shouldReturn` [1, 10, 2, 20, 3, 30]