-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Sandbox.Timestamp
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Timestamp file handling (for add-source dependencies).
-----------------------------------------------------------------------------
module Distribution.Client.Sandbox.Timestamp (
AddSourceTimestamp,
withAddTimestamps,
withUpdateTimestamps,
maybeAddCompilerTimestampRecord,
listModifiedDeps,
removeTimestamps,
-- * For testing
TimestampFileRecord,
readTimestampFile,
writeTimestampFile
) where
import Control.Monad (filterM, forM, when)
import Data.Char (isSpace)
import Data.List (partition)
import System.Directory (renameFile)
import System.FilePath ((<.>), (</>))
import qualified Data.Map as M
import Distribution.Compiler (CompilerId)
import Distribution.Simple.Utils (debug, die', warn)
import Distribution.System (Platform)
import Distribution.Text (display)
import Distribution.Verbosity (Verbosity)
import Distribution.Client.SrcDist (allPackageSourceFiles)
import Distribution.Client.Sandbox.Index
(ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks)
,listBuildTreeRefs)
import Distribution.Client.SetupWrapper
import Distribution.Compat.Exception (catchIO)
import Distribution.Compat.Time (ModTime, getCurTime,
getModTime,
posixSecondsToModTime)
-- | Timestamp of an add-source dependency.
type AddSourceTimestamp = (FilePath, ModTime)
-- | Timestamp file record - a string identifying the compiler & platform plus a
-- list of add-source timestamps.
type TimestampFileRecord = (String, [AddSourceTimestamp])
timestampRecordKey :: CompilerId -> Platform -> String
timestampRecordKey compId platform = display platform ++ "-" ++ display compId
-- | The 'add-source-timestamps' file keeps the timestamps of all add-source
-- dependencies. It is initially populated by 'sandbox add-source' and kept
-- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install
-- add-source deps manually with 'cabal install' after having edited them, so we
-- can err on the side of caution sometimes.
-- FIXME: We should keep this info in the index file, together with build tree
-- refs.
timestampFileName :: FilePath
timestampFileName = "add-source-timestamps"
-- | Read the timestamp file. Exits with error if the timestamp file is
-- corrupted. Returns an empty list if the file doesn't exist.
readTimestampFile :: Verbosity -> FilePath -> IO [TimestampFileRecord]
readTimestampFile verbosity timestampFile = do
timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"
case reads timestampString of
[(version, s)]
| version == (2::Int) ->
case reads s of
[(timestamps, s')] | all isSpace s' -> return timestamps
_ -> dieCorrupted
| otherwise -> dieWrongFormat
-- Old format (timestamps are POSIX seconds). Convert to new format.
[] ->
case reads timestampString of
[(timestamps, s)] | all isSpace s -> do
let timestamps' = map (\(i, ts) ->
(i, map (\(p, t) ->
(p, posixSecondsToModTime t)) ts))
timestamps
writeTimestampFile timestampFile timestamps'
return timestamps'
_ -> dieCorrupted
_ -> dieCorrupted
where
dieWrongFormat = die' verbosity $ wrongFormat ++ deleteAndRecreate
dieCorrupted = die' verbosity $ corrupted ++ deleteAndRecreate
wrongFormat = "The timestamps file is in the wrong format."
corrupted = "The timestamps file is corrupted."
deleteAndRecreate = " Please delete and recreate the sandbox."
-- | Write the timestamp file, atomically.
writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()
writeTimestampFile timestampFile timestamps = do
writeFile timestampTmpFile "2\n" -- version
appendFile timestampTmpFile (show timestamps ++ "\n")
renameFile timestampTmpFile timestampFile
where
timestampTmpFile = timestampFile <.> "tmp"
-- | Read, process and write the timestamp file in one go.
withTimestampFile :: Verbosity -> FilePath
-> ([TimestampFileRecord] -> IO [TimestampFileRecord])
-> IO ()
withTimestampFile verbosity sandboxDir process = do
let timestampFile = sandboxDir </> timestampFileName
timestampRecords <- readTimestampFile verbosity timestampFile >>= process
writeTimestampFile timestampFile timestampRecords
-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list
-- for each path. If a timestamp for a given path already exists in the list,
-- update it.
addTimestamps :: ModTime -> [AddSourceTimestamp] -> [FilePath]
-> [AddSourceTimestamp]
addTimestamps initial timestamps newPaths =
[ (p, initial) | p <- newPaths ] ++ oldTimestamps
where
(oldTimestamps, _toBeUpdated) =
partition (\(path, _) -> path `notElem` newPaths) timestamps
-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
-- we've reinstalled and a new timestamp value, update the timestamp value for
-- the deps in the list. If there are new paths in the list, ignore them.
updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> ModTime
-> [AddSourceTimestamp]
updateTimestamps timestamps pathsToUpdate newTimestamp =
foldr updateTimestamp [] timestamps
where
updateTimestamp t@(path, _oldTimestamp) rest
| path `elem` pathsToUpdate = (path, newTimestamp) : rest
| otherwise = t : rest
-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source
-- deps we've removed, remove those deps from the list.
removeTimestamps' :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]
removeTimestamps' l pathsToRemove = foldr removeTimestamp [] l
where
removeTimestamp t@(path, _oldTimestamp) rest =
if path `elem` pathsToRemove
then rest
else t : rest
-- | If a timestamp record for this compiler doesn't exist, add a new one.
maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath
-> CompilerId -> Platform
-> IO ()
maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
compId platform = do
let key = timestampRecordKey compId platform
withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
case lookup key timestampRecords of
Just _ -> return timestampRecords
Nothing -> do
buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks
indexFile
now <- getCurTime
let timestamps = map (\p -> (p, now)) buildTreeRefs
return $ (key, timestamps):timestampRecords
-- | Given an IO action that returns a list of build tree refs, add those
-- build tree refs to the timestamps file (for all compilers).
withAddTimestamps :: Verbosity -> FilePath -> IO [FilePath] -> IO ()
withAddTimestamps verbosity sandboxDir act = do
let initialTimestamp = minBound
withActionOnAllTimestamps (addTimestamps initialTimestamp) verbosity sandboxDir act
-- | Given a list of build tree refs, remove those
-- build tree refs from the timestamps file (for all compilers).
removeTimestamps :: Verbosity -> FilePath -> [FilePath] -> IO ()
removeTimestamps verbosity idxFile =
withActionOnAllTimestamps removeTimestamps' verbosity idxFile . return
-- | Given an IO action that returns a list of build tree refs, update the
-- timestamps of the returned build tree refs to the current time (only for the
-- given compiler & platform).
withUpdateTimestamps :: Verbosity -> FilePath -> CompilerId -> Platform
->([AddSourceTimestamp] -> IO [FilePath])
-> IO ()
withUpdateTimestamps =
withActionOnCompilerTimestamps updateTimestamps
-- | Helper for implementing 'withAddTimestamps' and
-- 'withRemoveTimestamps'. Runs a given action on the list of
-- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then
-- updates the timestamp file. The IO action is run only once.
withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]
-> [AddSourceTimestamp])
-> Verbosity
-> FilePath
-> IO [FilePath]
-> IO ()
withActionOnAllTimestamps f verbosity sandboxDir act =
withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
paths <- act
return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords]
-- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the
-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result
-- and then updates the timestamp file record. The IO action is run only once.
withActionOnCompilerTimestamps :: ([AddSourceTimestamp]
-> [FilePath] -> ModTime
-> [AddSourceTimestamp])
-> Verbosity
-> FilePath
-> CompilerId
-> Platform
-> ([AddSourceTimestamp] -> IO [FilePath])
-> IO ()
withActionOnCompilerTimestamps f verbosity sandboxDir compId platform act = do
let needle = timestampRecordKey compId platform
withTimestampFile verbosity sandboxDir $ \timestampRecords -> do
timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->
if key == needle
then do paths <- act timestamps
now <- getCurTime
return (key, f timestamps paths now)
else return r
return timestampRecords'
-- | Has this dependency been modified since we have last looked at it?
isDepModified :: Verbosity -> ModTime -> AddSourceTimestamp -> IO Bool
isDepModified verbosity now (packageDir, timestamp) = do
debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)
-- TODO: we should properly plumb the correct options through
-- instead of using defaultSetupScriptOptions
depSources <- allPackageSourceFiles verbosity defaultSetupScriptOptions packageDir
go depSources
where
go [] = return False
go (dep0:rest) = do
-- FIXME: What if the clock jumps backwards at any point? For now we only
-- print a warning.
let dep = packageDir </> dep0
modTime <- getModTime dep
when (modTime > now) $
warn verbosity $ "File '" ++ dep
++ "' has a modification time that is in the future."
if modTime >= timestamp
then do
debug verbosity ("Dependency has a modified source file: " ++ dep)
return True
else go rest
-- | List all modified dependencies.
listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform
-> M.Map FilePath a
-- ^ The set of all installed add-source deps.
-> IO [FilePath]
listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do
timestampRecords <- readTimestampFile verbosity (sandboxDir </> timestampFileName)
let needle = timestampRecordKey compId platform
timestamps <- maybe noTimestampRecord return
(lookup needle timestampRecords)
now <- getCurTime
fmap (map fst) . filterM (isDepModified verbosity now)
. filter (\ts -> fst ts `M.member` installedDepsMap)
$ timestamps
where
noTimestampRecord = die' verbosity $ "Сouldn't find a timestamp record for the given "
++ "compiler/platform pair. "
++ "Please report this on the Cabal bug tracker: "
++ "https://github.com/haskell/cabal/issues/new ."