Cache.hs

-- | Using a remote action cache, so that buck2 can reuse the results of
-- actions that were run before, in another checkout of the project or by an
-- earlier build with the same inputs.
--
-- Nothing is run remotely: the cache server (anything that speaks the Bazel
-- remote execution API's action cache and CAS, such as @bazel-remote@) only
-- stores results. Turning this on adds a block to the project's
-- @.buckconfig@ (see 'cacheBlock'); the buck2 support code reads
-- @[cabal_buck2] cache@ from it to enable the cache in its execution platform
-- and C\/C++ toolchain.
module Distribution.Client.Buck2.Cache
  ( CacheSetting (..)
  , cacheSetting
  , configureCache
  , cacheBlock
  , spliceBlock
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import System.Directory (doesFileExist)
import System.FilePath ((</>))

import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault)
import Distribution.Simple.Utils (die', notice)

import Distribution.Client.Buck2.Flags (Buck2Flags (..))

data CacheSetting
  = -- | Leave .buckconfig as it is.
    CacheUnchanged
  | CacheOn String
  | CacheOff
  deriving (Eq, Show)

-- | What the flags ask for, or an error if they contradict each other.
cacheSetting :: Buck2Flags -> Either String CacheSetting
cacheSetting flags =
  case (flagToMaybe (buck2CacheAddress flags), fromFlagOrDefault False (buck2NoCache flags)) of
    (Just _, True) -> Left "--cache and --no-cache can't be used together"
    (Just address, False)
      | any (`isPrefixOf` address) ["grpc://", "grpcs://"] -> Right (CacheOn address)
      | otherwise -> Left ("--cache: the address should start with grpc:// or grpcs://, not " ++ show address)
    (Nothing, True) -> Right CacheOff
    (Nothing, False) -> Right CacheUnchanged

-- | Add, change or remove the cache's block of @.buckconfig@.
configureCache :: Verbosity -> FilePath -> CacheSetting -> IO ()
configureCache _ _ CacheUnchanged = return ()
configureCache verbosity projectRoot setting = do
  let path = projectRoot </> ".buckconfig"
  exists <- doesFileExist path
  unless exists $ die' verbosity (path ++ " doesn't exist")
  old <- readFile path
  let new = spliceBlock (case setting of CacheOn address -> Just (cacheBlock address); _ -> Nothing) old
  when (new /= old) $ do
    length old `seq` writeFile path new
    notice verbosity $
      unlines
        [ case setting of
            CacheOn address -> "cabal buck2: using the action cache at " ++ address ++ " (see .buckconfig)"
            _ -> "cabal buck2: no longer using an action cache"
        , "cabal buck2: run `buck2 kill` now: a running buck2 daemon keeps using the old settings"
        , "(with a cache address but half of the new settings it retries connecting for ~45s on every build)"
        ]

-- | The lines @cabal buck2 --cache=ADDRESS@ puts in @.buckconfig@, without the
-- markers. @default_allow_cache_upload@ is needed because most actions of
-- the prelude don't opt in to having their results uploaded, and
-- @engine_address@ because buck2 won't connect to the cache without it, even
-- though nothing is run there. buck2 reads @[buck2_re_client]@ when its daemon
-- starts, but @[cabal_buck2] cache@ on every command, so a daemon that was
-- running before these settings were added has to be restarted.
cacheBlock :: String -> [String]
cacheBlock address =
  [ "[cabal_buck2]"
  , "  cache = true"
  , ""
  , "[buck2]"
  , "  default_allow_cache_upload = true"
  , ""
  , "[buck2_re_client]"
  , "  action_cache_address = " ++ address
  , "  cas_address = " ++ address
  , "  engine_address = " ++ address
  , "  tls = " ++ (if "grpcs://" `isPrefixOf` address then "true" else "false")
  ]

beginMarker, endMarker :: String
beginMarker = "# >>> cabal buck2: cache (generated by `cabal buck2 --cache`: change it with --cache, remove it with --no-cache) >>>"
endMarker = "# <<< cabal buck2: cache <<<"

-- | Replace the block between the markers in a config file by the given
-- lines (or remove it, if there are none). If there is no block the new one
-- is added at the end. Anything outside the markers is left as it is.
spliceBlock :: Maybe [String] -> String -> String
spliceBlock block contents = case break isBegin ls of
  (before, _ : rest)
    | (_, _ : after) <- break (== endMarker) rest -> unlines ((if null new then dropSeparator before else before) ++ new ++ after)
  _ | null new -> contents
  _ -> unlines (ls ++ separator ++ new)
  where
    ls = lines contents
    isBegin = ("# >>> cabal buck2: cache" `isPrefixOf`)
    new = maybe [] (\b -> [beginMarker] ++ b ++ [endMarker]) block
    -- A blank line between what is there and the new block.
    separator = case reverse ls of
      (l : _) | any (not . isSpace) l -> [""]
      _ -> []
    -- ... which goes when the block does.
    dropSeparator xs = case reverse xs of
      (l : rest) | all isSpace l -> reverse rest
      _ -> xs