diff --git a/package.yaml b/package.yaml index 9a6bd79..aa9e610 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index df519ef..72d43fc 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -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 diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs index 80b75fe..439e2ff 100644 --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -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 - niv add - -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///archive/.tar.gz" + (if githubSecure then "https://" else "http://") <> + githubHost <> githubPath <> "//archive/.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 + niv add + +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 + +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 diff --git a/src/Niv/Logger.hs b/src/Niv/Logger.hs index 9cd283e..5199ba4 100644 --- a/src/Niv/Logger.hs +++ b/src/Niv/Logger.hs @@ -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)) diff --git a/tests/default.nix b/tests/default.nix index d76d7b9..6defc1c 100644 --- a/tests/default.nix +++ b/tests/default.nix @@ -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}"'