cabal-install/src/Distribution/Client/ScriptUtils.hs

   1 {-# LANGUAGE LambdaCase #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5
   6 -- | Utilities to help commands with scripts
   7 --
   8 module Distribution.Client.ScriptUtils (
   9     getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,
  10     withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),
  11     updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',
  12     fakeProjectSourcePackage, lSrcpkgDescription
  13   ) where
  14
  15 import Prelude ()
  16 import Distribution.Client.Compat.Prelude hiding (toList)
  17
  18 import Distribution.Compat.Lens
  19 import qualified Distribution.Types.Lens as L
  20
  21 import Distribution.CabalSpecVersion
  22     ( CabalSpecVersion (..), cabalSpecLatest)
  23 import Distribution.Client.ProjectOrchestration
  24 import Distribution.Client.Config
  25     ( defaultScriptBuildsDir )
  26 import Distribution.Client.DistDirLayout
  27     ( DistDirLayout(..) )
  28 import Distribution.Client.HashValue
  29     ( hashValue, showHashValue )
  30 import Distribution.Client.HttpUtils
  31          ( HttpTransport, configureTransport )
  32 import Distribution.Client.NixStyleOptions
  33     ( NixStyleFlags (..) )
  34 import Distribution.Client.ProjectConfig
  35     ( ProjectConfig(..), ProjectConfigShared(..)
  36     , reportParseResult, withProjectOrGlobalConfig
  37     , projectConfigHttpTransport )
  38 import Distribution.Client.ProjectConfig.Legacy
  39     ( ProjectConfigSkeleton
  40     , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler )
  41 import Distribution.Client.ProjectFlags
  42     ( flagIgnoreProject )
  43 import Distribution.Client.RebuildMonad
  44     ( runRebuild )
  45 import Distribution.Client.Setup
  46     ( ConfigFlags(..), GlobalFlags(..) )
  47 import Distribution.Client.TargetSelector
  48     ( TargetSelectorProblem(..), TargetString(..) )
  49 import Distribution.Client.Types
  50     ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
  51 import Distribution.FieldGrammar
  52     ( parseFieldGrammar, takeFields )
  53 import Distribution.Fields
  54     ( ParseResult, parseFatalFailure, readFields )
  55 import Distribution.PackageDescription
  56     ( ignoreConditions )
  57 import Distribution.PackageDescription.FieldGrammar
  58     ( executableFieldGrammar )
  59 import Distribution.PackageDescription.PrettyPrint
  60     ( showGenericPackageDescription )
  61 import Distribution.Parsec
  62     ( Position(..) )
  63 import Distribution.Simple.Flag
  64     ( fromFlagOrDefault, flagToMaybe )
  65 import Distribution.Simple.PackageDescription
  66     ( parseString )
  67 import Distribution.Simple.Setup
  68     ( Flag(..) )
  69 import Distribution.Simple.Compiler
  70     ( compilerInfo )
  71 import Distribution.Simple.Utils
  72     ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )
  73 import qualified Distribution.SPDX.License as SPDX
  74 import Distribution.Solver.Types.SourcePackage as SP
  75     ( SourcePackage(..) )
  76 import Distribution.System
  77     ( Platform(..) )
  78 import Distribution.Types.BuildInfo
  79     ( BuildInfo(..) )
  80 import Distribution.Types.CondTree
  81     ( CondTree(..) )
  82 import Distribution.Types.Executable
  83     ( Executable(..) )
  84 import Distribution.Types.GenericPackageDescription as GPD
  85     ( GenericPackageDescription(..), emptyGenericPackageDescription )
  86 import Distribution.Types.PackageDescription
  87     ( PackageDescription(..), emptyPackageDescription )
  88 import Distribution.Types.PackageName.Magic
  89     ( fakePackageCabalFileName, fakePackageId )
  90 import Distribution.Utils.NubList
  91     ( fromNubList )
  92 import Distribution.Client.ProjectPlanning
  93     ( configureCompiler )
  94 import Distribution.Verbosity
  95     ( normal )
  96 import Language.Haskell.Extension
  97     ( Language(..) )
  98
  99 import Control.Concurrent.MVar
 100     ( newEmptyMVar, putMVar, tryTakeMVar )
 101 import Control.Exception
 102     ( bracket )
 103 import qualified Data.ByteString.Char8 as BS
 104 import Data.ByteString.Lazy ()
 105 import qualified Data.Set as S
 106 import System.Directory
 107     ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )
 108 import System.FilePath
 109     ( (</>), takeFileName )
 110 import qualified Text.Parsec as P
 111
 112 -- A note on multi-module script support #6787:
 113 -- Multi-module scripts are not supported and support is non-trivial.
 114 -- What you want to do is pass the absolute path to the script's directory in hs-source-dirs,
 115 -- but hs-source-dirs only accepts relative paths. This leaves you with several options none
 116 -- of which are particularly appealing.
 117 -- 1) Loosen the requirement that hs-source-dirs take relative paths
 118 -- 2) Add a field to BuildInfo that acts like an hs-source-dir, but accepts an absolute path
 119 -- 3) Use a path relative to the project root in hs-source-dirs, and pass extra flags to the
 120 --    repl to deal with the fact that the repl is relative to the working directory and not
 121 --    the project root.
 122
 123 -- | Get the hash of a script's absolute path)
 124 --
 125 -- Two hashes will be the same as long as the absolute paths
 126 -- are the same.
 127 getScriptHash :: FilePath -> IO String
 128 getScriptHash script = showHashValue . hashValue . fromString <$> canonicalizePath script
 129
 130 -- | Get the directory for caching a script build.
 131 --
 132 -- The only identity of a script is it's absolute path, so append the
 133 -- hashed path to the @script-builds@ dir to get the cache directory.
 134 getScriptCacheDirectory :: FilePath -> IO FilePath
 135 getScriptCacheDirectory script = (</>) <$> defaultScriptBuildsDir <*> getScriptHash script
 136
 137 -- | Get the directory for caching a script build and ensure it exists.
 138 --
 139 -- The only identity of a script is it's absolute path, so append the
 140 -- hashed path to the @script-builds@ dir to get the cache directory.
 141 ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath
 142 ensureScriptCacheDirectory verbosity script = do
 143   cacheDir <- getScriptCacheDirectory script
 144   createDirectoryIfMissingVerbose verbosity True cacheDir
 145   return cacheDir
 146
 147 -- | What your command should do when no targets are found.
 148 data AcceptNoTargets
 149   = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject'
 150   | AcceptNoTargets -- ^ return a default 'TargetSelector'
 151   deriving (Eq, Show)
 152
 153 -- | Information about the context in which we found the 'TargetSelector's.
 154 data TargetContext
 155   = ProjectContext -- ^ The target selectors are part of a project.
 156   | GlobalContext  -- ^ The target selectors are from the global context.
 157   | ScriptContext FilePath Executable
 158   -- ^ The target selectors refer to a script. Contains the path to the script and
 159   -- the executable metadata parsed from the script
 160   deriving (Eq, Show)
 161
 162 -- | Determine whether the targets represent regular targets or a script
 163 -- and return the proper context and target selectors.
 164 -- Die with an error message if selectors are valid as neither regular targets or as a script.
 165 --
 166 -- In the case that the context refers to a temporary directory,
 167 -- delete it after the action finishes.
 168 withContextAndSelectors
 169   :: AcceptNoTargets     -- ^ What your command should do when no targets are found.
 170   -> Maybe ComponentKind -- ^ A target filter
 171   -> NixStyleFlags a     -- ^ Command line flags
 172   -> [String]            -- ^ Target strings or a script and args.
 173   -> GlobalFlags         -- ^ Global flags.
 174   -> CurrentCommand      -- ^ Current Command (usually for error reporting).
 175   -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
 176   -- ^ The body of your command action.
 177   -> IO b
 178 withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act
 179   = withTemporaryTempDirectory $ \mkTmpDir -> do
 180     (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir)
 181
 182     (tc', ctx', sels) <- case targetStrings of
 183       -- Only script targets may contain spaces and or end with ':'.
 184       -- Trying to readTargetSelectors such a target leads to a parse error.
 185       [target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do
 186           scriptOrError target [TargetSelectorNoScript $ TargetString1 target]
 187       _                                                   -> do
 188         -- In the case where a selector is both a valid target and script, assume it is a target,
 189         -- because you can disambiguate the script with "./script"
 190         readTargetSelectors (localPackages ctx) kind targetStrings >>= \case
 191           Left err@(TargetSelectorNoTargetsInProject:_)
 192             | [] <- targetStrings
 193             , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget)
 194             | (script:_) <- targetStrings  -> scriptOrError script err
 195           Left err@(TargetSelectorNoSuch t _:_)
 196             | TargetString1 script <- t    -> scriptOrError script err
 197           Left err@(TargetSelectorExpected t _ _:_)
 198             | TargetString1 script <- t    -> scriptOrError script err
 199           Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name.
 200             | [script] <- targetStrings    -> scriptOrError script err
 201           Left err                         -> reportTargetSelectorProblems verbosity err
 202           Right sels                       -> return (tc, ctx, sels)
 203
 204     act tc' ctx' sels
 205   where
 206     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 207     ignoreProject = flagIgnoreProject projectFlags
 208     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
 209     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 210     defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing]
 211
 212     with = do
 213       ctx <- establishProjectBaseContext verbosity cliConfig cmd
 214       return (ProjectContext, ctx)
 215     without mkDir globalConfig = do
 216       distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkDir
 217       ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd
 218       return (GlobalContext, ctx)
 219     scriptOrError script err = do
 220       exists <- doesFileExist script
 221       if exists then do
 222         -- In the script case we always want a dummy context even when ignoreProject is False
 223         let mkCacheDir = ensureScriptCacheDirectory verbosity script
 224         (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir)
 225
 226         let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 227         writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script
 228
 229         scriptContents <- BS.readFile script
 230         executable     <- readExecutableBlockFromScript verbosity scriptContents
 231
 232
 233         httpTransport <- configureTransport verbosity
 234                      (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
 235                      (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
 236
 237         projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
 238
 239         let fetchCompiler = do
 240                (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
 241                pure (os, arch, compilerInfo compiler)
 242
 243         projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton
 244
 245         let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just
 246             ctx'        = ctx & lProjectConfig %~ (<> projectCfg)
 247         return (ScriptContext script executable', ctx', defaultTarget)
 248       else reportTargetSelectorProblems verbosity err
 249
 250 withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
 251 withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act
 252   where
 253     -- We return an (IO Filepath) instead of a FilePath for two reasons:
 254     -- 1) To give the consumer the discretion to not create the tmpDir,
 255     --    but still grantee that it's deleted if they do create it
 256     -- 2) Because the path returned by createTempDirectory is not predicable
 257     getMkTmp m = return $ do
 258       tmpDir <- getTemporaryDirectory >>= flip createTempDirectory "cabal-repl."
 259       putMVar m tmpDir
 260       return tmpDir
 261     rmTmp m _ = tryTakeMVar m >>= maybe (return ()) (handleDoesNotExist () . removeDirectoryRecursive)
 262
 263 -- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
 264 updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
 265 updateContextAndWriteProjectFile' ctx srcPkg = do
 266   let projectRoot      = distProjectRootDirectory $ distDirLayout ctx
 267       packageFile      = projectRoot </> fakePackageCabalFileName
 268       contents         = showGenericPackageDescription (srcpkgDescription srcPkg)
 269       writePackageFile = writeUTF8File packageFile contents
 270   -- TODO This is here to prevent reconfiguration of cached repl packages.
 271   -- It's worth investigating why it's needed in the first place.
 272   packageFileExists <- doesFileExist packageFile
 273   if packageFileExists then do
 274     cached <- force <$> readUTF8File packageFile
 275     when (cached /= contents)
 276       writePackageFile
 277   else writePackageFile
 278   return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg]))
 279
 280 -- | Add add the executable metadata to the context and write a .cabal file.
 281 updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext
 282 updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do
 283   let projectRoot = distProjectRootDirectory $ distDirLayout ctx
 284
 285   absScript <- canonicalizePath scriptPath
 286   let
 287     -- Replace characters which aren't allowed in the executable component name with '_'
 288     -- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled
 289     scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath)
 290     censor c | c `S.member` ccNamecore = c
 291              | otherwise               = '_'
 292
 293     sourcePackage = fakeProjectSourcePackage projectRoot
 294       & lSrcpkgDescription . L.condExecutables
 295       .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
 296     executable = scriptExecutable
 297       & L.modulePath .~ absScript
 298
 299   updateContextAndWriteProjectFile' ctx sourcePackage
 300
 301 parseScriptBlock :: BS.ByteString -> ParseResult Executable
 302 parseScriptBlock str =
 303     case readFields str of
 304         Right fs -> do
 305             let (fields, _) = takeFields fs
 306             parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
 307         Left perr -> parseFatalFailure pos (show perr) where
 308             ppos = P.errorPos perr
 309             pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)
 310
 311 readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
 312 readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"
 313
 314 -- | Extract the first encountered executable metadata block started and
 315 -- terminated by the below tokens or die.
 316 --
 317 -- * @{- cabal:@
 318 --
 319 -- * @-}@
 320 --
 321 -- Return the metadata.
 322 readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
 323 readExecutableBlockFromScript verbosity str = do
 324     str' <- case extractScriptBlock "cabal" str of
 325               Left e -> die' verbosity $ "Failed extracting script block: " ++ e
 326               Right x -> return x
 327     when (BS.all isSpace str') $ warn verbosity "Empty script block"
 328     readScriptBlock verbosity str'
 329
 330 -- | Extract the first encountered project metadata block started and
 331 -- terminated by the below tokens.
 332 --
 333 -- * @{- project:@
 334 --
 335 -- * @-}@
 336 --
 337 -- Return the metadata.
 338 readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
 339 readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do
 340     case extractScriptBlock "project" str of
 341         Left  _ -> return mempty
 342         Right x ->    reportParseResult verbosity "script" scriptName
 343                   =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x
 344
 345 -- | Extract the first encountered script metadata block started end
 346 -- terminated by the tokens
 347 --
 348 -- * @{- <header>:@
 349 --
 350 -- * @-}@
 351 --
 352 -- appearing alone on lines (while tolerating trailing whitespace).
 353 -- These tokens are not part of the 'Right' result.
 354 --
 355 -- In case of missing or unterminated blocks a 'Left'-error is
 356 -- returned.
 357 extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteString
 358 extractScriptBlock header str = goPre (BS.lines str)
 359   where
 360     isStartMarker = (== startMarker) . stripTrailSpace
 361     isEndMarker   = (== endMarker) . stripTrailSpace
 362
 363     stripTrailSpace = fst . BS.spanEnd isSpace
 364
 365     -- before start marker
 366     goPre ls = case dropWhile (not . isStartMarker) ls of
 367                  [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
 368                  (_:ls') -> goBody [] ls'
 369
 370     goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"
 371     goBody acc (l:ls)
 372       | isEndMarker l = Right $! BS.unlines $ reverse acc
 373       | otherwise     = goBody (l:acc) ls
 374
 375     startMarker, endMarker :: BS.ByteString
 376     startMarker = "{- " <> header <> ":"
 377     endMarker   = "-}"
 378
 379 -- | The base for making a 'SourcePackage' for a fake project.
 380 -- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.
 381 fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
 382 fakeProjectSourcePackage projectRoot = sourcePackage
 383   where
 384     sourcePackage = SourcePackage
 385       { srcpkgPackageId     = fakePackageId
 386       , srcpkgDescription   = genericPackageDescription
 387       , srcpkgSource        = LocalUnpackedPackage projectRoot
 388       , srcpkgDescrOverride = Nothing
 389       }
 390     genericPackageDescription = emptyGenericPackageDescription
 391       { GPD.packageDescription = packageDescription }
 392     packageDescription = emptyPackageDescription
 393       { package = fakePackageId
 394       , specVersion = CabalSpecV2_2
 395       , licenseRaw = Left SPDX.NONE
 396       }
 397
 398 -- Lenses
 399 -- | A lens for the 'srcpkgDescription' field of 'SourcePackage'
 400 lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
 401 lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s))
 402 {-# inline lSrcpkgDescription #-}
 403
 404 lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
 405 lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s))
 406 {-# inline lLocalPackages #-}
 407
 408 lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
 409 lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s))
 410 {-# inline lProjectConfig #-}
 411
 412 -- Character classes
 413 -- Transcribed from "templates/Lexer.x"
 414 ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
 415 ccSpace     = S.fromList " "
 416 ccCtrlchar  = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]
 417 ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar
 418 ccSymbol'   = S.fromList ",=<>+*&|!$%^@#?/\\~"
 419 ccParen     = S.fromList "()[]"
 420 ccNamecore  = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']