{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections, LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, NamedFieldPuns #-}
module Development.Rattle.Server(
Rattle, withRattle, Run(..),
addCmdOptions
) where
import Control.Monad.Extra
import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import General.Pool
import Development.Rattle.Types
import Development.Rattle.UI
import Development.Rattle.Shared
import Development.Rattle.Options hiding (rattleOptions)
import Development.Rattle.Hash
import Development.Rattle.Hazards
import Development.Rattle.CmdOption
import Control.Exception.Extra
import Control.Concurrent.Extra
import General.Extra
import Data.Either
import Data.Maybe
import System.Directory
import System.FilePath
import System.FilePattern
import System.IO.Extra
import System.IO.Unsafe(unsafeInterleaveIO)
import qualified Development.Shake.Command as C
import qualified Data.HashMap.Strict as Map
import qualified Data.HashSet as Set
import Data.IORef
import Data.List.Extra
import Data.Tuple.Extra
import System.Time.Extra
import General.FileName
import General.FileInfo
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as BS
newtype Run a = Run {fromRun :: ReaderT Rattle IO a}
deriving (Functor, Applicative, Monad, MonadIO)
instance a ~ () => C.CmdArguments (Run a) where
cmdArguments (C.CmdArgument x) = do
let (opts, args) = partitionEithers x
r <- Run ask
liftIO $ cmdRattle r opts args
data S = S
{started :: Map.HashMap Cmd (NoShow (IO ()))
,running :: [(Seconds, Cmd, Maybe (Touch FileName))]
,hazard :: HazardSet
,pending :: [(Seconds, Cmd, Trace (FileName, ModTime, Hash))]
,required :: [Cmd]
,speculatable :: [(Cmd, Touch FileName)]
,speculateNext :: Maybe Cmd
} deriving Show
data Problem
= Finished
| Hazard Hazard
throwProblem :: Problem -> IO a
throwProblem Finished = fail "Finished, but still trying to do stuff"
throwProblem (Hazard h) = throwIO h
data Rattle = Rattle
{options :: RattleOptions
,runIndex :: !RunIndex
,state :: Var (Either Problem S)
,timer :: IO Seconds
,speculated :: IORef Bool
,speculatableWrites :: Set.HashSet FileName
,pool :: Pool
,ui :: UI
,shared :: Shared
,shortener :: FileName -> FileName
}
addCmdOptions :: [C.CmdOption] -> Rattle -> Rattle
addCmdOptions new r@Rattle{options=o@RattleOptions{rattleCmdOptions=old}} =
r{options = o{rattleCmdOptions = old ++ new}}
withRattle :: RattleOptions -> (Rattle -> IO a) -> IO a
withRattle options@RattleOptions{..} act = withUI rattleUI (pure "Running") $ \ui -> withShared rattleFiles rattleShare $ \shared -> do
options@RattleOptions{..} <- rattleOptionsExplicit options
withNumCapabilities (rattleProcesses + 1) $ do
when (rattleProcesses > 1 && not rtsSupportsBoundThreads) $
putStrLn "WARNING: Running with multiple threads but not compiled with -threaded"
let expander = expand rattleNamedDirs
let shortener = shorten rattleNamedDirs
speculatable <- if rattleProcesses <= 1 then pure [] else do
speculatable <- maybe (pure []) (getSpeculate shared) rattleSpeculate
fmap (takeWhile (not . null . snd)) $
forM speculatable $ \x -> do
traces <- unsafeInterleaveIO (getCmdTraces shared x)
pure (x, normalizeTouch $ foldMap (fmap (expander . fst3) . tTouch) traces)
let speculatableWrites = Set.fromList $ concatMap (tWrite . snd) speculatable
speculated <- newIORef False
runIndex <- nextRun shared rattleMachine
timer <- offsetTime
let s0 = S Map.empty [] emptyHazardSet [] [] speculatable Nothing
state <- newVar $ Right $ ensureS s0
let saveSpeculate state =
whenJust rattleSpeculate $ \name ->
whenRightM (readVar state) $ \v ->
setSpeculate shared name $ reverse $ required v
let attempt1 = runPool True rattleProcesses $ \pool -> do
let r = Rattle{..}
runSpeculate r
(act r <* saveSpeculate state) `finally` writeVar state (Left Finished)
attempt1 `catch` \(h :: Hazard) -> do
b <- readIORef speculated
if not (recoverableHazard h || restartableHazard h) then throwIO h else do
putStrLn "Warning: Speculation lead to a hazard, retrying without speculation"
print h
state <- newVar $ Right s0{speculatable=[]}
runPool True rattleProcesses $ \pool -> do
let r = Rattle{..}
(act r <* saveSpeculate state) `finally` writeVar state (Left Finished)
runSpeculate :: Rattle -> IO ()
runSpeculate rattle@Rattle{..} = when (rattleProcesses options > 1) $
addPool PoolSpeculate pool $ do
run <- modifyS rattle $ \case
s@S{speculateNext=Just cmd} -> do
writeIORef speculated True
cmdRattleStarted rattle cmd s ["speculative"]
_ -> pure (Right Nothing, pure ())
ignore run
modifyS :: Rattle -> (S -> IO (Either Problem (Maybe S), IO a)) -> IO (IO a)
modifyS rattle@Rattle{..} act = modifyVar state $ \case
Left e -> throwProblem e
Right s -> do
(res, cont) <- act s
case res of
Left e -> pure (Left e, cont)
Right Nothing -> pure (Right s, cont)
Right (Just s) -> pure (Right $ ensureS s, runSpeculate rattle >> cont)
ensureS :: S -> S
ensureS = fillInNext . reduceSpeculate
where
reduceSpeculate s = s{speculatable = dropWhile (\(c, _) -> c `Map.member` started s) $ speculatable s}
fillInNext s = s{speculateNext = calculateSpeculateNext s}
calculateSpeculateNext :: S -> Maybe Cmd
calculateSpeculateNext S{speculatable, running, started, hazard}
| not $ null speculatable, Just xs <- mapM thd3 running = step (newTouchSet xs) speculatable
| otherwise = Nothing
where
step :: TouchSet -> [(Cmd, Touch FileName)] -> Maybe Cmd
step _ [] = Nothing
step rw ((x,_):xs)
| x `Map.member` started = step rw xs
step rw ((x, t@Touch{..}):xs)
| not $ any (\v -> v `Set.member` tsRead rw || v `Set.member` tsWrite rw || seenHazardSet v hazard) tWrite
, not $ any (`Set.member` tsWrite rw) tRead
= Just x
| otherwise
= step (addTouchSet rw t) xs
cmdRattle :: Rattle -> [C.CmdOption] -> [String] -> IO ()
cmdRattle rattle opts args = cmdRattleRequired rattle $ mkCmd (rattleCmdOptions (options rattle) ++ opts) args
cmdRattleRequired :: Rattle -> Cmd -> IO ()
cmdRattleRequired rattle@Rattle{..} cmd = addPoolWait PoolRequired pool $ do
modifyVar_ state $ pure . fmap (\s -> s{required = cmd : required s})
cmdRattleStart rattle cmd
cmdRattleStart :: Rattle -> Cmd -> IO ()
cmdRattleStart rattle cmd = join $ modifyS rattle $ \s ->
cmdRattleStarted rattle cmd s []
cmdRattleStarted :: Rattle -> Cmd -> S -> [String] -> IO (Either Problem (Maybe S), IO ())
cmdRattleStarted rattle@Rattle{..} cmd s msgs = do
start <- timer
case Map.lookup cmd (started s) of
Just (NoShow wait) -> pure (Right Nothing, wait)
Nothing -> do
hist <- unsafeInterleaveIO $ map (fmap (\(f,mt,h) -> (expand (rattleNamedDirs options) f, mt, h))) <$> getCmdTraces shared cmd
go <- once $ cmdRattleRun rattle cmd start hist msgs
let trimReads t = t{tRead = filter (`Set.member` speculatableWrites) $ tRead t}
let specHist = if null hist then Nothing else Just $ trimReads $ fmap fst3 $ tTouch $ last hist
s <- pure s{running = (start, cmd, specHist) : running s}
s <- pure s{started = Map.insert cmd (NoShow go) $ started s}
pure (Right $ Just s, go)
cmdRattleRun :: Rattle -> Cmd -> Seconds -> [Trace (FileName, ModTime, Hash)] -> [String] -> IO ()
cmdRattleRun rattle@Rattle{..} cmd@(Cmd _ opts args) startTimestamp hist msgs = do
let forwardOpt = rattleForward options
let match (fp, mt, h) = (== Just h) <$> (if forwardOpt then hashFileForwardIfStale else hashFileIfStale) fp mt h
histRead <- filterM (allM match . tRead . tTouch) hist
histBoth <- filterM (allM match . tWrite . tTouch) histRead
case histBoth of
t:_ ->
cmdRattleFinished rattle startTimestamp cmd t False
[] -> do
fetcher <- memoIO $ getFile shared
let fetch (fp, mt, h) = do v <- fetcher h; case v of Nothing -> pure Nothing; Just op -> pure $ Just $ op fp
download <- if not (rattleShare options)
then pure Nothing
else firstJustM (\t -> fmap (t,) <$> allMaybeM fetch (tWrite $ tTouch t)) histRead
case download of
Just (t, download) -> do
display ["copying"] $ sequence_ download
cmdRattleFinished rattle startTimestamp cmd t False
Nothing -> do
start <- timer
(opts2, c) <- display [] $ cmdRattleRaw ui opts args
stop <- timer
touch <- fsaTrace c
when forwardOpt $
checkHashForwardConsistency touch
let pats = matchMany [((), x) | Ignored xs <- opts2, x <- xs]
let hasTrailingPathSeparatorBS = maybe False (isPathSeparator . snd) . BS.unsnoc
let skip x = BS.isPrefixOf slashDev (fileNameToByteString x) ||
hasTrailingPathSeparatorBS (fileNameToByteString x) ||
pats [((),fileNameToString x)] /= []
let f hasher xs = mapMaybeM (\x -> fmap (\(mt,h) -> (x,mt,h)) <$> hasher x) $ filter (not . skip) xs
touch <- Touch <$> f (if forwardOpt then hashFileForward else hashFile) (tRead touch) <*> f hashFile (tWrite touch)
touch <- if forwardOpt then generateHashForwards cmd [x | HashNonDeterministic xs <- opts2, x <- xs] touch else pure touch
when (rattleShare options) $
forM_ (tWrite touch) $ \(fp, mt, h) ->
setFile shared fp h ((== Just h) <$> hashFileIfStale fp mt h)
cmdRattleFinished rattle startTimestamp cmd (Trace runIndex start stop touch) True
where
display :: [String] -> IO a -> IO a
display msgs2 = addUI ui (headDef cmdline overrides) (unwords $ msgs ++ msgs2)
overrides = [x | C.Traced x <- opts] ++ [x | C.UserCommand x <- opts]
cmdline = unwords $ ["cd " ++ x ++ " &&" | C.Cwd x <- opts] ++ args
slashDev :: BS.ByteString
slashDev = BS.pack "/dev/"
cmdRattleRaw :: UI -> [C.CmdOption] -> [String] -> IO ([CmdOption2], [C.FSATrace BS.ByteString])
cmdRattleRaw ui opts args = do
(opts, opts2) <- pure $ partitionEithers $ map fromCmdOption opts
case [x | WriteFile x <- opts2] of
[] -> do
let optsUI = if isControlledUI ui then [C.EchoStdout False,C.EchoStderr False] else []
res <- C.cmd (opts ++ optsUI) args
pure (opts2, res)
files -> do
forM_ files $ \file -> do
createDirectoryIfMissing True $ takeDirectory file
writeFileUTF8 file $ concat args
pure (opts2, map (C.FSAWrite . UTF8.fromString) files)
checkHashForwardConsistency :: Touch FileName -> IO ()
checkHashForwardConsistency Touch{..} = do
let sources = mapMaybe fromHashForward tWrite
let bad = sources \\ tWrite
when (bad /= []) $
fail $ "Wrote to the forwarding file, but not the source: " ++ show bad
forwards <- filterM doesFileNameExist $ mapMaybe toHashForward tWrite
let bad = forwards \\ tWrite
when (bad /= []) $
fail $ "Wrote to the source file which has a forwarding hash, but didn't touch the hash: " ++ show bad
generateHashForwards :: Cmd -> [FilePattern] -> Touch (FileName, ModTime, Hash) -> IO (Touch (FileName, ModTime, Hash))
generateHashForwards cmd ms t = do
let match = matchMany $ map ((),) ms
let (normal, forward) = partition (\(x, _, _) -> isJust (toHashForward x) && null (match [((), fileNameToString x)])) $ tWrite t
let Hash hash = hashString $ show (cmd, tRead t, normal)
let hhash = hashHash $ Hash hash
forward <- forM forward $ \(x,mt,_) -> do
let Just x2 = toHashForward x
BS.writeFile (fileNameToString x2) hash
pure (x2, mt,hhash)
pure t{tWrite = tWrite t ++ forward}
cmdRattleFinished :: Rattle -> Seconds -> Cmd -> Trace (FileName, ModTime, Hash) -> Bool -> IO ()
cmdRattleFinished rattle@Rattle{..} start cmd trace@Trace{..} save = join $ modifyS rattle $ \s -> do
stop <- timer
s <- pure s{running = filter ((/= start) . fst3) $ running s}
s <- pure s{pending = [(stop, cmd, trace) | save] ++ pending s}
case addHazardSet (required s) (hazard s) start stop cmd $ fmap fst3 tTouch of
(ps@(p:_), _) -> pure (Left $ Hazard p, print ps >> throwIO p)
([], hazard2) -> do
s <- pure s{hazard = hazard2}
maxTimestamp <- timer
let earliest = minimum $ maxTimestamp : map fst3 (running s)
(safe, pending) <- pure $ partition (\x -> fst3 x < earliest) $ pending s
s <- pure s{pending = pending}
pure (Right $ Just s, forM_ safe $ \(_,c,t) -> addCmdTrace shared c $ fmap (\(f,mt,h) -> (shortener f, mt,h)) t)