Add createDirRecursive, fixes #6

This commit is contained in:
Julian Ospald 2016-06-13 01:28:55 +02:00
parent ac381cbf60
commit 5b08e14b55
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 116 additions and 0 deletions

View File

@ -82,6 +82,7 @@ test-suite spec
HPath.IO.CopyFileOverwriteSpec
HPath.IO.CopyFileSpec
HPath.IO.CreateDirSpec
HPath.IO.CreateDirRecursiveSpec
HPath.IO.CreateRegularFileSpec
HPath.IO.CreateSymlinkSpec
HPath.IO.DeleteDirRecursiveSpec

View File

@ -55,6 +55,7 @@ module HPath.IO
-- * File creation
, createRegularFile
, createDir
, createDirRecursive
, createSymlink
-- * File renaming/moving
, renameFile
@ -115,9 +116,11 @@ import Foreign.C.Error
(
eEXIST
, eINVAL
, eNOENT
, eNOSYS
, eNOTEMPTY
, eXDEV
, getErrno
)
import Foreign.C.Types
(
@ -683,6 +686,37 @@ createDir :: FileMode -> Path Abs -> IO ()
createDir fm dest = createDirectory (fromAbs dest) 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:
--
-- @
-- mkdir -p \/destination\/somedir
-- @
--
-- Safety/reliability concerns:
--
-- * not atomic
--
-- Throws:
--
-- - `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
createDirRecursive :: FileMode -> Path Abs -> IO ()
createDirRecursive fm dest =
catchIOError (createDirectory (fromAbs dest) fm) $ \e -> do
errno <- getErrno
isd <- doesDirectoryExist dest
case errno of
en | en == eEXIST && isd -> return ()
| en == eNOENT -> createDirRecursive fm (dirname dest)
>> createDirectory (fromAbs dest) fm
| otherwise -> ioError e
-- |Create a symlink.
--
-- Throws:

View File

@ -0,0 +1,78 @@
{-# LANGUAGE OverloadedStrings #-}
module HPath.IO.CreateDirRecursiveSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
upTmpDir :: IO ()
upTmpDir = do
setTmpDir "CreateDirRecursiveSpec"
createTmpDir
setupFiles :: IO ()
setupFiles = do
createDir' "alreadyExists"
createRegularFile' "alreadyExistsF"
createDir' "noPerms"
createDir' "noWritePerms"
noPerms "noPerms"
noWritableDirPerms "noWritePerms"
cleanupFiles :: IO ()
cleanupFiles = do
normalDirPerms "noPerms"
normalDirPerms "noWritePerms"
deleteDir' "alreadyExists"
deleteDir' "noPerms"
deleteDir' "noWritePerms"
deleteFile' "alreadyExistsF"
spec :: Spec
spec = beforeAll_ (upTmpDir >> setupFiles) $ afterAll_ cleanupFiles $
describe "HPath.IO.createDirRecursive" $ do
-- successes --
it "createDirRecursive, all fine" $ do
createDirRecursive' "newDir"
deleteDir' "newDir"
it "createDirRecursive, parent directories do not exist" $ do
createDirRecursive' "some/thing/dada"
deleteDir' "some/thing/dada"
deleteDir' "some/thing"
deleteDir' "some"
it "createDirRecursive, destination directory already exists" $
createDirRecursive' "alreadyExists"
-- posix failures --
it "createDirRecursive, destination already exists and is a file" $
createDirRecursive' "alreadyExistsF"
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "createDirRecursive, can't write to output directory" $
createDirRecursive' "noWritePerms/newDir"
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createDirRecursive, can't open output directory" $
createDirRecursive' "noPerms/newDir"
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

View File

@ -182,6 +182,9 @@ createDir' :: ByteString -> IO ()
{-# NOINLINE createDir' #-}
createDir' dest = withTmpDir dest (createDir newDirPerms)
createDirRecursive' :: ByteString -> IO ()
{-# NOINLINE createDirRecursive' #-}
createDirRecursive' dest = withTmpDir dest (createDirRecursive newDirPerms)
createRegularFile' :: ByteString -> IO ()
{-# NOINLINE createRegularFile' #-}