1-----------------------------------------------------------------------------
2-- |
3-- Module      :  Distribution.Client.Sandbox.Timestamp
4-- Maintainer  :  cabal-devel@haskell.org
5-- Portability :  portable
6--
7-- Timestamp file handling (for add-source dependencies).
8-----------------------------------------------------------------------------
9
10module Distribution.Client.Sandbox.Timestamp (
11  AddSourceTimestamp,
12  withAddTimestamps,
13  withUpdateTimestamps,
14  maybeAddCompilerTimestampRecord,
15  listModifiedDeps,
16  removeTimestamps,
17
18  -- * For testing
19  TimestampFileRecord,
20  readTimestampFile,
21  writeTimestampFile
22  ) where
23
24import Control.Monad                                 (filterM, forM, when)
25import Data.Char                                     (isSpace)
26import Data.List                                     (partition)
27import System.Directory                              (renameFile)
28import System.FilePath                               ((<.>), (</>))
29import qualified Data.Map as M
30
31import Distribution.Compiler                         (CompilerId)
32import Distribution.Simple.Utils                     (debug, die', warn)
33import Distribution.System                           (Platform)
34import Distribution.Deprecated.Text                             (display)
35import Distribution.Verbosity                        (Verbosity)
36
37import Distribution.Client.SrcDist (allPackageSourceFiles)
38import Distribution.Client.Sandbox.Index
39  (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)
40  ,listBuildTreeRefs)
41import Distribution.Client.SetupWrapper
42
43import Distribution.Compat.Exception                 (catchIO)
44import Distribution.Compat.Time               (ModTime, getCurTime,
45                                                      getModTime,
46                                                      posixSecondsToModTime)
47
48
49-- | Timestamp of an add-source dependency.
50type AddSourceTimestamp  = (FilePath, ModTime)
51-- | Timestamp file record - a string identifying the compiler & platform plus a
52-- list of add-source timestamps.
53type TimestampFileRecord = (String, [AddSourceTimestamp])
54
55timestampRecordKey :: CompilerId -> Platform -> String
56timestampRecordKey compId platform = display platform ++ "-" ++ display compId
57
58-- | The 'add-source-timestamps' file keeps the timestamps of all add-source
59-- dependencies. It is initially populated by 'sandbox add-source' and kept
60-- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install
61-- add-source deps manually with 'cabal install' after having edited them, so we
62-- can err on the side of caution sometimes.
63-- FIXME: We should keep this info in the index file, together with build tree
64-- refs.
65timestampFileName :: FilePath
66timestampFileName = "add-source-timestamps"
67
68-- | Read the timestamp file. Exits with error if the timestamp file is
69-- corrupted. Returns an empty list if the file doesn't exist.
70readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord]
71readTimestampFile verbosity timestampFile = do
72  timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"
73  case reads timestampString of
74    [(version, s)]
75      | version == (2::Int) ->
76        case reads s of
77          [(timestamps, s')] | all isSpace s' -> return timestamps
78          _                                   -> dieCorrupted
79      | otherwise   -> dieWrongFormat
80
81    -- Old format (timestamps are POSIX seconds). Convert to new format.
82    [] ->
83      case reads timestampString of
84        [(timestamps, s)] | all isSpace s -> do
85          let timestamps' = map (\(i, ts) ->
86                                  (i, map (\(p, t) ->
87                                            (p, posixSecondsToModTime t)) ts))
88                            timestamps
89          writeTimestampFile timestampFile timestamps'
90          return timestamps'
91        _ -> dieCorrupted
92    _ -> dieCorrupted
93  where
94    dieWrongFormat    = die' verbosity $ wrongFormat ++ deleteAndRecreate
95    dieCorrupted      = die' verbosity $ corrupted ++ deleteAndRecreate
96    wrongFormat       = "The timestamps file is in the wrong format."
97    corrupted         = "The timestamps file is corrupted."
98    deleteAndRecreate = " Please delete and recreate the sandbox."
99
100-- | Write the timestamp file, atomically.
101writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()
102writeTimestampFile timestampFile timestamps = do
103  writeFile  timestampTmpFile "2\n" -- version
104  appendFile timestampTmpFile (show timestamps ++ "\n")
105  renameFile timestampTmpFile timestampFile
106  where
107    timestampTmpFile = timestampFile <.> "tmp"
108
109-- | Read, process and write the timestamp file in one go.
110withTimestampFile :: Verbosity -> FilePath
111                     -> ([TimestampFileRecord] -> IO [TimestampFileRecord])
112                     -> IO ()
113withTimestampFile verbosity sandboxDir process = do
114  let timestampFile = sandboxDir </> timestampFileName
115  timestampRecords <- readTimestampFile verbosity timestampFile >>= process
116  writeTimestampFile timestampFile timestampRecords
117
118-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
119-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list
120-- for each path. If a timestamp for a given path already exists in the list,
121-- update it.
122addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]
123                 -> [AddSourceTimestamp]
124addTimestamps initial timestamps newPaths =
125  [ (p, initial) | p <- newPaths ] ++ oldTimestamps
126  where
127    (oldTimestamps, _toBeUpdated) =
128      partition (\(path, _) -> path `notElem` newPaths) timestamps
129
130-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
131-- we've reinstalled and a new timestamp value, update the timestamp value for
132-- the deps in the list. If there are new paths in the list, ignore them.
133updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime
134                    -> [AddSourceTimestamp]
135updateTimestamps timestamps pathsToUpdate newTimestamp =
136  foldr updateTimestamp [] timestamps
137  where
138    updateTimestamp t@(path, _oldTimestamp) rest
139      | path `elem` pathsToUpdate = (path, newTimestamp) : rest
140      | otherwise                 = t : rest
141
142-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source
143-- deps we've removed, remove those deps from the list.
144removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]
145removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l
146  where
147    removeTimestamp t@(path, _oldTimestamp) rest =
148      if path `elem` pathsToRemove
149      then rest
150      else t : rest
151
152-- | If a timestamp record for this compiler doesn't exist, add a new one.
153maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath
154                                   -> CompilerId -> Platform
155                                   -> IO ()
156maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
157                                compId platform = do
158  let key = timestampRecordKey compId platform
159  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
160    case lookup key timestampRecords of
161      Just _  -> return timestampRecords
162      Nothing -> do
163        buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks
164                         indexFile
165        now <- getCurTime
166        let timestamps = map (\p -> (p, now)) buildTreeRefs
167        return $ (key, timestamps):timestampRecords
168
169-- | Given an IO action that returns a list of build tree refs, add those
170-- build tree refs to the timestamps file (for all compilers).
171withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO ()
172withAddTimestamps verbosity sandboxDir act = do
173  let initialTimestamp = minBound
174  withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act
175
176-- | Given a list of build tree refs, remove those
177-- build tree refs from the timestamps file (for all compilers).
178removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO ()
179removeTimestamps verbosity idxFile =
180  withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return
181
182-- | Given an IO action that returns a list of build tree refs, update the
183-- timestamps of the returned build tree refs to the current time (only for the
184-- given compiler & platform).
185withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform
186                        ->([AddSourceTimestamp] -> IO [FilePath])
187                        -> IO ()
188withUpdateTimestamps =
189  withActionOnCompilerTimestamps updateTimestamps
190
191-- | Helper for implementing 'withAddTimestamps' and
192-- 'withRemoveTimestamps'. Runs a given action on the list of
193-- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then
194-- updates the timestamp file. The IO action is run only once.
195withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]
196                              -> [AddSourceTimestamp])
197                             -> Verbosity
198                             -> FilePath
199                             -> IO [FilePath]
200                             -> IO ()
201withActionOnAllTimestamps f verbosity sandboxDir act =
202  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
203    paths <- act
204    return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords]
205
206-- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the
207-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result
208-- and then updates the timestamp file record. The IO action is run only once.
209withActionOnCompilerTimestamps :: ([AddSourceTimestamp]
210                                   -> [FilePath] -> ModTime
211                                   -> [AddSourceTimestamp])
212                                  -> Verbosity
213                                  -> FilePath
214                                  -> CompilerId
215                                  -> Platform
216                                  -> ([AddSourceTimestamp] -> IO [FilePath])
217                                  -> IO ()
218withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do
219  let needle = timestampRecordKey compId platform
220  withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
221    timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->
222      if key == needle
223      then do paths <- act timestamps
224              now   <- getCurTime
225              return (key, f timestamps paths now)
226      else return r
227    return timestampRecords'
228
229-- | Has this dependency been modified since we have last looked at it?
230isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool
231isDepModified verbosity now (packageDir, timestamp) = do
232  debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)
233  -- TODO: we should properly plumb the correct options through
234  -- instead of using defaultSetupScriptOptions
235  depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir
236  go depSources
237
238  where
239    go []         = return False
240    go (dep0:rest) = do
241      -- FIXME: What if the clock jumps backwards at any point? For now we only
242      -- print a warning.
243      let dep = packageDir </> dep0
244      modTime <- getModTime dep
245      when (modTime > now) $
246        warn verbosity $ "File '" ++ dep
247                         ++ "' has a modification time that is in the future."
248      if modTime >= timestamp
249        then do
250          debug verbosity ("Dependency has a modified source file: " ++ dep)
251          return True
252        else go rest
253
254-- | List all modified dependencies.
255listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform
256                    -> M.Map FilePath a
257                       -- ^ The set of all installed add-source deps.
258                    -> IO [FilePath]
259listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do
260  timestampRecords <- readTimestampFile verbosity (sandboxDir </> timestampFileName)
261  let needle        = timestampRecordKey compId platform
262  timestamps       <- maybe noTimestampRecord return
263                      (lookup needle timestampRecords)
264  now <- getCurTime
265  fmap (map fst) . filterM (isDepModified verbosity now)
266    . filter (\ts -> fst ts `M.member` installedDepsMap)
267    $ timestamps
268
269  where
270    noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given "
271                        ++ "compiler/platform pair. "
272                        ++ "Please report this on the Cabal bug tracker: "
273                        ++ "https://github.com/haskell/cabal/issues/new ."
274