niv 0.1.1 → 0.2.0
raw patch · 9 files changed
+562/−197 lines, 9 filesdep +ansi-terminaldep +http-conduitdep +profunctorsdep −github
Dependencies added: ansi-terminal, http-conduit, profunctors
Dependencies removed: github
Files
- README.md +20/−14
- niv.cabal +17/−7
- nix/sources.nix +89/−0
- src/Niv/Cli.hs +139/−108
- src/Niv/GitHub.hs +151/−66
- src/Niv/GitHub/Test.hs +57/−0
- src/Niv/Logger.hs +77/−0
- src/Niv/Test.hs +1/−0
- src/Niv/Update.hs +11/−2
README.md view
@@ -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/<owner>/<repo>/archive/<rev>.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/<version>.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
niv.cabal view
@@ -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
+ nix/sources.nix view
@@ -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 <nixpkgs> {}+ else+ import (builtins_fetchTarball { inherit (sources_nixpkgs) url sha256; }) {};++ sources_nixpkgs =+ if builtins.hasAttr "nixpkgs" sources+ then sources.nixpkgs+ else abort+ ''+ Please specify either <nixpkgs> (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 <nixpkgs>).success;+ hasThisAsNixpkgsPath =+ (builtins.tryEval <nixpkgs>).success && <nixpkgs> == ./.;++ 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
src/Niv/Cli.hs view
@@ -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/<version>.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- _ -> "<barabajagal>"- 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+ _ -> "<barabajagal>"+ 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 "<barabajagal>"+ 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]
src/Niv/GitHub.hs view
@@ -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 <package>- niv add <package-without-typo>--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/<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]+ -- 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 <package>+ niv add <package-without-typo>++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 <cmd>++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
src/Niv/GitHub/Test.hs view
@@ -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/<owner>/<repo>/archive/<rev>.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/<owner>/<repo>/archive/<rev>.tar.gz") ]
+ src/Niv/Logger.hs view
@@ -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]
src/Niv/Test.hs view
@@ -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 ]
src/Niv/Update.hs view
@@ -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