mirror of
https://github.com/nmattia/niv.git
synced 2024-09-16 01:47:08 +03:00
Move GitHub API calls to Niv.GitHub.API
This commit is contained in:
parent
1d3ec979cd
commit
2663cc56e0
@ -31,6 +31,7 @@ with rec
|
|||||||
"^src/Data/Aeson$"
|
"^src/Data/Aeson$"
|
||||||
"^src/Data/HashMap$"
|
"^src/Data/HashMap$"
|
||||||
"^src/Data/HashMap/Strict$"
|
"^src/Data/HashMap/Strict$"
|
||||||
|
"^src/Data/Text$"
|
||||||
"^src/Niv$"
|
"^src/Niv$"
|
||||||
"^src/Niv/GitHub$"
|
"^src/Niv/GitHub$"
|
||||||
"^src/Niv/Sources$"
|
"^src/Niv/Sources$"
|
||||||
|
14
src/Data/Text/Extended.hs
Normal file
14
src/Data/Text/Extended.hs
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
module Data.Text.Extended where
|
||||||
|
|
||||||
|
import System.Exit (exitFailure)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.IO as T
|
||||||
|
|
||||||
|
tshow :: Show a => a -> T.Text
|
||||||
|
tshow = T.pack . show
|
||||||
|
|
||||||
|
-- not quite the perfect place for this
|
||||||
|
abort :: T.Text -> IO a
|
||||||
|
abort msg = do
|
||||||
|
T.putStrLn msg
|
||||||
|
exitFailure
|
@ -18,8 +18,10 @@ import Data.Functor
|
|||||||
import Data.HashMap.Strict.Extended
|
import Data.HashMap.Strict.Extended
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Data.String.QQ (s)
|
import Data.String.QQ (s)
|
||||||
|
import Data.Text.Extended
|
||||||
import Data.Version (showVersion)
|
import Data.Version (showVersion)
|
||||||
import Niv.GitHub
|
import Niv.GitHub
|
||||||
|
import Niv.GitHub.API
|
||||||
import Niv.Logger
|
import Niv.Logger
|
||||||
import Niv.Sources
|
import Niv.Sources
|
||||||
import Niv.Update
|
import Niv.Update
|
||||||
|
@ -3,28 +3,16 @@
|
|||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Niv.GitHub where
|
module Niv.GitHub where
|
||||||
|
|
||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
import Data.Bool
|
import Data.Bool
|
||||||
import Data.Functor
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.QQ (s)
|
import Niv.GitHub.API
|
||||||
import Niv.Update
|
import Niv.Update
|
||||||
import System.Environment (lookupEnv)
|
|
||||||
import System.Exit (exitFailure)
|
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
|
||||||
import Text.Read (readMaybe)
|
|
||||||
import qualified Data.Aeson as Aeson
|
|
||||||
import qualified Data.ByteString.Char8 as BS8
|
|
||||||
import qualified Data.HashMap.Strict as HMS
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as T
|
|
||||||
import qualified Data.Text.IO as T
|
|
||||||
import qualified Network.HTTP.Simple as HTTP
|
|
||||||
|
|
||||||
-- | The GitHub update function
|
-- | The GitHub update function
|
||||||
-- TODO: fetchers for:
|
-- TODO: fetchers for:
|
||||||
@ -68,150 +56,3 @@ githubURLTemplate :: T.Text
|
|||||||
githubURLTemplate =
|
githubURLTemplate =
|
||||||
(if githubSecure then "https://" else "http://") <>
|
(if githubSecure then "https://" else "http://") <>
|
||||||
githubHost <> githubPath <> "<owner>/<repo>/archive/<rev>.tar.gz"
|
githubHost <> githubPath <> "<owner>/<repo>/archive/<rev>.tar.gz"
|
||||||
|
|
||||||
-- Bunch of GitHub helpers
|
|
||||||
|
|
||||||
data GithubRepo = GithubRepo
|
|
||||||
{ repoDescription :: Maybe T.Text
|
|
||||||
, repoHomepage :: Maybe T.Text
|
|
||||||
, repoDefaultBranch :: Maybe T.Text
|
|
||||||
}
|
|
||||||
|
|
||||||
githubRepo :: T.Text -> T.Text -> IO GithubRepo
|
|
||||||
githubRepo owner repo = do
|
|
||||||
request <- defaultRequest ["repos", owner, repo]
|
|
||||||
-- we don't use httpJSONEither because it adds an "Accept:
|
|
||||||
-- application/json" header that GitHub chokes on
|
|
||||||
resp0 <- HTTP.httpBS request
|
|
||||||
let resp = fmap Aeson.eitherDecodeStrict resp0
|
|
||||||
case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of
|
|
||||||
(200, Right (Aeson.Object m)) -> do
|
|
||||||
let lookupText k = case HMS.lookup k m of
|
|
||||||
Just (Aeson.String t) -> Just t
|
|
||||||
_ -> Nothing
|
|
||||||
pure GithubRepo
|
|
||||||
{ repoDescription = lookupText "description"
|
|
||||||
, repoHomepage = lookupText "homepage"
|
|
||||||
, repoDefaultBranch = lookupText "default_branch"
|
|
||||||
}
|
|
||||||
(200, Right v) -> do
|
|
||||||
error $ "expected object, got " <> show v
|
|
||||||
(200, Left e) -> do
|
|
||||||
error $ "github didn't return JSON: " <> show e
|
|
||||||
_ -> abortCouldNotFetchGitHubRepo (tshow (request,resp0)) (owner, repo)
|
|
||||||
|
|
||||||
-- | TODO: Error instead of T.Text?
|
|
||||||
abortCouldNotFetchGitHubRepo :: T.Text -> (T.Text, T.Text) -> IO a
|
|
||||||
abortCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) = do
|
|
||||||
putStrLn $ unlines [ line1, line2, T.unpack line3 ]
|
|
||||||
exitFailure
|
|
||||||
where
|
|
||||||
line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo
|
|
||||||
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 = T.unwords [ "(Error was:", e, ")" ]
|
|
||||||
|
|
||||||
defaultRequest :: [T.Text] -> IO HTTP.Request
|
|
||||||
defaultRequest (map T.encodeUtf8 -> parts) = do
|
|
||||||
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)
|
|
||||||
mtoken <- lookupEnv "GITHUB_TOKEN"
|
|
||||||
pure $
|
|
||||||
(flip (maybe id) mtoken $ \token ->
|
|
||||||
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
|
||||||
) $
|
|
||||||
HTTP.setRequestPath path $
|
|
||||||
HTTP.addRequestHeader "user-agent" "niv" $
|
|
||||||
HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" $
|
|
||||||
HTTP.setRequestSecure githubSecure $
|
|
||||||
HTTP.setRequestHost (T.encodeUtf8 githubApiHost) $
|
|
||||||
HTTP.setRequestPort githubApiPort $
|
|
||||||
HTTP.defaultRequest
|
|
||||||
|
|
||||||
-- | Get the latest revision for owner, repo and branch.
|
|
||||||
-- TODO: explain no error handling
|
|
||||||
githubLatestRev
|
|
||||||
:: T.Text
|
|
||||||
-- ^ owner
|
|
||||||
-> T.Text
|
|
||||||
-- ^ repo
|
|
||||||
-> T.Text
|
|
||||||
-- ^ branch
|
|
||||||
-> IO T.Text
|
|
||||||
githubLatestRev owner repo branch = do
|
|
||||||
request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&>
|
|
||||||
HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"
|
|
||||||
resp <- HTTP.httpBS request
|
|
||||||
case HTTP.getResponseStatusCode resp of
|
|
||||||
200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp
|
|
||||||
_ -> abortCouldNotGetRev owner repo branch resp
|
|
||||||
|
|
||||||
abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a
|
|
||||||
abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [ line1, line2, line3 ]
|
|
||||||
where
|
|
||||||
line1 = T.unwords
|
|
||||||
[ "Cannot get latest revision for branch"
|
|
||||||
, "'" <> branch <> "'"
|
|
||||||
, "(" <> owner <> "/" <> repo <> ")"
|
|
||||||
]
|
|
||||||
line2 = "The request failed: " <> tshow resp
|
|
||||||
line3 = [s|
|
|
||||||
NOTE: You may want to retry with an authentication token:
|
|
||||||
|
|
||||||
GITHUB_TOKEN=... niv <cmd>
|
|
||||||
|
|
||||||
For more information on rate-limiting, see
|
|
||||||
|
|
||||||
https://developer.github.com/v3/#rate-limiting
|
|
||||||
|
|
||||||
|]
|
|
||||||
|
|
||||||
githubHost :: T.Text
|
|
||||||
githubHost = unsafePerformIO $ do
|
|
||||||
lookupEnv "GITHUB_HOST" >>= \case
|
|
||||||
Just (T.pack -> x) -> pure x
|
|
||||||
Nothing -> pure "github.com"
|
|
||||||
|
|
||||||
githubApiPort :: Int
|
|
||||||
githubApiPort = unsafePerformIO $ do
|
|
||||||
lookupEnv "GITHUB_API_PORT" >>= \case
|
|
||||||
Just (readMaybe -> Just x) -> pure x
|
|
||||||
_ -> pure $ if githubSecure then 443 else 80
|
|
||||||
|
|
||||||
githubApiHost :: T.Text
|
|
||||||
githubApiHost = unsafePerformIO $ do
|
|
||||||
lookupEnv "GITHUB_API_HOST" >>= \case
|
|
||||||
Just (T.pack -> x) -> pure x
|
|
||||||
Nothing -> pure "api.github.com"
|
|
||||||
|
|
||||||
githubSecure :: Bool
|
|
||||||
githubSecure = unsafePerformIO $ do
|
|
||||||
lookupEnv "GITHUB_INSECURE" >>= \case
|
|
||||||
Just "" -> pure True
|
|
||||||
Just _ -> pure False
|
|
||||||
Nothing -> pure True
|
|
||||||
|
|
||||||
githubPath :: T.Text
|
|
||||||
githubPath = unsafePerformIO $ do
|
|
||||||
lookupEnv "GITHUB_PATH" >>= \case
|
|
||||||
Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/"
|
|
||||||
Nothing -> pure "/"
|
|
||||||
|
|
||||||
abort :: T.Text -> IO a
|
|
||||||
abort msg = do
|
|
||||||
T.putStrLn msg
|
|
||||||
exitFailure
|
|
||||||
|
|
||||||
tshow :: Show a => a -> T.Text
|
|
||||||
tshow = T.pack . show
|
|
||||||
|
160
src/Niv/GitHub/API.hs
Normal file
160
src/Niv/GitHub/API.hs
Normal file
@ -0,0 +1,160 @@
|
|||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
|
module Niv.GitHub.API where
|
||||||
|
|
||||||
|
import Data.Functor
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.String.QQ (s)
|
||||||
|
import Data.Text.Extended
|
||||||
|
import System.Environment (lookupEnv)
|
||||||
|
import System.Exit (exitFailure)
|
||||||
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
|
import Text.Read (readMaybe)
|
||||||
|
import qualified Data.Aeson as Aeson
|
||||||
|
import qualified Data.ByteString.Char8 as BS8
|
||||||
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Text.Encoding as T
|
||||||
|
import qualified Network.HTTP.Simple as HTTP
|
||||||
|
|
||||||
|
-- Bunch of GitHub helpers
|
||||||
|
|
||||||
|
data GithubRepo = GithubRepo
|
||||||
|
{ repoDescription :: Maybe T.Text
|
||||||
|
, repoHomepage :: Maybe T.Text
|
||||||
|
, repoDefaultBranch :: Maybe T.Text
|
||||||
|
}
|
||||||
|
|
||||||
|
githubRepo :: T.Text -> T.Text -> IO GithubRepo
|
||||||
|
githubRepo owner repo = do
|
||||||
|
request <- defaultRequest ["repos", owner, repo]
|
||||||
|
-- we don't use httpJSONEither because it adds an "Accept:
|
||||||
|
-- application/json" header that GitHub chokes on
|
||||||
|
resp0 <- HTTP.httpBS request
|
||||||
|
let resp = fmap Aeson.eitherDecodeStrict resp0
|
||||||
|
case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of
|
||||||
|
(200, Right (Aeson.Object m)) -> do
|
||||||
|
let lookupText k = case HMS.lookup k m of
|
||||||
|
Just (Aeson.String t) -> Just t
|
||||||
|
_ -> Nothing
|
||||||
|
pure GithubRepo
|
||||||
|
{ repoDescription = lookupText "description"
|
||||||
|
, repoHomepage = lookupText "homepage"
|
||||||
|
, repoDefaultBranch = lookupText "default_branch"
|
||||||
|
}
|
||||||
|
(200, Right v) -> do
|
||||||
|
error $ "expected object, got " <> show v
|
||||||
|
(200, Left e) -> do
|
||||||
|
error $ "github didn't return JSON: " <> show e
|
||||||
|
_ -> abortCouldNotFetchGitHubRepo (tshow (request,resp0)) (owner, repo)
|
||||||
|
|
||||||
|
-- | TODO: Error instead of T.Text?
|
||||||
|
abortCouldNotFetchGitHubRepo :: T.Text -> (T.Text, T.Text) -> IO a
|
||||||
|
abortCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) = do
|
||||||
|
putStrLn $ unlines [ line1, line2, T.unpack line3 ]
|
||||||
|
exitFailure
|
||||||
|
where
|
||||||
|
line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo
|
||||||
|
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 = T.unwords [ "(Error was:", e, ")" ]
|
||||||
|
|
||||||
|
defaultRequest :: [T.Text] -> IO HTTP.Request
|
||||||
|
defaultRequest (map T.encodeUtf8 -> parts) = do
|
||||||
|
let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)
|
||||||
|
mtoken <- lookupEnv "GITHUB_TOKEN"
|
||||||
|
pure $
|
||||||
|
(flip (maybe id) mtoken $ \token ->
|
||||||
|
HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)
|
||||||
|
) $
|
||||||
|
HTTP.setRequestPath path $
|
||||||
|
HTTP.addRequestHeader "user-agent" "niv" $
|
||||||
|
HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" $
|
||||||
|
HTTP.setRequestSecure githubSecure $
|
||||||
|
HTTP.setRequestHost (T.encodeUtf8 githubApiHost) $
|
||||||
|
HTTP.setRequestPort githubApiPort $
|
||||||
|
HTTP.defaultRequest
|
||||||
|
|
||||||
|
-- | Get the latest revision for owner, repo and branch.
|
||||||
|
-- TODO: explain no error handling
|
||||||
|
githubLatestRev
|
||||||
|
:: T.Text
|
||||||
|
-- ^ owner
|
||||||
|
-> T.Text
|
||||||
|
-- ^ repo
|
||||||
|
-> T.Text
|
||||||
|
-- ^ branch
|
||||||
|
-> IO T.Text
|
||||||
|
githubLatestRev owner repo branch = do
|
||||||
|
request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&>
|
||||||
|
HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"
|
||||||
|
resp <- HTTP.httpBS request
|
||||||
|
case HTTP.getResponseStatusCode resp of
|
||||||
|
200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp
|
||||||
|
_ -> abortCouldNotGetRev owner repo branch resp
|
||||||
|
|
||||||
|
abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a
|
||||||
|
abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [ line1, line2, line3 ]
|
||||||
|
where
|
||||||
|
line1 = T.unwords
|
||||||
|
[ "Cannot get latest revision for branch"
|
||||||
|
, "'" <> branch <> "'"
|
||||||
|
, "(" <> owner <> "/" <> repo <> ")"
|
||||||
|
]
|
||||||
|
line2 = "The request failed: " <> tshow resp
|
||||||
|
line3 = [s|
|
||||||
|
NOTE: You may want to retry with an authentication token:
|
||||||
|
|
||||||
|
GITHUB_TOKEN=... niv <cmd>
|
||||||
|
|
||||||
|
For more information on rate-limiting, see
|
||||||
|
|
||||||
|
https://developer.github.com/v3/#rate-limiting
|
||||||
|
|
||||||
|
|]
|
||||||
|
|
||||||
|
githubHost :: T.Text
|
||||||
|
githubHost = unsafePerformIO $ do
|
||||||
|
lookupEnv "GITHUB_HOST" >>= \case
|
||||||
|
Just (T.pack -> x) -> pure x
|
||||||
|
Nothing -> pure "github.com"
|
||||||
|
|
||||||
|
githubApiPort :: Int
|
||||||
|
githubApiPort = unsafePerformIO $ do
|
||||||
|
lookupEnv "GITHUB_API_PORT" >>= \case
|
||||||
|
Just (readMaybe -> Just x) -> pure x
|
||||||
|
_ -> pure $ if githubSecure then 443 else 80
|
||||||
|
|
||||||
|
githubApiHost :: T.Text
|
||||||
|
githubApiHost = unsafePerformIO $ do
|
||||||
|
lookupEnv "GITHUB_API_HOST" >>= \case
|
||||||
|
Just (T.pack -> x) -> pure x
|
||||||
|
Nothing -> pure "api.github.com"
|
||||||
|
|
||||||
|
githubSecure :: Bool
|
||||||
|
githubSecure = unsafePerformIO $ do
|
||||||
|
lookupEnv "GITHUB_INSECURE" >>= \case
|
||||||
|
Just "" -> pure True
|
||||||
|
Just _ -> pure False
|
||||||
|
Nothing -> pure True
|
||||||
|
|
||||||
|
githubPath :: T.Text
|
||||||
|
githubPath = unsafePerformIO $ do
|
||||||
|
lookupEnv "GITHUB_PATH" >>= \case
|
||||||
|
Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/"
|
||||||
|
Nothing -> pure "/"
|
@ -8,6 +8,7 @@ import Control.Monad
|
|||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Niv.GitHub
|
import Niv.GitHub
|
||||||
|
import Niv.GitHub.API
|
||||||
import Niv.Update
|
import Niv.Update
|
||||||
import qualified Data.HashMap.Strict as HMS
|
import qualified Data.HashMap.Strict as HMS
|
||||||
|
|
||||||
|
@ -13,7 +13,7 @@ import Data.Bifunctor (first)
|
|||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.String.QQ (s)
|
import Data.String.QQ (s)
|
||||||
import Niv.GitHub
|
import Data.Text.Extended
|
||||||
import Niv.Logger
|
import Niv.Logger
|
||||||
import Niv.Update
|
import Niv.Update
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
|
Loading…
Reference in New Issue
Block a user