ScriptUtils.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Utilities to help commands with scripts
--
module Distribution.Client.ScriptUtils (
    getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,
    withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),
    updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',
    fakeProjectSourcePackage, lSrcpkgDescription,
    movedExePath
  ) where

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

import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L

import Distribution.CabalSpecVersion
    ( CabalSpecVersion (..), cabalSpecLatest)
import Distribution.Client.ProjectOrchestration
import Distribution.Client.Config
    ( defaultScriptBuildsDir )
import Distribution.Client.DistDirLayout
    ( DistDirLayout(..), DistDirParams(..) )
import Distribution.Client.HashValue
    ( hashValue, showHashValueBase64 )
import Distribution.Client.HttpUtils
         ( HttpTransport, configureTransport )
import Distribution.Client.NixStyleOptions
    ( NixStyleFlags (..) )
import Distribution.Client.ProjectConfig
    ( ProjectConfig(..), ProjectConfigShared(..), PackageConfig(..)
    , reportParseResult, withGlobalConfig, withProjectOrGlobalConfig
    , projectConfigHttpTransport )
import Distribution.Client.ProjectConfig.Legacy
    ( ProjectConfigSkeleton
    , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler )
import Distribution.Client.ProjectFlags
    ( flagIgnoreProject )
import Distribution.Client.ProjectPlanning
    ( ElaboratedSharedConfig(..), ElaboratedConfiguredPackage(..) )
import Distribution.Client.RebuildMonad
    ( runRebuild )
import Distribution.Client.Setup
    ( ConfigFlags(..), GlobalFlags(..) )
import Distribution.Client.TargetSelector
    ( TargetSelectorProblem(..), TargetString(..) )
import Distribution.Client.Types
    ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
import Distribution.Compiler
    ( CompilerId(..), perCompilerFlavorToList )
import Distribution.FieldGrammar
    ( parseFieldGrammar, takeFields )
import Distribution.Fields
    ( ParseResult, parseFatalFailure, readFields )
import Distribution.PackageDescription
    ( ignoreConditions )
import Distribution.PackageDescription.FieldGrammar
    ( executableFieldGrammar )
import Distribution.PackageDescription.PrettyPrint
    ( showGenericPackageDescription )
import Distribution.Parsec
    ( Position(..) )
import Distribution.Simple.Flag
    ( fromFlagOrDefault, flagToMaybe )
import Distribution.Simple.PackageDescription
    ( parseString )
import Distribution.Simple.Setup
    ( Flag(..) )
import Distribution.Simple.Compiler
    ( Compiler(..), OptimisationLevel(..), compilerInfo )
import Distribution.Simple.Utils
    ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )
import qualified Distribution.SPDX.License as SPDX
import Distribution.Solver.Types.SourcePackage as SP
    ( SourcePackage(..) )
import Distribution.System
    ( Platform(..) )
import Distribution.Types.BuildInfo
    ( BuildInfo(..) )
import Distribution.Types.ComponentId
    ( mkComponentId )
import Distribution.Types.CondTree
    ( CondTree(..) )
import Distribution.Types.Executable
    ( Executable(..) )
import Distribution.Types.GenericPackageDescription as GPD
    ( GenericPackageDescription(..), emptyGenericPackageDescription )
import Distribution.Types.PackageDescription
    ( PackageDescription(..), emptyPackageDescription )
import Distribution.Types.PackageName.Magic
    ( fakePackageCabalFileName, fakePackageId )
import Distribution.Types.UnitId
    ( newSimpleUnitId )
import Distribution.Types.UnqualComponentName
    ( UnqualComponentName )
import Distribution.Utils.NubList
    ( fromNubList )
import Distribution.Client.ProjectPlanning
    ( configureCompiler )
import Distribution.Verbosity
    ( normal )
import Language.Haskell.Extension
    ( Language(..) )

import Control.Concurrent.MVar
    ( newEmptyMVar, putMVar, tryTakeMVar )
import Control.Exception
    ( bracket )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import System.Directory
    ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )
import System.FilePath
    ( (</>), makeRelative, takeDirectory, takeFileName )
