1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
{- directory creating
-
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory.Create (
createDirectoryUnder,
createDirectoryUnder',
) where
import Control.Monad
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.IfElse
import System.IO.Error
import Data.Maybe
import Prelude
import Utility.SystemDirectory
import Utility.Path.AbsRel
import Utility.Exception
import Utility.OsPath
import Utility.PartialPrelude
{- Like createDirectoryIfMissing True, but it will only create
- missing parent directories up to but not including a directory
- from the first parameter.
-
- For example, createDirectoryUnder ["/tmp/foo"] "/tmp/foo/bar/baz"
- will create /tmp/foo/bar if necessary, but if /tmp/foo does not exist,
- it will throw an exception.
-
- The exception thrown is the same that createDirectory throws if the
- parent directory does not exist.
-
- If the second FilePath is not under the first
- FilePath (or the same as it), it will fail with an exception
- even if the second FilePath's parent directory already exists.
-
- The FilePaths can be relative, or absolute.
- They will be normalized as necessary.
-
- Note that, the second FilePath, if relative, is relative to the current
- working directory.
-}
createDirectoryUnder :: [OsPath] -> OsPath -> IO ()
createDirectoryUnder topdirs dir =
createDirectoryUnder' topdirs dir createDirectory
createDirectoryUnder'
:: (MonadIO m, MonadCatch m)
=> [OsPath]
-> OsPath
-> (OsPath -> m ())
-> m ()
createDirectoryUnder' topdirs dir0 mkdir = do
relps <- liftIO $ forM topdirs $ \topdir -> relPathDirToFile topdir dir0
let relparts = map splitDirectories relps
-- Catch cases where dir0 is not beneath a topdir.
-- If the relative path between them starts with "..",
-- it's not. And on Windows, if they are on different drives,
-- the path will not be relative.
let notbeneath = \(_topdir, (relp, dirs)) ->
headMaybe dirs /= Just (literalOsPath "..") && not (isAbsolute relp)
case filter notbeneath $ zip topdirs (zip relps relparts) of
((topdir, (_relp, dirs)):_)
-- If dir0 is the same as the topdir, don't try to
-- create it, but make sure it does exist.
| null dirs ->
liftIO $ unlessM (doesDirectoryExist topdir) $
ioError $ customerror doesNotExistErrorType $
"createDirectoryUnder: " ++ fromOsPath topdir ++ " does not exist"
| otherwise -> createdirs $
map (topdir </>) (reverse (scanl1 (</>) dirs))
_ -> liftIO $ ioError $ customerror userErrorType
("createDirectoryUnder: not located in " ++ unwords (map fromOsPath topdirs))
where
customerror t s = mkIOError t s Nothing (Just (fromOsPath dir0))
createdirs [] = pure ()
createdirs (dir:[]) = createdir dir (liftIO . ioError)
createdirs (dir:dirs) = createdir dir $ \_ -> do
createdirs dirs
createdir dir (liftIO . ioError)
-- This is the same method used by createDirectoryIfMissing,
-- in particular the handling of errors that occur when the
-- directory already exists. See its source for explanation
-- of several subtleties.
createdir dir notexisthandler = tryIO (mkdir dir) >>= \case
Right () -> pure ()
Left e
| isDoesNotExistError e -> notexisthandler e
| isAlreadyExistsError e || isPermissionError e ->
liftIO $ unlessM (doesDirectoryExist dir) $
ioError e
| otherwise -> liftIO $ ioError e
|
