diff --git a/.github/workflows/integration-tests.yml b/.github/workflows/integration-tests.yml index 34fccde0ab..691cf6657a 100644 --- a/.github/workflows/integration-tests.yml +++ b/.github/workflows/integration-tests.yml @@ -11,6 +11,11 @@ on: - '**' workflow_dispatch: +# Stack will use the value of the GH_TOKEN environment variable to authenticate +# its requests of the GitHub REST API, providing a higher request rate limit. +env: + GH_TOKEN: ${{ secrets.GITHUB_TOKEN }} + # As of 26 December 2022, ubuntu-latest, windows-latest and macos-latest come # with Stack 2.9.1. ubuntu-latest and macos-latest come with GHC 9.4.3. # windows-latest comes with GHC 9.4.2. windows-latest comes with NSIS 3.08, for diff --git a/ChangeLog.md b/ChangeLog.md index 5f8bbd2677..7ebffeeb81 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -27,6 +27,9 @@ Other enhancements: * Better error message if the value of the `STACK_WORK` environment variable or `--work-dir` option is not a valid relative path. +* Stack will use the value of the `GH_TOKEN`, or `GITHUB_TOKEN`, environment + variable as credentials to authenticate its GitHub REST API requests. + Bug fixes: diff --git a/doc/environment_variables.md b/doc/environment_variables.md index 1a084f19ed..27364890e4 100644 --- a/doc/environment_variables.md +++ b/doc/environment_variables.md @@ -5,6 +5,22 @@ The environment variables listed in alphabetal order below can affect how Stack behaves. +## `GH_TOKEN` or `GITHUB_TOKEN` + +:octicons-tag-24: UNRELEASED + +Stack will use the value of the `GH_TOKEN` or, in the alternative, +`GITHUB_TOKEN` environment variable (if not an empty string) as credentials to +authenticate its requests of the GitHub REST API, using HTTP 'Basic' +authentication. + +GitHub limits the rate of unauthenticated requests to its API, although most +users of Stack will not experience that limit from the use of Stack alone. The +limit for authenticated requests is significantly higher. + +For more information about authentication of requests of the GitHub REST API, +see GitHub's REST API documentation. + ## `HACKAGE_KEY` [:octicons-tag-24: 2.7.5](https://github.com/commercialhaskell/stack/releases/tag/v2.7.5) diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index a31693e9f8..293df9ad8c 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -124,6 +124,9 @@ module Stack.Constants , relFileBuildLock , stackDeveloperModeDefault , globalFooter + , gitHubBasicAuthType + , gitHubTokenEnvVar + , altGitHubTokenEnvVar ) where import Data.ByteString.Builder ( byteString ) @@ -605,3 +608,17 @@ stackDeveloperModeDefault = STACK_DEVELOPER_MODE_DEFAULT globalFooter :: String globalFooter = "Command 'stack --help' for global options that apply to all subcommands." + +-- | The type for GitHub REST API HTTP \'Basic\' authentication. +gitHubBasicAuthType :: ByteString +gitHubBasicAuthType = "Bearer" + +-- | Environment variable to hold credentials for GitHub REST API HTTP \'Basic\' +-- authentication. +gitHubTokenEnvVar :: String +gitHubTokenEnvVar = "GH_TOKEN" + +-- | Alternate environment variable to hold credentials for GitHub REST API HTTP +-- \'Basic\' authentication. +altGitHubTokenEnvVar :: String +altGitHubTokenEnvVar = "GITHUB_TOKEN" diff --git a/src/Stack/New.hs b/src/Stack/New.hs index 1ffa94c10d..136bdc3b50 100644 --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -33,6 +33,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Time.Calendar ( toGregorian ) import Data.Time.Clock ( getCurrentTime, utctDay ) +import Network.HTTP.Client ( applyBasicAuth ) import Network.HTTP.StackClient ( HttpException (..), HttpExceptionContent (..) , Response (..), VerifiedDownloadException (..) @@ -45,7 +46,10 @@ import Path ( (), dirname, parent, parseRelDir, parseRelFile ) import Path.IO ( doesDirExist, doesFileExist, ensureDir, getCurrentDir ) import RIO.Process ( proc, runProcess_, withWorkingDir ) -import Stack.Constants ( backupUrlRelPath, wiredInPackages ) +import Stack.Constants + ( altGitHubTokenEnvVar, backupUrlRelPath, gitHubBasicAuthType + , gitHubTokenEnvVar, wiredInPackages + ) import Stack.Constants.Config ( templatesDir ) import Stack.Prelude import Stack.Types.Config ( Config (..), HasConfig (..), SCM (..) ) @@ -54,6 +58,7 @@ import Stack.Types.TemplateName , TemplatePath (..), defaultTemplateName , parseRepoPathWithService, templateName, templatePath ) +import System.Environment ( lookupEnv ) import qualified Text.Mustache as Mustache import qualified Text.Mustache.Render as Mustache import Text.ProjectTemplate @@ -332,16 +337,15 @@ loadTemplate name logIt = do (do f <- loadLocalFile relFile eitherByteStringToText logIt LocalTemp pure f) - (\(e :: PrettyException) -> do - case relSettings rawParam of - Just settings -> do - let url = tplDownloadUrl settings - extract = tplExtract settings - downloadTemplate url extract (templateDir relFile) - Nothing -> throwM e + ( \(e :: PrettyException) -> do + settings <- fromMaybe (throwM e) (relSettings rawParam) + let url = tplDownloadUrl settings + mBasicAuth = tplBasicAuth settings + extract = tplExtract settings + downloadTemplate url mBasicAuth extract (templateDir relFile) ) RepoPath rtp -> do - let settings = settingsFromRepoTemplatePath rtp + settings <- settingsFromRepoTemplatePath rtp downloadFromUrl settings templateDir where @@ -365,7 +369,7 @@ loadTemplate name logIt = do else throwM $ PrettyException $ LoadTemplateFailed name path - relSettings :: String -> Maybe TemplateDownloadSettings + relSettings :: String -> Maybe (RIO env TemplateDownloadSettings) relSettings req = do rtp <- parseRepoPathWithService defaultRepoService (T.pack req) pure (settingsFromRepoTemplatePath rtp) @@ -373,18 +377,22 @@ loadTemplate name logIt = do downloadFromUrl :: TemplateDownloadSettings -> Path Abs Dir -> RIO env Text downloadFromUrl settings templateDir = do let url = tplDownloadUrl settings + mBasicAuth = tplBasicAuth settings rel = fromMaybe backupUrlRelPath (parseRelFile url) - downloadTemplate url (tplExtract settings) (templateDir rel) - - downloadTemplate :: String - -> (ByteString - -> Either String Text) - -> Path Abs File - -> RIO env Text - downloadTemplate url extract path = do + downloadTemplate url mBasicAuth (tplExtract settings) (templateDir rel) + + downloadTemplate :: + String + -> Maybe (ByteString, ByteString) + -- ^ Optional HTTP \'Basic\' authentication (type, credentials) + -> (ByteString -> Either String Text) + -> Path Abs File + -> RIO env Text + downloadTemplate url mBasicAuth extract path = do req <- parseRequest url - let dReq = setForceDownload True $ - mkDownloadRequest (setRequestCheckStatus req) + let authReq = maybe id (uncurry applyBasicAuth) mBasicAuth req + dReq = setForceDownload True $ + mkDownloadRequest (setRequestCheckStatus authReq) logIt RemoteTemp catch ( do let label = T.pack $ toFilePath path @@ -414,8 +422,11 @@ loadTemplate name logIt = do throwM $ PrettyException $ DownloadTemplateFailed (templateName name) url exception +-- | Type representing settings for the download of Stack project templates. data TemplateDownloadSettings = TemplateDownloadSettings { tplDownloadUrl :: String + , tplBasicAuth :: Maybe (ByteString, ByteString) + -- ^ Optional HTTP 'Basic' authentication (type, credentials) , tplExtract :: ByteString -> Either String Text } @@ -425,32 +436,56 @@ eitherByteStringToText = mapLeft show . decodeUtf8' asIsFromUrl :: String -> TemplateDownloadSettings asIsFromUrl url = TemplateDownloadSettings { tplDownloadUrl = url + , tplBasicAuth = Nothing , tplExtract = eitherByteStringToText } --- | Construct a URL for downloading from a repo. -settingsFromRepoTemplatePath :: RepoTemplatePath -> TemplateDownloadSettings -settingsFromRepoTemplatePath (RepoTemplatePath GitHub user name) = - -- T.concat ["https://raw.githubusercontent.com", "/", user, "/stack-templates/master/", name] - TemplateDownloadSettings - { tplDownloadUrl = concat - [ "https://api.github.com/repos/" - , T.unpack user - , "/stack-templates/contents/" - , T.unpack name - ] - , tplExtract = \bs -> do - decodedJson <- eitherDecode (LB.fromStrict bs) - case decodedJson of - Object o | Just (String content) <- KeyMap.lookup "content" o -> do - let noNewlines = T.filter (/= '\n') - bsContent <- B64.decode $ T.encodeUtf8 (noNewlines content) - mapLeft show $ decodeUtf8' bsContent - _ -> - Left "Couldn't parse GitHub response as a JSON object with a \"content\" field" - } - -settingsFromRepoTemplatePath (RepoTemplatePath GitLab user name) = +-- | Construct settings for downloading a Stack project template from a +-- repository. +settingsFromRepoTemplatePath :: + HasTerm env + => RepoTemplatePath + -> RIO env TemplateDownloadSettings +settingsFromRepoTemplatePath (RepoTemplatePath GitHub user name) = do + let basicAuthMsg token = prettyInfoL + [ flow "Using content of" + , fromString token + , flow " environment variable to authenticate GitHub REST API." + ] + mBasicAuth <- do + wantGitHubToken <- liftIO $ fromMaybe "" <$> lookupEnv gitHubTokenEnvVar + if not (L.null wantGitHubToken) + then do + basicAuthMsg gitHubTokenEnvVar + pure $ Just (gitHubBasicAuthType, fromString wantGitHubToken) + else do + wantAltGitHubToken <- + liftIO $ fromMaybe "" <$> lookupEnv altGitHubTokenEnvVar + if not (L.null wantAltGitHubToken) + then do + basicAuthMsg altGitHubTokenEnvVar + pure $ Just (gitHubBasicAuthType, fromString wantAltGitHubToken) + else pure Nothing + pure $ TemplateDownloadSettings + { tplDownloadUrl = concat + [ "https://api.github.com/repos/" + , T.unpack user + , "/stack-templates/contents/" + , T.unpack name + ] + , tplBasicAuth = mBasicAuth + , tplExtract = \bs -> do + decodedJson <- eitherDecode (LB.fromStrict bs) + case decodedJson of + Object o | Just (String content) <- KeyMap.lookup "content" o -> do + let noNewlines = T.filter (/= '\n') + bsContent <- B64.decode $ T.encodeUtf8 (noNewlines content) + mapLeft show $ decodeUtf8' bsContent + _ -> + Left "Couldn't parse GitHub response as a JSON object with a \ + \\"content\" field" + } +settingsFromRepoTemplatePath (RepoTemplatePath GitLab user name) = pure $ asIsFromUrl $ concat [ "https://gitlab.com" , "/" @@ -458,7 +493,7 @@ settingsFromRepoTemplatePath (RepoTemplatePath GitLab user name) = , "/stack-templates/raw/master/" , T.unpack name ] -settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) = +settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) = pure $ asIsFromUrl $ concat [ "https://bitbucket.org" , "/"