nmattia/niv
1
1
Fork 0
mirror of https://github.com/nmattia/niv.git synced 2024-12-01 15:56:03 +03:00
Code Issues Projects Releases Wiki Activity

Use custom GitHub client

Browse Source
This commit is contained in:
Nicolas Mattia 2019-09-21 22:07:00 +02:00
parent 5e9671a9a8
commit 366d7476d7
5 changed files with 175 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
package.yaml
View File

@ -27,8 +27,8 @@ dependencies:
- directory
- file-embed
- filepath
- github
- hashable
- http-conduit
- mtl
- optparse-applicative
- process
@ -43,7 +43,6 @@ library:
- src
dependencies:
- aeson
- github
- tasty
- tasty-hunit
- unordered-containers

10
src/Niv/Cli.hs
View File

@ -20,7 +20,7 @@ import Data.String.QQ (s)
import Niv.Logger
import Niv.GitHub
import Niv.Update
import System.Exit (exitFailure, ExitCode(ExitSuccess))
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((</>), takeDirectory)
import System.Process (readProcessWithExitCode)
import UnliftIO
@ -520,11 +520,6 @@ mapWithKeyM_ f m = do
forM_ (HMS.toList m) $ \(k, v) ->
HMS.singleton k <$> f k v
abort :: T.Text -> IO a
abort msg = do
T.putStrLn msg
exitFailure
nixPrefetchURL :: Bool -> T.Text -> IO T.Text
nixPrefetchURL unpack (T.unpack -> url) = do
(exitCode, sout, serr) <- runNixPrefetch
@ -689,6 +684,3 @@ ticket:
Thanks! I'll buy you a beer.
|] <> T.unlines ["stdout: ", sout, "stderr: ", serr]
tshow :: Show a => a -> T.Text
tshow = T.pack . show

218
src/Niv/GitHub.hs
View File

