diff --git a/hpath.cabal b/hpath.cabal index 51dd7f2..2e0b862 100644 --- a/hpath.cabal +++ b/hpath.cabal @@ -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 diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs index d916a03..a2dc46a 100644 --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -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: diff --git a/test/HPath/IO/CreateDirRecursiveSpec.hs b/test/HPath/IO/CreateDirRecursiveSpec.hs new file mode 100644 index 0000000..ab09b3c --- /dev/null +++ b/test/HPath/IO/CreateDirRecursiveSpec.hs @@ -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) + + + diff --git a/test/Utils.hs b/test/Utils.hs index 3c93678..506de68 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -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' #-}