diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history for hpath-io +## 0.11.0 -- 2020-01-18 + +* `writeFile` not allows to set file mode and create file if it does not exist (this broke API) +* added various new functions: + * createDirIfMissing + * writeFileL (for lazy bytestring) + * isReadable + * isExecutable + * getModificationTime + * setModificationTime + * setModificationTimeHiRes + * getDirsFiles' (returns filenames instead of paths) + * withRawFilePath + * withHandle + ## 0.10.1 -- 2020-01-13 * Move file check functions to HPath.IO diff --git a/hpath-io.cabal b/hpath-io.cabal --- a/hpath-io.cabal +++ b/hpath-io.cabal @@ -1,5 +1,5 @@ name: hpath-io -version: 0.10.1 +version: 0.11.0 synopsis: High-level IO operations on files/directories description: High-level IO operations on files/directories, utilizing type-safe Paths -- bug-reports: @@ -33,14 +33,17 @@ c-sources: cbits/dirutils.c other-modules: Streamly.ByteString + Streamly.ByteString.Lazy -- other-extensions: build-depends: base >= 4.8 && <5 , IfElse , bytestring >= 0.10.0.0 + , exceptions , hpath >= 0.10 && < 0.11 - , hpath-filepath >= 0.10 && < 0.11 + , hpath-filepath >= 0.10.2 && < 0.11 , safe-exceptions >= 0.1 , streamly >= 0.7 + , time >= 1.8 , unix >= 2.5 , unix-bytestring , utf8-string @@ -65,6 +68,7 @@ HPath.IO.CopyDirRecursiveSpec HPath.IO.CopyFileOverwriteSpec HPath.IO.CopyFileSpec + HPath.IO.CreateDirIfMissingSpec HPath.IO.CreateDirRecursiveSpec HPath.IO.CreateDirSpec HPath.IO.CreateRegularFileSpec @@ -81,6 +85,7 @@ HPath.IO.RecreateSymlinkSpec HPath.IO.RenameFileSpec HPath.IO.ToAbsSpec + HPath.IO.WriteFileLSpec HPath.IO.WriteFileSpec Spec Utils @@ -93,6 +98,7 @@ , hpath-io , hspec >= 1.3 , process + , time >= 1.8 , unix , unix-bytestring , utf8-string diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -60,6 +60,7 @@ -- * File creation , createRegularFile , createDir + , createDirIfMissing , createDirRecursive , createSymlink -- * File renaming/moving @@ -70,6 +71,7 @@ , readFileStream -- * File writing , writeFile + , writeFileL , appendFile -- * File permissions , newFilePerms @@ -78,15 +80,24 @@ , doesExist , doesFileExist , doesDirectoryExist + , isReadable , isWritable + , isExecutable , canOpenDirectory + -- * File times + , getModificationTime + , setModificationTime + , setModificationTimeHiRes -- * Directory reading , getDirsFiles + , getDirsFiles' -- * Filetype operations , getFileType -- * Others , canonicalizePath , toAbs + , withRawFilePath + , withHandle ) where @@ -99,7 +110,9 @@ ( IOException , bracket + , bracketOnError , throwIO + , finally ) import Control.Monad ( @@ -107,6 +120,7 @@ , void , when ) +import Control.Monad.Catch (MonadThrow(..)) import Control.Monad.IfElse ( unlessM @@ -115,6 +129,8 @@ ( ByteString ) +import Data.Traversable ( for ) +import Data.Functor ( ($>) ) #if MIN_VERSION_bytestring(0,10,2) import Data.ByteString.Builder #else @@ -150,6 +166,8 @@ (<>) , mempty ) +import Data.Time.Clock +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Word ( Word8 @@ -184,6 +202,7 @@ import Prelude hiding (appendFile, readFile, writeFile) import Streamly import Streamly.ByteString +import qualified Streamly.ByteString.Lazy as SL import qualified Streamly.Data.Fold as FL import Streamly.Memory.Array import qualified Streamly.FileSystem.Handle as FH @@ -234,6 +253,7 @@ , setFileMode , unionFileModes ) +import qualified System.Posix.FilePath as FP 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 @@ -249,7 +269,9 @@ FileMode , ProcessID , Fd + , EpochTime ) +import System.Posix.Time @@ -716,7 +738,18 @@ createDir :: FileMode -> Path b -> IO () createDir fm (MkPath destBS) = createDirectory destBS fm +-- |Create an empty directory at the given directory with the given filename. +-- +-- Throws: +-- +-- - `PermissionDenied` if output directory cannot be written to +-- - `NoSuchThing` if any of the parent components of the path +-- do not exist +createDirIfMissing :: FileMode -> Path b -> IO () +createDirIfMissing fm (MkPath destBS) = + hideError AlreadyExists $ createDirectory destBS fm + -- |Create an empty directory at the given directory with the given filename. -- All parent directories are created with the same filemode. This -- basically behaves like: @@ -734,7 +767,7 @@ -- - `PermissionDenied` if any part of the path components do not -- exist and cannot be written to -- - `AlreadyExists` if destination already exists and --- is not a directory +-- is *not* a directory -- -- Note: calls `getcwd` if the input path is a relative path createDirRecursive :: FileMode -> Path b -> IO () @@ -922,7 +955,7 @@ -- |Write a given ByteString to a file, truncating the file beforehand. --- The file must exist. Follows symlinks. +-- Follows symlinks. -- -- Throws: -- @@ -930,12 +963,36 @@ -- - `PermissionDenied` if we cannot read the file or the directory -- containting it -- - `NoSuchThing` if the file does not exist -writeFile :: Path b -> ByteString -> IO () -writeFile (MkPath fp) bs = - bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] Nothing) (SPI.closeFd) $ \fd -> - void $ SPB.fdWrite fd bs +writeFile :: Path b + -> Maybe FileMode -- ^ if Nothing, file must exist + -> ByteString + -> IO () +writeFile (MkPath fp) fmode bs = + bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs +-- |Write a given lazy ByteString to a file, truncating the file beforehand. +-- Follows symlinks. +-- +-- Throws: +-- +-- - `InappropriateType` if file is not a regular file or a symlink +-- - `PermissionDenied` if we cannot read the file or the directory +-- containting it +-- - `NoSuchThing` if the file does not exist +-- +-- Note: uses streamly under the hood +writeFileL :: Path b + -> Maybe FileMode -- ^ if Nothing, file must exist + -> L.ByteString + -> IO () +writeFileL (MkPath fp) fmode lbs = do + handle <- bracketOnError (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ SPI.fdToHandle + finally (streamlyCopy handle) (SIO.hClose handle) + where + streamlyCopy tH = S.fold (FH.writeChunks tH) $ SL.fromByteString lbs + + -- |Append a given ByteString to a file. -- The file must exist. Follows symlinks. -- @@ -1022,6 +1079,16 @@ $ return False +-- |Checks whether a file or folder is readable. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +isReadable :: Path b -> IO Bool +isReadable (MkPath bs) = fileAccess bs True False False + -- |Checks whether a file or folder is writable. -- -- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). @@ -1033,6 +1100,18 @@ isWritable (MkPath bs) = fileAccess bs False True False +-- |Checks whether a file or folder is executable. +-- +-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False). +-- +-- Throws: +-- +-- - `NoSuchThing` if the file does not exist +isExecutable :: Path b -> IO Bool +isExecutable (MkPath bs) = fileAccess bs False False True + + + -- |Checks whether the directory at the given path exists and can be -- opened. This invokes `openDirStream` which follows symlinks. canOpenDirectory :: Path b -> IO Bool @@ -1046,6 +1125,30 @@ + ------------------ + --[ File times ]-- + ------------------ + + +getModificationTime :: Path b -> IO UTCTime +getModificationTime (MkPath bs) = do + fs <- PF.getFileStatus bs + pure $ posixSecondsToUTCTime $ PF.modificationTimeHiRes fs + +setModificationTime :: Path b -> EpochTime -> IO () +setModificationTime (MkPath bs) t = do + -- TODO: setFileTimes doesn't allow to pass NULL to utime + ctime <- epochTime + PF.setFileTimes bs ctime t + +setModificationTimeHiRes :: Path b -> POSIXTime -> IO () +setModificationTimeHiRes (MkPath bs) t = do + -- TODO: setFileTimesHiRes doesn't allow to pass NULL to utimes + ctime <- getPOSIXTime + PF.setFileTimesHiRes bs ctime t + + + ------------------------- --[ Directory reading ]-- ------------------------- @@ -1063,17 +1166,25 @@ -- - `InappropriateType` if file type is wrong (symlink to file) -- - `InappropriateType` if file type is wrong (symlink to dir) -- - `PermissionDenied` if directory cannot be opened +-- - `PathParseException` if a filename could not be parsed (should never happen) getDirsFiles :: Path b -- ^ dir to read -> IO [Path b] getDirsFiles p@(MkPath fp) = do + contents <- getDirsFiles' p + pure $ fmap (p ) contents + + +-- | Like 'getDirsFiles', but returns the filename only, instead +-- of prepending the base path. +getDirsFiles' :: Path b -- ^ dir to read + -> IO [Path Fn] +getDirsFiles' p@(MkPath fp) = do fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing - return - . catMaybes - . fmap (\x -> () p <$> (parseMaybe . snd $ x)) - =<< getDirectoryContents' fd - where - parseMaybe :: ByteString -> Maybe (Path Fn) - parseMaybe = parseFn + rawContents <- getDirectoryContents' fd + fmap catMaybes $ for rawContents $ \(_, f) -> + if FP.isSpecialDirectoryEntry f + then pure Nothing + else fmap Just $ parseFn f @@ -1139,3 +1250,37 @@ cwd <- getWorkingDirectory >>= parseAbs rel <- parseRel bs -- we know it must be relative now return $ cwd rel + + +-- | Helper function to use the Path library without +-- buying into the Path type too much. This uses 'parseAny' +-- under the hood and may throw `PathParseException`. +-- +-- Throws: +-- +-- - `PathParseException` if the bytestring could neither be parsed as +-- relative or absolute Path +withRawFilePath :: MonadThrow m => ByteString -> (Path a -> m b) -> m b +withRawFilePath bs action = do + path <- parseAny bs + action path + + +-- | Convenience function to open the path as a handle. +-- +-- If the file does not exist, it will be created with 'newFilePerms'. +-- +-- Throws: +-- +-- - `PathParseException` if the bytestring could neither be parsed as +-- relative or absolute Path +withHandle :: ByteString + -> SPI.OpenMode + -> ((SIO.Handle, Path a) -> IO a) + -> IO a +withHandle bs mode action = do + path <- parseAny bs + handle <- + bracketOnError (openFd bs mode [] (Just newFilePerms)) (SPI.closeFd) + $ SPI.fdToHandle + finally (action (handle, path)) (SIO.hClose handle) diff --git a/src/HPath/IO/Errors.hs b/src/HPath/IO/Errors.hs --- a/src/HPath/IO/Errors.hs +++ b/src/HPath/IO/Errors.hs @@ -38,6 +38,7 @@ , catchErrno , rethrowErrnoAs , handleIOError + , hideError , bracketeer , reactOnError ) @@ -281,9 +282,13 @@ handleIOError = flip catchIOError +hideError :: IOErrorType -> IO () -> IO () +hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e) + + -- |Like `bracket`, but allows to have different clean-up -- actions depending on whether the in-between computation --- has raised an exception or not. +-- 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 diff --git a/src/Streamly/ByteString/Lazy.hs b/src/Streamly/ByteString/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/ByteString/Lazy.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.ByteString.Lazy where + +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString, foldlChunks, fromChunks) +import Data.ByteString.Unsafe +import Data.Word (Word8) +import Foreign.ForeignPtr +import Foreign.ForeignPtr.Unsafe +import Foreign.Ptr (castPtr, minusPtr, plusPtr) +import Prelude hiding (length) +import Streamly +import Streamly.ByteString (arrayToByteString, byteStringToArray) +import Streamly.Memory.Array +import qualified Streamly.Prelude as S + +toByteString :: + forall m. (MonadIO m, MonadAsync m) + => SerialT m (Array Word8) + -> m ByteString +toByteString stream = do + ys :: [BS.ByteString] <- S.toList $ S.mapM arrayToByteString stream + pure $ fromChunks ys + +stepFunction :: + forall m. (MonadIO m) + => SerialT m (Array Word8) + -> BS.ByteString + -> SerialT m (Array Word8) +stepFunction stream1 bs = do + arr <- liftIO $ byteStringToArray bs + let stream2 = pure arr + stream1 <> stream2 + +fromByteString :: + forall m. (MonadIO m) + => ByteString + -> SerialT m (Array Word8) +fromByteString bs = foldlChunks stepFunction mempty bs + diff --git a/test/HPath/IO/CreateDirIfMissingSpec.hs b/test/HPath/IO/CreateDirIfMissingSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/CreateDirIfMissingSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HPath.IO.CreateDirIfMissingSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "CreateDirIfMissingSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createDir' "alreadyExists" + createDir' "noPerms" + createDir' "noWritePerms" + noPerms "noPerms" + noWritableDirPerms "noWritePerms" + + + +cleanupFiles :: IO () +cleanupFiles = do + normalDirPerms "noPerms" + normalDirPerms "noWritePerms" + deleteDir' "alreadyExists" + deleteDir' "noPerms" + deleteDir' "noWritePerms" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "HPath.IO.CreateDirIfMissing" $ do + + -- successes -- + it "createDirIfMissing, all fine" $ do + createDirIfMissing' "newDir" + removeDirIfExists "newDir" + + it "createDirIfMissing, destination directory already exists" $ + createDirIfMissing' "alreadyExists" + + -- posix failures -- + it "createDirIfMissing, parent directories do not exist" $ + createDirIfMissing' "some/thing/dada" + `shouldThrow` + (\e -> ioeGetErrorType e == NoSuchThing) + + it "createDirIfMissing, can't write to output directory" $ + createDirIfMissing' "noWritePerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) + + it "createDirIfMissing, can't open output directory" $ + createDirIfMissing' "noPerms/newDir" + `shouldThrow` + (\e -> ioeGetErrorType e == PermissionDenied) diff --git a/test/HPath/IO/GetDirsFilesSpec.hs b/test/HPath/IO/GetDirsFilesSpec.hs --- a/test/HPath/IO/GetDirsFilesSpec.hs +++ b/test/HPath/IO/GetDirsFilesSpec.hs @@ -8,7 +8,7 @@ sort ) import qualified HPath as P -import HPath.IO +import HPath.IO hiding (getDirsFiles') import Test.Hspec import System.IO.Error ( diff --git a/test/HPath/IO/WriteFileLSpec.hs b/test/HPath/IO/WriteFileLSpec.hs new file mode 100644 --- /dev/null +++ b/test/HPath/IO/WriteFileLSpec.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module HPath.IO.WriteFileLSpec where + + +import Test.Hspec +import System.IO.Error + ( + ioeGetErrorType + ) +import GHC.IO.Exception + ( + IOErrorType(..) + ) +import Utils + + + +upTmpDir :: IO () +upTmpDir = do + setTmpDir "WriteFileLSpec" + createTmpDir + +setupFiles :: IO () +setupFiles = do + createRegularFile' "fileWithContent" + createRegularFile' "fileWithoutContent" + createSymlink' "inputFileSymL" "fileWithContent" + createDir' "alreadyExistsD" + createRegularFile' "noPerms" + noPerms "noPerms" + createDir' "noPermsD" + createRegularFile' "noPermsD/inputFile" + noPerms "noPermsD" + writeFile' "fileWithContent" "BLKASL" + + +cleanupFiles :: IO () +cleanupFiles = do + deleteFile' "fileWithContent" + deleteFile' "fileWithoutContent" + deleteFile' "inputFileSymL" + deleteDir' "alreadyExistsD" + normalFilePerms "noPerms" + deleteFile' "noPerms" + normalDirPerms "noPermsD" + deleteFile' "noPermsD/inputFile" + deleteDir' "noPermsD" + + +spec :: Spec +spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $ + describe "HPath.IO.WriteFileL" $ do + + -- successes -- + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "blahfaselllll" + out <- readFile' "fileWithContent" + out `shouldBe` "blahfaselllll" + + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "gagagaga" + out <- readFile' "fileWithContent" + out `shouldBe` "gagagaga" + + it "WriteFileL file with content, everything clear" $ do + writeFileL' "fileWithContent" "" + out <- readFile' "fileWithContent" + out `shouldBe` "" + + it "WriteFileL file without content, everything clear" $ do + writeFileL' "fileWithoutContent" "blahfaselllll" + out <- readFile' "fileWithoutContent" + out `shouldBe` "blahfaselllll" + + it "WriteFileL, everything clear" $ do + writeFileL' "fileWithoutContent" "gagagaga" + out <- readFile' "fileWithoutContent" + out `shouldBe` "gagagaga" + + it "WriteFileL symlink, everything clear" $ do + writeFileL' "inputFileSymL" "blahfaselllll" + out <- readFile' "inputFileSymL" + out `shouldBe` "blahfaselllll" + + it "WriteFileL symlink, everything clear" $ do + writeFileL' "inputFileSymL" "gagagaga" + out <- readFile' "inputFileSymL" + out `shouldBe` "gagagaga" + + + -- posix failures -- + it "WriteFileL to dir, inappropriate type" $ do + writeFileL' "alreadyExistsD" "" + `shouldThrow` (\e -> ioeGetErrorType e == InappropriateType) + + it "WriteFileL, no permissions to file" $ do + writeFileL' "noPerms" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "WriteFileL, no permissions to file" $ do + writeFileL' "noPermsD/inputFile" "" + `shouldThrow` (\e -> ioeGetErrorType e == PermissionDenied) + + it "WriteFileL, file does not exist" $ do + writeFileL' "gaga" "" + `shouldThrow` (\e -> ioeGetErrorType e == NoSuchThing) diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -19,6 +19,7 @@ whenM ) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.IORef ( newIORef @@ -163,6 +164,10 @@ {-# NOINLINE createDir' #-} createDir' dest = withTmpDir dest (createDir newDirPerms) +createDirIfMissing' :: ByteString -> IO () +{-# NOINLINE createDirIfMissing' #-} +createDirIfMissing' dest = withTmpDir dest (createDirIfMissing newDirPerms) + createDirRecursive' :: ByteString -> IO () {-# NOINLINE createDirRecursive' #-} createDirRecursive' dest = withTmpDir dest (createDirRecursive newDirPerms) @@ -262,8 +267,13 @@ writeFile' :: ByteString -> ByteString -> IO () {-# NOINLINE writeFile' #-} -writeFile' ip bs = - withTmpDir ip $ \p -> writeFile p bs +writeFile' ip bs = + withTmpDir ip $ \p -> writeFile p Nothing bs + +writeFileL' :: ByteString -> BSL.ByteString -> IO () +{-# NOINLINE writeFileL' #-} +writeFileL' ip bs = + withTmpDir ip $ \p -> writeFileL p Nothing bs appendFile' :: ByteString -> ByteString -> IO ()