diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,34 @@ # Changelog +## v2.7.5 + +**Changes since v2.7.3:** + +Behavior changes: + +* Cloning git repositories isn't per sub-directory anymore, see + [#5411](https://github.com/commercialhaskell/stack/issues/5411) + +Other enhancements: + +* `stack setup` supports installing GHC for macOS aarch64 (M1) + +* `stack upload` supports authentication with a Hackage API key (via + `HACKAGE_KEY` environment variable). + +Bug fixes: + +* Ensure that `extra-path` works for case-insensitive `PATH`s on Windows. + See [rio#237](https://github.com/commercialhaskell/rio/pull/237) +* Fix handling of overwritten `ghc` and `ghc-pkg` locations. + [#5597](https://github.com/commercialhaskell/stack/pull/5597) +* Fix failure to find package when a dependency is shared between projects. + [#5680](https://github.com/commercialhaskell/stack/issues/5680) +* `stack ghci` now uses package flags in `stack.yaml` + [#5434](https://github.com/commercialhaskell/stack/issues/5434) + + ## v2.7.3 **Changes since v2.7.1:** @@ -30,8 +58,8 @@ * `stack setup` will look in sandboxed directories for executables, not relying on `findExecutables. See [GHC issue 20074](https://gitlab.haskell.org/ghc/ghc/-/issues/20074) -* Track changes to `setup-config` properly to avoid reconfiguring on every - change. See [#5578](https://github.com/commercialhaskell/stack/issues/5578) +* Track changes to `setup-config` properly to avoid reconfiguring on every change. + See [#5578](https://github.com/commercialhaskell/stack/issues/5578) ## v2.7.1 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015-2021, Stack contributors +Copyright (c) 2015-2022, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/doc/ChangeLog.md b/doc/ChangeLog.md --- a/doc/ChangeLog.md +++ b/doc/ChangeLog.md @@ -1,6 +1,34 @@ # Changelog +## v2.7.5 + +**Changes since v2.7.3:** + +Behavior changes: + +* Cloning git repositories isn't per sub-directory anymore, see + [#5411](https://github.com/commercialhaskell/stack/issues/5411) + +Other enhancements: + +* `stack setup` supports installing GHC for macOS aarch64 (M1) + +* `stack upload` supports authentication with a Hackage API key (via + `HACKAGE_KEY` environment variable). + +Bug fixes: + +* Ensure that `extra-path` works for case-insensitive `PATH`s on Windows. + See [rio#237](https://github.com/commercialhaskell/rio/pull/237) +* Fix handling of overwritten `ghc` and `ghc-pkg` locations. + [#5597](https://github.com/commercialhaskell/stack/pull/5597) +* Fix failure to find package when a dependency is shared between projects. + [#5680](https://github.com/commercialhaskell/stack/issues/5680) +* `stack ghci` now uses package flags in `stack.yaml` + [#5434](https://github.com/commercialhaskell/stack/issues/5434) + + ## v2.7.3 **Changes since v2.7.1:** @@ -30,8 +58,8 @@ * `stack setup` will look in sandboxed directories for executables, not relying on `findExecutables. See [GHC issue 20074](https://gitlab.haskell.org/ghc/ghc/-/issues/20074) -* Track changes to `setup-config` properly to avoid reconfiguring on every - change. See [#5578](https://github.com/commercialhaskell/stack/issues/5578) +* Track changes to `setup-config` properly to avoid reconfiguring on every change. + See [#5578](https://github.com/commercialhaskell/stack/issues/5578) ## v2.7.1 diff --git a/doc/GUIDE.md b/doc/GUIDE.md --- a/doc/GUIDE.md +++ b/doc/GUIDE.md @@ -1668,6 +1668,12 @@ [our blog post](https://www.fpcomplete.com/blog/2016/05/stack-security-gnupg-keys). * `--no-signature` disables signing of packages * `--candidate` upload a [package candidate](http://hackage.haskell.org/upload#candidates) + * Hackage API key can be used instead of username and password. Usage example: + + ```bash + HACKAGE_KEY= stack upload . + ``` + * `username` and `password` can be read by environment ```bash @@ -1745,7 +1751,7 @@ Building with debugging symbols in the [DWARF information](https://ghc.haskell.org/trac/ghc/wiki/DWARF) is supported by `stack`. This can be done by passing the flag `--ghc-options="-g"` and also to override the default behaviour of stripping executables of debugging symbols by passing either one of the following flags: `--no-strip`, `--no-library-stripping` or `--no-executable-stripping`. -In Windows GDB can be isntalled to debug an executable with `stack exec -- pacman -S gdb`. Windows visual studio compiler's debugging format PDB is not supported at the moment. This might be possible by [separating](https://stackoverflow.com/questions/866721/how-to-generate-gcc-debug-symbol-outside-the-build-target) debugging symbols and [converting](https://github.com/rainers/cv2pdb) their format. Or as an option when [using the LLVM backend](http://blog.llvm.org/2017/08/llvm-on-windows-now-supports-pdb-debug.html). +In Windows GDB can be installed to debug an executable with `stack exec -- pacman -S gdb`. Windows visual studio compiler's debugging format PDB is not supported at the moment. This might be possible by [separating](https://stackoverflow.com/questions/866721/how-to-generate-gcc-debug-symbol-outside-the-build-target) debugging symbols and [converting](https://github.com/rainers/cv2pdb) their format. Or as an option when [using the LLVM backend](http://blog.llvm.org/2017/08/llvm-on-windows-now-supports-pdb-debug.html). ## More resources diff --git a/doc/nix_integration.md b/doc/nix_integration.md --- a/doc/nix_integration.md +++ b/doc/nix_integration.md @@ -119,7 +119,7 @@ `stack setup` will start a nix-shell, so it will gather all the required packages, but given nix handles GHC installation, instead of stack, this will happen when running `stack build` if no setup has been performed -before. Therefore it is not longer necessary to run `stack setup` unless you +before. Therefore it is no longer necessary to run `stack setup` unless you want to cache a GHC installation before running the build. If `enable:` is omitted or set to `false`, you can still build in a nix-shell by diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -937,7 +937,7 @@ author-name: Your Name author-email: youremail@example.com category: Your Projects Category - copyright: 'Copyright (c) 2021 Your Name' + copyright: 'Copyright (c) 2022 Your Name' github-username: yourusername ``` diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -12,6 +12,7 @@ , tryGetConfigCache , tryGetCabalMod , tryGetSetupConfigMod + , tryGetPackageProjectRoot , getInstalledExes , tryGetFlagCache , deleteCaches @@ -22,6 +23,7 @@ , writeConfigCache , writeCabalMod , writeSetupConfigMod + , writePackageProjectRoot , TestStatus (..) , setTestStatus , getTestStatus @@ -34,6 +36,7 @@ import Stack.Prelude import Crypto.Hash (hashWith, SHA256(..)) import qualified Data.ByteArray as Mem (convert) +import Data.ByteString.Builder (byteString) import qualified Data.Map as M import qualified Data.Set as Set import qualified Data.Text as T @@ -154,6 +157,18 @@ liftIO $ either (const Nothing) (Just . modificationTime) <$> tryIO (getFileStatus fp) +-- | Try to read the project root from the last build of a package +tryGetPackageProjectRoot :: HasEnvConfig env + => Path Abs Dir -> RIO env (Maybe ByteString) +tryGetPackageProjectRoot dir = do + fp <- toFilePath <$> configPackageProjectRoot dir + tryReadFileBinary fp + +tryReadFileBinary :: MonadIO m => FilePath -> m (Maybe ByteString) +tryReadFileBinary fp = + liftIO $ either (const Nothing) Just <$> + tryIO (readFileBinary fp) + -- | Write the dirtiness cache for this package's files. writeBuildCache :: HasEnvConfig env => Path Abs Dir @@ -196,6 +211,16 @@ fp <- configSetupConfigMod dir writeBinaryFileAtomic fp "Just used for its modification time" liftIO $ setFileTimes (toFilePath fp) x x + +-- | See 'tryGetPackageProjectRoot' +writePackageProjectRoot + :: HasEnvConfig env + => Path Abs Dir + -> ByteString + -> RIO env () +writePackageProjectRoot dir projectRoot = do + fp <- configPackageProjectRoot dir + writeBinaryFileAtomic fp (byteString projectRoot) -- | Delete the caches for the project. deleteCaches :: HasEnvConfig env => Path Abs Dir -> RIO env () diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -849,6 +849,7 @@ liftIO $ either (const Nothing) (Just . modificationTime) <$> tryJust (guard . isDoesNotExistError) (getFileStatus (toFilePath setupConfigfp)) newSetupConfigMod <- getNewSetupConfigMod + newProjectRoot <- S8.pack . toFilePath <$> view projectRootL -- See https://github.com/commercialhaskell/stack/issues/3554 taskAnyMissingHack <- view $ actualCompilerVersionL.to getGhcVersion.to (< mkVersion [8, 4]) needConfig <- @@ -870,10 +871,12 @@ -- Cabal's setup-config is created per OS/Cabal version, multiple -- projects using the same package could get a conflict because of this mOldSetupConfigMod <- tryGetSetupConfigMod pkgDir + mOldProjectRoot <- tryGetPackageProjectRoot pkgDir return $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache) || mOldCabalMod /= Just newCabalMod || mOldSetupConfigMod /= newSetupConfigMod + || mOldProjectRoot /= Just newProjectRoot let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache when (taskBuildTypeConfig task) ensureConfigureScript @@ -886,11 +889,11 @@ let programNames = case cpWhich cp of Ghc -> - [ "--with-ghc=" ++ toFilePath (cpCompiler cp) - , "--with-ghc-pkg=" ++ toFilePath pkgPath + [ ("ghc", toFilePath (cpCompiler cp)) + , ("ghc-pkg", toFilePath pkgPath) ] - exes <- forM programNames $ \name -> do - mpath <- findExecutable name + exes <- forM programNames $ \(name, file) -> do + mpath <- findExecutable file return $ case mpath of Left _ -> [] Right x -> return $ concat ["--with-", name, "=", x] @@ -912,6 +915,7 @@ -- check if our config mod file is newer than the file above, but this -- seems reasonable too. getNewSetupConfigMod >>= writeSetupConfigMod pkgDir + writePackageProjectRoot pkgDir newProjectRoot return needConfig where diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} -- | The general Stack configuration that starts everything off. This should -- be smart to falback if there is no stack.yaml, instead relying on @@ -651,6 +652,14 @@ let resolved = ResolvedPath fp abs' pp <- mkProjectPackage YesPrintWarnings resolved (boptsHaddock bopts) pure (cpName $ ppCommon pp, pp) + + -- prefetch git repos to avoid cloning per subdirectory + -- see https://github.com/commercialhaskell/stack/issues/5411 + let gitRepos = mapMaybe (\case + (RPLImmutable (RPLIRepo repo rpm)) -> Just (repo, rpm) + _ -> Nothing) (projectDependencies project) + logDebug ("Prefetching git repos: " <> display (T.pack (show gitRepos))) + fetchReposRaw gitRepos (deps0, mcompleted) <- fmap unzip . forM (projectDependencies project) $ \rpl -> do (pl, mCompleted) <- case rpl of diff --git a/src/Stack/Constants/Config.hs b/src/Stack/Constants/Config.hs --- a/src/Stack/Constants/Config.hs +++ b/src/Stack/Constants/Config.hs @@ -11,6 +11,7 @@ , projectDockerSandboxDir , configCabalMod , configSetupConfigMod + , configPackageProjectRoot , buildCachesDir , testSuccessFile , testBuiltFile @@ -83,6 +84,15 @@ configSetupConfigMod dir = liftM ( $(mkRelFile "stack-setup-config-mod")) + (distDirFromDir dir) + +-- | The filename used for the project root from the last build of a package +configPackageProjectRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => Path Abs Dir -- ^ Package directory. + -> m (Path Abs File) +configPackageProjectRoot dir = + liftM + ( $(mkRelFile "stack-project-root")) (distDirFromDir dir) -- | Directory for HPC work. diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -644,11 +644,12 @@ (cpCabalConfigOpts . ppCommon <$> M.lookup name smProject) <|> (cpCabalConfigOpts . dpCommon <$> M.lookup name smDeps) + sourceMapFlags = maybe mempty (cpFlags . ppCommon) $ M.lookup name smProject config = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True - , packageConfigFlags = getLocalFlags buildOptsCLI name + , packageConfigFlags = getLocalFlags buildOptsCLI name `M.union` sourceMapFlags , packageConfigGhcOptions = sourceMapGhcOptions , packageConfigCabalConfigOpts = sourceMapCabalConfigOpts , packageConfigCompilerVersion = compilerVersion diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -836,15 +836,8 @@ if compilerTool `elem` installed then return (compilerTool,CompilerBuildStandard) else do - let repo = Repo - { repoCommit = commitId - , repoUrl = url - , repoType = RepoGit - , repoSubdir = mempty - } - -- clone the repository and execute the given commands - Pantry.withRepo repo $ do + Pantry.withRepo (Pantry.SimpleRepo url commitId RepoGit) $ do -- withRepo is guaranteed to set workingDirL, so let's get it mcwd <- traverse parseAbsDir =<< view workingDirL let cwd = fromMaybe (error "Invalid working directory") mcwd @@ -1266,6 +1259,8 @@ Platform Arm Cabal.Linux -> return "linux-armv7" Platform AArch64 Cabal.Linux -> return "linux-aarch64" Platform Sparc Cabal.Linux -> return "linux-sparc" + Platform AArch64 Cabal.OSX -> return "macosx-aarch64" + Platform AArch64 Cabal.FreeBSD -> return "freebsd-aarch64" Platform arch os -> throwM $ UnsupportedSetupCombo os arch downloadOrUseLocal diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -12,8 +12,12 @@ , uploadRevision -- * Credentials , HackageCreds - , loadCreds + , HackageAuth(..) + , HackageKey(..) + , loadAuth , writeFilePrivate + -- * Internal + , maybeGetHackageKey ) where import Stack.Prelude @@ -27,7 +31,13 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Conduit.Binary as CB import qualified Data.Text as T -import Network.HTTP.StackClient (Request, RequestBody(RequestBodyLBS), Response, withResponse, httpNoBody, getGlobalManager, getResponseStatusCode, +import Network.HTTP.StackClient (Request, + RequestBody(RequestBodyLBS), + Response, + withResponse, + httpNoBody, + getGlobalManager, + getResponseStatusCode, getResponseBody, setRequestHeader, parseRequest, @@ -41,9 +51,12 @@ removeFile, renameFile) import System.Environment (lookupEnv) import System.FilePath ((), takeFileName, takeDirectory) -import System.IO (putStrLn, putStr, print) -- TODO remove putStrLn, use logInfo import System.PosixCompat.Files (setFileMode) + +newtype HackageKey = HackageKey Text + deriving (Eq, Show) + -- | Username and password to log into Hackage. -- -- Since 0.1.0.0 @@ -52,8 +65,12 @@ , hcPassword :: !Text , hcCredsFile :: !FilePath } - deriving Show + deriving (Eq, Show) +data HackageAuth = HAKey HackageKey + | HACreds HackageCreds + deriving (Eq, Show) + instance ToJSON HackageCreds where toJSON (HackageCreds u p _) = object [ "username" .= u @@ -67,14 +84,26 @@ withEnvVariable :: Text -> IO Text -> IO Text withEnvVariable varName fromPrompt = lookupEnv (T.unpack varName) >>= maybe fromPrompt (pure . T.pack) +maybeGetHackageKey :: RIO m (Maybe HackageKey) +maybeGetHackageKey = liftIO $ fmap (HackageKey . T.pack) <$> lookupEnv "HACKAGE_KEY" + +loadAuth :: HasLogFunc m => Config -> RIO m HackageAuth +loadAuth config = do + maybeHackageKey <- maybeGetHackageKey + case maybeHackageKey of + Just key -> do + logInfo "HACKAGE_KEY found in env, using that for credentials." + return $ HAKey key + Nothing -> HACreds <$> loadUserAndPassword config + -- | Load Hackage credentials, either from a save file or the command -- line. -- -- Since 0.1.0.0 -loadCreds :: Config -> IO HackageCreds -loadCreds config = do - fp <- credsFile config - elbs <- tryIO $ L.readFile fp +loadUserAndPassword :: HasLogFunc m => Config -> RIO m HackageCreds +loadUserAndPassword config = do + fp <- liftIO $ credsFile config + elbs <- liftIO $ tryIO $ L.readFile fp case either (const Nothing) Just elbs >>= \lbs -> (lbs, ) <$> decode' lbs of Nothing -> fromPrompt fp Just (lbs, mkCreds) -> do @@ -83,14 +112,15 @@ writeFilePrivate fp $ lazyByteString lbs unless (configSaveHackageCreds config) $ do - putStrLn "WARNING: You've set save-hackage-creds to false" - putStrLn "However, credentials were found at:" - putStrLn $ " " ++ fp + logWarn "WARNING: You've set save-hackage-creds to false" + logWarn "However, credentials were found at:" + logWarn $ " " <> fromString fp return $ mkCreds fp where + fromPrompt :: HasLogFunc m => FilePath -> RIO m HackageCreds fromPrompt fp = do - username <- withEnvVariable "HACKAGE_USERNAME" (prompt "Hackage username: ") - password <- withEnvVariable "HACKAGE_PASSWORD" (promptPassword "Hackage password: ") + username <- liftIO $ withEnvVariable "HACKAGE_USERNAME" (prompt "Hackage username: ") + password <- liftIO $ withEnvVariable "HACKAGE_PASSWORD" (promptPassword "Hackage password: ") let hc = HackageCreds { hcUsername = username , hcPassword = password @@ -100,10 +130,10 @@ when (configSaveHackageCreds config) $ do shouldSave <- promptBool $ T.pack $ "Save hackage credentials to file at " ++ fp ++ " [y/n]? " - putStrLn "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false" + logInfo "NOTE: Avoid this prompt in the future by using: save-hackage-creds: false" when shouldSave $ do writeFilePrivate fp $ fromEncoding $ toEncoding hc - putStrLn "Saved!" + logInfo "Saved!" hFlush stdout return hc @@ -136,20 +166,30 @@ createDirectoryIfMissing True dir return $ dir "credentials.json" -applyCreds :: HackageCreds -> Request -> IO Request +addAPIKey :: HackageKey -> Request -> Request +addAPIKey (HackageKey key) req = + setRequestHeader "Authorization" [fromString $ "X-ApiKey" ++ " " ++ T.unpack key] req + +applyAuth :: HasLogFunc m => HackageAuth -> Request -> RIO m Request +applyAuth haAuth req0 = do + case haAuth of + HAKey key -> return (addAPIKey key req0) + HACreds creds -> applyCreds creds req0 + +applyCreds :: HasLogFunc m => HackageCreds -> Request -> RIO m Request applyCreds creds req0 = do - manager <- getGlobalManager - ereq <- applyDigestAuth + manager <- liftIO getGlobalManager + ereq <- liftIO $ applyDigestAuth (encodeUtf8 $ hcUsername creds) (encodeUtf8 $ hcPassword creds) req0 manager case ereq of Left e -> do - putStrLn "WARNING: No HTTP digest prompt found, this will probably fail" + logWarn "WARNING: No HTTP digest prompt found, this will probably fail" case fromException e of - Just e' -> putStrLn $ displayDigestAuthException e' - Nothing -> print e + Just e' -> logWarn $ fromString $ displayDigestAuthException e' + Nothing -> logWarn $ fromString $ displayException e return req0 Right req -> return req @@ -157,13 +197,14 @@ -- sending a file like 'upload', this sends a lazy bytestring. -- -- Since 0.1.2.1 -uploadBytes :: String -- ^ Hackage base URL - -> HackageCreds +uploadBytes :: HasLogFunc m + => String -- ^ Hackage base URL + -> HackageAuth -> String -- ^ tar file name -> UploadVariant -> L.ByteString -- ^ tar file contents - -> IO () -uploadBytes baseUrl creds tarName uploadVariant bytes = do + -> RIO m () +uploadBytes baseUrl auth tarName uploadVariant bytes = do let req1 = setRequestHeader "Accept" ["text/plain"] (fromString $ baseUrl <> "packages/" @@ -172,31 +213,36 @@ Candidate -> "candidates/" ) formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] - req2 <- formDataBody formData req1 - req3 <- applyCreds creds req2 - putStr $ "Uploading " ++ tarName ++ "... " + req2 <- liftIO $ formDataBody formData req1 + req3 <- applyAuth auth req2 + logInfo $ "Uploading " <> fromString tarName <> "... " hFlush stdout - withResponse req3 $ \res -> + withRunInIO $ \runInIO -> withResponse req3 (runInIO . inner) + where + inner :: HasLogFunc m => Response (ConduitM () S.ByteString IO ()) -> RIO m () + inner res = case getResponseStatusCode res of - 200 -> putStrLn "done!" + 200 -> logInfo "done!" 401 -> do - putStrLn "authentication failure" - handleIO (const $ return ()) (removeFile (hcCredsFile creds)) + logError "authentication failure" + case auth of + HACreds creds -> handleIO (const $ return ()) (liftIO $ removeFile (hcCredsFile creds)) + _ -> pure () throwString "Authentication failure uploading to server" 403 -> do - putStrLn "forbidden upload" - putStrLn "Usually means: you've already uploaded this package/version combination" - putStrLn "Ignoring error and continuing, full message from Hackage below:\n" - printBody res + logError "forbidden upload" + logError "Usually means: you've already uploaded this package/version combination" + logError "Ignoring error and continuing, full message from Hackage below:\n" + liftIO $ printBody res 503 -> do - putStrLn "service unavailable" - putStrLn "This error some times gets sent even though the upload succeeded" - putStrLn "Check on Hackage to see if your pacakge is present" - printBody res + logError "service unavailable" + logError "This error some times gets sent even though the upload succeeded" + logError "Check on Hackage to see if your pacakge is present" + liftIO $ printBody res code -> do - putStrLn $ "unhandled status code: " ++ show code - printBody res - throwString $ "Upload failed on " ++ tarName + logError $ "unhandled status code: " <> fromString (show code) + liftIO $ printBody res + throwString $ "Upload failed on " <> fromString tarName printBody :: Response (ConduitM () S.ByteString IO ()) -> IO () printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout @@ -204,20 +250,22 @@ -- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 -upload :: String -- ^ Hackage base URL - -> HackageCreds +upload :: HasLogFunc m + => String -- ^ Hackage base URL + -> HackageAuth -> FilePath -> UploadVariant - -> IO () -upload baseUrl creds fp uploadVariant = - uploadBytes baseUrl creds (takeFileName fp) uploadVariant =<< L.readFile fp + -> RIO m () +upload baseUrl auth fp uploadVariant = + uploadBytes baseUrl auth (takeFileName fp) uploadVariant =<< liftIO (L.readFile fp) -uploadRevision :: String -- ^ Hackage base URL - -> HackageCreds +uploadRevision :: HasLogFunc m + => String -- ^ Hackage base URL + -> HackageAuth -> PackageIdentifier -> L.ByteString - -> IO () -uploadRevision baseUrl creds ident@(PackageIdentifier name _) cabalFile = do + -> RIO m () +uploadRevision baseUrl auth ident@(PackageIdentifier name _) cabalFile = do req0 <- parseRequest $ concat [ baseUrl , "package/" @@ -231,5 +279,5 @@ , partBS "publish" "on" ] req0 - req2 <- applyCreds creds req1 + req2 <- applyAuth auth req1 void $ httpNoBody req2 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -655,21 +655,19 @@ config <- view configL let hackageUrl = T.unpack $ configHackageBaseUrl config uploadVariant = uoptsUploadVariant uploadOpts - getCreds <- liftIO $ memoizeRef $ Upload.loadCreds config + getCreds <- memoizeRef $ Upload.loadAuth config mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files forM_ files $ \file -> do tarFile <- resolveFile' file - liftIO $ do - creds <- runMemoized getCreds - Upload.upload hackageUrl creds (toFilePath tarFile) uploadVariant + creds <- runMemoized getCreds + Upload.upload hackageUrl creds (toFilePath tarFile) uploadVariant forM_ dirs $ \dir -> do pkgDir <- resolveDir' dir (tarName, tarBytes, mcabalRevision) <- getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir checkSDistTarball' sdistOpts tarName tarBytes - liftIO $ do - creds <- runMemoized getCreds - Upload.uploadBytes hackageUrl creds tarName uploadVariant tarBytes - forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds + creds <- runMemoized getCreds + Upload.uploadBytes hackageUrl creds tarName uploadVariant tarBytes + forM_ mcabalRevision $ uncurry $ Upload.uploadRevision hackageUrl creds sdistCmd :: SDistOpts -> RIO Runner () sdistCmd sdistOpts = diff --git a/src/test/Stack/UploadSpec.hs b/src/test/Stack/UploadSpec.hs --- a/src/test/Stack/UploadSpec.hs +++ b/src/test/Stack/UploadSpec.hs @@ -9,6 +9,7 @@ import Test.Hspec import System.Permissions (osIsWindows) import System.PosixCompat.Files (getFileStatus, fileMode) +import System.Environment (setEnv, unsetEnv) import Data.Bits ((.&.)) spec :: Spec @@ -26,3 +27,14 @@ unless osIsWindows $ do status <- getFileStatus fp (fileMode status .&. 0o777) `shouldBe` 0o600 + + it "finds a HACKAGE_KEY env variable" $ do + runRIO () maybeGetHackageKey `shouldReturn` Nothing + + withEnv "HACKAGE_KEY" "api_key" + $ runRIO () maybeGetHackageKey `shouldReturn` Just (HackageKey "api_key") + +withEnv :: String -> String -> IO a -> IO a +withEnv k v f = do + setEnv k v + f `finally` unsetEnv k diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: stack -version: 2.7.3 +version: 2.7.5 license: BSD3 license-file: LICENSE maintainer: manny@fpcomplete.com @@ -278,7 +278,7 @@ network-uri >=2.6.4.1, open-browser >=0.2.1.0, optparse-applicative >=0.14.3.0, - pantry >=0.5.2, + pantry >=0.5.3, path >=0.7.0, path-io >=1.6.3, persistent >=2.11.0.4, @@ -288,9 +288,8 @@ primitive >=0.7.1.0, process >=1.6.9.0, project-template >=0.2.1.0, - regex-applicative-text >=0.1.0.1, retry >=0.8.1.2, - rio >=0.1.18.0, + rio >=0.1.21.0, rio-prettyprint >=0.1.1.0, semigroups >=0.19.1, split >=0.2.3.4, @@ -405,7 +404,7 @@ network-uri >=2.6.4.1, open-browser >=0.2.1.0, optparse-applicative >=0.14.3.0, - pantry >=0.5.2, + pantry >=0.5.3, path >=0.7.0, path-io >=1.6.3, persistent >=2.11.0.4, @@ -415,9 +414,8 @@ primitive >=0.7.1.0, process >=1.6.9.0, project-template >=0.2.1.0, - regex-applicative-text >=0.1.0.1, retry >=0.8.1.2, - rio >=0.1.18.0, + rio >=0.1.21.0, rio-prettyprint >=0.1.1.0, semigroups >=0.19.1, split >=0.2.3.4, @@ -536,7 +534,7 @@ open-browser >=0.2.1.0, optparse-applicative >=0.14.3.0, optparse-generic >=1.3.1, - pantry >=0.5.2, + pantry >=0.5.3, path >=0.7.0, path-io >=1.6.3, persistent >=2.11.0.4, @@ -546,9 +544,8 @@ primitive >=0.7.1.0, process >=1.6.9.0, project-template >=0.2.1.0, - regex-applicative-text >=0.1.0.1, retry >=0.8.1.2, - rio >=0.1.18.0, + rio >=0.1.21.0, rio-prettyprint >=0.1.1.0, semigroups >=0.19.1, split >=0.2.3.4, @@ -594,9 +591,10 @@ ld-options: -static -pthread test-suite stack-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - hs-source-dirs: src/test + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover -any + hs-source-dirs: src/test other-modules: Stack.ArgsSpec Stack.Build.ExecuteSpec @@ -614,7 +612,7 @@ Stack.UploadSpec Paths_stack - default-language: Haskell2010 + default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -optP-Wno-nonportable-include-path @@ -671,7 +669,7 @@ network-uri >=2.6.4.1, open-browser >=0.2.1.0, optparse-applicative >=0.14.3.0, - pantry >=0.5.2, + pantry >=0.5.3, path >=0.7.0, path-io >=1.6.3, persistent >=2.11.0.4, @@ -682,9 +680,8 @@ process >=1.6.9.0, project-template >=0.2.1.0, raw-strings-qq >=1.1, - regex-applicative-text >=0.1.0.1, retry >=0.8.1.2, - rio >=0.1.18.0, + rio >=0.1.21.0, rio-prettyprint >=0.1.1.0, semigroups >=0.19.1, smallcheck >=1.2.1, diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -3,6 +3,11 @@ packages: - . +extra-deps: +- rio-0.1.21.0@rev:0 +- pantry-0.5.3@rev:0 + + docker: enable: false #repo: fpco/alpine-haskell-stack:8.10.4 diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -289,14 +289,19 @@ then return () else throwIO e --- | Changes working directory to Stack source directory -withSourceDirectory :: HasCallStack => IO () -> IO () -withSourceDirectory action = do - dir <- stackSrc +-- | Changes to the specified working directory. +withCwd :: HasCallStack => FilePath -> IO () -> IO () +withCwd dir action = do currentDirectory <- getCurrentDirectory let enterDir = setCurrentDirectory dir exitDir = setCurrentDirectory currentDirectory bracket_ enterDir exitDir action + +-- | Changes working directory to Stack source directory. +withSourceDirectory :: HasCallStack => IO () -> IO () +withSourceDirectory action = do + dir <- stackSrc + withCwd dir action -- | Mark a test as superslow, only to be run when explicitly requested. superslow :: HasCallStack => IO () -> IO ()