diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## Path IO 1.0.0 + +* Changed signature of `getAppUserDataDir`, so it takes `String` as the + first argument. + +* Removed deprecated `forgivingAbsence'` function. + +* Made `findFile` lazier, it stops searching as soon as a file is found. + +* Added some tests. + ## Path IO 0.3.1 * Introduced synonym for `forgivingAbsence'` — diff --git a/Path/IO.hs b/Path/IO.hs --- a/Path/IO.hs +++ b/Path/IO.hs @@ -66,7 +66,6 @@ , isLocationOccupied , forgivingAbsence , ignoringAbsence - , forgivingAbsence' -- * Permissions , D.Permissions , D.emptyPermissions @@ -96,7 +95,6 @@ import Data.Either (lefts, rights) import Data.Foldable (foldl') import Data.List ((\\)) -import Data.Maybe (listToMaybe) import Data.Time (UTCTime) import Path import System.IO (Handle) @@ -318,8 +316,7 @@ => Path b Dir -- ^ Directory to list -> m ([Path Abs Dir], [Path Abs File]) -- ^ Sub-directories and files listDirRecur path = do - bpath <- makeAbsolute path - items <- listDir bpath + items <- listDir path foldl' mappend items `liftM` mapM listDirRecur (fst items) -- | Copy directory recursively. This is not smart about symbolic links, but @@ -493,9 +490,9 @@ -- found. getAppUserDataDir :: (MonadIO m, MonadThrow m) - => Path Rel Dir -- ^ A relative path that is appended to the path + => String -- ^ Name of application (used in path construction) -> m (Path Abs Dir) -getAppUserDataDir = (>>= parseAbsDir) . liftD D.getAppUserDataDirectory +getAppUserDataDir = (>>= parseAbsDir) . liftIO . D.getAppUserDataDirectory -- | Returns the current user's document directory. -- @@ -543,9 +540,7 @@ -- * 'UnsupportedOperation' -- The operating system has no notion of temporary directory. -- --- * 'isDoesNotExistError' --- The temporary directory for the current user does not exist, or --- cannot be found. +-- The function doesn't verify whether the path exists. getTempDir :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) getTempDir = liftIO D.getTemporaryDirectory >>= resolveDir' @@ -597,7 +592,11 @@ -- Similar to 'normalise', an empty path is equivalent to the current -- directory. -- - -- /Known bug(s)/: on Windows, the function does not resolve symbolic links. + -- /Known bug(s)/: on Windows, the function does not resolve symbolic + -- links. + -- + -- Please note that before version 1.2.3.0 of @directory@ package, this + -- function had unpredictable behavior on non-existent paths. canonicalizePath :: (MonadIO m, MonadThrow m) => path -> m (AbsPath path) @@ -637,9 +636,7 @@ makeRelativeToCurrentDir p = getCurrentDir >>= flip makeRelative p -- | Append stringly-typed path to an absolute path and then canonicalize --- it. This can throw the same exceptions as 'canonicalizePath'. In --- particular, 'System.IO.Error.doesNotExistErrorType' is thrown if --- resulting file does not exist and thus its path cannot be canonicalized. +-- it. resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -- ^ Base directory @@ -792,7 +789,13 @@ => [Path b Dir] -- ^ Set of directories to search in -> Path Rel File -- ^ Filename of interest -> m (Maybe (Path Abs File)) -- ^ Absolute path to file (if found) -findFile dirs file = listToMaybe `liftM` findFiles dirs file +findFile [] _ = return Nothing +findFile (d:ds) file = do + bfile <- ( file) `liftM` makeAbsolute d + exist <- doesFileExist bfile + if exist + then return (Just bfile) + else findFile ds file -- | Search through the given set of directories for the given file and -- return a list of paths where the given file exists. @@ -973,13 +976,6 @@ ignoringAbsence :: (MonadIO m, MonadCatch m) => m a -> m () ignoringAbsence = liftM (const ()) . forgivingAbsence - --- | A synonym for 'ignoringAbsence'. - -{-# DEPRECATED forgivingAbsence' "Use 'ignoringAbsence' instead." #-} - -forgivingAbsence' :: (MonadIO m, MonadCatch m) => m a -> m () -forgivingAbsence' = ignoringAbsence ---------------------------------------------------------------------------- -- Permissions diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,9 @@ [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) [![Hackage](https://img.shields.io/hackage/v/path-io.svg?style=flat)](https://hackage.haskell.org/package/path-io) [![Stackage Nightly](http://stackage.org/package/path-io/badge/nightly)](http://stackage.org/nightly/package/path-io) +[![Stackage LTS](http://stackage.org/package/path-io/badge/lts)](http://stackage.org/lts/package/path-io) [![Build Status](https://travis-ci.org/mrkkrp/path-io.svg?branch=master)](https://travis-ci.org/mrkkrp/path-io) +[![Coverage Status](https://coveralls.io/repos/mrkkrp/path-io/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/path-io?branch=master) This package provides interface to [`directory`](https://hackage.haskell.org/package/directory) package for diff --git a/path-io.cabal b/path-io.cabal --- a/path-io.cabal +++ b/path-io.cabal @@ -31,7 +31,7 @@ -- POSSIBILITY OF SUCH DAMAGE. name: path-io -version: 0.3.1 +version: 1.0.0 cabal-version: >= 1.10 license: BSD3 license-file: LICENSE.md @@ -65,6 +65,21 @@ ghc-options: -Wall -Werror else ghc-options: -O2 -Wall + default-language: Haskell2010 + +test-suite tests + main-is: Main.hs + hs-source-dirs: tests + type: exitcode-stdio-1.0 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + build-depends: base >= 4.7 && < 5 + , exceptions >= 0.8 + , hspec >= 2.0 + , path >= 0.5 + , path-io >= 1.0.0 default-language: Haskell2010 source-repository head diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,186 @@ +-- +-- Tests for ‘path-io’ package. +-- +-- Copyright © 2016 Mark Karpov +-- +-- 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 Mark Karpov nor the names of 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 “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 HOLDERS 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. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +import Control.Monad +import Control.Monad.Catch +import Data.List (sort) +import Path +import Path.IO +import Test.Hspec +import System.Environment + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +main :: IO () +main = hspec . around withSandbox $ do + beforeWith populatedDir $ do + describe "listDir" listDirSpec + describe "listDirRecur" listDirRecurSpec + describe "copyDirRecur" copyDirRecurSpec + describe "findFile" findFileSpec + describe "getCurrentDir" getCurrentDirSpec + describe "setCurrentDir" setCurrentDirSpec + describe "withCurrentDir" withCurrentDirSpec + describe "getHomeDir" getHomeDirSpec + describe "getTempDir" getTempDirSpec + +listDirSpec :: SpecWith (Path Abs Dir) +listDirSpec = it "lists directory" $ \dir -> + getDirStructure listDir dir `shouldReturn` populatedDirTop + +listDirRecurSpec :: SpecWith (Path Abs Dir) +listDirRecurSpec = it "lists directory recursively" $ \dir -> + getDirStructure listDirRecur dir `shouldReturn` populatedDirStructure + +copyDirRecurSpec :: SpecWith (Path Abs Dir) +copyDirRecurSpec = it "copies directory" $ \src -> do + let dest = parent src $(mkRelDir "copied-dir") + copyDirRecur src dest + old <- getDirStructure listDirRecur src + new <- getDirStructure listDirRecur dest + old `shouldBe` new + +findFileSpec :: SpecWith (Path Abs Dir) +findFileSpec = it "finds a file lazily" $ \dir -> do + let relFile = head (snd populatedDirTop) + found <- findFile (dir : undefined) relFile + found `shouldBe` Just (dir relFile) + +getCurrentDirSpec :: SpecWith (Path Abs Dir) +getCurrentDirSpec = it "returns current dir" $ \dir -> + getCurrentDir `shouldNotReturn` dir + +setCurrentDirSpec :: SpecWith (Path Abs Dir) +setCurrentDirSpec = it "sets current dir" $ \dir -> do + wdir <- getCurrentDir + setCurrentDir dir + new <- getCurrentDir + setCurrentDir wdir + new `shouldBe` dir + +withCurrentDirSpec :: SpecWith (Path Abs Dir) +withCurrentDirSpec = it "temporarily modifies current dir" $ \dir -> do + withCurrentDir dir $ + getCurrentDir `shouldReturn` dir + getCurrentDir `shouldNotReturn` dir + +getHomeDirSpec :: SpecWith (Path Abs Dir) +getHomeDirSpec = + it "home dir is influenced by environment variable HOME" $ \dir -> + bracket (getEnv evar) (setEnv evar) $ \_ -> do + setEnv evar (toFilePath dir) + getHomeDir `shouldReturn` dir + where evar = "HOME" + +getTempDirSpec :: SpecWith (Path Abs Dir) +getTempDirSpec = + it "temp dir is influenced by environment variable TMPDIR" $ \dir -> + flip finally (unsetEnv evar) $ do + setEnv evar (toFilePath dir) + getTempDir `shouldReturn` dir + unsetEnv evar + where evar = "TMPDIR" + +---------------------------------------------------------------------------- +-- Helpers + +-- | Create sandbox directory to model some situation in it and run some +-- tests. Note that we're using new unique sandbox directory for each test +-- case to avoid contamination and it's unconditionally deleted after test +-- case finishes. + +withSandbox :: ActionWith (Path Abs Dir) -> IO () +withSandbox = withSystemTempDir "path-io-sandbox" + +-- | Create directory and some sub-directories and files in it. Return path +-- to that directory. +-- +-- Created objects are described in 'populatedDirStructure'. + +populatedDir :: Path Abs Dir -> IO (Path Abs Dir) +populatedDir root = do + let (dirs, files) = populatedDirStructure + pdir = root $(mkRelDir "pdir") + withinSandbox = (pdir ) + ensureDir pdir + forM_ dirs (ensureDir . withinSandbox) + forM_ files $ (`writeFile` "") . toFilePath . withinSandbox + return pdir + +-- | Get inner structure of a directory. Items are sorted, so it's easier to +-- compare results. + +getDirStructure + :: (Path Abs Dir -> IO ([Path Abs Dir], [Path Abs File])) + -- ^ Which function to use for scanning + -> Path Abs Dir + -- ^ Path to directory to scan + -> IO ([Path Rel Dir], [Path Rel File]) +getDirStructure f path = do + (dirs, files) <- f path + rdirs <- sort <$> mapM (makeRelative path) dirs + rfiles <- sort <$> mapM (makeRelative path) files + return (rdirs, rfiles) + +-- | Structure of directory created by the 'populatedDir' function. Please +-- keep it sorted. + +populatedDirStructure :: ([Path Rel Dir], [Path Rel File]) +populatedDirStructure = + ( [ $(mkRelDir "a") + , $(mkRelDir "b") + , $(mkRelDir "b/c") + ] + , [ $(mkRelFile "b/c/three.txt") + , $(mkRelFile "b/two.txt") + , $(mkRelFile "one.txt") + ] + ) + +-- | Top-level structure of populated directory as it should be scanned by +-- the 'listDir' function. + +populatedDirTop :: ([Path Rel Dir], [Path Rel File]) +populatedDirTop = + ( [ $(mkRelDir "a") + , $(mkRelDir "b") + ] + , [ $(mkRelFile "one.txt") + ] + )