import qualified Text.Parsec as P

-- A note on multi-module script support #6787:
-- Multi-module scripts are not supported and support is non-trivial.
-- What you want to do is pass the absolute path to the script's directory in hs-source-dirs,
-- but hs-source-dirs only accepts relative paths. This leaves you with several options none
-- of which are particularly appealing.
-- 1) Loosen the requirement that hs-source-dirs take relative paths
-- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path
-- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the
--    repl to deal with the fact that the repl is relative to the working directory and not
--    the project root.

-- | Get the hash of a script's absolute path)
--
-- Two hashes will be the same as long as the absolute paths
-- are the same.
getScriptHash :: FilePath -> IO String
getScriptHash script
  -- Base64 is shorter than Base16, which helps avoid long path issues on windows
  -- but it can contain /'s which aren't valid in file paths so replace them with
  -- %'s. 26 chars / 130 bits is enough to practically avoid collisions.
  = map (\c -> if c == '/' then '%' else c) . take 26
  . showHashValueBase64 . hashValue . fromString <$> canonicalizePath script

-- | Get the directory for caching a script build.
--
-- The only identity of a script is it's absolute path, so append the
-- hashed path to the @script-builds@ dir to get the cache directory.
getScriptCacheDirectory :: FilePath -> IO FilePath
getScriptCacheDirectory script = (</>) <$> defaultScriptBuildsDir <*> getScriptHash script

-- | Get the directory for caching a script build and ensure it exists.
--
-- The only identity of a script is it's absolute path, so append the
-- hashed path to the @script-builds@ dir to get the cache directory.
ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
ensureScriptCacheDirectory verbosity script = do
  cacheDir <- getScriptCacheDirectory script
  createDirectoryIfMissingVerbose verbosity True cacheDir
  return cacheDir

-- | What your command should do when no targets are found.
data AcceptNoTargets
  = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject'
  | AcceptNoTargets -- ^ return a default 'TargetSelector'
  deriving (Eq, Show)

-- | Information about the context in which we found the 'TargetSelector's.
data TargetContext
  = ProjectContext -- ^ The target selectors are part of a project.
  | GlobalContext  -- ^ The target selectors are from the global context.
  | ScriptContext FilePath Executable
  -- ^ The target selectors refer to a script. Contains the path to the script and
  -- the executable metadata parsed from the script
  deriving (Eq, Show)

-- | Determine whether the targets represent regular targets or a script
-- and return the proper context and target selectors.
-- Die with an error message if selectors are valid as neither regular targets or as a script.
--
-- In the case that the context refers to a temporary directory,
-- delete it after the action finishes.
withContextAndSelectors
  :: AcceptNoTargets     -- ^ What your command should do when no targets are found.
  -> Maybe ComponentKind -- ^ A target filter
  -> NixStyleFlags a     -- ^ Command line flags
  -> [String]            -- ^ Target strings or a script and args.
  -> GlobalFlags         -- ^ Global flags.
  -> CurrentCommand      -- ^ Current Command (usually for error reporting).
  -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
  -- ^ The body of your command action.
  -> IO b
withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act
  = withTemporaryTempDirectory $ \mkTmpDir -> do
    (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir)

    (tc', ctx', sels) <- case targetStrings of
      -- Only script targets may contain spaces and or end with ':'.
      -- Trying to readTargetSelectors such a target leads to a parse error.
      [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do
          scriptOrError target [TargetSelectorNoScript $ TargetString1 target]
      _                                                   -> do
        -- In the case where a selector is both a valid target and script, assume it is a target,
        -- because you can disambiguate the script with "./script"
        readTargetSelectors (localPackages ctx) kind targetStrings >>= \case
          Left err@(TargetSelectorNoTargetsInProject:_)
            | [] <- targetStrings
            , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget)
            | (script:_) <- targetStrings  -> scriptOrError script err
          Left err@(TargetSelectorNoSuch t _:_)
            | TargetString1 script <- t    -> scriptOrError script err
          Left err@(TargetSelectorExpected t _ _:_)
            | TargetString1 script <- t    -> scriptOrError script err
          Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name.
            | [script] <- targetStrings    -> scriptOrError script err
          Left err                         -> reportTargetSelectorProblems verbosity err
          Right sels                       -> return (tc, ctx, sels)

    act tc' ctx' sels
  where
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
    ignoreProject = flagIgnoreProject projectFlags
    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
    defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing]

    withProject = do
      ctx <- establishProjectBaseContext verbosity cliConfig cmd
      return (ProjectContext, ctx)
    withoutProject mkTmpDir globalConfig = do
      distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkTmpDir
      ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd
      return (GlobalContext, ctx)

    scriptBaseCtx script globalConfig = do
      let noDistDir = mempty { projectConfigShared = mempty { projectConfigDistDir = Flag "" } }
      let cfg = noDistDir <> globalConfig <> cliConfig
      rootDir <- ensureScriptCacheDirectory verbosity script
      distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir
      establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd

    scriptOrError script err = do
      exists <- doesFileExist script
      if exists then do
        ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script)

        let projectRoot = distProjectRootDirectory $ distDirLayout ctx
        writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script

        scriptContents <- BS.readFile script
        executable     <- readExecutableBlockFromScript verbosity scriptContents


        httpTransport <- configureTransport verbosity
                     (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
                     (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)

        projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents

        createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
        (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)

        projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compilerInfo compiler)) mempty projectCfgSkeleton

        let ctx' = ctx & lProjectConfig %~ (<> projectCfg)

            build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform
            exePath = build_dir </> "bin" </> scriptExeFileName script
            exePathRel = makeRelative projectRoot exePath

            executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just
                                     & L.buildInfo . L.options %~ fmap (setExePath exePathRel)

        createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath)

        return (ScriptContext script executable', ctx', defaultTarget)
      else reportTargetSelectorProblems verbosity err

withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act
  where
    -- We return an (IO Filepath) instead of a FilePath for two reasons:
    -- 1) To give the consumer the discretion to not create the tmpDir,
    --    but still grantee that it's deleted if they do create it
    -- 2) Because the path returned by createTempDirectory is not predicable
    getMkTmp m = return $ do
      tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl."
      putMVar m tmpDir
      return tmpDir
    rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive)

scriptComponenetName :: IsString s => FilePath -> s
scriptComponenetName scriptPath = fromString cname
  where
    cname = "script-" ++ map censor (takeFileName scriptPath)
    censor c | c `S.member` ccNamecore = c
             | otherwise               = '_'

scriptExeFileName :: FilePath -> FilePath
scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath

scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams
scriptDistDirParams scriptPath ctx compiler platform = DistDirParams
  { distParamUnitId         = newSimpleUnitId cid
  , distParamPackageId      = fakePackageId
  , distParamComponentId    = cid
  , distParamComponentName  = Just $ CExeName cn
  , distParamCompilerId     = compilerId compiler
  , distParamPlatform       = platform
  , distParamOptimization   = fromFlagOrDefault NormalOptimisation optimization
  }
  where
      cn = scriptComponenetName scriptPath
      cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn
      optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx

setExePath :: FilePath -> [String] -> [String]
setExePath exePath options
  | "-o" `notElem` options = "-o" : exePath : options
  | otherwise              = options

-- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ctx srcPkg = do
  let projectRoot      = distProjectRootDirectory $ distDirLayout ctx
      packageFile      = projectRoot </> fakePackageCabalFileName
      contents         = showGenericPackageDescription (srcpkgDescription srcPkg)
      writePackageFile = writeUTF8File packageFile contents
  -- TODO This is here to prevent reconfiguration of cached repl packages.
  -- It's worth investigating why it's needed in the first place.
  packageFileExists <- doesFileExist packageFile
  if packageFileExists then do
    cached <- force <$> readUTF8File packageFile
    when (cached /= contents)
      writePackageFile
  else writePackageFile
  return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg]))

