diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -46,6 +46,19 @@ `nix/sources.nix` file that returns the sources as a Nix object. * [Show](#show): shows the packages' information. +### Configuration + +The following environment variables are read by `niv`: + +| Name | Note | +| --------------- | ---- | +| GITHUB_TOKEN | When set, the value is used to authenticate GitHub API requests. | +| GITHUB_HOST | The GitHub host to use when fetching packages. Port may be appended here. | +| GITHUB_API_HOST | The host used when performing GitHub API requests. Use `GITHUB_API_PORT` for specifying the port. | +| GITHUB_API_PORT | The port used when performing GitHub API requests. Defaults to `443` for secure requests. Defaults to `80` for insecure requests. See also: `GITHUB_INSECURE`. | +| GITHUB_INSECURE | When set to anything but the empty string, requests are performed over `http` instead of `https`. | +| GITHUB_PATH | The base path used when performing GitHub API requests. | + The next two sections cover [common use cases](#getting-started) and [full command description](#commands). @@ -83,7 +96,7 @@ "nixpkgs": { "url": "https://github.com/NixOS/nixpkgs-channels/archive/109a28ab954a0ad129f7621d468f829981b8b96c.tar.gz", "owner": "NixOS", - "branch": "nixos-18.09", + "branch": "nixos-19.03", "url_template": "https://github.com///archive/.tar.gz", "repo": "nixpkgs-channels", "sha256": "12wnxla7ld4cgpdndaipdh3j4zdalifk287ihxhnmrzrghjahs3q", @@ -120,7 +133,7 @@ #### Tracking a nixpkgs branch The `init` command sets the `nix/sources.json` file to track the latest commit -present on nixpkgs 18.09 when the command was run. Run the following command to +present on nixpkgs 19.03 when the command was run. Run the following command to update it: ``` shell @@ -184,8 +197,10 @@ ### Commands ``` -NIV - Version manager for Nix projects +niv - dependency manager for Nix projects +version: 0.2.0 + Usage: niv COMMAND Available options: @@ -208,7 +223,7 @@ Examples: niv add stedolan/jq - niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09 + niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-19.03 niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip Usage: niv add [-n|--name NAME] PACKAGE ([-a|--attribute KEY=VAL] | @@ -291,22 +306,13 @@ #### show ``` -Usage: niv show +Usage: niv show [PACKAGE] Available options: -h,--help Show this help text ``` -## Related - -* [nix-flakes]: `niv` support a subset of the Nix flakes. In particular it does - not perform any kind of dependency resolution. -* [nix-path]: `niv` and `nix-path` share a similar goal and ideas tend to flow - back and forth freely. - [Nix]: https://nixos.org/nix/ [jq]: https://stedolan.github.io/jq/ [GHC]: https://www.haskell.org/ghc/ -[nix-flakes]: https://gist.github.com/edolstra/40da6e3a4d4ee8fd019395365e0772e7 -[nix-path]: https://github.com/zimbatm/nix-path diff --git a/niv.cabal b/niv.cabal --- a/niv.cabal +++ b/niv.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: bc48d4df56815a9a35980c932de97fa26843e0c9b65427e799c5973263e0771a +-- hash: 79bc5a116ffbf43a58aab2bed0b2381ff3620a4fe61ed5245b237e9d4253b0d1 name: niv -version: 0.1.1 +version: 0.2.0 synopsis: Easy dependency management for Nix projects description: Easy dependency management for Nix projects. category: Development @@ -17,9 +19,10 @@ license: MIT license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 extra-source-files: README.md +data-files: + nix/sources.nix source-repository head type: git @@ -30,6 +33,7 @@ Niv.Cli Niv.GitHub Niv.GitHub.Test + Niv.Logger Niv.Test Niv.Update Niv.Update.Test @@ -41,16 +45,18 @@ build-depends: aeson , aeson-pretty + , ansi-terminal , base <5 , bytestring , directory , file-embed , filepath - , github , hashable + , http-conduit , mtl , optparse-applicative , process + , profunctors , string-qq , tasty , tasty-hunit @@ -70,17 +76,19 @@ build-depends: aeson , aeson-pretty + , ansi-terminal , base <5 , bytestring , directory , file-embed , filepath - , github , hashable + , http-conduit , mtl , niv , optparse-applicative , process + , profunctors , string-qq , text , unliftio @@ -98,17 +106,19 @@ build-depends: aeson , aeson-pretty + , ansi-terminal , base <5 , bytestring , directory , file-embed , filepath - , github , hashable + , http-conduit , mtl , niv , optparse-applicative , process + , profunctors , string-qq , tasty , text diff --git a/nix/sources.nix b/nix/sources.nix new file mode 100644 --- /dev/null +++ b/nix/sources.nix @@ -0,0 +1,89 @@ +# This file has been generated by Niv. + +# A record, from name to path, of the third-party packages +with rec +{ + pkgs = + if hasNixpkgsPath + then + if hasThisAsNixpkgsPath + then import (builtins_fetchTarball { inherit (sources_nixpkgs) url sha256; }) {} + else import {} + else + import (builtins_fetchTarball { inherit (sources_nixpkgs) url sha256; }) {}; + + sources_nixpkgs = + if builtins.hasAttr "nixpkgs" sources + then sources.nixpkgs + else abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = + { url, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball { inherit url; } + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = + { url, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl { inherit url; } + else + fetchurl attrs; + + # A wrapper around pkgs.fetchzip that has inspectable arguments, + # annoyingly this means we have to specify them + fetchzip = { url, sha256 }@attrs: pkgs.fetchzip attrs; + + hasNixpkgsPath = (builtins.tryEval ).success; + hasThisAsNixpkgsPath = + (builtins.tryEval ).success && == ./.; + + sources = builtins.fromJSON (builtins.readFile ./sources.json); + + mapAttrs = builtins.mapAttrs or + (f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))); + + # borrowed from nixpkgs + functionArgs = f: f.__functionArgs or (builtins.functionArgs f); + callFunctionWith = autoArgs: f: args: + let auto = builtins.intersectAttrs (functionArgs f) autoArgs; + in f (auto // args); + + getFetcher = spec: + let fetcherName = + if builtins.hasAttr "type" spec + then builtins.getAttr "type" spec + else "builtin-tarball"; + in builtins.getAttr fetcherName { + "tarball" = fetchzip; + "builtin-tarball" = builtins_fetchTarball; + "file" = pkgs.fetchurl; + "builtin-url" = builtins_fetchurl; + }; +}; +# NOTE: spec must _not_ have an "outPath" attribute +mapAttrs (_: spec: + if builtins.hasAttr "outPath" spec + then abort + "The values in sources.json should not have an 'outPath' attribute" + else + if builtins.hasAttr "url" spec && builtins.hasAttr "sha256" spec + then + spec // + { outPath = callFunctionWith spec (getFetcher spec) { }; } + else spec + ) sources diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -17,12 +17,14 @@ import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) import Data.String.QQ (s) +import Niv.Logger import Niv.GitHub import Niv.Update -import System.Exit (exitFailure) +import System.Exit (ExitCode(ExitSuccess)) import System.FilePath ((), takeDirectory) -import System.Process (readProcess) +import System.Process (readProcessWithExitCode) import UnliftIO +import Data.Version (showVersion) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as AesonPretty import qualified Data.ByteString as B @@ -35,13 +37,19 @@ import qualified Options.Applicative.Help.Pretty as Opts import qualified System.Directory as Dir +-- I died a little +import Paths_niv (version) + cli :: IO () cli = join $ Opts.execParser opts where opts = Opts.info (parseCommand <**> Opts.helper) $ mconcat desc desc = [ Opts.fullDesc - , Opts.header "NIV - Version manager for Nix projects" + , Opts.headerDoc $ Just $ + "niv - dependency manager for Nix projects" Opts.<$$> + "" Opts.<$$> + "version:" Opts.<+> Opts.text (showVersion version) ] parseCommand :: Opts.Parser (IO ()) @@ -64,7 +72,7 @@ warnIfOutdated -- TODO: if doesn't exist: run niv init - putStrLn $ "Reading sources file" + say $ "Reading sources file" decodeFileStrict pathNixSourcesJson >>= \case Just (Aeson.Object obj) -> fmap (Sources . mconcat) $ @@ -166,43 +174,44 @@ cmdInit :: IO () cmdInit = do + job "Initializing" $ do - -- Writes all the default files - -- a path, a "create" function and an update function for each file. - forM_ - [ ( pathNixSourcesNix - , (`createFile` initNixSourcesNixContent) - , \path content -> do - if shouldUpdateNixSourcesNix content - then do - putStrLn "Updating sources.nix" - B.writeFile path initNixSourcesNixContent - else putStrLn "Not updating sources.nix" - ) - , ( pathNixSourcesJson - , \path -> do - createFile path initNixSourcesJsonContent - -- Imports @niv@ and @nixpkgs@ (18.09) - putStrLn "Importing 'niv' ..." - cmdAdd Nothing (PackageName "nmattia/niv", PackageSpec HMS.empty) - putStrLn "Importing 'nixpkgs' ..." - cmdAdd - (Just (PackageName "nixpkgs")) - ( PackageName "NixOS/nixpkgs-channels" - , PackageSpec (HMS.singleton "branch" "nixos-18.09")) - , \path _content -> dontCreateFile path) - ] $ \(path, onCreate, onUpdate) -> do - exists <- Dir.doesFileExist path - if exists then B.readFile path >>= onUpdate path else onCreate path + -- Writes all the default files + -- a path, a "create" function and an update function for each file. + forM_ + [ ( pathNixSourcesNix + , (`createFile` initNixSourcesNixContent) + , \path content -> do + if shouldUpdateNixSourcesNix content + then do + say "Updating sources.nix" + B.writeFile path initNixSourcesNixContent + else say "Not updating sources.nix" + ) + , ( pathNixSourcesJson + , \path -> do + createFile path initNixSourcesJsonContent + -- Imports @niv@ and @nixpkgs@ (19.03) + say "Importing 'niv' ..." + cmdAdd Nothing (PackageName "nmattia/niv", PackageSpec HMS.empty) + say "Importing 'nixpkgs' ..." + cmdAdd + (Just (PackageName "nixpkgs")) + ( PackageName "NixOS/nixpkgs-channels" + , PackageSpec (HMS.singleton "branch" "nixos-19.03")) + , \path _content -> dontCreateFile path) + ] $ \(path, onCreate, onUpdate) -> do + exists <- Dir.doesFileExist path + if exists then B.readFile path >>= onUpdate path else onCreate path where createFile :: FilePath -> B.ByteString -> IO () createFile path content = do let dir = takeDirectory path Dir.createDirectoryIfMissing True dir - putStrLn $ "Creating " <> path + say $ "Creating " <> path B.writeFile path content dontCreateFile :: FilePath -> IO () - dontCreateFile path = putStrLn $ "Not creating " <> path + dontCreateFile path = say $ "Not creating " <> path ------------------------------------------------------------------------------- -- ADD @@ -227,62 +236,83 @@ "Examples:" Opts.<$$> "" Opts.<$$> " niv add stedolan/jq" Opts.<$$> - " niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09" Opts.<$$> + " niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-19.03" Opts.<$$> " niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip" ] cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO () -cmdAdd mPackageName (PackageName str, cliSpec) = do +cmdAdd mPackageName (PackageName str, cliSpec) = + job ("Adding package " <> T.unpack str) $ do - -- Figures out the owner and repo - let (packageName, defaultSpec) = case T.span (/= '/') str of - ( owner@(T.null -> False) - , T.uncons -> Just ('/', repo@(T.null -> False))) -> do - (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ]) - _ -> (PackageName str, HMS.empty) + -- Figures out the owner and repo + let (packageName, defaultSpec) = case T.span (/= '/') str of + ( owner@(T.null -> False) + , T.uncons -> Just ('/', repo@(T.null -> False))) -> do + (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ]) + _ -> (PackageName str, HMS.empty) - sources <- unSources <$> getSources + sources <- unSources <$> getSources - let packageName' = fromMaybe packageName mPackageName + let packageName' = fromMaybe packageName mPackageName - when (HMS.member packageName' sources) $ - abortCannotAddPackageExists packageName' + when (HMS.member packageName' sources) $ + abortCannotAddPackageExists packageName' - let defaultSpec' = PackageSpec $ defaultSpec + let defaultSpec' = PackageSpec $ defaultSpec - eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate - (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec') - (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + let initialSpec = specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec' - case eFinalSpec of - Left e -> abortUpdateFailed [(packageName', e)] - Right finalSpec -> do - putStrLn $ "Writing new sources file" - setSources $ Sources $ - HMS.insert packageName' finalSpec sources + eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate + initialSpec + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + case eFinalSpec of + Left e -> abortUpdateFailed [(packageName', e)] + Right finalSpec -> do + say $ "Writing new sources file" + setSources $ Sources $ + HMS.insert packageName' finalSpec sources + ------------------------------------------------------------------------------- -- SHOW ------------------------------------------------------------------------------- parseCmdShow :: Opts.ParserInfo (IO ()) -parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc +parseCmdShow = + Opts.info + ((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper) + Opts.fullDesc -- TODO: nicer output -cmdShow :: IO () -cmdShow = do - putStrLn $ "Showing sources file" +cmdShow :: Maybe PackageName -> IO () +cmdShow = \case + Just packageName -> do + tsay $ "Showing package " <> unPackageName packageName - sources <- unSources <$> getSources + sources <- unSources <$> getSources - forWithKeyM_ sources $ \key (PackageSpec spec) -> do - T.putStrLn $ "Package: " <> unPackageName key - forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do - let attrValue = case attrValValue of - Aeson.String str -> str - _ -> "" - putStrLn $ " " <> T.unpack attrName <> ": " <> T.unpack attrValue + case HMS.lookup packageName sources of + Just (PackageSpec spec) -> do + forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do + let attrValue = case attrValValue of + Aeson.String str -> str + _ -> "" + tsay $ " " <> attrName <> ": " <> attrValue + Nothing -> abortCannotShowNoSuchPackage packageName + Nothing -> do + say $ "Showing sources file" + + sources <- unSources <$> getSources + + forWithKeyM_ sources $ \key (PackageSpec spec) -> do + tsay $ "Updating " <> tbold (unPackageName key) + forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do + let attrValue = case attrValValue of + Aeson.String str -> str + _ -> tfaint "" + tsay $ " " <> attrName <> ": " <> attrValue + ------------------------------------------------------------------------------- -- UPDATE ------------------------------------------------------------------------------- @@ -313,33 +343,35 @@ -- TODO: sexy logging + concurrent updates cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO () cmdUpdate = \case - Just (packageName, cliSpec) -> do - T.putStrLn $ "Updating single package: " <> unPackageName packageName - sources <- unSources <$> getSources + Just (packageName, cliSpec) -> + job ("Update " <> T.unpack (unPackageName packageName)) $ do + sources <- unSources <$> getSources - eFinalSpec <- case HMS.lookup packageName sources of - Just defaultSpec -> do - fmap attrsToSpec <$> tryEvalUpdate - (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) - (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + eFinalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> do + fmap attrsToSpec <$> tryEvalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) - Nothing -> abortCannotUpdateNoSuchPackage packageName + Nothing -> abortCannotUpdateNoSuchPackage packageName - case eFinalSpec of - Left e -> abortUpdateFailed [(packageName, e)] - Right finalSpec -> - setSources $ Sources $ - HMS.insert packageName finalSpec sources + case eFinalSpec of + Left e -> abortUpdateFailed [(packageName, e)] + Right finalSpec -> + setSources $ Sources $ + HMS.insert packageName finalSpec sources - Nothing -> do + Nothing -> job "Updating all packages" $ do sources <- unSources <$> getSources esources' <- forWithKeyM sources $ \packageName defaultSpec -> do - T.putStrLn $ "Package: " <> unPackageName packageName - fmap attrsToSpec <$> tryEvalUpdate - (specToFreeAttrs defaultSpec) + tsay $ "Package: " <> unPackageName packageName + let initialSpec = specToFreeAttrs defaultSpec + finalSpec <- fmap attrsToSpec <$> tryEvalUpdate + initialSpec (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + pure finalSpec let (failed, sources') = partitionEithersHMS esources' @@ -378,7 +410,7 @@ cmdModify :: (PackageName, PackageSpec) -> IO () cmdModify (packageName, cliSpec) = do - T.putStrLn $ "Modifying package: " <> unPackageName packageName + tsay $ "Modifying package: " <> unPackageName packageName sources <- unSources <$> getSources finalSpec <- case HMS.lookup packageName sources of @@ -414,7 +446,7 @@ cmdDrop :: PackageName -> [T.Text] -> IO () cmdDrop packageName = \case [] -> do - T.putStrLn $ "Dropping package: " <> unPackageName packageName + tsay $ "Dropping package: " <> unPackageName packageName sources <- unSources <$> getSources when (not $ HMS.member packageName sources) $ @@ -423,9 +455,8 @@ setSources $ Sources $ HMS.delete packageName sources attrs -> do - putStrLn $ "Dropping attributes :" <> - (T.unpack (T.intercalate " " attrs)) - T.putStrLn $ "In package: " <> unPackageName packageName + tsay $ "Dropping attributes :" <> T.intercalate " " attrs + tsay $ "In package: " <> unPackageName packageName sources <- unSources <$> getSources packageSpec <- case HMS.lookup packageName sources of @@ -496,18 +527,15 @@ 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) = - lines <$> readProcess "nix-prefetch-url" args "" >>= - \case - (l:_) -> pure (T.pack l) - _ -> abortNixPrefetchExpectedOutput - where args = if unpack then ["--unpack", url] else [url] +nixPrefetchURL unpack (T.unpack -> url) = do + (exitCode, sout, serr) <- runNixPrefetch + case (exitCode, lines sout) of + (ExitSuccess, l:_) -> pure $ T.pack l + _ -> abortNixPrefetchExpectedOutput (T.pack sout) (T.pack serr) + where + args = if unpack then ["--unpack", url] else [url] + runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" ------------------------------------------------------------------------------- -- Files and their content @@ -609,7 +637,7 @@ , "The package already exists. Use" , " niv drop " <> n , "and then re-add the package. Alternatively use" - , " niv update " <> n <> " --attr foo=bar" + , " niv update " <> n <> " --attribute foo=bar" , "to update the package's attributes." ] @@ -635,6 +663,12 @@ , "The package doesn't exist." ] +abortCannotShowNoSuchPackage :: PackageName -> IO a +abortCannotShowNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot show package " <> n <> "." + , "The package doesn't exist." + ] + abortCannotAttributesDropNoSuchPackage :: PackageName -> IO a abortCannotAttributesDropNoSuchPackage (PackageName n) = abort $ T.unlines [ "Cannot drop attributes of package " <> n <> "." @@ -648,15 +682,12 @@ pname <> ": " <> tshow e ) errs -abortNixPrefetchExpectedOutput :: IO a -abortNixPrefetchExpectedOutput = abort [s| +abortNixPrefetchExpectedOutput :: T.Text -> T.Text -> IO a +abortNixPrefetchExpectedOutput sout serr = abort $ [s| Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a ticket: https://github.com/nmattia/niv/issues/new Thanks! I'll buy you a beer. -|] - -tshow :: Show a => a -> T.Text -tshow = T.pack . show +|] <> T.unlines ["stdout: ", sout, "stderr: ", serr] diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Arrows #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,64 +10,23 @@ 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.Text as T -import qualified GitHub as GH -import qualified GitHub.Data.Name as GH import System.Environment (lookupEnv) - -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 = executeRequest >>= 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 - resolveRequestExecutionFn = do - token <- fmap (GH.OAuth . encodeUtf8 . T.pack) <$> lookupEnv "GITHUB_TOKEN" - return $ maybe GH.executeRequest' GH.executeRequest token - executeRequest :: IO (Either GH.Error GH.Repo) - executeRequest = resolveRequestExecutionFn >>= \fn -> fn (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, ")" ] +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: -- * npm -- * hackage @@ -106,8 +66,79 @@ 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] + -- 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 @@ -118,15 +149,69 @@ -> T.Text -- ^ branch -> IO T.Text -githubLatestRev owner repo branch = - GH.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 + +|] + +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/Test.hs b/src/Niv/GitHub/Test.hs --- a/src/Niv/GitHub/Test.hs +++ b/src/Niv/GitHub/Test.hs @@ -1,9 +1,12 @@ {-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Niv.GitHub.Test where import Control.Monad +import Data.IORef +import Data.Bifunctor import Niv.GitHub import Niv.Update import qualified Data.HashMap.Strict as HMS @@ -133,4 +136,58 @@ , ("url", "https://foo.com/tarball.tar.gz") , ("sha256", "some-sha") , ("type", "tarball") + ] + +test_githubUpdatesOnce :: IO () +test_githubUpdatesOnce = do + ioref <- newIORef False + tmpState <- evalUpdate initialState $ proc () -> + githubUpdate (prefetch ioref) latestRev ghRepo -< () + + unless ((snd <$> tmpState) == expectedState) $ + error $ "State mismatch: " <> show tmpState + + -- Set everything free + let tmpState' = HMS.map (first (\_ -> Free)) tmpState + actualState <- evalUpdate tmpState' $ proc () -> + githubUpdate (prefetch ioref) latestRev ghRepo -< () + + unless ((snd <$> actualState) == expectedState) $ + error $ "State mismatch: " <> show actualState + where + prefetch ioref _ _ = do + readIORef ioref >>= \case + False -> pure () + True -> error "Prefetch should be called once!" + writeIORef ioref True + pure "new-sha" + latestRev _ _ _ = pure "new-rev" + ghRepo _ _ = pure GithubRepo + { repoDescription = Just "some-descr" + , repoHomepage = Just "some-homepage" + , repoDefaultBranch = Just "master" + } + initialState = HMS.fromList + [ ("owner", (Free, "nmattia")) + , ("repo", (Free, "niv")) + , ("homepage", (Free, "some-homepage")) + , ("description", (Free, "some-descr")) + , ("branch", (Free, "master")) + , ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz")) + , ("rev", (Free, "some-rev")) + , ("sha256", (Free, "some-sha")) + , ("type", (Free, "tarball")) + , ("url_template", (Free, "https://github.com///archive/.tar.gz")) + ] + expectedState = HMS.fromList + [ ("owner", "nmattia") + , ("repo", "niv") + , ("homepage", "some-homepage") + , ("description", "some-descr") + , ("branch", "master") + , ("url", "https://github.com/nmattia/niv/archive/new-rev.tar.gz") + , ("rev", "new-rev") + , ("sha256", "new-sha") + , ("type", "tarball") + , ("url_template", "https://github.com///archive/.tar.gz") ] diff --git a/src/Niv/Logger.hs b/src/Niv/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Niv/Logger.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +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 +import qualified System.Console.ANSI as ANSI + +-- XXX: this assumes as single thread +job :: String -> IO () -> IO () +job str act = do + say (bold str) + indent + tryAny act <* deindent >>= \case + Right () -> say $ green "Done" <> ": " <> str + 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)) + +jobStackSize :: IO Int +jobStackSize = readIORef jobStack + +jobStack :: IORef Int +jobStack = unsafePerformIO $ newIORef 0 +{-# NOINLINE jobStackSize #-} + +tsay :: T.Text -> IO () +tsay = say . T.unpack + +say :: String -> IO () +say msg = do + stackSize <- jobStackSize + let indent = replicate (stackSize * 2) ' ' + putStrLn $ indent <> msg + +green :: String -> String +green str = + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] <> + str <> ANSI.setSGRCode [ANSI.Reset] + +red :: String -> String +red str = + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] <> + str <> ANSI.setSGRCode [ANSI.Reset] + +tbold :: T.Text -> T.Text +tbold = dimap T.unpack T.pack bold + +bold :: String -> String +bold str = + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <> + str <> ANSI.setSGRCode [ANSI.Reset] + +tfaint :: T.Text -> T.Text +tfaint = dimap T.unpack T.pack faint + +faint :: String -> String +faint str = + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity] <> + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <> + str <> ANSI.setSGRCode [ANSI.Reset] diff --git a/src/Niv/Test.hs b/src/Niv/Test.hs --- a/src/Niv/Test.hs +++ b/src/Niv/Test.hs @@ -23,6 +23,7 @@ , Tasty.testGroup "github" [ Tasty.testCase "inits properly" test_githubInitsProperly , Tasty.testCase "updates" test_githubUpdates + , Tasty.testCase "updates once" test_githubUpdatesOnce , Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev , Tasty.testCase "falls back to URL" test_githubURLFallback ] diff --git a/src/Niv/Update.hs b/src/Niv/Update.hs --- a/src/Niv/Update.hs +++ b/src/Niv/Update.hs @@ -209,8 +209,17 @@ Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v Just (Free, v) -> UpdateNeedMore $ \gtt -> do if (boxNew gtt) - then pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt - else pure $ UpdateSuccess attrs v + then do + v' <- boxOp v + gtt' <- boxOp gtt + -- Here we compare the old and new values, flagging the new one as + -- "boxNew" iff they differ. + -- TODO: generalize this to all boxes + let gtt'' = if v' /= gtt' then gtt { boxNew = True, boxOp = pure gtt' } + else gtt { boxNew = False, boxOp = pure gtt' } + pure $ UpdateSuccess (HMS.insert k (Locked, gtt'') attrs) gtt'' + else do + pure $ UpdateSuccess attrs v Nothing -> UpdateNeedMore $ \gtt -> do pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt Compose (Compose' f g) -> runUpdate' attrs g >>= \case