Add createDirRecursive, fixes #6

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

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:

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)
+
+
+

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' #-}