Skip to content

Commit

Permalink
Add support for scripts to cabal build.
Browse files Browse the repository at this point in the history 
Added module Distribution.Client.ScriptUtils for code to deal with
scripts that is common between commands.

WIP: #7842
  • Loading branch information
@bacchanalia
bacchanalia committed Dec 2, 2021
1 parent 92e5f14 commit 079c5f0
Show file tree
Hide file tree
Showing 4 changed files with 276 additions and 232 deletions.
1 change: 1 addition & 0 deletions cabal-install/cabal-install.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -159,6 +159,7 @@ library
Distribution.Client.Sandbox
Distribution.Client.Sandbox.PackageEnvironment
Distribution.Client.SavedFlags
Distribution.Client.ScriptUtils
Distribution.Client.Security.DNS
Distribution.Client.Security.HTTP
Distribution.Client.Setup
Expand Down
12 changes: 4 additions & 8 deletions cabal-install/src/Distribution/Client/CmdBuild.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,8 @@ import Distribution.Verbosity
( normal )
import Distribution.Simple.Utils
( wrapText, die' )
import Distribution.Client.ScriptUtils
( withTempTempDirectory, getContextAndSelectorsWithScripts )

import qualified Data.Map as Map

Expand Down Expand Up @@ -95,19 +97,15 @@ defaultBuildFlags = BuildFlags
-- "Distribution.Client.ProjectOrchestration"
--
buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = do
buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags = withTempTempDirectory $ \tmpDir -> do
-- TODO: This flags defaults business is ugly
let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags
<> buildOnlyConfigure buildFlags)
targetAction
| onlyConfigure = TargetActionConfigure
| otherwise = TargetActionBuild

baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand

targetSelectors <-
either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings
(baseCtx, targetSelectors) <- getContextAndSelectorsWithScripts flags targetStrings globalFlags tmpDir

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down Expand Up @@ -141,8 +139,6 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig globalFlags flags
mempty -- ClientInstallFlags, not needed here

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
Expand Down
239 changes: 15 additions & 224 deletions cabal-install/src/Distribution/Client/CmdRun.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,32 +36,21 @@ import Distribution.Client.Setup
( GlobalFlags(..), ConfigFlags(..) )
import Distribution.Client.GlobalFlags
( defaultGlobalFlags )
import Distribution.Client.Config
( getCabalDir )
import Distribution.Simple.Flag
( fromFlagOrDefault )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Types.ComponentName
( showComponentName )
import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)
import Distribution.Verbosity
( normal )
import Distribution.Simple.Utils
( wrapText, warn, die', info, notice
, createTempDirectory, handleDoesNotExist )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), ProjectConfigShared(..)
, withProjectOrGlobalConfig )
import Distribution.Client.ProjectFlags
( flagIgnoreProject )
( wrapText, die', info, notice )
import Distribution.Client.ProjectPlanning
( ElaboratedConfiguredPackage(..)
, ElaboratedInstallPlan, binDirectoryFor )
import Distribution.Client.ProjectPlanning.Types
( dataDirsEnvironmentForPlan )
import Distribution.Client.TargetSelector
( TargetSelectorProblem(..), TargetString(..) )
import Distribution.Client.InstallPlan
( toList, foldPlanPackage )
import Distribution.Types.UnqualComponentName
Expand All @@ -71,45 +60,14 @@ import Distribution.Simple.Program.Run
emptyProgramInvocation )
import Distribution.Types.UnitId
( UnitId )
import Distribution.Client.ScriptUtils
( withTempTempDirectory, getContextAndSelectorsWithScripts )

import Distribution.Client.Types
( PackageLocation(..), PackageSpecifier(..) )
import Distribution.FieldGrammar
( takeFields, parseFieldGrammar )
import Distribution.PackageDescription.FieldGrammar
( executableFieldGrammar )
import Distribution.PackageDescription.PrettyPrint
( writeGenericPackageDescription )
import Distribution.Parsec
( Position(..) )
import Distribution.Fields
( ParseResult, parseString, parseFatalFailure, readFields )
import qualified Distribution.SPDX.License as SPDX
import Distribution.Solver.Types.SourcePackage as SP
( SourcePackage(..) )
import Distribution.Types.BuildInfo
( BuildInfo(..) )
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
( fakePackageId )
import Language.Haskell.Extension
( Language(..) )

import qualified Data.ByteString.Char8 as BS
import qualified Data.Set as Set
import qualified Text.Parsec as P
import System.Directory
( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist, makeAbsolute )
( doesFileExist )
import System.FilePath
( (</>), isValid, isPathSeparator, takeExtension )

( (</>), isValid, isPathSeparator )

runCommand :: CommandUI (NixStyleFlags ())
runCommand = CommandUI
Expand Down Expand Up @@ -160,51 +118,13 @@ runCommand = CommandUI
-- "Distribution.Client.ProjectOrchestration"
--
runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
runAction flags@NixStyleFlags {..} targetStrings globalFlags = do
globalTmp <- getTemporaryDirectory
tmpDir <- createTempDirectory globalTmp "cabal-repl."

let
with =
establishProjectBaseContext verbosity cliConfig OtherCommand
without dir globalConfig = do
distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) dir
establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand

baseCtx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without tmpDir)

let
scriptOrError script err = do
exists <- doesFileExist script
let pol | takeExtension script == ".lhs" = LiterateHaskell
| otherwise = PlainHaskell
if exists
then do
cacheDir <- getScriptCacheDirectory script
ctx <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without cacheDir)
BS.readFile script >>= handleScriptCase verbosity pol ctx cacheDir
else reportTargetSelectorProblems verbosity err

