diff --git a/default.nix b/default.nix index 4c607e6..63b1edc 100644 --- a/default.nix +++ b/default.nix @@ -31,6 +31,7 @@ with rec "^src/Data/Aeson$" "^src/Data/HashMap$" "^src/Data/HashMap/Strict$" + "^src/Data/Text$" "^src/Niv$" "^src/Niv/GitHub$" "^src/Niv/Sources$" diff --git a/src/Data/Text/Extended.hs b/src/Data/Text/Extended.hs new file mode 100644 index 0000000..e0dd27e --- /dev/null +++ b/src/Data/Text/Extended.hs @@ -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 diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index 2b66a69..3bac9c5 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -18,8 +18,10 @@ import Data.Functor import Data.HashMap.Strict.Extended import Data.Hashable (Hashable) import Data.String.QQ (s) +import Data.Text.Extended import Data.Version (showVersion) import Niv.GitHub +import Niv.GitHub.API import Niv.Logger import Niv.Sources import Niv.Update diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs index 53a2be5..a9d57c7 100644 --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -3,28 +3,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} module Niv.GitHub where import Control.Arrow import Data.Bool -import Data.Functor import Data.Maybe -import Data.String.QQ (s) +import Niv.GitHub.API 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.Encoding as T -import qualified Data.Text.IO as T -import qualified Network.HTTP.Simple as HTTP -- | The GitHub update function -- TODO: fetchers for: @@ -68,150 +56,3 @@ githubURLTemplate :: T.Text githubURLTemplate = (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] - -- 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 - niv add - -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 - -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 diff --git a/src/Niv/GitHub/API.hs b/src/Niv/GitHub/API.hs new file mode 100644 index 0000000..e5bbe55 --- /dev/null +++ b/src/Niv/GitHub/API.hs @@ -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 + niv add + +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 + +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 "/" diff --git a/src/Niv/GitHub/Test.hs b/src/Niv/GitHub/Test.hs index b80d124..9ee3aee 100644 --- a/src/Niv/GitHub/Test.hs +++ b/src/Niv/GitHub/Test.hs @@ -8,6 +8,7 @@ import Control.Monad import Data.IORef import Data.Bifunctor import Niv.GitHub +import Niv.GitHub.API import Niv.Update import qualified Data.HashMap.Strict as HMS diff --git a/src/Niv/Sources.hs b/src/Niv/Sources.hs index 0e2732b..8605721 100644 --- a/src/Niv/Sources.hs +++ b/src/Niv/Sources.hs @@ -13,7 +13,7 @@ import Data.Bifunctor (first) import Data.Hashable (Hashable) import Data.List import Data.String.QQ (s) -import Niv.GitHub +import Data.Text.Extended import Niv.Logger import Niv.Update import System.FilePath (())