Merge pull request #6036 from commercialhaskell/fix6034

Fix #6034 Allow authenticated requests to GitHub REST API

Author: mpilgrem

.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

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:
 

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)

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"

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,26 +369,30 @@ 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)
 
   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,40 +436,64 @@ 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"
     , "/"
     , T.unpack user
     , "/stack-templates/raw/master/"
     , T.unpack name
     ]
-settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) =
+settingsFromRepoTemplatePath (RepoTemplatePath Bitbucket user name) = pure $
   asIsFromUrl $ concat
     [ "https://bitbucket.org"
     , "/"