-- | Add add the executable metadata to the context and write a .cabal file.
updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do
  let projectRoot = distProjectRootDirectory $ distDirLayout ctx

  absScript <- canonicalizePath scriptPath
  let
    sourcePackage = fakeProjectSourcePackage projectRoot
      & lSrcpkgDescription . L.condExecutables
      .~ [(scriptComponenetName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
    executable = scriptExecutable
      & L.modulePath .~ absScript

  updateContextAndWriteProjectFile' ctx sourcePackage

parseScriptBlock :: BS.ByteString -> ParseResult Executable
parseScriptBlock str =
    case readFields str of
        Right fs -> do
            let (fields, _) = takeFields fs
            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
        Left perr -> parseFatalFailure pos (show perr) where
            ppos = P.errorPos perr
            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)

readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"

-- | Extract the first encountered executable metadata block started and
-- terminated by the below tokens or die.
--
-- * @{- cabal:@
--
-- * @-}@
--
-- Return the metadata.
readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
readExecutableBlockFromScript verbosity str = do
    str' <- case extractScriptBlock "cabal" str of
              Left e -> die' verbosity $ "Failed extracting script block: " ++ e
              Right x -> return x
    when (BS.all isSpace str') $ warn verbosity "Empty script block"
    readScriptBlock verbosity str'

-- | Extract the first encountered project metadata block started and
-- terminated by the below tokens.
--
-- * @{- project:@
--
-- * @-}@
--
-- Return the metadata.
readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do
    case extractScriptBlock "project" str of
        Left  _ -> return mempty
        Right x ->    reportParseResult verbosity "script" scriptName
                  =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x

-- | Extract the first encountered script metadata block started end
-- terminated by the tokens
--
-- * @{- <header>:@
--
-- * @-}@
--
-- appearing alone on lines (while tolerating trailing whitespace).
-- These tokens are not part of the 'Right' result.
--
-- In case of missing or unterminated blocks a 'Left'-error is
-- returned.
extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString
extractScriptBlock header str = goPre (BS.lines str)
  where
    isStartMarker = (== startMarker) . stripTrailSpace
    isEndMarker   = (== endMarker) . stripTrailSpace

    stripTrailSpace = fst . BS.spanEnd isSpace

    -- before start marker
    goPre ls = case dropWhile (not . isStartMarker) ls of
                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
                 (_:ls') -> goBody [] ls'

    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"
    goBody acc (l:ls)
      | isEndMarker l = Right $! BS.unlines $ reverse acc
      | otherwise     = goBody (l:acc) ls

    startMarker, endMarker :: BS.ByteString
    startMarker = "{- " <> header <> ":"
    endMarker   = "-}"

-- | The base for making a 'SourcePackage' for a fake project.
-- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.
fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage projectRoot = sourcePackage
  where
    sourcePackage = SourcePackage
      { srcpkgPackageId     = fakePackageId
      , srcpkgDescription   = genericPackageDescription
      , srcpkgSource        = LocalUnpackedPackage projectRoot
      , srcpkgDescrOverride = Nothing
      }
    genericPackageDescription = emptyGenericPackageDescription
      { GPD.packageDescription = packageDescription }
    packageDescription = emptyPackageDescription
      { package = fakePackageId
      , specVersion = CabalSpecV2_2
      , licenseRaw = Left SPDX.NONE
      }

-- | Find the path of an exe that has been relocated with a "-o" option
movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath
movedExePath selectedComponent distDirLayout elabShared elabConfigured = do
  exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured
  let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared
  opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe)
  let projectRoot = distProjectRootDirectory distDirLayout
  fmap (projectRoot </>) . lookup "-o" $ reverse (zip opts (drop 1 opts))

-- Lenses
-- | A lens for the 'srcpkgDescription' field of 'SourcePackage'
lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s))
{-# inline lSrcpkgDescription #-}

lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s))
{-# inline lLocalPackages #-}

lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s))
{-# inline lProjectConfig #-}

-- Character classes
-- Transcribed from "templates/Lexer.x"
ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
ccSpace     = S.fromList " "
ccCtrlchar  = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]
ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar
ccSymbol'   = S.fromList ",=<>+*&|!$%^@#?/\\~"
ccParen     = S.fromList "()[]"
ccNamecore  = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']