Use custom GitHub client

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

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

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
+-- | The GitHub update function
-  { 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, ")" ]
-
 -- 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 =
+githubLatestRev owner repo branch = do
-    executeRequest (
+    request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&>
-      GH.commitsWithOptionsForR (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
+          HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"
-      [GH.CommitQuerySha branch]
+    resp <- HTTP.httpBS request
-      ) >>= \case
+    case HTTP.getResponseStatusCode resp of
-        Right (toList -> (commit:_)) -> do
+      200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp
-          let GH.N rev = GH.commitSha commit
+      _ -> abortCouldNotGetRev owner repo branch resp
-          pure $ rev
+
-        Right (toList -> []) -> do
+abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a
-          error "No rev: no commits"
+abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [ line1, line2, line3 ]
-        Left e -> error $ "No rev: " <> show e
+  where
-        _ -> error $ "No rev: impossible"
+    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

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))

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 's|githubHost = "github.com"|githubHost = "localhost:3333"|' -i src/Niv/GitHub.hs
-      sed "/import System.Environment (lookupEnv)/d" -i src/Niv/GitHub.hs
+      sed 's|githuApiHost = "github.com"|githuApiHost = "localhost:3333"|' -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|githubSecure = True|githubSecure = False|' -i src/Niv/GitHub.hs
-      sed "s|https://github.com|http://localhost:3333|" -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)
+    # (i.e. we use the second element of the commit array)
-    cat ${./data/repos/nmattia/niv/commits.json} | jq 'del(.[0])' > mock/repos/nmattia/niv/commits
+    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}"'