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