{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}

module Niv.GitHub.API where

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as BS8
import Data.Functor
import Data.Maybe
import Data.String.QQ (s)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Extended
import qualified Network.HTTP.Simple as HTTP
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)

-- Bunch of GitHub helpers

data GithubRepo = GithubRepo
  { GithubRepo -> Maybe Text
repoDescription :: Maybe T.Text,
    GithubRepo -> Maybe Text
repoHomepage :: Maybe T.Text,
    GithubRepo -> Maybe Text
repoDefaultBranch :: Maybe T.Text
  }

githubRepo :: T.Text -> T.Text -> IO GithubRepo
githubRepo :: Text -> Text -> IO GithubRepo
githubRepo Text
owner Text
repo = do
  Request
request <- [Text] -> IO Request
defaultRequest [Text
"repos", Text
owner, Text
repo]
  -- we don't use httpJSONEither because it adds an "Accept:
  -- application/json" header that GitHub chokes on
  Response ByteString
resp0 <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
HTTP.httpBS Request
request
  let resp :: Response (Either String Value)
resp = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict Response ByteString
resp0
  case (forall a. Response a -> Int
HTTP.getResponseStatusCode Response (Either String Value)
resp, forall a. Response a -> a
HTTP.getResponseBody Response (Either String Value)
resp) of
    (Int
200, Right (Aeson.Object Object
m)) -> do
      let lookupText :: Key -> Maybe Text
lookupText Key
k = case forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
k Object
m of
            Just (Aeson.String Text
t) -> forall a. a -> Maybe a
Just Text
t
            Maybe Value
_ -> forall a. Maybe a
Nothing
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        GithubRepo
          { repoDescription :: Maybe Text
repoDescription = Key -> Maybe Text
lookupText Key
"description",
            repoHomepage :: Maybe Text
repoHomepage = Key -> Maybe Text
lookupText Key
"homepage",
            repoDefaultBranch :: Maybe Text
repoDefaultBranch = Key -> Maybe Text
lookupText Key
"default_branch"
          }
    (Int
200, Right Value
v) -> do
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"expected object, got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
v
    (Int
200, Left String
e) -> do
      forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"github didn't return JSON: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
e
    (Int, Either String Value)
_ -> forall a. Text -> (Text, Text) -> IO a
abortCouldNotFetchGitHubRepo (forall a. Show a => a -> Text
tshow (Request
request, Response ByteString
resp0)) (Text
owner, Text
repo)

-- | TODO: Error instead of T.Text?
abortCouldNotFetchGitHubRepo :: T.Text -> (T.Text, T.Text) -> IO a
abortCouldNotFetchGitHubRepo :: forall a. Text -> (Text, Text) -> IO a
abortCouldNotFetchGitHubRepo Text
e (Text -> String
T.unpack -> String
owner, Text -> String
T.unpack -> String
repo) = do
  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
line1, String
line2, Text -> String
T.unpack Text
line3]
  forall a. IO a
exitFailure
  where
    line1 :: String
line1 = String
"WARNING: Could not read from GitHub repo: " forall a. Semigroup a => a -> a -> a
<> String
owner forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> String
repo
    line2 :: String
line2 =
      [s|
I assumed that your package was a GitHub repository. An error occurred while
gathering information from the repository. Check whether your package was added
correctly:

  niv show

If not, try re-adding it:

  niv drop <package>
  niv add <package-without-typo>

Make sure the repository exists.
|]
    line3 :: Text
line3 = [Text] -> Text
T.unwords [Text
"(Error was:", Text
e, Text
")"]

defaultRequest :: [T.Text] -> IO HTTP.Request
defaultRequest :: [Text] -> IO Request
defaultRequest (forall a b. (a -> b) -> [a] -> [b]
map Text -> ByteString
T.encodeUtf8 -> [ByteString]
parts) = do
  let path :: ByteString
path = Text -> ByteString
T.encodeUtf8 Text
githubPath forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
BS8.intercalate ByteString
"/" ([ByteString]
parts)
  Maybe String
mtoken <- String -> IO (Maybe String)
lookupEnv' String
"GITHUB_TOKEN"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ ( forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id) Maybe String
mtoken forall a b. (a -> b) -> a -> b
$ \String
token ->
          HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"authorization" (ByteString
"token " forall a. Semigroup a => a -> a -> a
<> String -> ByteString
BS8.pack String
token)
      )
    forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestPath ByteString
path
    forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"user-agent" ByteString
"niv"
    forall a b. (a -> b) -> a -> b
$ HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"accept" ByteString
"application/vnd.github.v3+json"
    forall a b. (a -> b) -> a -> b
$ Bool -> Request -> Request
HTTP.setRequestSecure Bool
githubSecure
    forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
HTTP.setRequestHost (Text -> ByteString
T.encodeUtf8 Text
githubApiHost)
    forall a b. (a -> b) -> a -> b
$ Int -> Request -> Request
HTTP.setRequestPort Int
githubApiPort
    forall a b. (a -> b) -> a -> b
$ Request
HTTP.defaultRequest

-- | Get the latest revision for owner, repo and branch.
-- TODO: explain no error handling
githubLatestRev ::
  -- | owner
  T.Text ->
  -- | repo
  T.Text ->
  -- | branch
  T.Text ->
  IO T.Text
githubLatestRev :: Text -> Text -> Text -> IO Text
githubLatestRev Text
owner Text
repo Text
branch = do
  Request
request <-
    [Text] -> IO Request
defaultRequest [Text
"repos", Text
owner, Text
repo, Text
"commits", Text
branch]
      forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> HeaderName -> ByteString -> Request -> Request
HTTP.addRequestHeader HeaderName
"accept" ByteString
"application/vnd.github.v3.sha"
  Response ByteString
resp <- forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
HTTP.httpBS Request
request
  case forall a. Response a -> Int
HTTP.getResponseStatusCode Response ByteString
resp of
    Int
200 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
HTTP.getResponseBody Response ByteString
resp
    Int
_ -> forall a. Text -> Text -> Text -> Response ByteString -> IO a
abortCouldNotGetRev Text
owner Text
repo Text
branch Response ByteString
resp

abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a
abortCouldNotGetRev :: forall a. Text -> Text -> Text -> Response ByteString -> IO a
abortCouldNotGetRev Text
owner Text
repo Text
branch Response ByteString
resp = forall (io :: * -> *) a. MonadIO io => Text -> io a
abort forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [Text
line1, Text
line2, Text
line3]
  where
    line1 :: Text
line1 =
      [Text] -> Text
T.unwords
        [ Text
"Cannot get latest revision for branch",
          Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
branch forall a. Semigroup a => a -> a -> a
<> Text
"'",
          Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
owner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
repo forall a. Semigroup a => a -> a -> a
<> Text
")"
        ]
    line2 :: Text
line2 = Text
"The request failed: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Response ByteString
resp
    line3 :: Text
line3 =
      [s|
NOTE: You may want to retry with an authentication token:

    GITHUB_TOKEN=... niv <cmd>

For more information on rate-limiting, see

    https://docs.github.com/en/rest/overview/resources-in-the-rest-api#rate-limiting

|]

-- | Like lookupEnv "foo" but also looks up "NIV_foo"
lookupEnv' :: String -> IO (Maybe String)
lookupEnv' :: String -> IO (Maybe String)
lookupEnv' String
vn =
  String -> IO (Maybe String)
lookupEnv String
vn forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just String
x)
    Maybe String
Nothing -> String -> IO (Maybe String)
lookupEnv (String
"NIV_" forall a. Semigroup a => a -> a -> a
<> String
vn)

githubHost :: T.Text
githubHost :: Text
githubHost = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO (Maybe String)
lookupEnv' String
"GITHUB_HOST" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (String -> Text
T.pack -> Text
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"github.com"

githubApiPort :: Int
githubApiPort :: Int
githubApiPort = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO (Maybe String)
lookupEnv' String
"GITHUB_API_PORT" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (forall a. Read a => String -> Maybe a
readMaybe -> Just Int
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x
    Maybe String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
githubSecure then Int
443 else Int
80

githubApiHost :: T.Text
githubApiHost :: Text
githubApiHost = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO (Maybe String)
lookupEnv' String
"GITHUB_API_HOST" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (String -> Text
T.pack -> Text
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"api.github.com"

-- For these two we prepend NIV_ to the variable name because the variable
-- names can have different meanings, see
-- https://github.com/nmattia/niv/issues/280

githubSecure :: Bool
githubSecure :: Bool
githubSecure = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO (Maybe String)
lookupEnv String
"NIV_GITHUB_INSECURE" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
"" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

githubPath :: T.Text
githubPath :: Text
githubPath = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO (Maybe String)
lookupEnv String
"NIV_GITHUB_PATH" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (String -> Text
T.pack -> Text
x) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Text
x (Text -> Text -> Maybe Text
T.stripSuffix Text
"/" Text
x) forall a. Semigroup a => a -> a -> a
<> Text
"/"
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"/"