Merge pull request #3287 from commercialhaskell/3218-custom-snapshots…

…-scripts

Allow properly loading custom snapshots in scripts #3218

src/Stack/Config.hs

@@ -468,7 +468,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do
 
     config <-
         case mproject of
-          LCSNoConfig -> configNoLocalConfig stackRoot mresolver configArgs
+          LCSNoConfig _ -> configNoLocalConfig stackRoot mresolver configArgs
           LCSProject project -> loadHelper $ Just project
           LCSNoProject -> loadHelper Nothing
     unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
@@ -488,7 +488,7 @@ loadConfigMaybeProject configArgs mresolver mproject = do
             case mprojectRoot of
               LCSProject fp -> Just fp
               LCSNoProject  -> Nothing
-              LCSNoConfig   -> Nothing
+              LCSNoConfig _ -> Nothing
         }
 
 -- | Load the configuration, using current directory, environment variables,
@@ -517,9 +517,14 @@ loadBuildConfig mproject mresolver mcompiler = do
     (project', stackYamlFP) <- case mproject of
       LCSProject (project, fp, _) -> do
           forM_ (projectUserMsg project) ($logWarn . T.pack)
-          return (project, fp)
-      LCSNoConfig -> do
-          p <- getEmptyProject
+          resolver <-
+              case mresolver of
+                  Nothing -> return $ projectResolver project
+                  Just aresolver ->
+                      runRIO config $ makeConcreteResolver (Just (parent fp)) aresolver
+          return (project { projectResolver = resolver }, fp)
+      LCSNoConfig parentDir -> do
+          p <- getEmptyProject (Just parentDir)
           return (p, configUserConfigPath config)
       LCSNoProject -> do
             $logDebug "Run from outside a project, using implicit global project config"
@@ -552,7 +557,7 @@ loadBuildConfig mproject mresolver mcompiler = do
                else do
                    $logInfo ("Writing implicit global project config file to: " <> T.pack dest')
                    $logInfo "Note: You can change the snapshot via the resolver field there."
-                   p <- getEmptyProject
+                   p <- getEmptyProject Nothing
                    liftIO $ do
                        S.writeFile dest' $ S.concat
                            [ "# This is the implicit global project's config file, which is only used when\n"
@@ -568,17 +573,11 @@ loadBuildConfig mproject mresolver mcompiler = do
                            [ "This is the implicit global project, which is used only when 'stack' is run\n"
                            , "outside of a real project.\n" ]
                    return (p, dest)
-    resolver <-
-        case mresolver of
-            Nothing -> return $ projectResolver project'
-            Just aresolver ->
-                runRIO config $ makeConcreteResolver (Just (parent stackYamlFP)) aresolver
     let project = project'
-            { projectResolver = resolver
-            , projectCompiler = mcompiler <|> projectCompiler project'
+            { projectCompiler = mcompiler <|> projectCompiler project'
             }
 
-    sd0 <- runRIO config $ loadResolver resolver
+    sd0 <- runRIO config $ loadResolver $ projectResolver project
     let sd = maybe id setCompilerVersion (projectCompiler project) sd0
 
     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
@@ -596,14 +595,15 @@ loadBuildConfig mproject mresolver mcompiler = do
             case mproject of
                 LCSNoProject -> True
                 LCSProject _ -> False
-                LCSNoConfig  -> False
+                LCSNoConfig _ -> False
         }
   where
-    getEmptyProject :: RIO Config Project
-    getEmptyProject = do
+    getEmptyProject :: Maybe (Path Abs Dir) -- ^ directory used for making concrete resolver
+                    -> RIO Config Project
+    getEmptyProject mparentDir = do
       r <- case mresolver of
             Just aresolver -> do
-                r' <- makeConcreteResolver Nothing aresolver
+                r' <- makeConcreteResolver mparentDir aresolver
                 $logInfo ("Using resolver: " <> resolverRawName r' <> " specified on command line")
                 return r'
             Nothing -> do
@@ -862,12 +862,13 @@ getProjectConfig SYLDefault = do
         if exists
             then return $ Just fp
             else return Nothing
-getProjectConfig SYLNoConfig = return LCSNoConfig
+getProjectConfig (SYLNoConfig parentDir) = return (LCSNoConfig parentDir)
 
 data LocalConfigStatus a
     = LCSNoProject
     | LCSProject a
-    | LCSNoConfig
+    | LCSNoConfig !(Path Abs Dir)
+    -- ^ parent directory for making a concrete resolving
     deriving (Show,Functor,Foldable,Traversable)
 
 -- | Find the project config file location, respecting environment variables
@@ -888,9 +889,9 @@ loadProjectConfig mstackYaml = do
         LCSNoProject -> do
             $logDebug $ "No project config file found, using defaults."
             return LCSNoProject
-        LCSNoConfig -> do
+        LCSNoConfig mparentDir -> do
             $logDebug "Ignoring config files"
-            return LCSNoConfig
+            return (LCSNoConfig mparentDir)
   where
     load fp = do
         ProjectAndConfigMonoid project config <- loadConfigYaml (parseProjectAndConfigMonoid (parent fp)) fp
@@ -943,7 +944,13 @@ getFakeConfigPath stackRoot ar = do
     case ar of
       ARResolver r -> return $ T.unpack $ resolverRawName r
       _ -> throwM $ InvalidResolverForNoLocalConfig $ show ar
-  asDir <- parseRelDir asString
+  -- This takeWhile is an ugly hack. We don't actually need this
+  -- path for anything useful. But if we take the raw value for
+  -- a custom snapshot, it will be unparseable in a PATH.
+  -- Therefore, we add in this silly "strip up to :".
+  -- Better would be to defer figuring out this value until
+  -- after we have a fully loaded snapshot with a hash.
+  asDir <- parseRelDir $ takeWhile (/= ':') asString
   let full = stackRoot </> $(mkRelDir "script") </> asDir </> $(mkRelFile "config.yaml")
   ensureDir (parent full)
   return full

src/Stack/ConfigCmd.hs

@@ -61,7 +61,7 @@ cfgCmdSet go cmd = do
                      case mstackYaml of
                          LCSProject stackYaml -> return stackYaml
                          LCSNoProject -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir conf)
-                         LCSNoConfig -> throwString "config command used when no local configuration available"
+                         LCSNoConfig _ -> throwString "config command used when no local configuration available"
                  CommandScopeGlobal -> return (configUserConfigPath conf)
     -- We don't need to worry about checking for a valid yaml here
     (config :: Yaml.Object) <-

src/Stack/Script.hs

@@ -30,11 +30,12 @@ import           System.Process.Read
 -- | Run a Stack Script
 scriptCmd :: ScriptOpts -> GlobalOpts -> IO ()
 scriptCmd opts go' = do
+    file <- resolveFile' $ soFile opts
     let go = go'
             { globalConfigMonoid = (globalConfigMonoid go')
                 { configMonoidInstallGHC = First $ Just True
                 }
-            , globalStackYaml = SYLNoConfig
+            , globalStackYaml = SYLNoConfig $ parent file
             }
     withBuildConfigAndLock go $ \lk -> do
         -- Some warnings in case the user somehow tries to set a
@@ -46,7 +47,7 @@ scriptCmd opts go' = do
           SYLOverride fp -> $logError $ T.pack
             $ "Ignoring override stack.yaml file for script command: " ++ fp
           SYLDefault -> return ()
-          SYLNoConfig -> assert False (return ())
+          SYLNoConfig _ -> assert False (return ())
 
         config <- view configL
         menv <- liftIO $ configEnvOverride config defaultEnvSettings
@@ -100,7 +101,6 @@ scriptCmd opts go' = do
           SEInterpret -> exec menv ("run" ++ compilerExeName wc)
                 (ghcArgs ++ soFile opts : soArgs opts)
           _ -> do
-            file <- resolveFile' $ soFile opts
             let dir = parent file
             -- use sinkProcessStdout to ensure a ProcessFailed
             -- exception is generated for better error messages

src/Stack/Snapshot.hs

@@ -77,6 +77,7 @@ data SnapshotException
   | FilepathInCustomSnapshot !Text
   | NeedResolverOrCompiler !Text
   | MissingPackages !(Set PackageName)
+  | CustomResolverException !Text !(Either Request FilePath) !ParseException
   deriving Typeable
 instance Exception SnapshotException
 instance Show SnapshotException where
@@ -123,6 +124,14 @@ instance Show SnapshotException where
   show (MissingPackages names) =
     "The following packages specified by flags or options are not found: " ++
     unwords (map packageNameString (Set.toList names))
+  show (CustomResolverException url loc e) = concat
+    [ "Unable to load custom resolver "
+    , T.unpack url
+    , " from location\n"
+    , show loc
+    , "\nException: "
+    , show e
+    ]
 
 -- | Convert a 'Resolver' into a 'SnapshotDef'
 loadResolver
@@ -233,7 +242,7 @@ loadResolver (ResolverCompiler compiler) = return SnapshotDef
     , sdGlobalHints = Map.empty
     }
 loadResolver (ResolverCustom url loc) = do
-  $logDebug $ "Loading " <> url <> " build plan"
+  $logDebug $ "Loading " <> url <> " build plan from " <> T.pack (show loc)
   case loc of
     Left req -> download' req >>= load . toFilePath
     Right fp -> load fp
@@ -255,7 +264,7 @@ loadResolver (ResolverCustom url loc) = do
     load fp = do
       WithJSONWarnings (sd0, mparentResolver, mcompiler) warnings <-
         liftIO (decodeFileEither fp) >>= either
-          throwM
+          (throwM . CustomResolverException url loc)
           (either (throwM . AesonException) return . parseEither parseCustom)
       logJSONWarnings (T.unpack url) warnings
 

src/Stack/Types/Config.hs

@@ -444,7 +444,9 @@ data GlobalOpts = GlobalOpts
 data StackYamlLoc filepath
     = SYLDefault
     | SYLOverride !filepath
-    | SYLNoConfig
+    | SYLNoConfig !(Path Abs Dir)
+    -- ^ FilePath is the directory containing the script file, used
+    -- for resolving custom snapshot files.
     deriving (Show,Functor,Foldable,Traversable)
 
 -- | Parsed global command-line options monoid.