diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, John Lato + +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 John Lato 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/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/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Bench.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} +import Control.Applicative +import Control.Monad +import System.Directory +import System.FilePath (()) +import System.Posix.ByteString.FilePath +import System.Posix.Directory.ByteString as PosixBS +import System.Posix.Directory.Traversals +import qualified System.Posix.FilePath as PosixBS +import System.Posix.Files.ByteString + +import Control.Exception +import qualified Data.ByteString.Char8 as BS + +import System.Environment (getArgs, withArgs) +import System.IO.Error +import System.IO.Unsafe +import System.Process (system) +import Criterion.Main + + +listFilesRecursive :: FilePath -> IO [FilePath] +listFilesRecursive topdir = do + names <- System.Directory.getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + isDir <- doesDirectoryExist path + if isDir + then listFilesRecursive path + else return [path] + return (topdir : concat paths) + +---------------------------------------------------------- + +getDirectoryContentsBS :: RawFilePath -> IO [RawFilePath] +getDirectoryContentsBS path = + modifyIOError ((`ioeSetFileName` (BS.unpack path)) . + (`ioeSetLocation` "getDirectoryContentsBS")) $ do + bracket + (PosixBS.openDirStream path) + PosixBS.closeDirStream + loop + where + loop dirp = do + e <- PosixBS.readDirStream dirp + if BS.null e then return [] else do + es <- loop dirp + return (e:es) + + +listFilesRecursiveBS :: RawFilePath -> IO [RawFilePath] +listFilesRecursiveBS topdir = do + names <- getDirectoryContentsBS topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> unsafeInterleaveIO $ do + let path = PosixBS.combine topdir name + isDir <- isDirectory <$> getFileStatus path + if isDir + then listFilesRecursiveBS path + else return [path] + return (topdir : concat paths) +---------------------------------------------------------- + + +benchTraverse :: RawFilePath -> IO () +benchTraverse = traverseDirectory (\() p -> BS.putStrLn p) () + +main :: IO () +main = do + args <- getArgs + let (d,otherArgs) = case args of + [] -> ("/usr/local",[]) + x:xs -> (x,xs) + withArgs otherArgs $ defaultMain + [ bench "traverse (FilePath)" $ nfIO $ listFilesRecursive d >>= mapM_ putStrLn + , bench "traverse (RawFilePath)" $ nfIO $ listFilesRecursiveBS (BS.pack d) >>= mapM_ BS.putStrLn + , bench "allDirectoryContents" $ nfIO $ allDirectoryContents (BS.pack d) >>= mapM_ BS.putStrLn + , bench "allDirectoryContents'" $ nfIO $ allDirectoryContents' (BS.pack d) >>= mapM_ BS.putStrLn + , bench "traverseDirectory" $ nfIO $ benchTraverse (BS.pack d) + , bench "unix find" $ nfIO $ void $ system ("find " ++ d) + ] diff --git a/cbits/dirutils.c b/cbits/dirutils.c new file mode 100644 --- /dev/null +++ b/cbits/dirutils.c @@ -0,0 +1,7 @@ +#include "dirutils.h" +unsigned int + __posixdir_d_type(struct dirent* d) + { + return(d -> d_type); + } + diff --git a/cbits/dirutils.h b/cbits/dirutils.h new file mode 100644 --- /dev/null +++ b/cbits/dirutils.h @@ -0,0 +1,13 @@ +#ifndef POSIXPATHS_CBITS_DIRUTILS_H +#define POSIXPATHS_CBITS_DIRUTILS_H + +#include +#include +#include +#include +#include + +extern unsigned int + __posixdir_d_type(struct dirent* d) + ; +#endif diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,5 @@ +module Main where + +import Test.DocTest + +main = doctest ["-isrc", "-XOverloadedStrings", "src/System/Posix/FilePath"] diff --git a/posix-paths.cabal b/posix-paths.cabal new file mode 100644 --- /dev/null +++ b/posix-paths.cabal @@ -0,0 +1,62 @@ +name: posix-paths +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +maintainer: jwlato@gmail.com +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/unix +synopsis: POSIX filepath/directory functionality +category: System +description: + This package gives access to certain POSIX-based Filepath/Directory + services. + . + The package is not supported under Windows (except under Cygwin). +extra-source-files: cbits/dirutils.h + doctests.hs + benchmarks/*.hs +extra-tmp-files: +build-type: Simple +Cabal-Version: >= 1.14 + +Library + hs-source-dirs: src + default-language: Haskell2010 + c-sources: cbits/dirutils.c + exposed-modules: System.Posix.Directory.Foreign, + System.Posix.Directory.Traversals, + System.Posix.FilePath + build-depends: base >= 4.2 && < 4.7, + bytestring >= 0.9.2.0 && < 0.11, + unix >= 2.5 && < 2.7 + +test-suite doctests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: doctests.hs + build-depends: base, + bytestring, + unix, + posix-paths, + doctest >= 0.8 + +benchmark bench.hs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Bench.hs + + build-depends: + base, + posix-paths, + bytestring, + unix, + directory >= 1.1 && < 1.3, + filepath >= 1.2 && < 1.4, + process >= 1.0 && < 1.2, + criterion >= 0.6 && < 0.7 + ghc-options: -O2 + +source-repository head + type: git + location: git://github.com/JohnLato/posix-paths.git diff --git a/src/System/Posix/Directory/Foreign.hsc b/src/System/Posix/Directory/Foreign.hsc new file mode 100644 --- /dev/null +++ b/src/System/Posix/Directory/Foreign.hsc @@ -0,0 +1,25 @@ +module System.Posix.Directory.Foreign where + +import Data.Bits +import Data.List (foldl') +import Foreign.C.Types + +#include +#include +#include +#include +#include +#include + +newtype DirType = DirType Int deriving (Eq, Show) +newtype Flags = Flags { unFlags :: Int } deriving (Eq, Show) + +#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN} + +#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CLOEXEC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_SYNC, O_TRUNC} + +pathMax :: Int +pathMax = #{const PATH_MAX} + +unionFlags :: [Flags] -> CInt +unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0 diff --git a/src/System/Posix/Directory/Traversals.hs b/src/System/Posix/Directory/Traversals.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/Directory/Traversals.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} +module System.Posix.Directory.Traversals ( + + getDirectoryContents + +, allDirectoryContents +, allDirectoryContents' +, traverseDirectory + +-- lower-level stuff +, openAt +, fdOpendir +, readDirEnt +, packDirStream +, unpackDirStream + +, realpath +) where + +import Control.Applicative +import Control.Monad +import System.Posix.FilePath (()) +import System.Posix.Directory.Foreign + +import qualified System.Posix as Posix +import qualified System.Posix.IO.ByteString as PosixBS +import System.IO.Error +import Control.Exception +import qualified Data.ByteString.Char8 as BS +import System.Posix.ByteString.FilePath +import System.Posix.Directory.ByteString as PosixBS +import System.Posix.Files.ByteString + +import System.IO.Unsafe +import Unsafe.Coerce (unsafeCoerce) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc (alloca,allocaBytes) +import Foreign.Ptr +import Foreign.Storable + +---------------------------------------------------------- + +-- | Get all files from a directory and its subdirectories. +-- +-- Upon entering a directory, 'allDirectoryContents' will get all entries +-- strictly. However the returned list is lazy in that directories will only +-- be accessed on demand. +allDirectoryContents :: RawFilePath -> IO [RawFilePath] +allDirectoryContents topdir = do + namesAndTypes <- getDirectoryContents topdir + let properNames = filter ((`notElem` [".", ".."]) . snd) namesAndTypes + paths <- forM properNames $ \(typ,name) -> unsafeInterleaveIO $ do + let path = topdir name + case () of + () | typ == dtDir -> allDirectoryContents path + | typ == dtUnknown -> do + isDir <- isDirectory <$> getFileStatus path + if isDir + then allDirectoryContents path + else return [path] + | otherwise -> return [path] + return (topdir : concat paths) + +-- | Get all files from a directory and its subdirectories strictly. +-- +allDirectoryContents' :: RawFilePath -> IO [RawFilePath] +allDirectoryContents' = fmap reverse . traverseDirectory (\acc fp -> return (fp:acc)) [] +-- this uses traverseDirectory because it's more efficient than forcing the +-- lazy version. + +-- recursively apply the 'action' to the parent directory and all +-- files/subdirectories. +traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s +traverseDirectory act s0 topdir = bracket someOpenFunc Posix.closeFd toploop + where + someOpenFunc = PosixBS.openFd topdir Posix.ReadOnly Nothing + (Posix.defaultFileFlags {Posix.nonBlock = True, Posix.noctty = True}) + toploop fd = do + isDir <- isDirectory <$> getFileStatus topdir + s' <- act s0 topdir + if isDir then actOnDirContents fd "." s' (loop topdir) + else return s' + + loop relpath typ fd path acc = do + let fullpath = relpath path + isDir <- case () of + () | typ == dtDir -> return True + | typ == dtUnknown -> isDirectory <$> getFileStatus fullpath + | otherwise -> return False + if isDir + then act acc path >>= \acc' -> actOnDirContents fd path acc' (loop fullpath) + else act acc path + + +actOnDirContents :: Posix.Fd -> RawFilePath -> b -> (DirType -> Posix.Fd -> RawFilePath -> b -> IO b) -> IO b +actOnDirContents dirFd relpath b f = + modifyIOError ((`ioeSetFileName` (BS.unpack relpath)) . + (`ioeSetLocation` "findBSTypRel")) $ do + bracket + (openAt dirFd relpath) + (Posix.closeFd) + (\p -> fdOpendir p >>= \dirp -> loop p dirp b) + where + loop fd dirp b' = do + (typ,e) <- readDirEnt dirp + if (e == "") + then return b' + else do + if (e == "." || e == "..") + then loop fd dirp b' + else f typ fd e b' >>= loop fd dirp + +---------------------------------------------------------- +-- dodgy stuff + +type CDir = () +type CDirent = () + +-- Posix doesn't export DirStream, so to re-use that type we need to use +-- unsafeCoerce. It's just a newtype, so this is a legitimate usage. +-- ugly trick. +unpackDirStream :: DirStream -> Ptr CDir +unpackDirStream = unsafeCoerce + +packDirStream :: Ptr CDir -> DirStream +packDirStream = unsafeCoerce + +-- the __hscore_* functions are defined in the unix package. We can import them and let +-- the linker figure it out. +foreign import ccall unsafe "__hscore_readdir" + c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt + +foreign import ccall unsafe "__hscore_free_dirent" + c_freeDirEnt :: Ptr CDirent -> IO () + +foreign import ccall unsafe "__hscore_d_name" + c_name :: Ptr CDirent -> IO CString + +foreign import ccall unsafe "__posixdir_d_type" + c_type :: Ptr CDirent -> IO DirType + +foreign import ccall unsafe "fdopendir" + c_fdopendir :: Posix.Fd -> IO (Ptr ()) + +foreign import ccall unsafe "openat" + c_openat :: Posix.Fd -> CString -> CInt -> IO Posix.Fd + +foreign import ccall "realpath" + c_realpath :: CString -> CString -> IO CString + +fdOpendir :: Posix.Fd -> IO DirStream +fdOpendir fd = + packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) + +openAt :: Posix.Fd -> RawFilePath -> IO Posix.Fd +openAt relfd path = + BS.useAsCString path $ throwErrnoIfMinus1Retry "openAt" . flip (c_openat relfd) defFlags + where + defFlags = unionFlags [oRdonly, oNonblock, oDirectory, oCloexec] + +---------------------------------------------------------- +-- less dodgy but still lower-level + +readDirEnt :: DirStream -> IO (DirType, RawFilePath) +readDirEnt (unpackDirStream -> dirp) = + alloca $ \ptr_dEnt -> loop ptr_dEnt + where + loop ptr_dEnt = do + resetErrno + r <- c_readdir dirp ptr_dEnt + if (r == 0) + then do + dEnt <- peek ptr_dEnt + if (dEnt == nullPtr) + then return (dtUnknown,BS.empty) + else do + dName <- c_name dEnt >>= peekFilePath + dType <- c_type dEnt + c_freeDirEnt dEnt + return (dType, dName) + else do + errno <- getErrno + if (errno == eINTR) + then loop ptr_dEnt + else do + let (Errno eo) = errno + if (eo == 0) + then return (dtUnknown,BS.empty) + else throwErrno "readDirEnt" + +getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)] +getDirectoryContents path = + modifyIOError ((`ioeSetFileName` (BS.unpack path)) . + (`ioeSetLocation` "System.Posix.Directory.Traversals.getDirectoryContents")) $ do + bracket + (PosixBS.openDirStream path) + PosixBS.closeDirStream + loop + where + loop dirp = do + t@(_typ,e) <- readDirEnt dirp + if BS.null e then return [] else do + es <- loop dirp + return (t:es) + +-- | return the canonicalized absolute pathname +-- +-- like canonicalizePath, but uses realpath(3) +realpath :: RawFilePath -> IO RawFilePath +realpath inp = do + allocaBytes pathMax $ \tmp -> do + void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp + BS.packCString tmp diff --git a/src/System/Posix/FilePath.hs b/src/System/Posix/FilePath.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/FilePath.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} + +module System.Posix.FilePath ( + + pathSeparator +, isPathSeparator +, searchPathSeparator +, isSearchPathSeparator +, extSeparator +, isExtSeparator + +, splitExtension +, takeExtension +, replaceExtension +, dropExtension +, addExtension +, hasExtension +, (<.>) +, splitExtensions +, dropExtensions +, takeExtensions + +, splitFileName +, takeFileName +, replaceFileName +, dropFileName +, takeBaseName +, replaceBaseName +, takeDirectory +, replaceDirectory +, combine +, () +, splitPath +, joinPath +, splitDirectories + +, hasTrailingPathSeparator +, addTrailingPathSeparator +, dropTrailingPathSeparator + +, isRelative +, isAbsolute + +, module System.Posix.ByteString.FilePath +) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import System.Posix.ByteString.FilePath + +import Data.Char (ord) +import Data.Maybe (isJust) +import Data.Word (Word8) + +import Control.Arrow (second) + +-- $setup +-- >>> import Data.Char +-- >>> import Test.QuickCheck +-- >>> import Control.Applicative +-- >>> import qualified Data.ByteString as BS +-- >>> instance Arbitrary ByteString where arbitrary = BS.pack <$> arbitrary +-- >>> instance CoArbitrary ByteString where coarbitrary = coarbitrary . BS.unpack +-- +-- >>> let _chr :: Word8 -> Char; _chr = chr . fromIntegral + + +-- | Path separator charactor +pathSeparator :: Word8 +pathSeparator = fromIntegral $ ord '/' + +-- | Check if a charactor is the path separator +-- +-- prop> \n -> (_chr n == '/') == isPathSeparator n +isPathSeparator :: Word8 -> Bool +isPathSeparator = (== pathSeparator) + +-- | Search path separator +searchPathSeparator :: Word8 +searchPathSeparator = fromIntegral $ ord ':' + +-- | Check if a charactor is the search path separator +-- +-- prop> \n -> (_chr n == ':') == isSearchPathSeparator n +isSearchPathSeparator :: Word8 -> Bool +isSearchPathSeparator = (== searchPathSeparator) + +-- | File extension separator +extSeparator :: Word8 +extSeparator = fromIntegral $ ord '.' + +-- | Check if a charactor is the file extension separator +-- +-- prop> \n -> (_chr n == '.') == isExtSeparator n +isExtSeparator :: Word8 -> Bool +isExtSeparator = (== extSeparator) + +------------------------ +-- extension stuff + +-- | Split a 'RawFilePath' into a path+filename and extension +-- +-- >>> splitExtension "file.exe" +-- ("file",".exe") +-- +-- >>> splitExtension "file" +-- ("file","") +-- +-- >>> splitExtension "/path/file.tar.gz" +-- ("/path/file.tar",".gz") +-- +-- prop> \path -> uncurry (BS.append) (splitExtension path) == path +splitExtension :: RawFilePath -> (RawFilePath, ByteString) +splitExtension x = if BS.null basename + then (x,"") + else (BS.concat [path,BS.init basename],BS.cons extSeparator fileExt) + where + (path,file) = splitFileNameRaw x + (basename,fileExt) = BS.breakEnd isExtSeparator file + +-- | Get the final extension from a 'RawFilePath' +-- +-- >>> takeExtension "file.exe" +-- ".exe" +-- +-- >>> takeExtension "file" +-- "" +-- +-- >>> takeExtension "/path/file.tar.gz" +-- ".gz" +takeExtension :: RawFilePath -> ByteString +takeExtension = snd . splitExtension + +-- | Change a file's extension +-- +-- prop> \path -> let ext = takeExtension path in replaceExtension path ext == path +replaceExtension :: RawFilePath -> ByteString -> RawFilePath +replaceExtension path ext = dropExtension path <.> ext + +-- | Drop the final extension from a 'RawFilePath' +-- +-- >>> dropExtension "file.exe" +-- "file" +-- +-- >>> dropExtension "file" +-- "file" +-- +-- >>> dropExtension "/path/file.tar.gz" +-- "/path/file.tar" +dropExtension :: RawFilePath -> RawFilePath +dropExtension = fst . splitExtension + +-- | Add an extension to a 'RawFilePath' +-- +-- >>> addExtension "file" ".exe" +-- "file.exe" +-- +-- >>> addExtension "file.tar" ".gz" +-- "file.tar.gz" +-- +-- >>> addExtension "/path/" ".ext" +-- "/path/.ext" +addExtension :: RawFilePath -> ByteString -> RawFilePath +addExtension file ext + | BS.null ext = file + | isExtSeparator (BS.head ext) = BS.concat [file, ext] + | otherwise = BS.concat [file, BS.singleton extSeparator, ext] + + +-- | Operator version of 'addExtension' +(<.>) :: RawFilePath -> ByteString -> RawFilePath +(<.>) = addExtension + +-- | Check if a 'RawFilePath' has an extension +-- >>> hasExtension "file" +-- False +-- +-- >>> hasExtension "file.tar" +-- True +-- +-- >>> hasExtension "/path.part1/" +-- False +hasExtension :: RawFilePath -> Bool +hasExtension = isJust . BS.elemIndex extSeparator . takeFileName + +-- | Split a 'RawFilePath' on the first extension +-- +-- >>> splitExtensions "/path/file.tar.gz" +-- ("/path/file",".tar.gz") +-- +-- prop> \path -> uncurry addExtension (splitExtensions path) == path +splitExtensions :: RawFilePath -> (RawFilePath, ByteString) +splitExtensions x = if BS.null basename + then (x,"") + else (BS.concat [path,basename],fileExt) + where + (path,file) = splitFileNameRaw x + (basename,fileExt) = BS.break isExtSeparator file + +-- | Remove all extensions from a 'RawFilePath' +-- +-- >>> dropExtensions "/path/file.tar.gz" +-- "/path/file" +dropExtensions :: RawFilePath -> RawFilePath +dropExtensions = fst . splitExtensions + +-- | Take all extensions from a 'RawFilePath' +-- +-- >>> takeExtensions "/path/file.tar.gz" +-- ".tar.gz" +takeExtensions :: RawFilePath -> ByteString +takeExtensions = snd . splitExtensions + +------------------------ +-- more stuff + +-- Split a 'RawFilePath' into (path,file). 'combine' is the inverse +-- +-- >>> splitFileName "path/file.txt" +-- ("path/","file.txt") +-- +-- >>> splitFileName "path/" +-- ("path/","") +-- +-- >>> splitFileName "file.txt" +-- ("./","file.txt") +-- +-- prop> \path -> uncurry combine (splitFileName path) == path || fst (splitFileName path) == "./" +splitFileName :: RawFilePath -> (RawFilePath, RawFilePath) +splitFileName x = if BS.null path + then ("./", file) + else (path,file) + where + (path,file) = splitFileNameRaw x + +-- | Get the file name +-- +-- >>> takeFileName "path/file.txt" +-- "file.txt" +-- +-- >>> takeFileName "path/" +-- "" +takeFileName :: RawFilePath -> RawFilePath +takeFileName = snd . splitFileName + +-- | Change the file name +-- +-- prop> \path -> replaceFileName path (takeFileName path) == path +replaceFileName :: RawFilePath -> ByteString -> RawFilePath +replaceFileName x y = fst (splitFileNameRaw x) y + +-- | Drop the file name +-- +-- >>> dropFileName "path/file.txt" +-- "path/" +-- +-- >>> dropFileName "file.txt" +-- "./" +dropFileName :: RawFilePath -> RawFilePath +dropFileName = fst . splitFileName + +-- | Get the file name, without a trailing extension +-- +-- >>> takeBaseName "path/file.tar.gz" +-- "file.tar" +-- +-- >>> takeBaseName "" +-- "" +takeBaseName :: RawFilePath -> ByteString +takeBaseName = dropExtension . takeFileName + +-- | Change the base name +-- +-- >>> replaceBaseName "path/file.tar.gz" "bob" +-- "path/bob.gz" +-- +-- prop> \path -> replaceBaseName path (takeBaseName path) == path +replaceBaseName :: RawFilePath -> ByteString -> RawFilePath +replaceBaseName path name = combineRaw dir (name <.> ext) + where + (dir,file) = splitFileNameRaw path + ext = takeExtension file + +-- | Get the directory, moving up one level if it's already a directory +-- +-- >>> takeDirectory "path/file.txt" +-- "path" +-- +-- >>> takeDirectory "file" +-- "." +-- +-- >>> takeDirectory "/path/to/" +-- "/path/to" +-- +-- >>> takeDirectory "/path/to" +-- "/path" +takeDirectory :: RawFilePath -> RawFilePath +takeDirectory x = case () of + () | x == "/" -> x + | BS.null res && not (BS.null file) -> file + | otherwise -> res + where + res = fst $ BS.spanEnd isPathSeparator file + file = dropFileName x + +-- | Change the directory component of a 'RawFilePath' +-- +-- prop> \path -> replaceDirectory path (takeDirectory path) `_equalFilePath` path || takeDirectory path == "." +replaceDirectory :: RawFilePath -> ByteString -> RawFilePath +replaceDirectory file dir = combineRaw dir (takeFileName file) + +-- | Join two paths together +-- +-- >>> combine "/" "file" +-- "/file" +-- >>> combine "/path/to" "file" +-- "/path/to/file" +-- >>> combine "file" "/absolute/path" +-- "/absolute/path" +combine :: RawFilePath -> RawFilePath -> RawFilePath +combine a b | not (BS.null b) && isPathSeparator (BS.head b) = b + | otherwise = combineRaw a b + +-- | Operator version of combine +() :: RawFilePath -> RawFilePath -> RawFilePath +() = combine + +-- | Split a path into a list of components: +-- +-- >>> splitPath "/path/to/file.txt" +-- ["/","path/","to/","file.txt"] +-- +-- prop> \path -> BS.concat (splitPath path) == path +splitPath :: RawFilePath -> [RawFilePath] +splitPath = splitter + where + splitter x + | BS.null x = [] + | otherwise = case BS.elemIndex pathSeparator x of + Nothing -> [x] + Just ix -> case BS.findIndex (not . isPathSeparator) $ BS.drop (ix+1) x of + Nothing -> [x] + Just runlen -> uncurry (:) . second splitter $ BS.splitAt (ix+1+runlen) x + +-- | Like 'splitPath', but without trailing slashes +-- +-- >>> splitDirectories "/path/to/file.txt" +-- ["/","path","to","file.txt"] +-- >>> splitDirectories "" +-- [] +splitDirectories :: RawFilePath -> [RawFilePath] +splitDirectories x + | BS.null x = [] + | isPathSeparator (BS.head x) = let (root,rest) = BS.splitAt 1 x + in root : splitter rest + | otherwise = splitter x + where + splitter = filter (not . BS.null) . BS.split pathSeparator + +-- | Join a split path back together +-- +-- prop> \path -> joinPath (splitPath path) == path +-- +-- >>> joinPath ["path","to","file.txt"] +-- "path/to/file.txt" +joinPath :: [RawFilePath] -> RawFilePath +joinPath = foldr () BS.empty + + +------------------------ +-- trailing path separators + +-- | Check if the last character of a 'RawFilePath' is '/', unless it's the +-- root. +-- +-- >>> hasTrailingPathSeparator "/path/" +-- True +-- >>> hasTrailingPathSeparator "/" +-- False +hasTrailingPathSeparator :: RawFilePath -> Bool +hasTrailingPathSeparator x + | BS.null x = False + | x == "/" = False + | otherwise = isPathSeparator $ BS.last x + +-- | Add a trailing path separator. +-- +-- >>> addTrailingPathSeparator "/path" +-- "/path/" +-- +-- >>> addTrailingPathSeparator "/path/" +-- "/path/" +addTrailingPathSeparator :: RawFilePath -> RawFilePath +addTrailingPathSeparator x = if hasTrailingPathSeparator x + then x + else x `BS.snoc` pathSeparator + +-- | Remove a trailing path separator +-- +-- >>> dropTrailingPathSeparator "/path/" +-- "/path" +-- +-- >>> dropTrailingPathSeparator "/" +-- "/" +dropTrailingPathSeparator :: RawFilePath -> RawFilePath +dropTrailingPathSeparator x = if hasTrailingPathSeparator x + then BS.init x + else x + +------------------------ +-- Filename/system stuff + +-- | Check if a path is absolute +-- +-- >>> isAbsolute "/path" +-- True +-- >>> isAbsolute "path" +-- False +-- >>> isAbsolute "" +-- False +isAbsolute :: RawFilePath -> Bool +isAbsolute x + | BS.length x > 0 = isPathSeparator (BS.head x) + | otherwise = False + +-- | Check if a path is relative +-- +-- prop> \path -> isRelative path /= isAbsolute path +isRelative :: RawFilePath -> Bool +isRelative = not . isAbsolute + +------------------------ +-- internal stuff + +-- Just split the input FileName without adding/normalizing or changing +-- anything. +splitFileNameRaw :: RawFilePath -> (RawFilePath, RawFilePath) +splitFileNameRaw x = BS.breakEnd isPathSeparator x + +-- | Combine two paths, assuming rhs is NOT absolute. +combineRaw :: RawFilePath -> RawFilePath -> RawFilePath +combineRaw a b | BS.null a = b + | BS.null b = a + | isPathSeparator (BS.last a) = BS.concat [a, b] + | otherwise = BS.concat [a,BS.singleton pathSeparator, b] + +-- | we don't even attempt to fully normalize file paths, this is just enough +-- equality to test some operations. +-- +_equalFilePath :: RawFilePath -> RawFilePath -> Bool +_equalFilePath a b = norm a == norm b + where + norm = dropDups . dropTrailingSlash . dropInitialDot + dropTrailingSlash path + | BS.length path >= 2 && isPathSeparator (BS.last path) = BS.init path + | otherwise = path + dropInitialDot path + | BS.length path >= 2 && BS.take 2 path == "./" = BS.drop 2 path + | otherwise = path + dropDups = joinPath . map f . splitPath + f component + | BS.isSuffixOf "//" component = BS.init component + | otherwise = component