diff --git a/doc/upload_command.md b/doc/upload_command.md index 6e1ed4b369..d84a11fd6c 100644 --- a/doc/upload_command.md +++ b/doc/upload_command.md @@ -2,11 +2,23 @@ # The `stack upload` command +Either (one or more packages) + ~~~text stack upload [DIR] [--pvp-bounds PVP-BOUNDS] [--ignore-check] [--[no-]test-tarball] [--tar-dir ARG] [--candidate] ~~~ +or (documentation for a package) + +~~~text + +stack upload DIR (-d|--documentation) [--candidate] [--setup-info-yaml URL] + [--snapshot-location-base URL] +~~~ + +## Upload one or more packages + Hackage accepts packages for uploading in a standard form, a compressed archive ('tarball') in the format produced by Cabal's `sdist` action. @@ -18,6 +30,56 @@ current working directory is the root directory of your project: stack upload . ~~~ +### `--ignore-check` flag + +Pass the flag to disable checks of the package for common mistakes. By default, +the command will check the package for common mistakes. + +### `--pvp-bounds` option + +The `--pvp-bounds ` option determines whether and, if so, how +PVP version bounds should be added to the Cabal file of the package. The +available modes for basic use are: `none`, `lower`, `upper`, and `both`. The +available modes for use with Cabal file revisions are `lower-revision`, +`upper-revision` and `both-revision`. + +For futher information, see the +[YAML configuration](yaml_configuration.md#pvp-bounds) documentation. + +### `--tar-dir` option + +The `--tar-dir ` option determines whether the package +archive should be copied to the specified directory. + +### `--[no-]test-tarball` flag + +Default: Disabled + +Set the flag to cause Stack to test the resulting package archive, by attempting +to build it. + +## Upload documentation for a package + +:octicons-beaker-24: Experimental + +:octicons-tag-24: UNRELEASED + +Hackage accepts documentation for a package for uploading in a standard form and +in a compressed archive ('tarball') in the `.tar.gz` format. + +For further information about how to create such an archive file, see the +documentation for the +[`stack haddock --haddock-for-hackage`](build_command.md#-no-haddock-for-haddock-flag) +command. + +`stack upload --documentation` uploads an existing archive +file of documentation for the specified package to Hackage. For example, if the +current working directory is the root directory of your project: + +~~~text +stack upload . --documentation +~~~ + ## The `HACKAGE_USERNAME` and `HACKAGE_PASSWORD` environment variables [:octicons-tag-24: 2.3.1](https://github.com/commercialhaskell/stack/releases/tag/v2.3.1) @@ -71,32 +133,5 @@ example: ## `--candidate` flag Pass the flag to upload a -[package candidate](http://hackage.haskell.org/upload#candidates). - -## `--ignore-check` flag - -Pass the flag to disable checks of the package for common mistakes. By default, -the command will check the package for common mistakes. - -## `--pvp-bounds` option - -The `--pvp-bounds ` option determines whether and, if so, how -PVP version bounds should be added to the Cabal file of the package. The -available modes for basic use are: `none`, `lower`, `upper`, and `both`. The -available modes for use with Cabal file revisions are `lower-revision`, -`upper-revision` and `both-revision`. - -For futher information, see the -[YAML configuration](yaml_configuration.md#pvp-bounds) documentation. - -## `--tar-dir` option - -The `--tar-dir ` option determines whether the package -archive should be copied to the specified directory. - -## `--[no-]test-tarball` flag - -Default: Disabled - -Set the flag to cause Stack to test the resulting package archive, by attempting -to build it. +[package candidate](http://hackage.haskell.org/upload#candidates) or +documentation for a package candidate. diff --git a/src/Network/HTTP/StackClient.hs b/src/Network/HTTP/StackClient.hs index b0c19c53cd..874dbe9020 100644 --- a/src/Network/HTTP/StackClient.hs +++ b/src/Network/HTTP/StackClient.hs @@ -14,6 +14,7 @@ module Network.HTTP.StackClient , setRequestCheckStatus , setRequestMethod , setRequestHeader + , setRequestHeaders , addRequestHeader , setRequestBody , getResponseHeaders @@ -92,7 +93,8 @@ import qualified Network.HTTP.Download as Download import Network.HTTP.Simple ( addRequestHeader, getResponseBody, getResponseHeaders , getResponseStatusCode, setRequestBody - , setRequestCheckStatus, setRequestHeader, setRequestMethod + , setRequestCheckStatus, setRequestHeader, setRequestHeaders + , setRequestMethod ) import qualified Network.HTTP.Simple ( httpJSON, httpLbs, httpNoBody, httpSink, withResponse ) diff --git a/src/Stack/CLI.hs b/src/Stack/CLI.hs index 6481ca28ac..134befcb8e 100644 --- a/src/Stack/CLI.hs +++ b/src/Stack/CLI.hs @@ -511,7 +511,7 @@ commandLineHandler currentDir progName isInterpreter = upload = addCommand' "upload" - "Upload a package to Hackage." + "Upload one or more packages, or documentation for a package, to Hackage." uploadCmd uploadOptsParser diff --git a/src/Stack/Options/UploadParser.hs b/src/Stack/Options/UploadParser.hs index 6c4496b321..e5a10f24f4 100644 --- a/src/Stack/Options/UploadParser.hs +++ b/src/Stack/Options/UploadParser.hs @@ -5,19 +5,48 @@ module Stack.Options.UploadParser ( uploadOptsParser ) where -import Options.Applicative ( Parser, flag, help, long ) -import Stack.Options.SDistParser ( sdistOptsParser ) +import Options.Applicative + ( Parser, completer, flag, help, idm, long, metavar, short + , strArgument, strOption, switch + ) +import Options.Applicative.Builder.Extra ( boolFlags, dirCompleter ) +import Stack.Options.HpcReportParser ( pvpBoundsOption ) import Stack.Prelude import Stack.Upload ( UploadOpts (..), UploadVariant (..) ) -- | Parse command line arguments for Stack's @upload@ command. uploadOptsParser :: Parser UploadOpts -uploadOptsParser = - UploadOpts - <$> sdistOptsParser - <*> uploadVariant - where - uploadVariant = flag Publishing Candidate - ( long "candidate" - <> help "Upload as a package candidate." +uploadOptsParser = UploadOpts + <$> dirsToWorkWithParser + <*> documentationParser + <*> optional pvpBoundsOption + <*> ignoreCheckSwitch + <*> buildPackageOption + <*> tarDirParser + <*> uploadVariantParser + where + dirsToWorkWithParser = many (strArgument + ( metavar "DIR" + <> completer dirCompleter + )) + documentationParser = flag False True + ( long "documentation" + <> short 'd' + <> help "Upload documentation." + ) + ignoreCheckSwitch = switch + ( long "ignore-check" + <> help "Do not check package for common mistakes." ) + buildPackageOption = boolFlags False + "test-tarball" + "building of the resulting tarball." + idm + tarDirParser = optional (strOption + ( long "tar-dir" + <> help "If specified, copy all the tar to this directory." + )) + uploadVariantParser = flag Publishing Candidate + ( long "candidate" + <> help "Upload as, or for, a package candidate." + ) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index dc277257dc..22b7b0d0aa 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -9,6 +9,7 @@ module Stack.SDist , getSDistTarball , checkSDistTarball , checkSDistTarball' + , readLocalPackage ) where import qualified Codec.Archive.Tar as Tar @@ -129,15 +130,15 @@ instance Exception SDistPrettyException -- | Type representing command line options for @stack sdist@ command. data SDistOpts = SDistOpts { sdoptsDirsToWorkWith :: [String] - -- ^ Directories to package + -- ^ Directories to package , sdoptsPvpBounds :: Maybe PvpBounds - -- ^ PVP Bounds overrides + -- ^ PVP Bounds overrides , sdoptsIgnoreCheck :: Bool - -- ^ Whether to ignore check of the package for common errors + -- ^ Whether to ignore check of the package for common errors , sdoptsBuildTarball :: Bool - -- ^ Whether to build the tarball + -- ^ Whether to build the tarball , sdoptsTarPath :: Maybe FilePath - -- ^ Where to copy the tarball + -- ^ Where to copy the tarball } -- | Function underlying the @stack sdist@ command. @@ -193,7 +194,12 @@ getSDistTarball :: -- ^ Override Config value -> Path Abs Dir -- ^ Path to local package - -> RIO env (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString)) + -> RIO + env + ( FilePath + , L.ByteString + , Maybe (PackageIdentifier, L.ByteString) + ) -- ^ Filename, tarball contents, and option Cabal file revision to upload getSDistTarball mpvpBounds pkgDir = do config <- view configL @@ -243,7 +249,7 @@ getSDistTarball mpvpBounds pkgDir = do -- prone and more predictable to read everything in at once, so that's what -- we're doing for now: let tarPath isDir fp = - case Tar.toTarPath isDir (forceUtf8Enc (pkgId FP. fp)) of + case Tar.toTarPath isDir (forceUtf8Enc (pkgIdName FP. fp)) of Left e -> prettyThrowIO $ ToTarPathException e Right tp -> pure tp -- convert a String of proper characters to a String of bytes in UTF8 @@ -268,8 +274,9 @@ getSDistTarball mpvpBounds pkgDir = do pure $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime } | otherwise = packWith packFileEntry False fp isCabalFp fp = toFilePath pkgDir FP. fp == toFilePath cabalfp - tarName = pkgId FP.<.> "tar.gz" - pkgId = packageIdentifierString (packageIdentifier (lpPackage lp)) + tarName = pkgIdName FP.<.> "tar.gz" + pkgIdName = packageIdentifierString pkgId + pkgId = packageIdentifier (lpPackage lp) dirEntries <- mapM packDir (dirsFromFiles files) fileEntries <- mapM packFile files mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef) diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs index 4d694e1d1a..c0002af83c 100644 --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -1,10 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Types and functions related to Stack's @upload@ command. module Stack.Upload ( -- * Upload UploadOpts (..) + , SDistOpts (..) , UploadVariant (..) , uploadCmd , upload @@ -35,25 +37,29 @@ import Network.HTTP.StackClient , applyDigestAuth, displayDigestAuthException, formDataBody , getGlobalManager, getResponseBody, getResponseStatusCode , httpNoBody, parseRequest, partBS, partFileRequestBody - , partLBS, setRequestHeader, withResponse + , partLBS, setRequestHeader, setRequestHeaders, withResponse ) +import Path ( (), addExtension, parseRelFile ) import Path.IO ( resolveDir', resolveFile' ) +import Stack.Constants.Config ( distDirFromDir ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withDefaultEnvConfig ) import Stack.SDist ( SDistOpts (..), checkSDistTarball, checkSDistTarball' - , getSDistTarball + , getSDistTarball, readLocalPackage ) import Stack.Types.Config ( Config (..), configL, stackRootL ) +import Stack.Types.Package ( LocalPackage (..), packageIdentifier ) import Stack.Types.Runner ( Runner ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist , removeFile, renameFile ) import System.Environment ( lookupEnv ) -import System.FilePath ( (), takeDirectory, takeFileName ) +import qualified System.FilePath as FP import System.PosixCompat.Files ( setFileMode ) +import Stack.Types.PvpBounds (PvpBounds) -- | Type representing \'pretty\' exceptions thrown by functions exported by the -- "Stack.Upload" module. @@ -80,72 +86,143 @@ instance Pretty UploadPrettyException where instance Exception UploadPrettyException --- Type representing variants for uploading to Hackage. +-- | Type representing forms of content for upload to Hackage. +data UploadContent + = SDist + | DocArchive + +-- | Type representing variants for uploading to Hackage. data UploadVariant = Publishing - -- ^ Publish the package + -- ^ Publish the package/a published package. | Candidate - -- ^ Create a package candidate + -- ^ Create a package candidate/a package candidate. -- | Type representing command line options for the @stack upload@ command. data UploadOpts = UploadOpts - { uoptsSDistOpts :: SDistOpts - , uoptsUploadVariant :: UploadVariant - -- ^ Says whether to publish the package or upload as a release candidate + { uoDirsToWorkWith :: ![String] + , uoDocumentation :: !Bool + , uoPvpBounds :: !(Maybe PvpBounds) + , uoCheck :: !Bool + , uoBuildPackage :: !Bool + , uoTarPath :: !(Maybe FilePath) + , uoUploadVariant :: !UploadVariant } -- | Function underlying the @stack upload@ command. Upload to Hackage. uploadCmd :: UploadOpts -> RIO Runner () -uploadCmd (UploadOpts (SDistOpts [] _ _ _ _) _) = do +uploadCmd (UploadOpts [] uoDocumentation _ _ _ _ _) = do + let subject = if uoDocumentation + then "documentation for the current package," + else "the current package," prettyErrorL - [ flow "To upload the current package, please run" + [ flow "To upload" + , flow subject + , flow "please run" , style Shell "stack upload ." , flow "(with the period at the end)" ] liftIO exitFailure -uploadCmd uploadOpts = do - let partitionM _ [] = pure ([], []) - partitionM f (x:xs) = do - r <- f x - (as, bs) <- partitionM f xs - pure $ if r then (x:as, bs) else (as, x:bs) - sdistOpts = uoptsSDistOpts uploadOpts - (files, nonFiles) <- - liftIO $ partitionM doesFileExist (sdoptsDirsToWorkWith sdistOpts) - (dirs, invalid) <- liftIO $ partitionM doesDirectoryExist nonFiles - withConfig YesReexec $ withDefaultEnvConfig $ do - unless (null invalid) $ do - let invalidList = bulletedList $ map (style File . fromString) invalid - prettyErrorL - [ style Shell "stack upload" - , flow "expects a list of sdist tarballs or package directories." - , flow "Can't find:" - , line <> invalidList - ] - exitFailure - when (null files && null dirs) $ do - prettyErrorL - [ style Shell "stack upload" - , flow "expects a list of sdist tarballs or package directories, but none were specified." - ] - exitFailure - config <- view configL - let hackageUrl = T.unpack $ configHackageBaseUrl config - uploadVariant = uoptsUploadVariant uploadOpts - getCreds <- memoizeRef $ loadAuth config - mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files - forM_ files $ \file -> do - tarFile <- resolveFile' file - creds <- runMemoized getCreds - upload hackageUrl creds (toFilePath tarFile) uploadVariant - forM_ dirs $ \dir -> do - pkgDir <- resolveDir' dir - (tarName, tarBytes, mcabalRevision) <- - getSDistTarball (sdoptsPvpBounds sdistOpts) pkgDir - checkSDistTarball' sdistOpts tarName tarBytes - creds <- runMemoized getCreds - uploadBytes hackageUrl creds tarName uploadVariant tarBytes - forM_ mcabalRevision $ uncurry $ uploadRevision hackageUrl creds +uploadCmd (UploadOpts {..}) = if uoDocumentation + then case uoDirsToWorkWith of + [dirToWorkWith] -> do + isDir <- liftIO $ doesDirectoryExist dirToWorkWith + unless isDir $ + uploadDocError "expects a package directory, but none was specified." + withConfig YesReexec $ withDefaultEnvConfig $ do + config <- view configL + let hackageUrl = T.unpack $ configHackageBaseUrl config + getCreds <- memoizeRef $ loadAuth config + when isDir $ do + pkgDir <- resolveDir' dirToWorkWith + distDir <- distDirFromDir pkgDir + lp <- readLocalPackage pkgDir + let pkgId = packageIdentifier (lpPackage lp) + pkgIdName = packageIdentifierString pkgId + name = pkgIdName <> "-docs" + tarGzFileName = fromMaybe + (error "impossible") + ( do nameRelFile <- parseRelFile name + addExtension ".gz" =<< addExtension ".tar" nameRelFile + ) + tarGzFile = distDir Path. tarGzFileName + creds <- runMemoized getCreds + upload + hackageUrl + creds + DocArchive + (Just pkgId) + (toFilePath tarGzFile) + uoUploadVariant + _ -> uploadDocError + "expects a package directory, but more than one was specified." + else do + let partitionM _ [] = pure ([], []) + partitionM f (x:xs) = do + r <- f x + (as, bs) <- partitionM f xs + pure $ if r then (x:as, bs) else (as, x:bs) + (files, nonFiles) <- + liftIO $ partitionM doesFileExist uoDirsToWorkWith + (dirs, invalid) <- liftIO $ partitionM doesDirectoryExist nonFiles + withConfig YesReexec $ withDefaultEnvConfig $ do + unless (null invalid) $ do + let invalidList = bulletedList $ map (style File . fromString) invalid + prettyErrorL + [ style Shell "stack upload" + , flow "expects a list of sdist tarballs or package directories." + , flow "Can't find:" + , line <> invalidList + ] + exitFailure + when (null files && null dirs) $ do + prettyErrorL + [ style Shell "stack upload" + , flow "expects a list of sdist tarballs or package directories, but \ + \none were specified." + ] + exitFailure + config <- view configL + let hackageUrl = T.unpack $ configHackageBaseUrl config + sdistOpts = SDistOpts + uoDirsToWorkWith + uoPvpBounds + uoCheck + uoBuildPackage + uoTarPath + getCreds <- memoizeRef $ loadAuth config + mapM_ (resolveFile' >=> checkSDistTarball sdistOpts) files + forM_ files $ \file -> do + tarFile <- resolveFile' file + creds <- runMemoized getCreds + upload + hackageUrl + creds + SDist + Nothing + (toFilePath tarFile) + uoUploadVariant + forM_ dirs $ \dir -> do + pkgDir <- resolveDir' dir + (tarName, tarBytes, mcabalRevision) <- getSDistTarball uoPvpBounds pkgDir + checkSDistTarball' sdistOpts tarName tarBytes + creds <- runMemoized getCreds + uploadBytes + hackageUrl + creds + SDist + Nothing + tarName + uoUploadVariant + tarBytes + forM_ mcabalRevision $ uncurry $ uploadRevision hackageUrl creds + where + uploadDocError msg = do + prettyErrorL + [ style Shell "stack upload --documentation" + , flow msg + ] + exitFailure newtype HackageKey = HackageKey Text deriving (Eq, Show) @@ -251,7 +328,7 @@ loadUserAndPassword config = do -- * https://github.com/commercialhaskell/stack/pull/4665 writeFilePrivate :: MonadIO m => FilePath -> Builder -> m () writeFilePrivate fp builder = - liftIO $ withTempFile (takeDirectory fp) (takeFileName fp) $ \fpTmp h -> do + liftIO $ withTempFile (FP.takeDirectory fp) (FP.takeFileName fp) $ \fpTmp h -> do -- Temp file is created such that only current user can read and write it. -- See docs for openTempFile: -- https://www.stackage.org/haddock/lts-13.14/base-4.12.0.0/System-IO.html#v:openTempFile @@ -268,9 +345,9 @@ writeFilePrivate fp builder = credsFile :: Config -> IO FilePath credsFile config = do - let dir = toFilePath (view stackRootL config) "upload" + let dir = toFilePath (view stackRootL config) FP. "upload" createDirectoryIfMissing True dir - pure $ dir "credentials.json" + pure $ dir FP. "credentials.json" addAPIKey :: HackageKey -> Request -> Request addAPIKey (HackageKey key) = setRequestHeader @@ -312,28 +389,49 @@ applyCreds creds req0 = do pure req0 Right req -> pure req --- | Upload a single tarball with the given @Uploader@. Instead of --- sending a file like 'upload', this sends a lazy bytestring. +-- | Upload a single tarball with the given @Uploader@. Instead of sending a +-- file like 'upload', this sends a lazy bytestring. -- -- Since 0.1.2.1 -uploadBytes :: HasTerm m - => String -- ^ Hackage base URL - -> HackageAuth - -> String -- ^ tar file name - -> UploadVariant - -> L.ByteString -- ^ tar file contents - -> RIO m () -uploadBytes baseUrl auth tarName uploadVariant bytes = do - let req1 = setRequestHeader - "Accept" - ["text/plain"] - (fromString - $ baseUrl - <> "packages/" - <> case uploadVariant of - Publishing -> "" - Candidate -> "candidates/" - ) +uploadBytes :: + HasTerm m + => String -- ^ Hackage base URL + -> HackageAuth + -> UploadContent + -- ^ Form of the content to be uploaded. + -> Maybe PackageIdentifier + -- ^ Optional package identifier, applies only to the upload of + -- documentation. + -> String -- ^ tar file name + -> UploadVariant + -> L.ByteString -- ^ tar file contents + -> RIO m () +uploadBytes baseUrl auth contentForm mPkgId tarName uploadVariant bytes = do + let url = baseUrl <> case contentForm of + SDist -> "packages/" <> variant + DocArchive -> + "package/" <> pkgIdName <> "/" <> variant <> "docs" + variant = case uploadVariant of + Publishing -> "" + Candidate -> "candidates/" + headers = case contentForm of + SDist -> [("Accept", "text/plain")] + DocArchive -> + [ ("Accept", "application/x-tar") + , ("Accept-Encoding", "gzip") + ] + pkgIdName = case contentForm of + SDist -> maybe + ("" :: String) + (const $ error "uploadBytes: package identified specified") + mPkgId + DocArchive -> maybe + (error "uploadBytes: package identified not specified") + packageIdentifierString + mPkgId + req1 = setRequestHeaders + headers + (fromString url) formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] req2 <- liftIO $ formDataBody formData req1 req3 <- applyAuth auth req2 @@ -342,7 +440,9 @@ uploadBytes baseUrl auth tarName uploadVariant bytes = do , style Current (fromString tarName) <> "..." ] hFlush stdout - withRunInIO $ \runInIO -> withResponse req3 (runInIO . inner) + prettyInfo $ + fromString (show req3) + -- withRunInIO $ \runInIO -> withResponse req3 (runInIO . inner) where inner :: HasTerm m => Response (ConduitM () S.ByteString IO ()) -> RIO m () inner res = @@ -389,14 +489,20 @@ printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout -- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 -upload :: (HasLogFunc m, HasTerm m) - => String -- ^ Hackage base URL - -> HackageAuth - -> FilePath - -> UploadVariant - -> RIO m () -upload baseUrl auth fp uploadVariant = - uploadBytes baseUrl auth (takeFileName fp) uploadVariant +upload :: + (HasLogFunc m, HasTerm m) + => String -- ^ Hackage base URL + -> HackageAuth + -> UploadContent + -> Maybe PackageIdentifier + -- ^ Optional package identifier, applies only to the upload of + -- documentation. + -> FilePath + -- ^ Path to archive file. + -> UploadVariant + -> RIO m () +upload baseUrl auth contentForm mPkgId fp uploadVariant = + uploadBytes baseUrl auth contentForm mPkgId (FP.takeFileName fp) uploadVariant =<< liftIO (L.readFile fp) uploadRevision :: (HasLogFunc m, HasTerm m)