diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,35 @@ +0.5.9: + * Adds our posix-paths fork and a lot of IO operations. +0.5.8: + * First version of the fork. +0.5.7: + * Fix haddock problem. +0.5.6: + * Reject only .. and . +0.5.5: + * Use filepath's isValid function for additional sanity checks +0.5.4: + * Disable parsing of path consisting only of "." + * Add NFData instance for Path + * Some typo/docs improvements + * Add standard headers to modules +0.5.3: + * Added conversion functions. + +0.2.0: + + * Rename parentAbs to simply parent. + * Add dirname. + +0.3.0: + * Removed Generic instance. + +0.4.0: + * Implemented stricter parsing, disabling use of "..". + * Made stripDir generic over MonadThrow + +0.5.0: + * Fix stripDir p p /= Nothing bug. + +0.5.2: + * Removed unused DeriveGeneric. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# HPath + +[![Build Status](https://api.travis-ci.org/hasufell/hpath.png?branch=master)](http://travis-ci.org/hasufell/hpath) + +Support for well-typed paths in Haskell. Also provides ByteString based filepath +manipulation. + +## Motivation + +The motivation came during development of +[hsfm](https://github.com/hasufell/hsfm) +which has a pretty strict File type, but lacks a strict Path type, e.g. +for user input. + +The library that came closest to my needs was +[path](https://github.com/chrisdone/path), +but the API turned out to be oddly complicated for my use case, so I +decided to fork it. + +Similarly, [posix-paths](https://github.com/JohnLato/posix-paths) +was exactly what I wanted for the low-level operations, but upstream seems dead, +so it is forked as well and merged into this library. + +## Goals + +* well-typed paths +* high-level API to file operations like recursive directory copy +* safe filepath manipulation, never using String as filepath, but ByteString +* still allowing sufficient control to interact with the underlying low-level calls + +## Differences to 'path' + +* doesn't attempt to fake IO-related information into the path, so whether a path points to a file or directory is up to your IO-code to decide... +* trailing path separators will be preserved if they exist, no messing with that +* uses safe ByteString for filepaths under the hood instead of unsafe String +* fixes broken [dirname](https://github.com/chrisdone/path/issues/18) +* renames dirname/filename to basename/dirname to match the POSIX shell functions +* introduces a new `Path Fn` for safe filename guarantees and a `RelC` class +* allows pattern matching via unidirectional PatternSynonym +* uses simple doctest for testing +* allows `~/` as relative path, because on posix level `~` is just a regular filename that does _NOT_ point to `$HOME` +* remove TH, it sucks + +## Differences to 'posix-paths' + +* `hasTrailingPathSeparator` behaves in the same way as `System.FilePath` +* `dropTrailingPathSeparator` behaves in the same way as `System.FilePath` +* added various functions like `isValid`, `normalise` and `equalFilePath` +* uses the `word8` package for save word8 literals instead of `OverloadedStrings` +* has custom versions of `openFd` and `getDirectoryContents` + 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,90 @@ +{-# 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 + + +-- | Based on code from 'Real World Haskell', at +-- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html#id620419 +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) + + +-- | similar to 'listFilesRecursive, but uses RawFilePaths +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-hpath.hs b/doctests-hpath.hs new file mode 100644 --- /dev/null +++ b/doctests-hpath.hs @@ -0,0 +1,13 @@ +module Main where + + +import Test.DocTest +import Test.HUnit + +main = + doctest + ["-isrc" + , "-XOverloadedStrings" + , "src/HPath.hs" + ] + diff --git a/doctests-posix.hs b/doctests-posix.hs new file mode 100644 --- /dev/null +++ b/doctests-posix.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Applicative +import System.Posix.Directory.Traversals + +import Test.DocTest +import Test.HUnit + +main = do + doctest + [ "-isrc" + , "-XOverloadedStrings" + , "System.Posix.FilePath" + ] + runTestTT unitTests + + +unitTests :: Test +unitTests = test + [ TestCase $ do + r <- (==) <$> allDirectoryContents "." <*> allDirectoryContents' "." + assertBool "allDirectoryContents == allDirectoryContents'" r + ] diff --git a/hpath.cabal b/hpath.cabal new file mode 100644 --- /dev/null +++ b/hpath.cabal @@ -0,0 +1,121 @@ +name: hpath +version: 0.5.9 +synopsis: Support for well-typed paths +description: Support for well-typed paths, utilizing ByteString under the hood. +license: GPL-2 +license-file: LICENSE +author: Julian Ospald +maintainer: Julian Ospald +copyright: Julian Ospald 2016 +category: Filesystem +build-type: Simple +cabal-version: >=1.14 +extra-source-files: README.md + CHANGELOG + benchmarks/*.hs + cbits/dirutils.h + doctests-hpath.hs + doctests-posix.hs + +library + hs-source-dirs: src/ + default-language: Haskell2010 + ghc-options: -Wall + c-sources: cbits/dirutils.c + exposed-modules: HPath, + HPath.IO, + HPath.IO.Errors, + HPath.IO.Utils, + HPath.Internal, + System.Posix.Directory.Foreign, + System.Posix.Directory.Traversals, + System.Posix.FilePath + build-depends: base >= 4.2 && <5 + , bytestring >= 0.9.2.0 + , deepseq + , exceptions + , hspec + , unix >= 2.5 + , unix-bytestring + , utf8-string + , word8 + + +test-suite doctests-hpath + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: doctests-hpath.hs + build-depends: base + , HUnit + , QuickCheck + , doctest >= 0.8 + , hpath + +test-suite doctests-posix + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: doctests-posix.hs + build-depends: base, + bytestring, + unix, + hpath, + doctest >= 0.8, + HUnit, + QuickCheck + +test-suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: test + Main-Is: Main.hs + other-modules: + Spec + HPath.IO.CopyDirRecursiveSpec + HPath.IO.CopyDirRecursiveOverwriteSpec + HPath.IO.CopyFileSpec + HPath.IO.CopyFileOverwriteSpec + HPath.IO.CreateDirSpec + HPath.IO.CreateRegularFileSpec + HPath.IO.DeleteDirRecursiveSpec + HPath.IO.DeleteDirSpec + HPath.IO.DeleteFileSpec + HPath.IO.GetDirsFilesSpec + HPath.IO.GetFileTypeSpec + HPath.IO.MoveFileSpec + HPath.IO.MoveFileOverwriteSpec + HPath.IO.RecreateSymlinkSpec + HPath.IO.RenameFileSpec + Utils + GHC-Options: -Wall + Build-Depends: base + , HUnit + , bytestring + , hpath + , hspec >= 1.3 + , process + , unix + , utf8-string + +benchmark bench.hs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Bench.hs + + build-depends: + base, + hpath, + bytestring, + unix, + directory >= 1.1 && < 1.3, + filepath >= 1.2 && < 1.4, + process >= 1.0 && < 1.3, + criterion >= 0.6 && < 0.9 + ghc-options: -O2 + +source-repository head + type: git + location: https://github.com/hasufell/hpath + diff --git a/src/HPath.hs b/src/HPath.hs new file mode 100644 --- /dev/null +++ b/src/HPath.hs @@ -0,0 +1,369 @@ +-- | +-- Module : HPath +-- Copyright : © 2015–2016 FP Complete, 2016 Julian Ospald +-- License : BSD 3 clause +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Support for well-typed paths. + + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE PatternSynonyms #-} + +module HPath + ( + -- * Types + Abs + ,Path + ,Rel + ,Fn + ,PathParseException + ,PathException + -- * PatternSynonyms/ViewPatterns + ,pattern Path + -- * Path Parsing + ,parseAbs + ,parseFn + ,parseRel + -- * Path Conversion + ,fromAbs + ,fromRel + ,toFilePath + -- * Path Operations + ,() + ,basename + ,dirname + ,isParentOf + ,getAllParents + ,stripDir + -- * Path IO helpers + ,withAbsPath + ,withRelPath + ,withFnPath + -- * ByteString operations + ,fpToString + ,userStringToFP + ) + where + +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow(..)) +#if MIN_VERSION_bytestring(0,10,8) +import Data.ByteString(ByteString, stripPrefix) +#else +import Data.ByteString(ByteString) +#endif +import qualified Data.ByteString as BS +import Data.Data +import qualified Data.List as L +import Data.Maybe +import Data.Word8 +import HPath.Internal +import System.Posix.FilePath hiding (()) + + +-------------------------------------------------------------------------------- +-- Types + +-- | An absolute path. +data Abs deriving (Typeable) + +-- | A relative path; one without a root. +data Rel deriving (Typeable) + +-- | A filename, without any '/'. +data Fn deriving (Typeable) + +-- | Exception when parsing a location. +data PathParseException + = InvalidAbs ByteString + | InvalidRel ByteString + | InvalidFn ByteString + | Couldn'tStripPrefixTPS ByteString ByteString + deriving (Show,Typeable) +instance Exception PathParseException + +data PathException = RootDirHasNoBasename + deriving (Show,Typeable) +instance Exception PathException + +instance RelC Rel +instance RelC Fn + +-------------------------------------------------------------------------------- +-- PatternSynonyms + +pattern Path x <- (MkPath x) + +-------------------------------------------------------------------------------- +-- Path Parsers + + + +-- | Get a location for an absolute path. Produces a normalised path. +-- +-- Throws: 'PathParseException' +-- +-- >>> parseAbs "/abc" :: Maybe (Path Abs) +-- Just "/abc" +-- >>> parseAbs "/" :: Maybe (Path Abs) +-- Just "/" +-- >>> parseAbs "/abc/def" :: Maybe (Path Abs) +-- Just "/abc/def" +-- >>> parseAbs "/abc/def/.///" :: Maybe (Path Abs) +-- Just "/abc/def/" +-- >>> parseAbs "abc" :: Maybe (Path Abs) +-- Nothing +-- >>> parseAbs "" :: Maybe (Path Abs) +-- Nothing +-- >>> parseAbs "/abc/../foo" :: Maybe (Path Abs) +-- Nothing +parseAbs :: MonadThrow m + => ByteString -> m (Path Abs) +parseAbs filepath = + if isAbsolute filepath && + isValid filepath && + not (hasParentDir filepath) + then return (MkPath $ normalise filepath) + else throwM (InvalidAbs filepath) + + +-- | Get a location for a relative path. Produces a normalised +-- path. +-- +-- Note that @filepath@ may contain any number of @./@ but may not consist +-- solely of @./@. It also may not contain a single @..@ anywhere. +-- +-- Throws: 'PathParseException' +-- +-- >>> parseRel "abc" :: Maybe (Path Rel) +-- Just "abc" +-- >>> parseRel "def/" :: Maybe (Path Rel) +-- Just "def/" +-- >>> parseRel "abc/def" :: Maybe (Path Rel) +-- Just "abc/def" +-- >>> parseRel "abc/def/." :: Maybe (Path Rel) +-- Just "abc/def/" +-- >>> parseRel "/abc" :: Maybe (Path Rel) +-- Nothing +-- >>> parseRel "" :: Maybe (Path Rel) +-- Nothing +-- >>> parseRel "abc/../foo" :: Maybe (Path Rel) +-- Nothing +-- >>> parseRel "." :: Maybe (Path Rel) +-- Nothing +-- >>> parseRel ".." :: Maybe (Path Rel) +-- Nothing +parseRel :: MonadThrow m + => ByteString -> m (Path Rel) +parseRel filepath = + if not (isAbsolute filepath) && + filepath /= BS.singleton _period && + filepath /= BS.pack [_period, _period] && + not (hasParentDir filepath) && + isValid filepath + then return (MkPath $ normalise filepath) + else throwM (InvalidRel filepath) + + +-- | Parses a filename. Filenames must not contain slashes. +-- Excludes '.' and '..'. +-- +-- Throws: 'PathParseException' +-- +-- >>> parseFn "abc" :: Maybe (Path Fn) +-- Just "abc" +-- >>> parseFn "..." :: Maybe (Path Fn) +-- Just "..." +-- >>> parseFn "def/" :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "abc/def" :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "abc/def/." :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "/abc" :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "" :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "abc/../foo" :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn "." :: Maybe (Path Fn) +-- Nothing +-- >>> parseFn ".." :: Maybe (Path Fn) +-- Nothing +parseFn :: MonadThrow m + => ByteString -> m (Path Fn) +parseFn filepath = + if isFileName filepath && + filepath /= BS.singleton _period && + filepath /= BS.pack [_period, _period] && + isValid filepath + then return (MkPath filepath) + else throwM (InvalidFn filepath) + + + +-------------------------------------------------------------------------------- +-- Path Conversion + +-- | Convert any Path to a ByteString type. +toFilePath :: Path b -> ByteString +toFilePath (MkPath l) = l + +-- | Convert an absolute Path to a ByteString type. +fromAbs :: Path Abs -> ByteString +fromAbs = toFilePath + +-- | Convert a relative Path to a ByteString type. +fromRel :: RelC r => Path r -> ByteString +fromRel = toFilePath + + + +-------------------------------------------------------------------------------- +-- Path Operations + +-- | Append two paths. +-- +-- The second argument must always be a relative path, which ensures +-- that undefinable things like `"/abc" "/def"` cannot happen. +-- +-- Technically, the first argument can be a path that points to a non-directory, +-- because this library is IO-agnostic and makes no assumptions about +-- file types. +-- +-- >>> (MkPath "/") (MkPath "file" :: Path Rel) +-- "/file" +-- >>> (MkPath "/path/to") (MkPath "file" :: Path Rel) +-- "/path/to/file" +-- >>> (MkPath "/") (MkPath "file/lal" :: Path Rel) +-- "/file/lal" +-- >>> (MkPath "/") (MkPath "file/" :: Path Rel) +-- "/file/" +() :: RelC r => Path b -> Path r -> Path b +() (MkPath a) (MkPath b) = MkPath (a' `BS.append` b) + where + a' = if BS.last a == pathSeparator + then a + else addTrailingPathSeparator a + +-- | Strip directory from path, making it relative to that directory. +-- Throws 'Couldn'tStripPrefixDir' if directory is not a parent of the path. +-- +-- The bases must match. +-- +-- >>> (MkPath "/lal/lad") `stripDir` (MkPath "/lal/lad/fad") :: Maybe (Path Rel) +-- Just "fad" +-- >>> (MkPath "lal/lad") `stripDir` (MkPath "lal/lad/fad") :: Maybe (Path Rel) +-- Just "fad" +-- >>> (MkPath "/") `stripDir` (MkPath "/") :: Maybe (Path Rel) +-- Nothing +-- >>> (MkPath "/lal/lad/fad") `stripDir` (MkPath "/lal/lad") :: Maybe (Path Rel) +-- Nothing +-- >>> (MkPath "fad") `stripDir` (MkPath "fad") :: Maybe (Path Rel) +-- Nothing +stripDir :: MonadThrow m + => Path b -> Path b -> m (Path Rel) +stripDir (MkPath p) (MkPath l) = + case stripPrefix p' l of + Nothing -> throwM (Couldn'tStripPrefixTPS p' l) + Just ok -> if BS.null ok + then throwM (Couldn'tStripPrefixTPS p' l) + else return (MkPath ok) + where + p' = addTrailingPathSeparator p + +-- | Is p a parent of the given location? Implemented in terms of +-- 'stripDir'. The bases must match. +-- +-- >>> (MkPath "/lal/lad") `isParentOf` (MkPath "/lal/lad/fad") +-- True +-- >>> (MkPath "lal/lad") `isParentOf` (MkPath "lal/lad/fad") +-- True +-- >>> (MkPath "/") `isParentOf` (MkPath "/") +-- False +-- >>> (MkPath "/lal/lad/fad") `isParentOf` (MkPath "/lal/lad") +-- False +-- >>> (MkPath "fad") `isParentOf` (MkPath "fad") +-- False +isParentOf :: Path b -> Path b -> Bool +isParentOf p l = isJust (stripDir p l :: Maybe (Path Rel)) + + +-- |Get all parents of a path. +-- +-- >>> getAllParents (MkPath "/abs/def/dod") +-- ["/abs/def","/abs","/"] +-- >>> getAllParents (MkPath "/") +-- [] +getAllParents :: Path Abs -> [Path Abs] +getAllParents (MkPath p) + | np == BS.singleton pathSeparator = [] + | otherwise = dirname (MkPath np) : getAllParents (dirname $ MkPath np) + where + np = dropTrailingPathSeparator . normalise $ p + + +-- | Extract the directory name of a path. +-- +-- The following properties hold: +-- +-- @dirname (p \<\/> a) == dirname p@ +-- +-- >>> dirname (MkPath "/abc/def/dod") +-- "/abc/def" +-- >>> dirname (MkPath "/") +-- "/" +dirname :: Path Abs -> Path Abs +dirname (MkPath fp) = MkPath (takeDirectory $ dropTrailingPathSeparator fp) + +-- | Extract the file part of a path. +-- +-- +-- The following properties hold: +-- +-- @basename (p \<\/> a) == basename a@ +-- +-- Throws: `PathException` if given the root path "/" +-- +-- >>> basename (MkPath "/abc/def/dod") :: Maybe (Path Fn) +-- Just "dod" +-- >>> basename (MkPath "/") :: Maybe (Path Fn) +-- Nothing +basename :: MonadThrow m => Path b -> m (Path Fn) +basename (MkPath l) + | not (isAbsolute rl) = return $ MkPath rl + | otherwise = throwM RootDirHasNoBasename + where + rl = last . splitPath . dropTrailingPathSeparator $ l + + +-------------------------------------------------------------------------------- +-- Path IO helpers + + +withAbsPath :: Path Abs -> (ByteString -> IO a) -> IO a +withAbsPath (MkPath p) action = action p + + +withRelPath :: Path Rel -> (ByteString -> IO a) -> IO a +withRelPath (MkPath p) action = action p + + +withFnPath :: Path Fn -> (ByteString -> IO a) -> IO a +withFnPath (MkPath p) action = action p + + +------------------------ +-- ByteString helpers + +#if MIN_VERSION_bytestring(0,10,8) +#else +stripPrefix :: ByteString -> ByteString -> Maybe ByteString +stripPrefix a b = BS.pack `fmap` L.stripPrefix (BS.unpack a) (BS.unpack b) +#endif diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs new file mode 100644 --- /dev/null +++ b/src/HPath/IO.hs @@ -0,0 +1,819 @@ +-- | +-- Module : HPath.IO +-- Copyright : © 2016 Julian Ospald +-- License : GPL-2 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- This module provides high-level IO related file operations like +-- copy, delete, move and so on. It only operates on /Path Abs/ which +-- guarantees us well-typed paths which are absolute. +-- +-- Some functions are just path-safe wrappers around +-- unix functions, others have stricter exception handling +-- and some implement functionality that doesn't have a unix +-- counterpart (like `copyDirRecursive`). +-- +-- Some of these operations are due to their nature __not atomic__, which +-- means they may do multiple syscalls which form one context. Some +-- of them also have to examine the filetypes explicitly before the +-- syscalls, so a reasonable decision can be made. That means +-- the result is undefined if another process changes that context +-- while the non-atomic operation is still happening. However, where +-- possible, as few syscalls as possible are used and the underlying +-- exception handling is kept. +-- +-- Note: `BlockDevice`, `CharacterDevice`, `NamedPipe` and `Socket` +-- are not explicitly supported right now. Calling any of these +-- functions on such a file may throw an exception. + +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO + ( + -- * Types + FileType(..) + -- * File copying + , copyDirRecursive + , copyDirRecursiveOverwrite + , recreateSymlink + , copyFile + , copyFileOverwrite + , easyCopy + , easyCopyOverwrite + -- * File deletion + , deleteFile + , deleteDir + , deleteDirRecursive + , easyDelete + -- * File opening + , openFile + , executeFile + -- * File creation + , createRegularFile + , createDir + -- * File renaming/moving + , renameFile + , moveFile + , moveFileOverwrite + -- * File permissions + , newFilePerms + , newDirPerms + -- * Directory reading + , getDirsFiles + -- * Filetype operations + , getFileType + -- * Others + , canonicalizePath + ) + where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Exception + ( + bracket + , bracketOnError + , throwIO + ) +import Control.Monad + ( + void + , when + ) +import Data.ByteString + ( + ByteString + ) +import Data.Foldable + ( + for_ + ) +import Data.Maybe + ( + catMaybes + ) +import Data.Word + ( + Word8 + ) +import Foreign.C.Error + ( + eEXIST + , eNOTEMPTY + , eXDEV + ) +import Foreign.C.Types + ( + CSize + ) +import Foreign.Marshal.Alloc + ( + allocaBytes + ) +import Foreign.Ptr + ( + Ptr + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import HPath +import HPath.Internal +import HPath.IO.Errors +import HPath.IO.Utils +import Prelude hiding (readFile) +import System.IO.Error + ( + catchIOError + , ioeGetErrorType + ) +import System.Posix.ByteString + ( + exclusive + ) +import System.Posix.Directory.ByteString + ( + createDirectory + , removeDirectory + ) +import System.Posix.Directory.Traversals + ( + getDirectoryContents' + ) +import System.Posix.Files.ByteString + ( + createSymbolicLink + , fileMode + , getFdStatus + , groupExecuteMode + , groupReadMode + , groupWriteMode + , otherExecuteMode + , otherReadMode + , otherWriteMode + , ownerModes + , ownerReadMode + , ownerWriteMode + , readSymbolicLink + , removeLink + , rename + , setFileMode + , unionFileModes + ) +import qualified System.Posix.Files.ByteString as PF +import qualified "unix" System.Posix.IO.ByteString as SPI +import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB +import qualified System.Posix.Directory.Traversals as SPDT +import qualified System.Posix.Directory.Foreign as SPDF +import qualified System.Posix.Process.ByteString as SPP +import System.Posix.Types + ( + FileMode + , ProcessID + , Fd + ) + + + + + +data FileType = Directory + | RegularFile + | SymbolicLink + | BlockDevice + | CharacterDevice + | NamedPipe + | Socket + deriving (Eq, Show) + + + + + + -------------------- + --[ File Copying ]-- + -------------------- + + + +-- |Copies a directory recursively to the given destination. +-- Does not follow symbolic links. +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- * examines filetypes explicitly +-- * an explicit check `throwDestinationInSource` is carried out for the +-- top directory for basic sanity, because otherwise we might end up +-- with an infinite copy loop... however, this operation is not +-- carried out recursively (because it's slow) +-- +-- Throws: +-- +-- - `NoSuchThing` if source directory does not exist +-- - `PermissionDenied` if output directory is not writable +-- - `PermissionDenied` if source directory can't be opened +-- - `InvalidArgument` if source directory is wrong type (symlink) +-- - `InvalidArgument` if source directory is wrong type (regular file) +-- - `SameFile` if source and destination are the same file (`HPathIOException`) +-- - `AlreadyExists` if destination already exists +-- - `DestinationInSource` if destination is contained in source (`HPathIOException`) +copyDirRecursive :: Path Abs -- ^ source dir + -> Path Abs -- ^ full destination + -> IO () +copyDirRecursive fromp destdirp + = do + -- for performance, sanity checks are only done for the top dir + throwSameFile fromp destdirp + throwDestinationInSource fromp destdirp + go fromp destdirp + where + go :: Path Abs -> Path Abs -> IO () + go fromp' destdirp' = do + -- order is important here, so we don't get empty directories + -- on failure + contents <- getDirsFiles fromp' + + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') + createDirectory (fromAbs destdirp') fmode' + + for_ contents $ \f -> do + ftype <- getFileType f + newdest <- (destdirp' ) <$> basename f + case ftype of + SymbolicLink -> recreateSymlink f newdest + Directory -> go f newdest + RegularFile -> copyFile f newdest + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + + +-- |Like `copyDirRecursive` except it overwrites contents of directories +-- if any. +-- +-- Throws: +-- +-- - `NoSuchThing` if source directory does not exist +-- - `PermissionDenied` if output directory is not writable +-- - `PermissionDenied` if source directory can't be opened +-- - `InvalidArgument` if source directory is wrong type (symlink) +-- - `InvalidArgument` if source directory is wrong type (regular file) +-- - `SameFile` if source and destination are the same file (`HPathIOException`) +-- - `DestinationInSource` if destination is contained in source (`HPathIOException`) +copyDirRecursiveOverwrite :: Path Abs -- ^ source dir + -> Path Abs -- ^ full destination + -> IO () +copyDirRecursiveOverwrite fromp destdirp + = do + -- for performance, sanity checks are only done for the top dir + throwSameFile fromp destdirp + throwDestinationInSource fromp destdirp + go fromp destdirp + where + go :: Path Abs -> Path Abs -> IO () + go fromp' destdirp' = do + -- order is important here, so we don't get empty directories + -- on failure + contents <- getDirsFiles fromp' + + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fromAbs fromp') + catchIOError (createDirectory (fromAbs destdirp') fmode') $ \e -> + case ioeGetErrorType e of + AlreadyExists -> setFileMode (fromAbs destdirp') fmode' + _ -> ioError e + + for_ contents $ \f -> do + ftype <- getFileType f + newdest <- (destdirp' ) <$> basename f + case ftype of + SymbolicLink -> whenM (doesFileExist newdest) (deleteFile newdest) + >> recreateSymlink f newdest + Directory -> go f newdest + RegularFile -> copyFileOverwrite f newdest + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + + +-- |Recreate a symlink. +-- +-- Throws: +-- +-- - `InvalidArgument` if symlink file is wrong type (file) +-- - `InvalidArgument` if symlink file is wrong type (directory) +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `AlreadyExists` if destination file already exists +-- - `SameFile` if source and destination are the same file (`HPathIOException`) +-- +-- Note: calls `symlink` +recreateSymlink :: Path Abs -- ^ the old symlink file + -> Path Abs -- ^ destination file + -> IO () +recreateSymlink symsource newsym + = do + throwSameFile symsource newsym + sympoint <- readSymbolicLink (fromAbs symsource) + createSymbolicLink sympoint (fromAbs newsym) + + +-- |Copies the given regular file to the given destination. +-- Neither follows symbolic links, nor accepts them. +-- For "copying" symbolic links, use `recreateSymlink` instead. +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory is not writable +-- - `PermissionDenied` if source directory can't be opened +-- - `InvalidArgument` if source file is wrong type (symlink) +-- - `InvalidArgument` if source file is wrong type (directory) +-- - `SameFile` if source and destination are the same file (`HPathIOException`) +-- - `AlreadyExists` if destination already exists +-- +-- Note: calls `sendfile` +copyFile :: Path Abs -- ^ source file + -> Path Abs -- ^ destination file + -> IO () +copyFile from to = do + throwSameFile from to + _copyFile [SPDF.oNofollow] + [SPDF.oNofollow, SPDF.oExcl] + from to + + +-- |Like `copyFile` except it overwrites the destination if it already +-- exists. +-- This also works if source and destination are the same file. +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- * falls back to delete-copy method with explicit checks +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory is not writable +-- - `PermissionDenied` if source directory can't be opened +-- - `InvalidArgument` if source file is wrong type (symlink) +-- - `InvalidArgument` if source file is wrong type (directory) +-- - `SameFile` if source and destination are the same file (`HPathIOException`) +-- +-- Note: calls `sendfile` +copyFileOverwrite :: Path Abs -- ^ source file + -> Path Abs -- ^ destination file + -> IO () +copyFileOverwrite from to = do + throwSameFile from to + catchIOError (_copyFile [SPDF.oNofollow] + [SPDF.oNofollow, SPDF.oTrunc] + from to) $ \e -> + case ioeGetErrorType e of + -- if the destination file is not writable, we need to + -- figure out if we can still copy by deleting it first + PermissionDenied -> do + exists <- doesFileExist to + writable <- isWritable (dirname to) + if exists && writable + then deleteFile to >> copyFile from to + else ioError e + _ -> ioError e + + +_copyFile :: [SPDF.Flags] + -> [SPDF.Flags] + -> Path Abs -- ^ source file + -> Path Abs -- ^ destination file + -> IO () +_copyFile sflags dflags from to + = + -- TODO: add sendfile support + withAbsPath to $ \to' -> withAbsPath from $ \from' -> + void $ fallbackCopy from' to' + where + -- low-level copy operation utilizing read(2)/write(2) + -- in case `sendFileCopy` fails/is unsupported + fallbackCopy source dest = + bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing) + SPI.closeFd + $ \sfd -> do + fileM <- System.Posix.Files.ByteString.fileMode + <$> getFdStatus sfd + bracketeer (SPDT.openFd dest SPI.WriteOnly + dflags $ Just fileM) + SPI.closeFd + (\fd -> SPI.closeFd fd >> deleteFile to) + $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf -> + write' sfd dfd buf 0 + where + bufSize :: CSize + bufSize = 8192 + write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int + write' sfd dfd buf totalsize = do + size <- SPB.fdReadBuf sfd buf bufSize + if size == 0 + then return $ fromIntegral totalsize + else do rsize <- SPB.fdWriteBuf dfd buf size + when (rsize /= size) (throwIO . CopyFailed $ "wrong size!") + write' sfd dfd buf (totalsize + fromIntegral size) + + +-- |Copies anything. In case of a symlink, +-- it is just recreated, even if it points to a directory. +-- +-- Safety/reliability concerns: +-- +-- * examines filetypes explicitly +-- * calls `copyDirRecursive` for directories +easyCopy :: Path Abs + -> Path Abs + -> IO () +easyCopy from to = do + ftype <- getFileType from + case ftype of + SymbolicLink -> recreateSymlink from to + RegularFile -> copyFile from to + Directory -> copyDirRecursive from to + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + + +-- |Like `easyCopy` except it overwrites the destination if it already exists. +-- For directories, this overwrites contents without pruning them, so the resulting +-- directory may have more files than have been copied. +easyCopyOverwrite :: Path Abs + -> Path Abs + -> IO () +easyCopyOverwrite from to = do + ftype <- getFileType from + case ftype of + SymbolicLink -> whenM (doesFileExist to) (deleteFile to) + >> recreateSymlink from to + RegularFile -> copyFileOverwrite from to + Directory -> copyDirRecursiveOverwrite from to + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + + + + + + + --------------------- + --[ File Deletion ]-- + --------------------- + + +-- |Deletes the given file, does not follow symlinks. Raises `eISDIR` +-- if run on a directory. Does not follow symbolic links. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (directory) +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if the directory cannot be read +deleteFile :: Path Abs -> IO () +deleteFile p = withAbsPath p removeLink + + +-- |Deletes the given directory, which must be empty, never symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (symlink to directory) +-- - `InappropriateType` for wrong file type (regular file) +-- - `NoSuchThing` if directory does not exist +-- - `UnsatisfiedConstraints` if directory is not empty +-- - `PermissionDenied` if we can't open or write to parent directory +-- +-- Notes: calls `rmdir` +deleteDir :: Path Abs -> IO () +deleteDir p = withAbsPath p removeDirectory + + +-- |Deletes the given directory recursively. Does not follow symbolic +-- links. Tries `deleteDir` first before attemtping a recursive +-- deletion. +-- +-- Safety/reliability concerns: +-- +-- * not atomic +-- * examines filetypes explicitly +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (symlink to directory) +-- - `InappropriateType` for wrong file type (regular file) +-- - `NoSuchThing` if directory does not exist +-- - `PermissionDenied` if we can't open or write to parent directory +deleteDirRecursive :: Path Abs -> IO () +deleteDirRecursive p = + catchErrno [eNOTEMPTY, eEXIST] + (deleteDir p) + $ do + files <- getDirsFiles p + for_ files $ \file -> do + ftype <- getFileType file + case ftype of + SymbolicLink -> deleteFile file + Directory -> deleteDirRecursive file + RegularFile -> deleteFile file + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + removeDirectory . toFilePath $ p + + +-- |Deletes a file, directory or symlink, whatever it may be. +-- In case of directory, performs recursive deletion. In case of +-- a symlink, the symlink file is deleted. +-- +-- Safety/reliability concerns: +-- +-- * examines filetypes explicitly +-- * calls `deleteDirRecursive` for directories +easyDelete :: Path Abs -> IO () +easyDelete p = do + ftype <- getFileType p + case ftype of + SymbolicLink -> deleteFile p + Directory -> deleteDirRecursive p + RegularFile -> deleteFile p + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + + + + + -------------------- + --[ File Opening ]-- + -------------------- + + +-- |Opens a file appropriately by invoking xdg-open. The file type +-- is not checked. This forks a process. +openFile :: Path Abs + -> IO ProcessID +openFile p = + withAbsPath p $ \fp -> + SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing + + +-- |Executes a program with the given arguments. This forks a process. +executeFile :: Path Abs -- ^ program + -> [ByteString] -- ^ arguments + -> IO ProcessID +executeFile fp args + = withAbsPath fp $ \fpb -> + SPP.forkProcess + $ SPP.executeFile fpb True args Nothing + + + + + --------------------- + --[ File Creation ]-- + --------------------- + + +-- |Create an empty regular file at the given directory with the given filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `AlreadyExists` if destination file already exists +createRegularFile :: Path Abs -> IO () +createRegularFile dest = + bracket (SPI.openFd (fromAbs dest) SPI.WriteOnly (Just newFilePerms) + (SPI.defaultFileFlags { exclusive = True })) + SPI.closeFd + (\_ -> return ()) + + +-- |Create an empty directory at the given directory with the given filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `AlreadyExists` if destination directory already exists +createDir :: Path Abs -> IO () +createDir dest = createDirectory (fromAbs dest) newDirPerms + + + + + ---------------------------- + --[ File Renaming/Moving ]-- + ---------------------------- + + +-- |Rename a given file with the provided filename. Destination and source +-- must be on the same device, otherwise `eXDEV` will be raised. +-- +-- Does not follow symbolic links, but renames the symbolic link file. +-- +-- Safety/reliability concerns: +-- +-- * has a separate set of exception handling, apart from the syscall +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `UnsupportedOperation` if source and destination are on different devices +-- - `FileDoesExist` if destination file already exists +-- - `DirDoesExist` if destination directory already exists +-- - `SameFile` if destination and source are the same file (`HPathIOException`) +-- +-- Note: calls `rename` (but does not allow to rename over existing files) +renameFile :: Path Abs -> Path Abs -> IO () +renameFile fromf tof = do + throwSameFile fromf tof + throwFileDoesExist tof + throwDirDoesExist tof + rename (fromAbs fromf) (fromAbs tof) + + +-- |Move a file. This also works across devices by copy-delete fallback. +-- And also works on directories. +-- +-- Does not follow symbolic links, but renames the symbolic link file. +-- +-- Safety/reliability concerns: +-- +-- * copy-delete fallback is inherently non-atomic +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `FileDoesExist` if destination file already exists +-- - `DirDoesExist` if destination directory already exists +-- - `SameFile` if destination and source are the same file (`HPathIOException`) +-- +-- Note: calls `rename` (but does not allow to rename over existing files) +moveFile :: Path Abs -- ^ file to move + -> Path Abs -- ^ destination + -> IO () +moveFile from to = do + throwSameFile from to + catchErrno [eXDEV] (renameFile from to) $ do + easyCopy from to + easyDelete from + + +-- |Like `moveFile`, but overwrites the destination if it exists. +-- +-- Does not follow symbolic links, but renames the symbolic link file. +-- +-- Safety/reliability concerns: +-- +-- * copy-delete fallback is inherently non-atomic +-- * checks for file types and destination file existence explicitly +-- +-- Throws: +-- +-- - `NoSuchThing` if source file does not exist +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `SameFile` if destination and source are the same file (`HPathIOException`) +-- +-- Note: calls `rename` (but does not allow to rename over existing files) +moveFileOverwrite :: Path Abs -- ^ file to move + -> Path Abs -- ^ destination + -> IO () +moveFileOverwrite from to = do + throwSameFile from to + ft <- getFileType from + writable <- isWritable $ dirname to + case ft of + RegularFile -> do + exists <- doesFileExist to + when (exists && writable) (deleteFile to) + SymbolicLink -> do + exists <- doesFileExist to + when (exists && writable) (deleteFile to) + Directory -> do + exists <- doesDirectoryExist to + when (exists && writable) (deleteDir to) + _ -> ioError $ userError $ "Don't know how to handle filetype " ++ + show ft + moveFile from to + + + + + ----------------------- + --[ File Permissions]-- + ----------------------- + + +-- |Default permissions for a new file. +newFilePerms :: FileMode +newFilePerms + = ownerWriteMode + `unionFileModes` ownerReadMode + `unionFileModes` groupWriteMode + `unionFileModes` groupReadMode + `unionFileModes` otherWriteMode + `unionFileModes` otherReadMode + + +-- |Default permissions for a new directory. +newDirPerms :: FileMode +newDirPerms + = ownerModes + `unionFileModes` groupExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` otherExecuteMode + `unionFileModes` otherReadMode + + + + ------------------------- + --[ Directory reading ]-- + ------------------------- + + +-- |Gets all filenames of the given directory. This excludes "." and "..". +-- This version does not follow symbolic links. +-- +-- Throws: +-- +-- - `NoSuchThing` if directory does not exist +-- - `InappropriateType` if file type is wrong (file) +-- - `InappropriateType` if file type is wrong (symlink to file) +-- - `InappropriateType` if file type is wrong (symlink to dir) +-- - `PermissionDenied` if directory cannot be opened +getDirsFiles :: Path Abs -- ^ dir to read + -> IO [Path Abs] +getDirsFiles p = + withAbsPath p $ \fp -> + bracketOnError (SPDT.openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing) + SPI.closeFd + $ \fd -> + return + . catMaybes + . fmap (\x -> () p <$> (parseMaybe . snd $ x)) + =<< getDirectoryContents' fd + where + parseMaybe :: ByteString -> Maybe (Path Fn) + parseMaybe = parseFn + + + + + --------------------------- + --[ FileType operations ]-- + --------------------------- + + +-- |Get the file type of the file located at the given path. Does +-- not follow symbolic links. +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if any part of the path is not accessible +getFileType :: Path Abs -> IO FileType +getFileType p = do + fs <- PF.getSymbolicLinkStatus (fromAbs p) + decide fs + where + decide fs + | PF.isDirectory fs = return Directory + | PF.isRegularFile fs = return RegularFile + | PF.isSymbolicLink fs = return SymbolicLink + | PF.isBlockDevice fs = return BlockDevice + | PF.isCharacterDevice fs = return CharacterDevice + | PF.isNamedPipe fs = return NamedPipe + | PF.isSocket fs = return Socket + | otherwise = ioError $ userError "No filetype?!" + + + + -------------- + --[ Others ]-- + -------------- + + + +-- |Applies `realpath` on the given absolute path. +-- +-- Throws: +-- +-- - `NoSuchThing` if the file at the given path does not exist +-- - `NoSuchThing` if the symlink is broken +canonicalizePath :: Path Abs -> IO (Path Abs) +canonicalizePath (MkPath l) = do + nl <- SPDT.realpath l + return $ MkPath nl diff --git a/src/HPath/IO/Errors.hs b/src/HPath/IO/Errors.hs new file mode 100644 --- /dev/null +++ b/src/HPath/IO/Errors.hs @@ -0,0 +1,330 @@ +-- | +-- Module : HPath.IO.Errors +-- Copyright : © 2016 Julian Ospald +-- License : GPL-2 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Provides error handling. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HPath.IO.Errors where + + +import Control.Applicative + ( + (<$>) + ) +import Control.Exception +import Control.Monad + ( + forM + , when + ) +import Data.ByteString + ( + ByteString + ) +import Data.Data + ( + Data(..) + ) +import Data.Typeable +import Foreign.C.Error + ( + getErrno + , Errno + ) +import GHC.IO.Exception + ( + IOErrorType + ) +import HPath +import HPath.IO.Utils +import System.IO.Error + ( + catchIOError + , ioeGetErrorType + ) + +import qualified System.Posix.Directory.ByteString as PFD +import System.Posix.Files.ByteString + ( + fileAccess + , getFileStatus + ) +import qualified System.Posix.Files.ByteString as PF + + +data HPathIOException = FileDoesNotExist ByteString + | DirDoesNotExist ByteString + | PathNotAbsolute ByteString + | FileNotExecutable ByteString + | SameFile ByteString ByteString + | NotAFile ByteString + | NotADir ByteString + | DestinationInSource ByteString ByteString + | FileDoesExist ByteString + | DirDoesExist ByteString + | IsSymlink ByteString + | InvalidOperation String + | InvalidFileName + | Can'tOpenDirectory ByteString + | CopyFailed String + | MoveFailed String + deriving (Typeable, Eq, Data) + + +instance Show HPathIOException where + show (FileDoesNotExist fp) = "File does not exist:" ++ fpToString fp + show (DirDoesNotExist fp) = "Directory does not exist: " + ++ fpToString fp + show (PathNotAbsolute fp) = "Path not absolute: " ++ fpToString fp + show (FileNotExecutable fp) = "File not executable: " + ++ fpToString fp + show (SameFile fp1 fp2) = fpToString fp1 + ++ " and " ++ fpToString fp2 + ++ " are the same file!" + show (NotAFile fp) = "Not a file: " ++ fpToString fp + show (NotADir fp) = "Not a directory: " ++ fpToString fp + show (DestinationInSource fp1 fp2) = fpToString fp1 + ++ " is contained in " + ++ fpToString fp2 + show (FileDoesExist fp) = "File does exist: " ++ fpToString fp + show (DirDoesExist fp) = "Directory does exist: " ++ fpToString fp + show (IsSymlink fp) = "Is a symlink: " ++ fpToString fp + show (InvalidOperation str) = "Invalid operation: " ++ str + show InvalidFileName = "Invalid file name!" + show (Can'tOpenDirectory fp) = "Can't open directory: " + ++ fpToString fp + show (CopyFailed str) = "Copying failed: " ++ str + show (MoveFailed str) = "Moving failed: " ++ str + + + +instance Exception HPathIOException + + + +isDestinationInSource :: HPathIOException -> Bool +isDestinationInSource (DestinationInSource _ _) = True +isDestinationInSource _ = False + + +isSameFile :: HPathIOException -> Bool +isSameFile (SameFile _ _) = True +isSameFile _ = False + + +isFileDoesExist :: HPathIOException -> Bool +isFileDoesExist (FileDoesExist _) = True +isFileDoesExist _ = False + + +isDirDoesExist :: HPathIOException -> Bool +isDirDoesExist (DirDoesExist _) = True +isDirDoesExist _ = False + + + + ---------------------------- + --[ Path based functions ]-- + ---------------------------- + + +throwFileDoesExist :: Path Abs -> IO () +throwFileDoesExist fp = + whenM (doesFileExist fp) (throwIO . FileDoesExist + . fromAbs $ fp) + + +throwDirDoesExist :: Path Abs -> IO () +throwDirDoesExist fp = + whenM (doesDirectoryExist fp) (throwIO . DirDoesExist + . fromAbs $ fp) + + +throwFileDoesNotExist :: Path Abs -> IO () +throwFileDoesNotExist fp = + unlessM (doesFileExist fp) (throwIO . FileDoesNotExist + . fromAbs $ fp) + + +throwDirDoesNotExist :: Path Abs -> IO () +throwDirDoesNotExist fp = + unlessM (doesDirectoryExist fp) (throwIO . DirDoesNotExist + . fromAbs $ fp) + + +-- |Uses `isSameFile` and throws `SameFile` if it returns True. +throwSameFile :: Path Abs + -> Path Abs + -> IO () +throwSameFile fp1 fp2 = + whenM (sameFile fp1 fp2) + (throwIO $ SameFile (fromAbs fp1) (fromAbs fp2)) + + +-- |Check if the files are the same by examining device and file id. +-- This follows symbolic links. +sameFile :: Path Abs -> Path Abs -> IO Bool +sameFile fp1 fp2 = + withAbsPath fp1 $ \fp1' -> withAbsPath fp2 $ \fp2' -> + handleIOError (\_ -> return False) $ do + fs1 <- getFileStatus fp1' + fs2 <- getFileStatus fp2' + + if ((PF.deviceID fs1, PF.fileID fs1) == + (PF.deviceID fs2, PF.fileID fs2)) + then return True + else return False + + +-- |Checks whether the destination directory is contained +-- within the source directory by comparing the device+file ID of the +-- source directory with all device+file IDs of the parent directories +-- of the destination. +throwDestinationInSource :: Path Abs -- ^ source dir + -> Path Abs -- ^ full destination, `dirname dest` + -- must exist + -> IO () +throwDestinationInSource source dest = do + dest' <- (\x -> maybe x (\y -> x y) $ basename dest) + {- <$> (canonicalizePath $ P.dirname dest) -} + <$> (return $ dirname dest) + dids <- forM (getAllParents dest') $ \p -> do + fs <- PF.getSymbolicLinkStatus (fromAbs p) + return (PF.deviceID fs, PF.fileID fs) + sid <- fmap (\x -> (PF.deviceID x, PF.fileID x)) + $ PF.getFileStatus (fromAbs source) + when (elem sid dids) + (throwIO $ DestinationInSource (fromAbs dest) + (fromAbs source)) + + +-- |Checks if the given file exists and is not a directory. +-- Does not follow symlinks. +doesFileExist :: Path Abs -> IO Bool +doesFileExist fp = + handleIOError (\_ -> return False) $ do + fs <- PF.getSymbolicLinkStatus (fromAbs fp) + return $ not . PF.isDirectory $ fs + + +-- |Checks if the given file exists and is a directory. +-- Does not follow symlinks. +doesDirectoryExist :: Path Abs -> IO Bool +doesDirectoryExist fp = + handleIOError (\_ -> return False) $ do + fs <- PF.getSymbolicLinkStatus (fromAbs fp) + return $ PF.isDirectory fs + + +-- |Checks whether a file or folder is writable. +isWritable :: Path Abs -> IO Bool +isWritable fp = + handleIOError (\_ -> return False) $ + fileAccess (fromAbs fp) False True False + + +-- |Checks whether the directory at the given path exists and can be +-- opened. This invokes `openDirStream` which follows symlinks. +canOpenDirectory :: Path Abs -> IO Bool +canOpenDirectory fp = + handleIOError (\_ -> return False) $ do + bracket (PFD.openDirStream . fromAbs $ fp) + PFD.closeDirStream + (\_ -> return ()) + return True + + +-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given +-- path cannot be opened. +throwCantOpenDirectory :: Path Abs -> IO () +throwCantOpenDirectory fp = + unlessM (canOpenDirectory fp) + (throwIO . Can'tOpenDirectory . fromAbs $ fp) + + + + -------------------------------- + --[ Error handling functions ]-- + -------------------------------- + + +-- |Carries out an action, then checks if there is an IOException and +-- a specific errno. If so, then it carries out another action, otherwise +-- it rethrows the error. +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e + + +-- |Execute the given action and retrow IO exceptions as a new Exception +-- that have the given errno. If errno does not match the exception is rethrown +-- as is. +rethrowErrnoAs :: Exception e + => [Errno] -- ^ errno to catch + -> e -- ^ rethrow as if errno matches + -> IO a -- ^ action to try + -> IO a +rethrowErrnoAs en fmex action = catchErrno en action (throwIO fmex) + + + +-- |Like `catchIOError`, with arguments swapped. +handleIOError :: (IOError -> IO a) -> IO a -> IO a +handleIOError = flip catchIOError + + +-- |Like `bracket`, but allows to have different clean-up +-- actions depending on whether the in-between computation +-- has raised an exception or not. +bracketeer :: IO a -- ^ computation to run first + -> (a -> IO b) -- ^ computation to run last, when + -- no exception was raised + -> (a -> IO b) -- ^ computation to run last, + -- when an exception was raised + -> (a -> IO c) -- ^ computation to run in-between + -> IO c +bracketeer before after afterEx thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` afterEx a + _ <- after a + return r + + +reactOnError :: IO a + -> [(IOErrorType, IO a)] -- ^ reaction on IO errors + -> [(HPathIOException, IO a)] -- ^ reaction on FmIOException + -> IO a +reactOnError a ios fmios = + a `catches` [iohandler, fmiohandler] + where + iohandler = Handler $ + \(ex :: IOException) -> + foldr (\(t, a') y -> if ioeGetErrorType ex == t + then a' + else y) + (throwIO ex) + ios + fmiohandler = Handler $ + \(ex :: HPathIOException) -> + foldr (\(t, a') y -> if toConstr ex == toConstr t + then a' + else y) + (throwIO ex) + fmios diff --git a/src/HPath/IO/Utils.hs b/src/HPath/IO/Utils.hs new file mode 100644 --- /dev/null +++ b/src/HPath/IO/Utils.hs @@ -0,0 +1,32 @@ +-- | +-- Module : HPath.IO.Utils +-- Copyright : © 2016 Julian Ospald +-- License : GPL-2 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Random and general IO/monad utilities. + + +module HPath.IO.Utils where + + +import Control.Monad + ( + when + , unless + ) + + +-- |If the value of the first argument is True, then execute the action +-- provided in the second argument, otherwise do nothing. +whenM :: Monad m => m Bool -> m () -> m () +whenM mb a = mb >>= (`when` a) + + +-- |If the value of the first argument is False, then execute the action +-- provided in the second argument, otherwise do nothing. +unlessM :: Monad m => m Bool -> m () -> m () +unlessM mb a = mb >>= (`unless` a) diff --git a/src/HPath/Internal.hs b/src/HPath/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HPath/Internal.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Internal types and functions. + +module HPath.Internal + (Path(..) + ,RelC) + where + +import Control.DeepSeq (NFData (..)) +import Data.ByteString (ByteString) +import Data.Data + +-- | Path of some base and type. +-- +-- Internally is a string. The string can be of two formats only: +-- +-- 1. without trailing path separator: @file.txt@, @foo\/bar.txt@, @\/foo\/bar.txt@ +-- 2. with trailing path separator: @foo\/@, @\/foo\/bar\/@ +-- +-- There are no duplicate +-- path separators @\/\/@, no @..@, no @.\/@, no @~\/@, etc. +data Path b = MkPath ByteString + deriving (Typeable) + +-- | String equality. +-- +-- The following property holds: +-- +-- @show x == show y ≡ x == y@ +instance Eq (Path b) where + (==) (MkPath x) (MkPath y) = x == y + +-- | String ordering. +-- +-- The following property holds: +-- +-- @show x \`compare\` show y ≡ x \`compare\` y@ +instance Ord (Path b) where + compare (MkPath x) (MkPath y) = compare x y + +-- | Same as 'Path.toFilePath'. +-- +-- The following property holds: +-- +-- @x == y ≡ show x == show y@ +instance Show (Path b) where + show (MkPath x) = show x + +instance NFData (Path b) where + rnf (MkPath x) = rnf x + + +class RelC m + 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,55 @@ +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) +data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show) + +unFlags :: Flags -> Int +unFlags (Flags i) = i +unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform") + +-- |Returns @True@ if posix-paths was compiled with support for the provided +-- flag. (As of this writing, the only flag for which this check may be +-- necessary is 'oCloexec'; all other flags will always yield @True@.) +isSupported :: Flags -> Bool +isSupported (Flags _) = True +isSupported _ = False + +-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use +-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was +-- compiled into your version of posix-paths. (If not, using @oCloexec@ will +-- throw an exception.) +oCloexec :: Flags +#ifdef O_CLOEXEC +oCloexec = Flags #{const O_CLOEXEC} +#else +{-# WARNING oCloexec + "This version of posix-paths was compiled without @O_CLOEXEC@ support." #-} +oCloexec = UnsupportedFlag "O_CLOEXEC" +#endif + + + +-- If these enum declarations occur earlier in the file, haddock +-- gets royally confused about the above doc comments. +-- Probably http://trac.haskell.org/haddock/ticket/138 + +#{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_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, 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,269 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wall #-} +module System.Posix.Directory.Traversals ( + + getDirectoryContents +, getDirectoryContents' + +, allDirectoryContents +, allDirectoryContents' +, traverseDirectory + +-- lower-level stuff +, readDirEnt +, packDirStream +, unpackDirStream +, openFd + +, realpath +) where + +import Control.Applicative +import Control.Monad +import System.Posix.FilePath (()) +import System.Posix.Directory.Foreign + +import qualified System.Posix as Posix +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. +-- +-- This function allows for memory-efficient traversals. +traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s +traverseDirectory act s0 topdir = toploop + where + toploop = do + isDir <- isDirectory <$> getFileStatus topdir + s' <- act s0 topdir + if isDir then actOnDirContents topdir s' loop + else return s' + loop typ path acc = do + isDir <- case () of + () | typ == dtDir -> return True + | typ == dtUnknown -> isDirectory <$> getFileStatus path + | otherwise -> return False + if isDir + then act acc path >>= \acc' -> actOnDirContents path acc' loop + else act acc path + +actOnDirContents :: RawFilePath + -> b + -> (DirType -> RawFilePath -> b -> IO b) + -> IO b +actOnDirContents pathRelToTop b f = + modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) . + (`ioeSetLocation` "findBSTypRel")) $ do + bracket + (openDirStream pathRelToTop) + (Posix.closeDirStream) + (\dirp -> loop dirp b) + where + loop dirp b' = do + (typ,e) <- readDirEnt dirp + if (e == "") + then return b' + else do + if (e == "." || e == "..") + then loop dirp b' + else f typ (pathRelToTop e) b' >>= loop 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 "realpath" + c_realpath :: CString -> CString -> IO CString + +foreign import ccall unsafe "fdopendir" + c_fdopendir :: Posix.Fd -> IO (Ptr ()) + +foreign import ccall unsafe "open" + c_open :: CString -> CInt -> Posix.CMode -> IO CInt + +---------------------------------------------------------- +-- 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) + + +fdOpendir :: Posix.Fd -> IO DirStream +fdOpendir fd = + packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd) + + +getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)] +getDirectoryContents' fd = + bracket + (fdOpendir fd) + 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) + + +open_ :: CString + -> Posix.OpenMode + -> [Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +open_ str how optional_flags maybe_mode = do + fd <- c_open str all_flags mode_w + return (Posix.Fd fd) + where + all_flags = unionFlags $ optional_flags ++ [open_mode] ++ creat + + + (creat, mode_w) = case maybe_mode of + Nothing -> ([],0) + Just x -> ([oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> oRdonly + Posix.WriteOnly -> oWronly + Posix.ReadWrite -> oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +openFd :: RawFilePath + -> Posix.OpenMode + -> [Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +openFd name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + + +-- | 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,649 @@ +-- | +-- Module : System.Posix.FilePath +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- The equivalent of "System.FilePath" on raw (byte string) file paths. +-- +-- Not all functions of "System.FilePath" are implemented yet. Feel free to contribute! + +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wall #-} + + +module System.Posix.FilePath ( + + -- * Separators + pathSeparator +, isPathSeparator +, searchPathSeparator +, isSearchPathSeparator +, extSeparator +, isExtSeparator + + -- * File extensions +, splitExtension +, takeExtension +, replaceExtension +, dropExtension +, addExtension +, hasExtension +, (<.>) +, splitExtensions +, dropExtensions +, takeExtensions + + -- * Filenames/Directory names +, splitFileName +, takeFileName +, replaceFileName +, dropFileName +, takeBaseName +, replaceBaseName +, takeDirectory +, replaceDirectory + + -- * Path combinators and splitters +, combine +, () +, splitPath +, joinPath +, splitDirectories + + -- * Path conversions +, normalise + + -- * Trailing path separator +, hasTrailingPathSeparator +, addTrailingPathSeparator +, dropTrailingPathSeparator + + -- * Queries +, isRelative +, isAbsolute +, isValid +, isFileName +, hasParentDir +, equalFilePath +, hiddenFile + + -- * Type conversion +, fpToString +, userStringToFP + +, module System.Posix.ByteString.FilePath +) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (fromString, toString) +import System.Posix.ByteString.FilePath + +import Data.Maybe (isJust) +import Data.Word8 + +import Control.Arrow (second) + +-- $setup +-- >>> import Data.Char +-- >>> import Test.QuickCheck +-- >>> import Control.Applicative +-- >>> import qualified Data.ByteString as BS +-- >>> import Data.ByteString (ByteString) +-- >>> 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 character +pathSeparator :: Word8 +pathSeparator = _slash + +-- | Check if a character is the path separator +-- +-- prop> \n -> (_chr n == '/') == isPathSeparator n +isPathSeparator :: Word8 -> Bool +isPathSeparator = (== pathSeparator) + +-- | Search path separator +searchPathSeparator :: Word8 +searchPathSeparator = _colon + +-- | Check if a character is the search path separator +-- +-- prop> \n -> (_chr n == ':') == isSearchPathSeparator n +isSearchPathSeparator :: Word8 -> Bool +isSearchPathSeparator = (== searchPathSeparator) + +-- | File extension separator +extSeparator :: Word8 +extSeparator = _period + +-- | Check if a character 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,BS.empty) + else (BS.append 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.append file ext + | otherwise = BS.intercalate (BS.singleton extSeparator) [file, 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 (path,fileExt) + else (BS.append 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 (dotSlash, file) + else (path,file) + where + (path,file) = splitFileNameRaw x + dotSlash = _period `BS.cons` (BS.singleton pathSeparator) + + +-- | 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 == BS.singleton pathSeparator -> 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 + + +-- |Normalise a file. +-- +-- >>> normalise "/file/\\test////" +-- "/file/\\test/" +-- >>> normalise "/file/./test" +-- "/file/test" +-- >>> normalise "/test/file/../bob/fred/" +-- "/test/file/../bob/fred/" +-- >>> normalise "../bob/fred/" +-- "../bob/fred/" +-- >>> normalise "./bob/fred/" +-- "bob/fred/" +-- >>> normalise "./bob////.fred/./...///./..///#." +-- "bob/.fred/.../../#." +-- >>> normalise "." +-- "." +-- >>> normalise "./" +-- "./" +-- >>> normalise "./." +-- "./" +-- >>> normalise "/./" +-- "/" +-- >>> normalise "/" +-- "/" +-- >>> normalise "bob/fred/." +-- "bob/fred/" +-- >>> normalise "//home" +-- "/home" +normalise :: RawFilePath -> RawFilePath +normalise filepath = + result `BS.append` + (if addPathSeparator + then BS.singleton pathSeparator + else BS.empty) + where + result = let n = f filepath + in if BS.null n + then BS.singleton _period + else n + addPathSeparator = isDirPath filepath && + not (hasTrailingPathSeparator result) + isDirPath xs = hasTrailingPathSeparator xs + || not (BS.null xs) && BS.last xs == _period + && hasTrailingPathSeparator (BS.init xs) + f = joinPath . dropDots . propSep . splitDirectories + propSep :: [ByteString] -> [ByteString] + propSep (x:xs) + | BS.all (== pathSeparator) x = BS.singleton pathSeparator : xs + | otherwise = x : xs + propSep [] = [] + dropDots :: [ByteString] -> [ByteString] + dropDots = filter (BS.singleton _period /=) + + +------------------------ +-- trailing path separators + +-- | Check if the last character of a 'RawFilePath' is '/'. +-- +-- >>> hasTrailingPathSeparator "/path/" +-- True +-- >>> hasTrailingPathSeparator "/" +-- True +-- >>> hasTrailingPathSeparator "/path" +-- False +hasTrailingPathSeparator :: RawFilePath -> Bool +hasTrailingPathSeparator x + | BS.null x = False + | otherwise = isPathSeparator $ BS.last x + +-- | Add a trailing path separator. +-- +-- >>> addTrailingPathSeparator "/path" +-- "/path/" +-- >>> addTrailingPathSeparator "/path/" +-- "/path/" +-- >>> addTrailingPathSeparator "/" +-- "/" +addTrailingPathSeparator :: RawFilePath -> RawFilePath +addTrailingPathSeparator x = if hasTrailingPathSeparator x + then x + else x `BS.snoc` pathSeparator + +-- | Remove a trailing path separator +-- +-- >>> dropTrailingPathSeparator "/path/" +-- "/path" +-- >>> dropTrailingPathSeparator "/path////" +-- "/path" +-- >>> dropTrailingPathSeparator "/" +-- "/" +-- >>> dropTrailingPathSeparator "//" +-- "/" +dropTrailingPathSeparator :: RawFilePath -> RawFilePath +dropTrailingPathSeparator x + | x == BS.singleton pathSeparator = x + | otherwise = if hasTrailingPathSeparator x + then dropTrailingPathSeparator $ 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 + +-- | Is a FilePath valid, i.e. could you create a file like it? +-- +-- >>> isValid "" +-- False +-- >>> isValid "\0" +-- False +-- >>> isValid "/random_ path:*" +-- True +isValid :: RawFilePath -> Bool +isValid filepath + | BS.null filepath = False + | _nul `BS.elem` filepath = False + | otherwise = True + +-- | Is the given filename a valid filename? +-- +-- >>> isFileName "lal" +-- True +-- >>> isFileName "." +-- True +-- >>> isFileName ".." +-- True +-- >>> isFileName "" +-- False +-- >>> isFileName "\0" +-- False +-- >>> isFileName "/random_ path:*" +-- False +isFileName :: ByteString -> Bool +isFileName filepath = + not (BS.singleton pathSeparator `BS.isInfixOf` filepath) && + not (BS.null filepath) && + not (_nul `BS.elem` filepath) + +-- | Helper function: check if the filepath has any parent directories in it. +-- +-- >>> hasParentDir "/.." +-- True +-- >>> hasParentDir "foo/bar/.." +-- True +-- >>> hasParentDir "foo/../bar/." +-- True +-- >>> hasParentDir "foo/bar" +-- False +-- >>> hasParentDir "foo" +-- False +-- >>> hasParentDir "" +-- False +-- >>> hasParentDir ".." +-- False +hasParentDir :: ByteString -> Bool +hasParentDir filepath = + ((pathSeparator `BS.cons` pathDoubleDot) + `BS.isSuffixOf` filepath + ) || + ((BS.singleton pathSeparator + `BS.append` pathDoubleDot + `BS.append` BS.singleton pathSeparator + ) `BS.isInfixOf` filepath + ) || + ((pathDoubleDot `BS.append` BS.singleton pathSeparator + ) `BS.isPrefixOf` filepath + ) + where + pathDoubleDot = BS.pack [_period, _period] + +-- |Equality of two filepaths. The filepaths are normalised +-- and trailing path separators are dropped. +-- +-- >>> equalFilePath "foo" "foo" +-- True +-- >>> equalFilePath "foo" "foo/" +-- True +-- >>> equalFilePath "foo" "./foo" +-- True +-- >>> equalFilePath "foo" "/foo" +-- False +-- >>> equalFilePath "foo" "FOO" +-- False +-- >>> equalFilePath "foo" "../foo" +-- False +-- +-- prop> \p -> equalFilePath p p +equalFilePath :: RawFilePath -> RawFilePath -> Bool +equalFilePath p1 p2 = f p1 == f p2 + where + f x = dropTrailingPathSeparator $ normalise x + + +-- | Whether the file is a hidden file. +-- +-- >>> hiddenFile ".foo" +-- True +-- >>> hiddenFile "..foo.bar" +-- True +-- >>> hiddenFile "..." +-- True +-- >>> hiddenFile "dod" +-- False +-- >>> hiddenFile "dod.bar" +-- False +hiddenFile :: RawFilePath -> Bool +hiddenFile fp + | fp == BS.pack [_period, _period] = False + | fp == BS.pack [_period] = False + | otherwise = BS.pack [extSeparator] + `BS.isPrefixOf` fp + +------------------------ +-- conversion + +-- |Uses UTF-8 decoding to convert the bytestring into a String. +fpToString :: ByteString -> String +fpToString = toString + + +-- |Uses UTF-8 encoding to convert a user provided String into +-- a ByteString, which represents a filepath. +userStringToFP :: String -> ByteString +userStringToFP = fromString + + +------------------------ +-- 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.append a b + | otherwise = BS.intercalate (BS.singleton pathSeparator) [a, b] + diff --git a/test/HPath/IO/CopyDirRecursiveOverwriteSpec.hs b/test/HPath/IO/CopyDirRecursiveOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyDirRecursiveOverwriteSpec.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CopyDirRecursiveOverwriteSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/copyDirRecursiveOverwriteSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.copyDirRecursiveOverwrite" $ do + + -- successes -- + it "copyDirRecursiveOverwrite, all fine" $ do + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "outputDir") + removeDirIfExists $ specDir `ba` "outputDir" + + it "copyDirRecursiveOverwrite, all fine and compare" $ do + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "outputDir") + (system $ "diff -r --no-dereference " + ++ specDir' ++ "inputDir" ++ " " + ++ specDir' ++ "outputDir") + `shouldReturn` ExitSuccess + removeDirIfExists $ specDir `ba` "outputDir" + + it "copyDirRecursiveOverwrite, destination dir already exists" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "alreadyExistsD") + + -- posix failures -- + it "copyDirRecursiveOverwrite, source directory does not exist" $ + copyDirRecursiveOverwrite' (specDir `ba` "doesNotExist") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyDirRecursiveOverwrite, no write permission on output dir" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "noWritePerm/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursiveOverwrite, cannot open output dir" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursiveOverwrite, cannot open source dir" $ + copyDirRecursiveOverwrite' (specDir `ba` "noPerms/inputDir") + (specDir `ba` "foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursiveOverwrite, destination already exists and is a file" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursiveOverwrite, wrong input (regular file)" $ + copyDirRecursiveOverwrite' (specDir `ba` "wrongInput") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursiveOverwrite, wrong input (symlink to directory)" $ + copyDirRecursiveOverwrite' (specDir `ba` "wrongInputSymL") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + -- custom failures + it "copyDirRecursiveOverwrite, destination in source" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "inputDir/foo") + `shouldThrow` + isDestinationInSource + + it "copyDirRecursiveOverwrite, destination and source same directory" $ + copyDirRecursiveOverwrite' (specDir `ba` "inputDir") + (specDir `ba` "inputDir") + `shouldThrow` + isSameFile diff --git a/test/HPath/IO/CopyDirRecursiveSpec.hs b/test/HPath/IO/CopyDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyDirRecursiveSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CopyDirRecursiveSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/copyDirRecursiveSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.copyDirRecursive" $ do + + -- successes -- + it "copyDirRecursive, all fine" $ do + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "outputDir") + removeDirIfExists (specDir `ba` "outputDir") + + it "copyDirRecursive, all fine and compare" $ do + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "outputDir") + (system $ "diff -r --no-dereference " + ++ specDir' ++ "inputDir" ++ " " + ++ specDir' ++ "outputDir") + `shouldReturn` ExitSuccess + removeDirIfExists (specDir `ba` "outputDir") + + -- posix failures -- + it "copyDirRecursive, source directory does not exist" $ + copyDirRecursive' (specDir `ba` "doesNotExist") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyDirRecursive, no write permission on output dir" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "noWritePerm/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, cannot open output dir" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, cannot open source dir" $ + copyDirRecursive' (specDir `ba` "noPerms/inputDir") + (specDir `ba` "foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyDirRecursive, destination dir already exists" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyDirRecursive, destination already exists and is a file" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyDirRecursive, wrong input (regular file)" $ + copyDirRecursive' (specDir `ba` "wrongInput") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyDirRecursive, wrong input (symlink to directory)" $ + copyDirRecursive' (specDir `ba` "wrongInputSymL") + (specDir `ba` "outputDir") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + -- custom failures + it "copyDirRecursive, destination in source" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "inputDir/foo") + `shouldThrow` + isDestinationInSource + + it "copyDirRecursive, destination and source same directory" $ + copyDirRecursive' (specDir `ba` "inputDir") + (specDir `ba` "inputDir") + `shouldThrow` + isSameFile diff --git a/test/HPath/IO/CopyFileOverwriteSpec.hs b/test/HPath/IO/CopyFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyFileOverwriteSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CopyFileOverwriteSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/copyFileOverwriteSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.copyFileOverwrite" $ do + + -- successes -- + it "copyFileOverwrite, everything clear" $ do + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "outputFile") + removeFileIfExists (specDir `ba` "outputFile") + + it "copyFileOverwrite, output file already exists, all clear" $ do + copyFile' (specDir `ba` "alreadyExists") (specDir `ba` "alreadyExists.bak") + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "alreadyExists") + (system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " " + ++ specDir' ++ "alreadyExists") + `shouldReturn` ExitSuccess + removeFileIfExists (specDir `ba` "alreadyExists") + copyFile' (specDir `ba` "alreadyExists.bak") (specDir `ba` "alreadyExists") + removeFileIfExists (specDir `ba` "alreadyExists.bak") + + it "copyFileOverwrite, and compare" $ do + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "outputFile") + (system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " " + ++ specDir' ++ "outputFile") + `shouldReturn` ExitSuccess + removeFileIfExists (specDir `ba` "outputFile") + + -- posix failures -- + it "copyFileOverwrite, input file does not exist" $ + copyFileOverwrite' (specDir `ba` "noSuchFile") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyFileOverwrite, no permission to write to output directory" $ + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "outputDirNoWrite/outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFileOverwrite, cannot open output directory" $ + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "noPerms/outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFileOverwrite, cannot open source directory" $ + copyFileOverwrite' (specDir `ba` "noPerms/inputFile") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFileOverwrite, wrong input type (symlink)" $ + copyFileOverwrite' (specDir `ba` "inputFileSymL") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "copyFileOverwrite, wrong input type (directory)" $ + copyFileOverwrite' (specDir `ba` "wrongInput") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyFileOverwrite, output file already exists and is a dir" $ + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + -- custom failures -- + it "copyFileOverwrite, output and input are same file" $ + copyFileOverwrite' (specDir `ba` "inputFile") + (specDir `ba` "inputFile") + `shouldThrow` isSameFile diff --git a/test/HPath/IO/CopyFileSpec.hs b/test/HPath/IO/CopyFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CopyFileSpec.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CopyFileSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import System.Exit +import System.Process +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/copyFileSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.copyFile" $ do + + -- successes -- + it "copyFile, everything clear" $ do + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "outputFile") + removeFileIfExists (specDir `ba` "outputFile") + + it "copyFile, and compare" $ do + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "outputFile") + (system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " " + ++ specDir' ++ "outputFile") + `shouldReturn` ExitSuccess + removeFileIfExists (specDir `ba` "outputFile") + + -- posix failures -- + it "copyFile, input file does not exist" $ + copyFile' (specDir `ba` "noSuchFile") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "copyFile, no permission to write to output directory" $ + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "outputDirNoWrite/outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile, cannot open output directory" $ + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "noPerms/outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile, cannot open source directory" $ + copyFile' (specDir `ba` "noPerms/inputFile") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "copyFile, wrong input type (symlink)" $ + copyFile' (specDir `ba` "inputFileSymL") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "copyFile, wrong input type (directory)" $ + copyFile' (specDir `ba` "wrongInput") + (specDir `ba` "outputFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "copyFile, output file already exists" $ + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "copyFile, output file already exists and is a dir" $ + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + -- custom failures -- + it "copyFile, output and input are same file" $ + copyFile' (specDir `ba` "inputFile") + (specDir `ba` "inputFile") + `shouldThrow` + isSameFile diff --git a/test/HPath/IO/CreateDirSpec.hs b/test/HPath/IO/CreateDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateDirSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CreateDirSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/createDirSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.createDir" $ do + + -- successes -- + it "createDir, all fine" $ do + createDir' (specDir `ba` "newDir") + removeDirIfExists (specDir `ba` "newDir") + + -- posix failures -- + it "createDir, can't write to output directory" $ + createDir' (specDir `ba` "noWritePerms/newDir") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDir, can't open output directory" $ + createDir' (specDir `ba` "noPerms/newDir") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDir, destination directory already exists" $ + createDir' (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + diff --git a/test/HPath/IO/CreateRegularFileSpec.hs b/test/HPath/IO/CreateRegularFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateRegularFileSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CreateRegularFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/createRegularFileSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.createRegularFile" $ do + + -- successes -- + it "createRegularFile, all fine" $ do + createRegularFile' (specDir `ba` "newDir") + removeFileIfExists (specDir `ba` "newDir") + + -- posix failures -- + it "createRegularFile, can't write to destination directory" $ + createRegularFile' (specDir `ba` "noWritePerms/newDir") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createRegularFile, can't write to destination directory" $ + createRegularFile' (specDir `ba` "noPerms/newDir") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createRegularFile, destination file already exists" $ + createRegularFile' (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + diff --git a/test/HPath/IO/DeleteDirRecursiveSpec.hs b/test/HPath/IO/DeleteDirRecursiveSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteDirRecursiveSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.DeleteDirRecursiveSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/deleteDirRecursiveSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.deleteDirRecursive" $ do + + -- successes -- + it "deleteDirRecursive, empty directory, all fine" $ do + createDir' (specDir `ba` "testDir") + deleteDirRecursive' (specDir `ba` "testDir") + getSymbolicLinkStatus (specDir `ba` "testDir") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDirRecursive, empty directory with null permissions, all fine" $ do + createDir' (specDir `ba` "noPerms/testDir") + noPerms (specDir `ba` "noPerms/testDir") + deleteDirRecursive' (specDir `ba` "noPerms/testDir") + + it "deleteDirRecursive, non-empty directory, all fine" $ do + createDir' (specDir `ba` "nonEmpty") + createDir' (specDir `ba` "nonEmpty/dir1") + createDir' (specDir `ba` "nonEmpty/dir2") + createDir' (specDir `ba` "nonEmpty/dir2/dir3") + createRegularFile' (specDir `ba` "nonEmpty/file1") + createRegularFile' (specDir `ba` "nonEmpty/dir1/file2") + deleteDirRecursive' (specDir `ba` "nonEmpty") + getSymbolicLinkStatus (specDir `ba` "nonEmpty") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteDirRecursive, can't open parent directory" $ do + createDir' (specDir `ba` "noPerms/foo") + noPerms (specDir `ba` "noPerms") + (deleteDirRecursive' (specDir `ba` "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied)) + >> normalDirPerms (specDir `ba` "noPerms") + >> deleteDir' (specDir `ba` "noPerms/foo") + + it "deleteDirRecursive, can't write to parent directory" $ do + createDir' (specDir `ba` "noWritable/foo") + noWritableDirPerms (specDir `ba` "noWritable") + (deleteDirRecursive' (specDir `ba` "noWritable/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied)) + normalDirPerms (specDir `ba` "noWritable") + deleteDir' (specDir `ba` "noWritable/foo") + + it "deleteDirRecursive, wrong file type (symlink to directory)" $ + deleteDirRecursive' (specDir `ba` "dirSym") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDirRecursive, wrong file type (regular file)" $ + deleteDirRecursive' (specDir `ba` "file") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDirRecursive, directory does not exist" $ + deleteDirRecursive' (specDir `ba` "doesNotExist") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + diff --git a/test/HPath/IO/DeleteDirSpec.hs b/test/HPath/IO/DeleteDirSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteDirSpec.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.DeleteDirSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/deleteDirSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.deleteDir" $ do + + -- successes -- + it "deleteDir, empty directory, all fine" $ do + createDir' (specDir `ba` "testDir") + deleteDir' (specDir `ba` "testDir") + getSymbolicLinkStatus (specDir `ba` "testDir") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDir, directory with null permissions, all fine" $ do + createDir' (specDir `ba` "noPerms/testDir") + noPerms (specDir `ba` "noPerms/testDir") + deleteDir' (specDir `ba` "noPerms/testDir") + getSymbolicLinkStatus (specDir `ba` "testDir") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteDir, wrong file type (symlink to directory)" $ + deleteDir' (specDir `ba` "dirSym") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDir, wrong file type (regular file)" $ + deleteDir' (specDir `ba` "file") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteDir, directory does not exist" $ + deleteDir' (specDir `ba` "doesNotExist") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteDir, directory not empty" $ + deleteDir' (specDir `ba` "dir") + `shouldThrow` + (\e -> ioeGetErrorType e == UnsatisfiedConstraints) + + it "deleteDir, can't open parent directory" $ do + createDir' (specDir `ba` "noPerms/foo") + noPerms (specDir `ba` "noPerms") + (deleteDir' (specDir `ba` "noPerms/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied)) + >> normalDirPerms (specDir `ba` "noPerms") + >> deleteDir' (specDir `ba` "noPerms/foo") + + it "deleteDir, can't write to parent directory, still fine" $ do + createDir' (specDir `ba` "noWritable/foo") + noWritableDirPerms (specDir `ba` "noWritable") + (deleteDir' (specDir `ba` "noWritable/foo") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied)) + normalDirPerms (specDir `ba` "noWritable") + deleteDir' (specDir `ba` "noWritable/foo") + + + diff --git a/test/HPath/IO/DeleteFileSpec.hs b/test/HPath/IO/DeleteFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/DeleteFileSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.DeleteFileSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Files.ByteString + ( + getSymbolicLinkStatus + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/deleteFileSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.deleteFile" $ do + + -- successes -- + it "deleteFile, regular file, all fine" $ do + createRegularFile' (specDir `ba` "testFile") + deleteFile' (specDir `ba` "testFile") + getSymbolicLinkStatus (specDir `ba` "testFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteFile, symlink, all fine" $ do + recreateSymlink' (specDir `ba` "syml") + (specDir `ba` "testFile") + deleteFile' (specDir `ba` "testFile") + getSymbolicLinkStatus (specDir `ba` "testFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + -- posix failures -- + it "deleteFile, wrong file type (directory)" $ + deleteFile' (specDir `ba` "dir") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "deleteFile, file does not exist" $ + deleteFile' (specDir `ba` "doesNotExist") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "deleteFile, can't read directory" $ + deleteFile' (specDir `ba` "noPerms/blah") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + diff --git a/test/HPath/IO/GetDirsFilesSpec.hs b/test/HPath/IO/GetDirsFilesSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/GetDirsFilesSpec.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.GetDirsFilesSpec where + + +import Control.Applicative + ( + (<$>) + ) +import Data.List + ( + sort + ) +import Data.Maybe + ( + fromJust + ) +import qualified HPath as P +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import System.Posix.Env.ByteString + ( + getEnv + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/getDirsFilesSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.getDirsFiles" $ do + + -- successes -- + it "getDirsFiles, all fine" $ do + pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs + expectedFiles <- mapM P.parseRel [(specDir `ba ` ".hidden") + ,(specDir `ba ` "Lala") + ,(specDir `ba ` "dir") + ,(specDir `ba ` "dirsym") + ,(specDir `ba ` "file") + ,(specDir `ba ` "noPerms") + ,(specDir `ba ` "syml")] + (fmap sort $ getDirsFiles' specDir) + `shouldReturn` fmap (pwd P.) expectedFiles + + -- posix failures -- + it "getDirsFiles, nonexistent directory" $ + getDirsFiles' (specDir `ba ` "nothingHere") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "getDirsFiles, wrong file type (file)" $ + getDirsFiles' (specDir `ba ` "file") + `shouldThrow` + (\e -> ioeGetErrorType e == InappropriateType) + + it "getDirsFiles, wrong file type (symlink to file)" $ + getDirsFiles' (specDir `ba ` "syml") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "getDirsFiles, wrong file type (symlink to dir)" $ + getDirsFiles' (specDir `ba ` "dirsym") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "getDirsFiles, can't open directory" $ + getDirsFiles' (specDir `ba ` "noPerms") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + + + diff --git a/test/HPath/IO/GetFileTypeSpec.hs b/test/HPath/IO/GetFileTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/GetFileTypeSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.GetFileTypeSpec where + + +import HPath.IO +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/getFileTypeSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.getFileType" $ do + + -- successes -- + it "getFileType, regular file" $ + getFileType' (specDir `ba` "regularfile") + `shouldReturn` RegularFile + + it "getFileType, directory" $ + getFileType' (specDir `ba` "directory") + `shouldReturn` Directory + + it "getFileType, directory with null permissions" $ + getFileType' (specDir `ba` "noPerms") + `shouldReturn` Directory + + it "getFileType, symlink to file" $ + getFileType' (specDir `ba` "symlink") + `shouldReturn` SymbolicLink + + it "getFileType, symlink to directory" $ + getFileType' (specDir `ba` "symlinkD") + `shouldReturn` SymbolicLink + + it "getFileType, broken symlink" $ + getFileType' (specDir `ba` "brokenSymlink") + `shouldReturn` SymbolicLink + + -- posix failures -- + it "getFileType, file does not exist" $ + getFileType' (specDir `ba` "nothingHere") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "getFileType, can't open directory" $ + getFileType' (specDir `ba` "noPerms/forz") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + diff --git a/test/HPath/IO/MoveFileOverwriteSpec.hs b/test/HPath/IO/MoveFileOverwriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/MoveFileOverwriteSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.MoveFileOverwriteSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/moveFileOverwriteSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.moveFileOverwrite" $ do + + -- successes -- + it "moveFileOverwrite, all fine" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "movedFile") + + it "moveFileOverwrite, all fine" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "dir/movedFile") + + it "moveFileOverwrite, all fine on symlink" $ + moveFileOverwrite' (specDir `ba` "myFileL") + (specDir `ba` "movedFile") + + it "moveFileOverwrite, all fine on directory" $ + moveFileOverwrite' (specDir `ba` "dir") + (specDir `ba` "movedFile") + + it "moveFileOverwrite, destination file already exists" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "alreadyExists") + + -- posix failures -- + it "moveFileOverwrite, source file does not exist" $ + moveFileOverwrite' (specDir `ba` "fileDoesNotExist") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "moveFileOverwrite, can't write to destination directory" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "noWritePerm/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFileOverwrite, can't open destination directory" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "noPerms/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFileOverwrite, can't open source directory" $ + moveFileOverwrite' (specDir `ba` "noPerms/myFile") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "moveFileOverwrite, move from file to dir" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + isDirDoesExist + + it "moveFileOverwrite, source and dest are same file" $ + moveFileOverwrite' (specDir `ba` "myFile") + (specDir `ba` "myFile") + `shouldThrow` + isSameFile + diff --git a/test/HPath/IO/MoveFileSpec.hs b/test/HPath/IO/MoveFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/MoveFileSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.MoveFileSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/moveFileSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.moveFile" $ do + + -- successes -- + it "moveFile, all fine" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "movedFile") + + it "moveFile, all fine" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "dir/movedFile") + + it "moveFile, all fine on symlink" $ + moveFile' (specDir `ba` "myFileL") + (specDir `ba` "movedFile") + + it "moveFile, all fine on directory" $ + moveFile' (specDir `ba` "dir") + (specDir `ba` "movedFile") + + -- posix failures -- + it "moveFile, source file does not exist" $ + moveFile' (specDir `ba` "fileDoesNotExist") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "moveFile, can't write to destination directory" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "noWritePerm/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile, can't open destination directory" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "noPerms/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "moveFile, can't open source directory" $ + moveFile' (specDir `ba` "noPerms/myFile") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "moveFile, destination file already exists" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "alreadyExists") + `shouldThrow` + isFileDoesExist + + it "moveFile, move from file to dir" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + isDirDoesExist + + it "moveFile, source and dest are same file" $ + moveFile' (specDir `ba` "myFile") + (specDir `ba` "myFile") + `shouldThrow` + isSameFile + diff --git a/test/HPath/IO/RecreateSymlinkSpec.hs b/test/HPath/IO/RecreateSymlinkSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/RecreateSymlinkSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.RecreateSymlinkSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/recreateSymlinkSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.recreateSymlink" $ do + + -- successes -- + it "recreateSymLink, all fine" $ do + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "movedFile") + removeFileIfExists (specDir `ba` "movedFile") + + it "recreateSymLink, all fine" $ do + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "dir/movedFile") + removeFileIfExists (specDir `ba` "dir/movedFile") + + -- posix failures -- + it "recreateSymLink, wrong input type (file)" $ + recreateSymlink' (specDir `ba` "myFile") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink, wrong input type (directory)" $ + recreateSymlink' (specDir `ba` "dir") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == InvalidArgument) + + it "recreateSymLink, can't write to destination directory" $ + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "noWritePerm/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink, can't open destination directory" $ + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "noPerms/movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink, can't open source directory" $ + recreateSymlink' (specDir `ba` "noPerms/myFileL") + (specDir `ba` "movedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "recreateSymLink, destination file already exists" $ + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "alreadyExists") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + it "recreateSymLink, destination already exists and is a dir" $ + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + (\e -> ioeGetErrorType e == AlreadyExists) + + -- custom failures -- + it "recreateSymLink, source and destination are the same file" $ + recreateSymlink' (specDir `ba` "myFileL") + (specDir `ba` "myFileL") + `shouldThrow` + isSameFile + diff --git a/test/HPath/IO/RenameFileSpec.hs b/test/HPath/IO/RenameFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/RenameFileSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.RenameFileSpec where + + +import Test.Hspec +import HPath.IO.Errors +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils +import qualified Data.ByteString as BS +import Data.ByteString.UTF8 (toString) + + +ba :: BS.ByteString -> BS.ByteString -> BS.ByteString +ba = BS.append + +specDir :: BS.ByteString +specDir = "test/HPath/IO/renameFileSpec/" + +specDir' :: String +specDir' = toString specDir + + +spec :: Spec +spec = + describe "HPath.IO.renameFile" $ do + + -- successes -- + it "renameFile, all fine" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "renamedFile") + + it "renameFile, all fine" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "dir/renamedFile") + + it "renameFile, all fine on symlink" $ + renameFile' (specDir `ba` "myFileL") + (specDir `ba` "renamedFile") + + it "renameFile, all fine on directory" $ + renameFile' (specDir `ba` "dir") + (specDir `ba` "renamedFile") + + -- posix failures -- + it "renameFile, source file does not exist" $ + renameFile' (specDir `ba` "fileDoesNotExist") + (specDir `ba` "renamedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "renameFile, can't write to output directory" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "noWritePerm/renamedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "renameFile, can't open output directory" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "noPerms/renamedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "renameFile, can't open source directory" $ + renameFile' (specDir `ba` "noPerms/myFile") + (specDir `ba` "renamedFile") + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + -- custom failures -- + it "renameFile, destination file already exists" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "alreadyExists") + `shouldThrow` + isFileDoesExist + + it "renameFile, move from file to dir" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "alreadyExistsD") + `shouldThrow` + isDirDoesExist + + it "renameFile, source and dest are same file" $ + renameFile' (specDir `ba` "myFile") + (specDir `ba` "myFile") + `shouldThrow` + isSameFile + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Hspec +import Test.Hspec.Runner +import Test.Hspec.Formatters +import qualified Spec +import Utils + + +-- TODO: chardev, blockdev, namedpipe, socket + + +main :: IO () +main = + hspecWith + defaultConfig { configFormatter = Just progress } + $ before_ fixPermissions + $ after_ revertPermissions + $ Spec.spec >> Spec.spec + where + noWriteDirs = ["test/HPath/IO/copyFileSpec/outputDirNoWrite" + ,"test/HPath/IO/copyFileOverwriteSpec/outputDirNoWrite" + ,"test/HPath/IO/copyDirRecursiveSpec/noWritePerm" + ,"test/HPath/IO/copyDirRecursiveOverwriteSpec/noWritePerm" + ,"test/HPath/IO/createDirSpec/noWritePerms" + ,"test/HPath/IO/createRegularFileSpec/noWritePerms" + ,"test/HPath/IO/renameFileSpec/noWritePerm" + ,"test/HPath/IO/moveFileSpec/noWritePerm" + ,"test/HPath/IO/moveFileOverwriteSpec/noWritePerm" + ,"test/HPath/IO/recreateSymlinkSpec/noWritePerm" + ] + noPermsDirs = ["test/HPath/IO/copyFileSpec/noPerms" + ,"test/HPath/IO/copyFileOverwriteSpec/noPerms" + ,"test/HPath/IO/copyDirRecursiveSpec/noPerms" + ,"test/HPath/IO/copyDirRecursiveOverwriteSpec/noPerms" + ,"test/HPath/IO/createDirSpec/noPerms" + ,"test/HPath/IO/createRegularFileSpec/noPerms" + ,"test/HPath/IO/renameFileSpec/noPerms" + ,"test/HPath/IO/moveFileSpec/noPerms" + ,"test/HPath/IO/moveFileOverwriteSpec/noPerms" + ,"test/HPath/IO/recreateSymlinkSpec/noPerms" + ,"test/HPath/IO/getFileTypeSpec/noPerms" + ,"test/HPath/IO/getDirsFilesSpec/noPerms" + ,"test/HPath/IO/deleteFileSpec/noPerms" + ] + fixPermissions = do + sequence_ $ fmap noWritableDirPerms noWriteDirs + sequence_ $ fmap noPerms noPermsDirs + revertPermissions = do + sequence_ $ fmap normalDirPerms noWriteDirs + sequence_ $ fmap normalDirPerms noPermsDirs + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +-- file test/Spec.hs +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Utils where + + +import Control.Applicative + ( + (<$>) + ) +import HPath.IO +import HPath.IO.Errors +import HPath.IO.Utils +import Data.Maybe + ( + fromJust + ) +import qualified HPath as P +import System.Posix.Env.ByteString + ( + getEnv + ) +import Data.ByteString + ( + ByteString + ) +import System.Posix.Files.ByteString + ( + groupExecuteMode + , groupReadMode + , nullFileMode + , otherExecuteMode + , otherReadMode + , ownerExecuteMode + , ownerReadMode + , setFileMode + , unionFileModes + ) + + + + ----------------- + --[ Utilities ]-- + ----------------- + + +withPwd :: ByteString -> (P.Path P.Abs -> IO a) -> IO a +withPwd ip f = do + pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs + p <- (pwd P.) <$> P.parseRel ip + f p + + +withPwd' :: ByteString + -> ByteString + -> (P.Path P.Abs -> P.Path P.Abs -> IO a) + -> IO a +withPwd' ip1 ip2 f = do + pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs + p1 <- (pwd P.) <$> P.parseRel ip1 + p2 <- (pwd P.) <$> P.parseRel ip2 + f p1 p2 + + +removeFileIfExists :: ByteString -> IO () +removeFileIfExists bs = + withPwd bs $ \p -> whenM (doesFileExist p) (deleteFile p) + + +removeDirIfExists :: ByteString -> IO () +removeDirIfExists bs = + withPwd bs $ \p -> whenM (doesDirectoryExist p) (deleteDirRecursive p) + + +copyFile' :: ByteString -> ByteString -> IO () +copyFile' inputFileP outputFileP = + withPwd' inputFileP outputFileP copyFile + + +copyFileOverwrite' :: ByteString -> ByteString -> IO () +copyFileOverwrite' inputFileP outputFileP = + withPwd' inputFileP outputFileP copyFileOverwrite + + +copyDirRecursive' :: ByteString -> ByteString -> IO () +copyDirRecursive' inputDirP outputDirP = + withPwd' inputDirP outputDirP copyDirRecursive + + +copyDirRecursiveOverwrite' :: ByteString -> ByteString -> IO () +copyDirRecursiveOverwrite' inputDirP outputDirP = + withPwd' inputDirP outputDirP copyDirRecursiveOverwrite + + +createDir' :: ByteString -> IO () +createDir' dest = withPwd dest createDir + + +createRegularFile' :: ByteString -> IO () +createRegularFile' dest = withPwd dest createRegularFile + + +renameFile' :: ByteString -> ByteString -> IO () +renameFile' inputFileP outputFileP = + withPwd' inputFileP outputFileP $ \i o -> do + renameFile i o + renameFile o i + + +moveFile' :: ByteString -> ByteString -> IO () +moveFile' inputFileP outputFileP = + withPwd' inputFileP outputFileP $ \i o -> do + moveFile i o + moveFile o i + + +moveFileOverwrite' :: ByteString -> ByteString -> IO () +moveFileOverwrite' inputFileP outputFileP = + withPwd' inputFileP outputFileP $ \i o -> do + moveFileOverwrite i o + moveFile o i + + +recreateSymlink' :: ByteString -> ByteString -> IO () +recreateSymlink' inputFileP outputFileP = + withPwd' inputFileP outputFileP recreateSymlink + + +noWritableDirPerms :: ByteString -> IO () +noWritableDirPerms path = withPwd path $ \p -> + setFileMode (P.fromAbs p) perms + where + perms = ownerReadMode + `unionFileModes` ownerExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` groupExecuteMode + `unionFileModes` otherReadMode + `unionFileModes` otherExecuteMode + + +noPerms :: ByteString -> IO () +noPerms path = withPwd path $ \p -> setFileMode (P.fromAbs p) nullFileMode + + +normalDirPerms :: ByteString -> IO () +normalDirPerms path = + withPwd path $ \p -> setFileMode (P.fromAbs p) newDirPerms + + +getFileType' :: ByteString -> IO FileType +getFileType' path = withPwd path getFileType + + +getDirsFiles' :: ByteString -> IO [P.Path P.Abs] +getDirsFiles' path = withPwd path getDirsFiles + + +deleteFile' :: ByteString -> IO () +deleteFile' p = withPwd p deleteFile + + +deleteDir' :: ByteString -> IO () +deleteDir' p = withPwd p deleteDir + + +deleteDirRecursive' :: ByteString -> IO () +deleteDirRecursive' p = withPwd p deleteDirRecursive + + +canonicalizePath' :: ByteString -> IO (P.Path P.Abs) +canonicalizePath' p = withPwd p canonicalizePath +