-- We pass the baseCtx made with tmpDir to readTargetSelectors and only create a ctx with cacheDir
-- if no target is found because we want global targets to have higher priority than scripts.
-- In case of a collision, `cabal run target` can be rewritten as `cabal run ./target`
-- to specify the script, but there is no alternate way to specify the global target.
(baseCtx', targetSelectors) <-
readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings)
>>= \case
Left err@(TargetSelectorNoTargetsInProject:_)
| (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 -> reportTargetSelectorProblems verbosity err
Right sels -> return (baseCtx, sels)
runAction flags@NixStyleFlags {..} targetStrings globalFlags = withTempTempDirectory $ \tmpDir -> do
(baseCtx, targetSelectors) <- getContextAndSelectorsWithScripts flags targetStrings globalFlags tmpDir

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

when (buildSettingOnlyDeps (buildSettings baseCtx')) $
when (buildSettingOnlyDeps (buildSettings baseCtx)) $
die' verbosity $
"The run command does not support '--only-dependencies'. "
++ "You may wish to use 'build --only-dependencies' and then "
Expand Down Expand Up @@ -246,10 +166,10 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do
++ "phase has been reached. This is a bug.")
$ targetsMap buildCtx

printPlan verbosity baseCtx' buildCtx
printPlan verbosity baseCtx buildCtx

buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx
runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes


let elaboratedPlan = elaboratedPlanToExecute buildCtx
Expand Down Expand Up @@ -287,14 +207,14 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do
++ exeName
++ ":\n"
++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
let exePath = binDirectoryFor (distDirLayout baseCtx')
let exePath = binDirectoryFor (distDirLayout baseCtx)
(elaboratedShared buildCtx)
pkg
exeName
</> exeName
let args = drop 1 targetStrings
dryRun = buildSettingDryRun (buildSettings baseCtx')
|| buildSettingOnlyDownload (buildSettings baseCtx')
dryRun = buildSettingDryRun (buildSettings baseCtx)
|| buildSettingOnlyDownload (buildSettings baseCtx)

if dryRun
then notice verbosity "Running of executable suppressed by flag(s)"
Expand All @@ -308,23 +228,8 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do
(distDirLayout baseCtx)
elaboratedPlan
}

handleDoesNotExist () (removeDirectoryRecursive tmpDir)
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
ignoreProject = flagIgnoreProject projectFlags
cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)

-- | Get the directory for caching a script build.
--
-- The only identity of a script is it's absolute path, so append that path
-- to <cabal_dir>/script-builds/ to get the cache directory.
getScriptCacheDirectory :: FilePath -> IO FilePath
getScriptCacheDirectory script = do
scriptAbs <- dropWhile (\c -> c == '/' || c == '\\') <$> makeAbsolute script
cabalDir <- getCabalDir
return $ cabalDir </> "script-builds" </> scriptAbs

-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was
-- invoked as a script interpreter, i.e. via
Expand Down Expand Up @@ -352,120 +257,6 @@ handleShebang :: FilePath -> [String] -> IO ()
handleShebang script args =
runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags

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"

readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString)
readScriptBlockFromScript verbosity pol str = do
str' <- case extractScriptBlock pol 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"
(\x -> (x, noShebang)) <$> readScriptBlock verbosity str'
where
noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str

-- | Extract the first encountered script metadata block started end
-- terminated by the tokens
--
-- * @{- cabal:@
--
-- * @-}@
--
-- 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 :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString
extractScriptBlock _pol 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 = fromString "{- cabal:"
endMarker = fromString "-}"

data PlainOrLiterate
= PlainHaskell
| LiterateHaskell

handleScriptCase
:: Verbosity
-> PlainOrLiterate
-> ProjectBaseContext
-> FilePath
-> BS.ByteString
-> IO (ProjectBaseContext, [TargetSelector])
handleScriptCase verbosity pol baseCtx tmpDir scriptContents = do
(executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents

-- We need to create a dummy package that lives in our dummy project.
let
mainName = case pol of
PlainHaskell -> "Main.hs"
LiterateHaskell -> "Main.lhs"

sourcePackage = SourcePackage
{ srcpkgPackageId = pkgId
, srcpkgDescription = genericPackageDescription
, srcpkgSource = LocalUnpackedPackage tmpDir
, srcpkgDescrOverride = Nothing
}
genericPackageDescription = emptyGenericPackageDescription
{ GPD.packageDescription = packageDescription
, condExecutables = [("script", CondNode executable' targetBuildDepends [])]
}
executable' = executable
{ modulePath = mainName
, buildInfo = binfo
{ defaultLanguage =
case defaultLanguage of
just@(Just _) -> just
Nothing -> Just Haskell2010
}
}
binfo@BuildInfo{..} = buildInfo executable
packageDescription = emptyPackageDescription
{ package = pkgId
, specVersion = CabalSpecV2_2
, licenseRaw = Left SPDX.NONE
}
pkgId = fakePackageId

writeGenericPackageDescription (tmpDir </> "fake-package.cabal") genericPackageDescription
BS.writeFile (tmpDir </> mainName) contents'

let
baseCtx' = baseCtx
{ localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] }
targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]

return (baseCtx', targetSelectors)

singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
singleExeOrElse action targetsMap =
case Set.toList . distinctTargetComponents $ targetsMap
Expand Down
Loading

0 comments on commit 079c5f0

Please sign in to comment.