tests/createDirectoryIfMissing001.hs

   1 module Main(main) where
   2
   3 import Control.Concurrent
   4 import Control.Monad
   5 import Control.Exception
   6 import System.Directory
   7 import System.FilePath
   8 import System.IO.Error hiding (try)
   9
  10 testdir = "createDirectoryIfMissing001.d"
  11 testdir_a = testdir </> "a"
  12
  13 main = do
  14   cleanup
  15
  16   report $ createDirectoryIfMissing False testdir
  17   cleanup
  18
  19   report $ createDirectoryIfMissing False testdir_a
  20    -- should fail with does not exist
  21
  22   report $ createDirectoryIfMissing True testdir_a
  23    -- should succeed with no error
  24   report $ createDirectoryIfMissing False testdir_a
  25    -- should succeed with no error
  26   report $ createDirectoryIfMissing False (addTrailingPathSeparator testdir_a)
  27    -- should succeed with no error
  28
  29   cleanup
  30   report $ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a)
  31
  32   -- look for race conditions: #2808.  This fails with
  33   -- +RTS -N2 and directory 1.0.0.2.
  34   m <- newEmptyMVar
  35   forkIO $ do replicateM_ 10000 create; putMVar m ()
  36   forkIO $ do replicateM_ 10000 cleanup; putMVar m ()
  37   replicateM_ 2 $ takeMVar m
  38
  39 -- This test fails on Windows; see #2924
  40 --  replicateM_ 2 $
  41 --     forkIO $ do replicateM_ 5000 (do create; cleanup); putMVar m ()
  42 --  replicateM_ 2 $ takeMVar m
  43
  44   cleanup
  45
  46 -- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if
  47 -- another process/thread removes one of the directories during the proces
  48 -- of creating the hierarchy.
  49 create = tryJust (guard . isDoesNotExistError) $ createDirectoryIfMissing True testdir_a
  50
  51 cleanup = ignore $ removeDirectoryRecursive testdir
  52
  53 report :: Show a => IO a -> IO ()
  54 report io = do
  55   r <- try io
  56   case r of
  57    Left e  -> print (e :: SomeException)
  58    Right a -> print a
  59
  60 ignore :: IO a -> IO ()
  61 ignore io = do
  62   r <- try io
  63   case r of
  64    Left e  -> let _ = e :: SomeException in return ()
  65    Right a -> return ()