@ -10,68 +10,23 @@ module Niv.GitHub where
import Control.Arrow
import Data.Bool
import Data.Functor
import Data.Maybe
import Data.String.QQ (s)
import GHC.Exts (toList)
import Niv.Update
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Aeson as Aeson
import qualified Data.Text as T
import qualified GitHub as GH
import qualified GitHub.Data.Name as GH
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 Data.Text.IO as T
import qualified Network.HTTP.Simple as HTTP
data GithubRepo = GithubRepo
{ repoDescription :: Maybe T.Text
, repoHomepage :: Maybe T.Text
, repoDefaultBranch :: Maybe T.Text
}
executeRequest
:: Aeson.FromJSON a => GH.Request 'GH.RO a -> IO (Either GH.Error a)
executeRequest req = do
token <- fmap (GH.OAuth . encodeUtf8 . T.pack) <$> lookupEnv "GITHUB_TOKEN"
GH.executeRequestMaybe token req
githubRepo :: T.Text -> T.Text -> IO GithubRepo
githubRepo owner repo = request >>= pickResponse >>= return . translate
where
pickResponse :: Either GH.Error GH.Repo -> IO GH.Repo
pickResponse = \case
Left e -> do
warnCouldNotFetchGitHubRepo e (owner, repo)
error (show e)
Right x -> return x
request :: IO (Either GH.Error GH.Repo)
request = executeRequest (GH.repositoryR (GH.N owner) (GH.N repo))
translate :: GH.Repo -> GithubRepo
translate r = GithubRepo
{ repoDescription = GH.repoDescription r
, repoHomepage = GH.repoHomepage r
, repoDefaultBranch = GH.repoDefaultBranch r
}
warnCouldNotFetchGitHubRepo :: GH.Error -> (T.Text, T.Text) -> IO ()
warnCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) =
putStrLn $ unlines [ line1, line2, line3 ]
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 = unwords [ "(Error was:", show e, ")" ]
-- | The GitHub update function
-- TODO: fetchers for:
-- * npm
-- * hackage
@ -111,7 +66,74 @@ githubUpdate prefetch latestRev ghRepo = proc () -> do
githubURLTemplate :: T.Text
githubURLTemplate =
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
(if githubSecure then "https://" else "http://") <>
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]
resp <- HTTP.httpJSONEither request -- >>= \case
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 resp) (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, 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 = unwords [ "(Error was:", show 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 "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
@ -123,15 +145,71 @@ githubLatestRev
-> T.Text
-- ^ branch
-> IO T.Text
githubLatestRev owner repo branch =
executeRequest (
GH.commitsWithOptionsForR (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
[GH.CommitQuerySha branch]
) >>= \case
Right (toList -> (commit:_)) -> do
let GH.N rev = GH.commitSha commit
pure $ rev
Right (toList -> []) -> do
error "No rev: no commits"
Left e -> error $ "No rev: " <> show e
_ -> error $ "No rev: impossible"
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
|]
-- TODO: document all of these
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 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

9
src/Niv/Logger.hs
View File

@ -7,6 +7,7 @@ module Niv.Logger where
import Control.Monad
import Data.Profunctor
import System.Exit (exitFailure)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as T
import UnliftIO
@ -19,7 +20,13 @@ job str act = do
indent
tryAny act <* deindent >>= \case
Right () -> say $ green "Done" <> ": " <> str
Left e -> say $ red "ERROR" <> ":\n" <> show e
Left e -> do
-- don't wrap if the error ain't too long
let showErr = do
let se = show e
(if length se > 40 then ":\n" else ": ") <> se
say $ red "ERROR" <> showErr
exitFailure
where
indent = void $ atomicModifyIORef jobStack (\x -> (x + 1, undefined))
deindent = void $ atomicModifyIORef jobStack (\x -> (x - 1, undefined))

27
tests/default.nix
View File

@ -22,16 +22,15 @@ let
# TODO: Remove this patch by adding an argument to the github
# subcommand to support GitHub entreprise.
prePatch = ''
sed "/import Data.Text.Encoding (encodeUtf8)/d" -i src/Niv/GitHub.hs
sed "/import System.Environment (lookupEnv)/d" -i src/Niv/GitHub.hs
sed "s|token <- fmap (GH.OAuth . encodeUtf8 . T.pack) <$> lookupEnv \"GITHUB_TOKEN\"|let token = Just (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i src/Niv/GitHub.hs
sed "s|https://github.com|http://localhost:3333|" -i src/Niv/GitHub.hs
sed 's|githubHost = "github.com"|githubHost = "localhost:3333"|' -i src/Niv/GitHub.hs
sed 's|githuApiHost = "github.com"|githuApiHost = "localhost:3333"|' -i src/Niv/GitHub.hs
sed 's|githubSecure = True|githubSecure = False|' -i src/Niv/GitHub.hs
'';
});
in pkgs.runCommand "test"
{ buildInputs =
[ pkgs.haskellPackages.wai-app-static
nivForTest
niv
pkgs.nix
pkgs.jq
pkgs.netcat-gnu
@ -40,6 +39,11 @@ in pkgs.runCommand "test"
''
set -euo pipefail
export GITHUB_HOST="localhost:3333"
export GITHUB_API_HOST="localhost"
export GITHUB_API_PORT="3333"
export GITHUB_INSECURE="true"
echo *** Starting the webserver...
mkdir -p mock
@ -63,15 +67,18 @@ in pkgs.runCommand "test"
mkdir -p mock/repos/nmattia/niv/
cp ${./data/repos/nmattia/niv/repository.json} mock/repos/nmattia/niv/index.html
mkdir -p mock/repos/nmattia/niv/commits
cat ${./data/repos/nmattia/niv/commits.json} | jq -j '.[0] | .sha' > mock/repos/nmattia/niv/commits/master
# XXX: cat so we don't inherit the read-only permissions
cat ${./data/repos/nmattia/niv/commits.json} > mock/repos/nmattia/niv/commits
mkdir -p mock/nmattia/niv/archive
cp ${./data/archives + "/${niv_HEAD}.tar.gz"} \
mock/nmattia/niv/archive/${niv_HEAD}.tar.gz
mkdir -p mock/repos/NixOS/nixpkgs-channels
cp ${./data/repos/NixOS/nixpkgs-channels/repository.json} mock/repos/NixOS/nixpkgs-channels/index.html
cat ${./data/repos/NixOS/nixpkgs-channels/commits.json} > mock/repos/NixOS/nixpkgs-channels/commits
mkdir -p mock/repos/NixOS/nixpkgs-channels/commits
cat ${./data/repos/NixOS/nixpkgs-channels/commits.json} | jq -j '.[0] | .sha' > mock/repos/NixOS/nixpkgs-channels/commits/nixos-19.03
mkdir -p mock/NixOS/nixpkgs-channels/archive
cp ${./data/archives + "/${nixpkgs-channels_HEAD}.tar.gz"} \
mock/NixOS/nixpkgs-channels/archive/${nixpkgs-channels_HEAD}.tar.gz
@ -97,8 +104,8 @@ in pkgs.runCommand "test"
echo -e "\n*** niv add nmattia/niv"
# We use the HEAD~1 commit to update it in the next step
# (e.g. we drop the first element of the commit array)
cat ${./data/repos/nmattia/niv/commits.json} | jq 'del(.[0])' > mock/repos/nmattia/niv/commits
# (i.e. we use the second element of the commit array)
cat ${./data/repos/nmattia/niv/commits.json} | jq -j '.[1] | .sha' > mock/repos/nmattia/niv/commits/master
cp ${./data/archives + "/${niv_HEAD-}.tar.gz"} \
mock/nmattia/niv/archive/${niv_HEAD-}.tar.gz
niv add nmattia/niv
@ -111,7 +118,7 @@ in pkgs.runCommand "test"
## - nixpkgs-channels points to HEAD
echo -e "\n*** niv update niv"
cat ${./data/repos/nmattia/niv/commits.json} | jq '.[0] | [.]' > mock/repos/nmattia/niv/commits
cat ${./data/repos/nmattia/niv/commits.json} | jq -j '.[0] | .sha' > mock/repos/nmattia/niv/commits/master
niv update niv
echo -n "niv.rev == ${niv_HEAD} (HEAD): "
cat nix/sources.json | jq -e '.niv | .rev == "${niv_HEAD}"'