-
Notifications
You must be signed in to change notification settings - Fork 17
/
redo.hs
230 lines (219 loc) · 12.3 KB
/
redo.hs
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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK prune #-}
module Main where
import Control.Exception (catch, catchJust, IOException)
import Control.Monad (filterM, liftM, unless, guard)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Digest.Pure.MD5 as MD5
import Data.Map.Lazy (insert, fromList, toList, adjust)
import Data.Maybe (listToMaybe)
-- import Debug.Trace (traceShow)
import GHC.IO.Exception (IOErrorType(..))
import System.Directory (renameFile, removeFile, doesFileExist, getDirectoryContents, removeDirectoryRecursive, createDirectoryIfMissing, getCurrentDirectory, setCurrentDirectory)
import System.Environment (getArgs, getEnvironment, getProgName, lookupEnv)
import System.Exit (ExitCode(..), exitWith)
import System.FilePath (hasExtension, replaceBaseName, takeBaseName, (</>), splitFileName)
import System.IO (hPutStrLn, stderr, hGetLine, withFile, IOMode(..), hFileSize)
import System.IO.Error (ioeGetErrorType, isDoesNotExistError)
import System.Process (createProcess, waitForProcess, shell, CreateProcess(..))
-- traceShow' arg = traceShow arg arg
-- | This is the directory that redo will store and read metadata on targets from.
metaDir = ".redo"
main :: IO ()
main = do
-- The redo function depends on the given target existing in the current
-- working directory. We keep track of the directory we were invoked from
-- here, changing the current working directory as necessary for each target
-- specified on the commandline.
topDir <- getCurrentDirectory
getArgs >>= mapM_ (\arg -> do
-- Separate out the directory component from the target. If there was no
-- directory specified, dir will we "./".
let (dir, file) = splitFileName arg
setCurrentDirectory dir
-- redo doesn't make use of dir other than to use it to output a "progress"
-- line if it decides that it needs to rebuild the target. I'd like to get
-- rid of this argument, but it will require non-trivial refactoring.
redo file dir
setCurrentDirectory topDir)
progName <- getProgName
-- The `REDO_TARGET` environment variable is set when `redo` or
-- `redo-ifchange` is spawned by another `redo` process. This lets us know
-- that we're in a recursive context and its value tells us the name of the
-- parent target. TODO: Maybe this should be renamed to REDO_PARENT_TARGET?
redoTarget' <- lookupEnv "REDO_TARGET"
-- We look at the name that we were invoked as to determine how to behave.
-- Doing so allows us to share functionality between `redo` and
-- `redo-ifchange` without building 2 separate programs: instead we can just
-- symlink `redo-ifchange` to `redo` (or make a copy if symlinks aren't
-- available on the filesystem).
case (progName, redoTarget') of
-- The only thing special about `redo-ifchange` is that it writes out MD5
-- information for the dependencies it was provided with. For example, a
-- .do script like:
-- redo-ifchange source.hs
-- tells later invocations of redo to check if source.hs has changed, whereas
-- redo source.hs
-- effectively says to rebuild source.hs if necessary but don't note it as
-- a dependency of this target. Thinking about this, I can't really see a
-- useful case for doing so, so later versions of redo might instead change
-- the meaning to be "force the (re)building of this dependency".
("redo-ifchange", Just redoTarget) -> mapM_ (writeMD5 redoTarget) =<< getArgs
("redo-ifchange", Nothing) -> error "Missing REDO_TARGET environment variable."
-- There's no case here for "redo" because it doesn't do any bookkeeping.
_ -> return ()
-- | Rebuild a given target if it's out-of-date or doesn't exist.
redo :: String -- ^ target (file) name
-> FilePath -- ^ the current directory (for output purposes only)
-> IO ()
redo target dir = do
upToDate' <- upToDate target
unless upToDate' $ maybe missingDo redo' =<< doPath target
where redo' :: FilePath -> IO ()
redo' path = do
-- At this point, we know that the target is out-of-date so we're just
-- going to rebuild it. We send a progress line to stderr to let the
-- user know that we're now (re)building this target. This should be
-- the only place that the `dir` argument is used.
hPutStrLn stderr $ "redo " ++ (if dir == "./" then "" else dir) ++ target
-- Remove the contents of the `.redo/target` metadata directory if it
-- exists because it's possibly stale (we're going to get a fresh list
-- of dependencies when we run the .do script).
catchJust (guard . isDoesNotExistError)
(removeDirectoryRecursive metaDepsDir)
(\_ -> return ())
createDirectoryIfMissing True metaDepsDir
-- A redo target implicitly depends on the .do script for the target
-- itself, so we note that here by writing out the MD5 for the .do
-- script.
writeMD5 target path
-- Read the existing environment variable list so that we can
-- append/overwrite the REDO_TARGET variable with the value of the
-- current target. Any `redo-ifchange` call in the .do script depends
-- on this information.
oldEnv <- getEnvironment
-- TODO: Remove `.` from the PATH now that we have an install target.
let newEnv = toList $ adjust (++ ":.") "PATH" $ insert "REDO_TARGET" target $ fromList oldEnv
(_, _, _, ph) <- createProcess $ (shell $ cmd path) {env = Just newEnv}
-- Wait for this .do script (and any recursive invocations of `redo`
-- or `redo-ifchange`) to complete before continuing.
exit <- waitForProcess ph
case exit of
ExitSuccess -> do
-- OK, the target (temporary) file is presumed to have been built
-- correctly. If the file is 0 bytes, the .do script didn't
-- produce any output. Since there was no error indicated by the
-- build script, we consider this a "phony" or empty target. An
-- example of an empty target is "install.do": it takes an action
-- somewhere but doesn't produce a file in the current directory.
size <- fileSize tmp
if size > 0
-- Valid output produced, atomically rename it in place.
then renameFile tmp target
else removeFile tmp
-- If the .do script returns a non-zero error code for any reason,
-- we consider the build to have failed, output a message on stderr,
-- and remove the temporary file. This means that the target file
-- shouldn't be touched.
ExitFailure code -> do hPutStrLn stderr $ "Redo script exited with non-zero exit code: " ++ show code
removeFile tmp
exitWith $ ExitFailure code
-- The temporary file name is simply target---redoing, arbitrarily
-- chosen to match the implementation of redo in Alan Grosskurth's
-- thesis paper.
-- TODO: As suggested by viewer Rotten194, we probably want to switch to
-- using a file in the temporary file system, taking advantage of any
-- faster/restricted temporary file system (RAM, partition, etc.).
tmp = target ++ "---redoing"
-- Every target in the current directory records dependencies in the
-- directory .redo/target
metaDepsDir = metaDir </> target
missingDo = do
exists <- doesFileExist target
unless exists $ error $ "No .do file found for target '" ++ target ++ "'"
-- All .do scripts are invoked by sh. We use the -e argument to cause
-- the script to bail on any errors. The first argument is 0 to indicate
-- that it's unused (but to maintain the ordering of the other arguments
-- for compatibility with other redo implementations). The second
-- argument is just the basename of the target (the file name with the
-- last (if any) extension removed).
-- Note that the temporary file is provided as a third argument to the
-- script while stdout is also directed to it. TODO: This could lead to
-- some confusion about what happens if both are used (output is both
-- sent to stdout and written to $3), and the behavior should at least
-- be documented.
cmd path = unwords ["sh -e", path, "0", takeBaseName target, tmp, ">", tmp]
-- | Determine the .do script path for a given target name.
doPath :: FilePath -- ^ the target (file) name
-> IO (Maybe FilePath) -- ^ the preferred .do script file if one exists
doPath target = listToMaybe `liftM` filterM doesFileExist candidates
-- There are only 2 potential candidate .do scripts: an exact match and an
-- extension-based default.
where candidates = (target ++ ".do") : if hasExtension target
then [replaceBaseName target "default" ++ ".do"]
else []
-- | Determine whether or not a target is up-to-date (i.e. it exists and none of its dependencies have changed or are out-of-date themselves).
upToDate :: FilePath -- ^ the target (file) name
-> IO Bool -- ^ True if the target is up-to-date
upToDate target = catch
(do exists <- doesFileExist target
if exists
-- If the target exists, it's up-to-date it all of its dependencies are
-- up-to-date.
then do md5s <- getDirectoryContents (metaDir </> target)
and `liftM` mapM depUpToDate md5s
-- If the target doesn't exist, it's certainly out-of-date.
else return False)
(\(_ :: IOException) -> return False)
where depUpToDate :: String -> IO Bool
depUpToDate oldMD5 = catch
-- To avoid having to escape directory path separators (such as
-- converting / to !), each dependency is stored in a file named
-- by its MD5. e.g. a dependency named `redo.hs` with an MD5 of
-- 29e57f39b7ea2795ab2e452ada562778 and for the target `redo`
-- would be stored in the file
-- `.redo/redo/29e57f39b7ea2795ab2e452ada562778`. The contents of
-- the file would be the relative path to the dependency (in this
-- case, simply "redo.hs").
(do dep <- withFile (metaDir </> target </> oldMD5) ReadMode hGetLine
newMD5 <- fileMD5 dep
doScript <- doPath dep
case doScript of
-- Simple dependencies are up-to-date if their MD5s match that
-- of the last time that they were checked.
Nothing -> return $ oldMD5 == newMD5
-- But a dependency can itself depend on other files, so aside
-- from just having their MD5s match between runs, all of their
-- dependencies must also be up-to-date.
Just _ -> do upToDate' <- upToDate dep
return $ (oldMD5 == newMD5) && upToDate')
-- If the target metadata directory (e.g. `.redo/redo`) doesn't exist
-- (for example, on the first run of redo), we trap the IO exception
-- and just indicate that the target is out-of-date.
-- TODO: The way this is written, it looks as if it would say that the
-- target /is/ up-to-date if the metadata directory is missing, which
-- would be wrong.
(\e -> return (ioeGetErrorType e == InappropriateType))
-- | Calculate the MD5 checksum of a file.
--
-- For example:
--
-- >>> fileMD5 "redo.hs"
-- "29e57f39b7ea2795ab2e452ada562778"
fileMD5 :: FilePath -- ^ the file to calculate the checksum of
-> IO String -- ^ a 32-character MD5 checksum
fileMD5 path = (show . MD5.md5) `liftM` BL.readFile path
-- TODO: This function is confusing (which are we writing which for?).
-- | Write out the MD5 checksum of a given dependency of a target.
writeMD5 :: String -- ^ the target (file) for this dependency
-> FilePath -- ^ the file path of the dependency
-> IO ()
writeMD5 redoTarget dep = do
md5 <- fileMD5 dep
writeFile (metaDir </> redoTarget </> md5) dep
-- | Determine a file's size.
fileSize :: FilePath -- ^ the file to determine the size of
-> IO Integer -- ^ the file's size in bytes
fileSize path = withFile path ReadMode hFileSize
-- I don't know of a more efficient way to determine file size in a
-- cross-platform way.