diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,7 @@ +Copyright 2019 Nicolas Mattia + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,312 @@ +# niv + +[![CircleCI](https://circleci.com/gh/nmattia/niv.svg?style=svg)](https://circleci.com/gh/nmattia/niv) +[![Netlify Status](https://api.netlify.com/api/v1/badges/48532eaa-259f-4ca2-aadf-67f7c6b957fd/deploy-status)](https://niv.nmattia.com) + +Painless dependencies for [Nix] projects. Read more in the [Getting started](#getting-started) section below. + +

+ +

+ +## Install + +``` bash +$ nix-env -iA niv -f https://github.com/nmattia/niv/tarball/master +``` + +## Build + +Inside the provided nix shell: + +``` bash +$ repl +``` + +Run the test suite with this command: + +``` bash +$ ./script/test +``` + +## Usage + +`niv` simplifies [adding](#add) and [updating](#update) dependencies in Nix +projects. It uses a single file, `nix/sources.json`, where it stores the data +necessary for fetching and updating the packages. + +* [Add](#add): inserts a package in `nix/sources.json`. +* [Update](#update): updates one or all packages in `nix/sources.json`. +* [Drop](#drop): deletes a package from `nix/sources.json`. + +`niv` has two more utility functions: + +* [Init](#init): bootstraps a Nix project, in particular creates a + `nix/sources.json` file containing `niv` and `nixpkgs` as well as a + `nix/sources.nix` file that returns the sources as a Nix object. +* [Show](#show): shows the packages' information. + +The next two sections cover [common use cases](#getting-started) and [full command +description](#commands). + +### Getting started + +This section covers common use cases: + +* [Bootstrapping a Nix project](#bootstrapping-a-nix-project). +* [Tracking a different nixpkgs branch](#tracking-a-nixpkgs-branch). +* [Importing packages from GitHub](#importing-packages-from-github). +* [Fetching packages from custom URLs](#using-custom-urls). + +#### Bootstrapping a Nix project + +Use the `init` command when starting a new Nix project or when porting an +existing Nix project to niv: + +``` shell +$ niv init +... +$ tree +. +└── nix +    ├── sources.json +    └── sources.nix + +1 directory, 2 files +``` + +The file `nix/sources.json` is the file used by niv to store versions and is +initialized with niv and nixpkgs: + +``` json +{ + "nixpkgs": { + "url": "https://github.com/NixOS/nixpkgs-channels/archive/109a28ab954a0ad129f7621d468f829981b8b96c.tar.gz", + "owner": "NixOS", + "branch": "nixos-18.09", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "nixpkgs-channels", + "sha256": "12wnxla7ld4cgpdndaipdh3j4zdalifk287ihxhnmrzrghjahs3q", + "description": "Nixpkgs/NixOS branches that track the Nixpkgs/NixOS channels", + "rev": "109a28ab954a0ad129f7621d468f829981b8b96c" + }, + "niv": { + "homepage": "https://github.com/nmattia/niv", + "url": "https://github.com/nmattia/niv/archive/72e77204544527279e8f1e2d982d29503482b8f4.tar.gz", + "owner": "nmattia", + "branch": "master", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "niv", + "sha256": "1zjcyzxhq9iwxh58j5d7sx1vz5s3r1f6gpmnfgj2a3rxmclwvn3c", + "description": "Easy dependency management for Nix projects", + "rev": "72e77204544527279e8f1e2d982d29503482b8f4" + } +} +``` + +To use those dependencies `import` the file `nix/sources.nix`, e.g.: + +``` nix +{ sources ? import ./sources.nix }: # import the sources +with + { overlay = _: pkgs: + { niv = import sources.niv {}; # use the sources :) + }; + }; +import sources.nixpkgs # and use them again! + { overlays = [ overlay ] ; config = {}; } +``` + +#### 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 +update it: + +``` shell +$ niv update nixpkgs +``` + +To change the branch being tracked run this command: + +``` shell +$ niv update nixpkgs -b nixos-19.03 # equivalent to --branch nixos-19.03 +``` + +#### Importing packages from GitHub + +The `add` command will infer information about the package being added, when +possible. This works very well for GitHub repositories. Run this command to add +[jq] to your project: + + +``` shell +$ niv add stedolan/jq +``` + +The following data was added in `nix/sources.json` for `jq`: + +``` json +{ + "homepage": "http://stedolan.github.io/jq/", + "url": "https://github.com/stedolan/jq/archive/9fa2e51099c55af56e3e541dc4b399f11de74abe.tar.gz", + "owner": "stedolan", + "branch": "master", + "url_template": "https://github.com///archive/.tar.gz", + "repo": "jq", + "sha256": "0819rvk8057qgcqvgn7fpldvly2pfdw9fxcjrlqa8gr59p8a1cic", + "description": "Command-line JSON processor", + "rev": "9fa2e51099c55af56e3e541dc4b399f11de74abe" +} +``` + +#### Using custom URLs + +It is possible to use niv to fetch packages from custom URLs. Run this command +to add the Haskell compiler [GHC] to your `nix/sources.json`: + +``` shell +$ niv add ghc \ + -v 8.4.3 \ + -t 'https://downloads.haskell.org/~ghc//ghc--i386-deb8-linux.tar.xz' +``` + +The option `-v` sets the "version" attribute to `8.4.3`. The option `-t` sets a +template that can be reused by niv when fetching a new URL (see the +documentation for [add](#add) and [update](#update)). + +For updating the version of GHC used run this command: + +``` shell +$ niv update ghc -v 8.6.2 +``` + +### Commands + +``` +NIV - Version manager for Nix projects + +Usage: niv COMMAND + +Available options: + -h,--help Show this help text + +Available commands: + init Initialize a Nix project. Existing files won't be + modified. + add Add dependency + show + update Update dependencies + modify Modify dependency + drop Drop dependency + +``` + +#### Add + +``` +Examples: + + niv add stedolan/jq + niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09 + 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] | + [-b|--branch BRANCH] | [-o|--owner OWNER] | [-r|--repo REPO] | + [-v|--version VERSION] | [-t|--template URL] | [-T|--type TYPE]) + Add dependency + +Available options: + -n,--name NAME Set the package name to + -a,--attribute KEY=VAL Set the package spec attribute to + -b,--branch BRANCH Equivalent to --attribute branch= + -o,--owner OWNER Equivalent to --attribute owner= + -r,--repo REPO Equivalent to --attribute repo= + -v,--version VERSION Equivalent to --attribute version= + -t,--template URL Used during 'update' when building URL. Occurrences + of are replaced with attribute 'foo'. + -T,--type TYPE The type of the URL target. The value can be either + 'file' or 'tarball'. If not set, the value is + inferred from the suffix of the URL. + -h,--help Show this help text + +``` + +#### Update + +``` +Examples: + + niv update + niv update nixpkgs + niv update my-package -v beta-0.2 + +Usage: niv update [PACKAGE] ([-a|--attribute KEY=VAL] | [-b|--branch BRANCH] | + [-o|--owner OWNER] | [-r|--repo REPO] | [-v|--version VERSION] + | [-t|--template URL] | [-T|--type TYPE]) + Update dependencies + +Available options: + -a,--attribute KEY=VAL Set the package spec attribute to + -b,--branch BRANCH Equivalent to --attribute branch= + -o,--owner OWNER Equivalent to --attribute owner= + -r,--repo REPO Equivalent to --attribute repo= + -v,--version VERSION Equivalent to --attribute version= + -t,--template URL Used during 'update' when building URL. Occurrences + of are replaced with attribute 'foo'. + -T,--type TYPE The type of the URL target. The value can be either + 'file' or 'tarball'. If not set, the value is + inferred from the suffix of the URL. + -h,--help Show this help text + +``` + +#### Drop + +``` +Examples: + + niv drop jq + niv drop my-package version + +Usage: niv drop PACKAGE [ATTRIBUTE] + Drop dependency + +Available options: + -h,--help Show this help text + +``` + +#### Init + +``` +Usage: niv init + Initialize a Nix project. Existing files won't be modified. + +Available options: + -h,--help Show this help text + +``` + +#### show + +``` +Usage: niv show + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Niv.hs b/app/Niv.hs new file mode 100644 --- /dev/null +++ b/app/Niv.hs @@ -0,0 +1,6 @@ +module Niv where + +import Niv.Cli + +main :: IO () +main = Niv.Cli.cli diff --git a/app/NivTest.hs b/app/NivTest.hs new file mode 100644 --- /dev/null +++ b/app/NivTest.hs @@ -0,0 +1,6 @@ +module NivTest where + +import Niv.Test + +main :: IO () +main = Niv.Test.test diff --git a/niv.cabal b/niv.cabal new file mode 100644 --- /dev/null +++ b/niv.cabal @@ -0,0 +1,117 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6f5b84916f782273e667d406893e0bfc85ce6d315fc6941b94dd68e760b11196 + +name: niv +version: 0.1.0 +synopsis: Easy dependency management for Nix projects +description: Easy dependency management for Nix projects. +category: Development +homepage: https://github.com/deckgo/wai-lambda#readme +bug-reports: https://github.com/deckgo/wai-lambda/issues +author: Nicolas Mattia +maintainer: Nicolas Mattia +copyright: (c) 2019 Nicolas Mattia +license: MIT +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/deckgo/wai-lambda + +library + exposed-modules: + Niv.Cli + Niv.GitHub + Niv.GitHub.Test + Niv.Test + Niv.Update + Niv.Update.Test + other-modules: + Paths_niv + hs-source-dirs: + src + ghc-options: -Wall -optP-Wno-nonportable-include-path + build-depends: + aeson + , aeson-pretty + , base <5 + , bytestring + , directory + , file-embed + , filepath + , github + , hashable + , mtl + , optparse-applicative + , process + , string-qq + , tasty + , tasty-hunit + , text + , unliftio + , unordered-containers + default-language: Haskell2010 + +executable niv + main-is: Niv.hs + other-modules: + NivTest + Paths_niv + hs-source-dirs: + app + ghc-options: -Wall -optP-Wno-nonportable-include-path -main-is Niv.main + build-depends: + aeson + , aeson-pretty + , base <5 + , bytestring + , directory + , file-embed + , filepath + , github + , hashable + , mtl + , niv + , optparse-applicative + , process + , string-qq + , text + , unliftio + , unordered-containers + default-language: Haskell2010 + +executable niv-test + main-is: NivTest.hs + other-modules: + Niv + Paths_niv + hs-source-dirs: + app + ghc-options: -Wall -optP-Wno-nonportable-include-path -main-is NivTest.main + build-depends: + aeson + , aeson-pretty + , base <5 + , bytestring + , directory + , file-embed + , filepath + , github + , hashable + , mtl + , niv + , optparse-applicative + , process + , string-qq + , tasty + , text + , unliftio + , unordered-containers + default-language: Haskell2010 diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Niv/Cli.hs @@ -0,0 +1,662 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Niv.Cli where + +import Control.Applicative +import Control.Monad +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=)) +import Data.Char (isSpace) +import Data.FileEmbed (embedFile) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.String.QQ (s) +import Niv.GitHub +import Niv.Update +import System.Exit (exitFailure) +import System.FilePath ((), takeDirectory) +import System.Process (readProcess) +import UnliftIO +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as AesonPretty +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Options.Applicative as Opts +import qualified Options.Applicative.Help.Pretty as Opts +import qualified System.Directory as Dir + +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" + ] + +parseCommand :: Opts.Parser (IO ()) +parseCommand = Opts.subparser ( + Opts.command "init" parseCmdInit <> + Opts.command "add" parseCmdAdd <> + Opts.command "show" parseCmdShow <> + Opts.command "update" parseCmdUpdate <> + Opts.command "modify" parseCmdModify <> + Opts.command "drop" parseCmdDrop ) + +newtype Sources = Sources + { unSources :: HMS.HashMap PackageName PackageSpec } + deriving newtype (FromJSON, ToJSON) + +getSources :: IO Sources +getSources = do + exists <- Dir.doesFileExist pathNixSourcesJson + unless exists abortSourcesDoesntExist + + warnIfOutdated + -- TODO: if doesn't exist: run niv init + putStrLn $ "Reading sources file" + decodeFileStrict pathNixSourcesJson >>= \case + Just (Aeson.Object obj) -> + fmap (Sources . mconcat) $ + forM (HMS.toList obj) $ \(k, v) -> + case v of + Aeson.Object v' -> + pure $ HMS.singleton (PackageName k) (PackageSpec v') + _ -> abortAttributeIsntAMap + Just _ -> abortSourcesIsntAMap + Nothing -> abortSourcesIsntJSON + +setSources :: Sources -> IO () +setSources sources = encodeFile pathNixSourcesJson sources + +newtype PackageName = PackageName { unPackageName :: T.Text } + deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) + +parsePackageName :: Opts.Parser PackageName +parsePackageName = PackageName <$> + Opts.argument Opts.str (Opts.metavar "PACKAGE") + +newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } + deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) + +-- | Simply discards the 'Freedom' +attrsToSpec :: Attrs -> PackageSpec +attrsToSpec = PackageSpec . fmap snd + +parsePackageSpec :: Opts.Parser PackageSpec +parsePackageSpec = + (PackageSpec . HMS.fromList . fmap fixupAttributes) <$> + many parseAttribute + where + parseAttribute :: Opts.Parser (T.Text, T.Text) + parseAttribute = + Opts.option (Opts.maybeReader parseKeyVal) + ( Opts.long "attribute" <> + Opts.short 'a' <> + Opts.metavar "KEY=VAL" <> + Opts.help "Set the package spec attribute to " + ) <|> shortcutAttributes <|> + (("url_template",) <$> Opts.strOption + ( Opts.long "template" <> + Opts.short 't' <> + Opts.metavar "URL" <> + Opts.help "Used during 'update' when building URL. Occurrences of are replaced with attribute 'foo'." + )) <|> + (("type",) <$> Opts.strOption + ( Opts.long "type" <> + Opts.short 'T' <> + Opts.metavar "TYPE" <> + Opts.help "The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL." + )) + + -- Parse "key=val" into ("key", "val") + parseKeyVal :: String -> Maybe (T.Text, T.Text) + parseKeyVal str = case span (/= '=') str of + (key, '=':val) -> Just (T.pack key, T.pack val) + _ -> Nothing + + -- Shortcuts for common attributes + shortcutAttributes :: Opts.Parser (T.Text, T.Text) + shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$> + [ "branch", "owner", "repo", "version" ] + + -- TODO: infer those shortcuts from 'Update' keys + mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text) + mkShortcutAttribute = \case + attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption + ( Opts.long (T.unpack attr) <> + Opts.short c <> + Opts.metavar (T.unpack $ T.toUpper attr) <> + Opts.help + ( T.unpack $ + "Equivalent to --attribute " <> + attr <> "=<" <> (T.toUpper attr) <> ">" + ) + ) + _ -> empty + + fixupAttributes :: (T.Text, T.Text) -> (T.Text, Aeson.Value) + fixupAttributes (k, v) = (k, Aeson.String v) + +parsePackage :: Opts.Parser (PackageName, PackageSpec) +parsePackage = (,) <$> parsePackageName <*> parsePackageSpec + +------------------------------------------------------------------------------- +-- INIT +------------------------------------------------------------------------------- + +parseCmdInit :: Opts.ParserInfo (IO ()) +parseCmdInit = Opts.info (pure cmdInit <**> Opts.helper) $ mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc + "Initialize a Nix project. Existing files won't be modified." + ] + +cmdInit :: IO () +cmdInit = 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 + where + createFile :: FilePath -> B.ByteString -> IO () + createFile path content = do + let dir = takeDirectory path + Dir.createDirectoryIfMissing True dir + putStrLn $ "Creating " <> path + B.writeFile path content + dontCreateFile :: FilePath -> IO () + dontCreateFile path = putStrLn $ "Not creating " <> path + +------------------------------------------------------------------------------- +-- ADD +------------------------------------------------------------------------------- + +parseCmdAdd :: Opts.ParserInfo (IO ()) +parseCmdAdd = + Opts.info ((cmdAdd <$> optName <*> parsePackage) <**> Opts.helper) $ + mconcat desc + where + optName :: Opts.Parser (Maybe PackageName) + optName = Opts.optional $ PackageName <$> Opts.strOption + ( Opts.long "name" <> + Opts.short 'n' <> + Opts.metavar "NAME" <> + Opts.help "Set the package name to " + ) + desc = + [ Opts.fullDesc + , Opts.progDesc "Add dependency" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv add stedolan/jq" Opts.<$$> + " niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09" 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 + + -- 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 + + let packageName' = fromMaybe packageName mPackageName + + when (HMS.member packageName' sources) $ + abortCannotAddPackageExists packageName' + + let defaultSpec' = PackageSpec $ defaultSpec + + eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec') + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + case eFinalSpec of + Left e -> abortUpdateFailed [(packageName', e)] + Right finalSpec -> do + putStrLn $ "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 + +-- TODO: nicer output +cmdShow :: IO () +cmdShow = do + putStrLn $ "Showing sources file" + + 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 + +------------------------------------------------------------------------------- +-- UPDATE +------------------------------------------------------------------------------- + +parseCmdUpdate :: Opts.ParserInfo (IO ()) +parseCmdUpdate = + Opts.info + ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $ + mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc "Update dependencies" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv update" Opts.<$$> + " niv update nixpkgs" Opts.<$$> + " niv update my-package -v beta-0.2" + ] + +specToFreeAttrs :: PackageSpec -> Attrs +specToFreeAttrs = fmap (Free,) . unPackageSpec + +specToLockedAttrs :: PackageSpec -> Attrs +specToLockedAttrs = fmap (Locked,) . unPackageSpec + +-- 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 + + eFinalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> do + fmap attrsToSpec <$> tryEvalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + Nothing -> abortCannotUpdateNoSuchPackage packageName + + case eFinalSpec of + Left e -> abortUpdateFailed [(packageName, e)] + Right finalSpec -> + setSources $ Sources $ + HMS.insert packageName finalSpec sources + + Nothing -> do + sources <- unSources <$> getSources + + esources' <- forWithKeyM sources $ + \packageName defaultSpec -> do + T.putStrLn $ "Package: " <> unPackageName packageName + fmap attrsToSpec <$> tryEvalUpdate + (specToFreeAttrs defaultSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + let (failed, sources') = partitionEithersHMS esources' + + unless (HMS.null failed) $ + abortUpdateFailed (HMS.toList failed) + + setSources $ Sources sources' + +partitionEithersHMS + :: (Eq k, Hashable k) + => HMS.HashMap k (Either a b) -> (HMS.HashMap k a, HMS.HashMap k b) +partitionEithersHMS = + flip HMS.foldlWithKey' (HMS.empty, HMS.empty) $ \(ls, rs) k -> \case + Left l -> (HMS.insert k l ls, rs) + Right r -> (ls, HMS.insert k r rs) + +------------------------------------------------------------------------------- +-- MODIFY +------------------------------------------------------------------------------- + +parseCmdModify :: Opts.ParserInfo (IO ()) +parseCmdModify = + Opts.info + ((cmdModify <$> parsePackage) <**> Opts.helper) $ + mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc "Modify dependency" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv modify nixpkgs -v beta-0.2" Opts.<$$> + " niv modify nixpkgs -a branch=nixpkgs-unstable" + ] + +cmdModify :: (PackageName, PackageSpec) -> IO () +cmdModify (packageName, cliSpec) = do + T.putStrLn $ "Modifying package: " <> unPackageName packageName + sources <- unSources <$> getSources + + finalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> pure $ attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) + Nothing -> abortCannotModifyNoSuchPackage packageName + + setSources $ Sources $ HMS.insert packageName finalSpec sources + +------------------------------------------------------------------------------- +-- DROP +------------------------------------------------------------------------------- + +parseCmdDrop :: Opts.ParserInfo (IO ()) +parseCmdDrop = + Opts.info + ((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**> + Opts.helper) $ + mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc "Drop dependency" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv drop jq" Opts.<$$> + " niv drop my-package version" + ] + parseDropAttributes :: Opts.Parser [T.Text] + parseDropAttributes = many $ + Opts.argument Opts.str (Opts.metavar "ATTRIBUTE") + +cmdDrop :: PackageName -> [T.Text] -> IO () +cmdDrop packageName = \case + [] -> do + T.putStrLn $ "Dropping package: " <> unPackageName packageName + sources <- unSources <$> getSources + + when (not $ HMS.member packageName sources) $ + abortCannotDropNoSuchPackage packageName + + setSources $ Sources $ + HMS.delete packageName sources + attrs -> do + putStrLn $ "Dropping attributes :" <> + (T.unpack (T.intercalate " " attrs)) + T.putStrLn $ "In package: " <> unPackageName packageName + sources <- unSources <$> getSources + + packageSpec <- case HMS.lookup packageName sources of + Nothing -> + abortCannotAttributesDropNoSuchPackage packageName + Just (PackageSpec packageSpec) -> pure $ PackageSpec $ + HMS.mapMaybeWithKey + (\k v -> if k `elem` attrs then Nothing else Just v) packageSpec + + setSources $ Sources $ + HMS.insert packageName packageSpec sources + +------------------------------------------------------------------------------- +-- Aux +------------------------------------------------------------------------------- + +--- Aeson + +-- | Efficiently deserialize a JSON value from a file. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- The input file's content must consist solely of a JSON document, +-- with no trailing data except for whitespace. +-- +-- This function parses immediately, but defers conversion. See +-- 'json' for details. +decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) +decodeFileStrict = fmap Aeson.decodeStrict . B.readFile + +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. +encodeFile :: (ToJSON a) => FilePath -> a -> IO () +encodeFile fp = L.writeFile fp . AesonPretty.encodePretty' config + where + config = AesonPretty.defConfig { AesonPretty.confTrailingNewline = True, AesonPretty.confCompare = compare } + +--- HashMap + +forWithKeyM + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m v2) + -> m (HMS.HashMap k v2) +forWithKeyM = flip mapWithKeyM + +forWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m ()) + -> m () +forWithKeyM_ = flip mapWithKeyM_ + +mapWithKeyM + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m v2) + -> HMS.HashMap k v1 + -> m (HMS.HashMap k v2) +mapWithKeyM f m = do + fmap mconcat $ forM (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v + +mapWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m ()) + -> HMS.HashMap k v1 + -> m () +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) = + lines <$> readProcess "nix-prefetch-url" args "" >>= + \case + (l:_) -> pure (T.pack l) + _ -> abortNixPrefetchExpectedOutput + where args = if unpack then ["--unpack", url] else [url] + +------------------------------------------------------------------------------- +-- Files and their content +------------------------------------------------------------------------------- + +-- | Checks if content is different than default and if it does /not/ contain +-- a comment line with @niv: no_update@ +shouldUpdateNixSourcesNix :: B.ByteString -> Bool +shouldUpdateNixSourcesNix content = + content /= initNixSourcesNixContent && + not (any lineForbids (B8.lines content)) + where + lineForbids :: B8.ByteString -> Bool + lineForbids str = + case B8.uncons (B8.dropWhile isSpace str) of + Just ('#',rest) -> case B8.stripPrefix "niv:" (B8.dropWhile isSpace rest) of + Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of + Just{} -> True + _ -> False + _ -> False + _ -> False + +warnIfOutdated :: IO () +warnIfOutdated = do + tryAny (B.readFile pathNixSourcesNix) >>= \case + Left e -> T.putStrLn $ T.unlines + [ "Could not read " <> T.pack pathNixSourcesNix + , "Error: " <> tshow e + ] + Right content -> + if shouldUpdateNixSourcesNix content + then + T.putStrLn $ T.unlines + [ "WARNING: " <> T.pack pathNixSourcesNix <> " is out of date." + , "Please run" + , " niv init" + , "or add the following line in the " <> T.pack pathNixSourcesNix <> " file:" + , " # niv: no_update" + ] + else pure () + +-- | @nix/sources.nix@ +pathNixSourcesNix :: FilePath +pathNixSourcesNix = "nix" "sources.nix" + +-- | Glue code between nix and sources.json +initNixSourcesNixContent :: B.ByteString +initNixSourcesNixContent = $(embedFile "nix/sources.nix") + +-- | @nix/sources.json" +pathNixSourcesJson :: FilePath +pathNixSourcesJson = "nix" "sources.json" + +-- | Empty JSON map +initNixSourcesJsonContent :: B.ByteString +initNixSourcesJsonContent = "{}" + +------------------------------------------------------------------------------- +-- Abort +------------------------------------------------------------------------------- + +abortSourcesDoesntExist :: IO a +abortSourcesDoesntExist = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The sources file does not exist! You may need to run 'niv init'. +|] + +abortSourcesIsntAMap :: IO a +abortSourcesIsntAMap = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The sources file should be a JSON map from package name to package +specification, e.g.: + { ... } +|] + +abortAttributeIsntAMap :: IO a +abortAttributeIsntAMap = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The package specifications in the sources file should be JSON maps from +attribute name to attribute value, e.g.: + { "nixpkgs": { "foo": "bar" } } +|] + +abortSourcesIsntJSON :: IO a +abortSourcesIsntJSON = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = "The sources file should be JSON." + +abortCannotAddPackageExists :: PackageName -> IO a +abortCannotAddPackageExists (PackageName n) = abort $ T.unlines + [ "Cannot add package " <> n <> "." + , "The package already exists. Use" + , " niv drop " <> n + , "and then re-add the package. Alternatively use" + , " niv update " <> n <> " --attr foo=bar" + , "to update the package's attributes." + ] + +abortCannotUpdateNoSuchPackage :: PackageName -> IO a +abortCannotUpdateNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot update package " <> n <> "." + , "The package doesn't exist. Use" + , " niv add " <> n + , "to add the package." + ] + +abortCannotModifyNoSuchPackage :: PackageName -> IO a +abortCannotModifyNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot modify package " <> n <> "." + , "The package doesn't exist. Use" + , " niv add " <> n + , "to add the package." + ] + +abortCannotDropNoSuchPackage :: PackageName -> IO a +abortCannotDropNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot drop package " <> n <> "." + , "The package doesn't exist." + ] + +abortCannotAttributesDropNoSuchPackage :: PackageName -> IO a +abortCannotAttributesDropNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot drop attributes of package " <> n <> "." + , "The package doesn't exist." + ] + +abortUpdateFailed :: [ (PackageName, SomeException) ] -> IO a +abortUpdateFailed errs = abort $ T.unlines $ + [ "One or more packages failed to update:" ] <> + map (\(PackageName pname, e) -> + pname <> ": " <> tshow e + ) errs + +abortNixPrefetchExpectedOutput :: IO a +abortNixPrefetchExpectedOutput = 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 diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Niv/GitHub.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Niv.GitHub where + +import Control.Arrow +import Data.Bool +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, ")" ] + +-- TODO: fetchers for: +-- * npm +-- * hackage +-- * docker +-- * ... ? +githubUpdate + :: (Bool -> T.Text -> IO T.Text) + -- ^ prefetch + -> (T.Text -> T.Text -> T.Text -> IO T.Text) + -- ^ latest revision + -> (T.Text -> T.Text -> IO GithubRepo) + -- ^ get repo + -> Update () () +githubUpdate prefetch latestRev ghRepo = proc () -> do + urlTemplate <- template <<< + (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -< + () + url <- update "url" -< urlTemplate + let isTar = ("tar.gz" `T.isSuffixOf`) <$> url + useOrSet "type" -< bool "file" "tarball" <$> isTar :: Box T.Text + let doUnpack = isTar + _sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url + returnA -< () + where + completeSpec :: Update () (Box T.Text) + completeSpec = proc () -> do + owner <- load "owner" -< () + repo <- load "repo" -< () + repoInfo <- run (\(a, b) -> ghRepo a b) -< (,) <$> owner <*> repo + branch <- useOrSet "branch" <<< arr (fmap $ fromMaybe "master") -< + repoDefaultBranch <$> repoInfo + _description <- useOrSet "description" -< repoDescription <$> repoInfo + _homepage <- useOrSet "homepage" -< repoHomepage <$> repoInfo + _ <- update "rev" <<< run' (\(a,b,c) -> latestRev a b c) -< + (,,) <$> owner <*> repo <*> branch + returnA -< pure githubURLTemplate + +githubURLTemplate :: T.Text +githubURLTemplate = + "https://github.com///archive/.tar.gz" + +-- | 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 = + 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" diff --git a/src/Niv/GitHub/Test.hs b/src/Niv/GitHub/Test.hs new file mode 100644 --- /dev/null +++ b/src/Niv/GitHub/Test.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} + +module Niv.GitHub.Test where + +import Control.Monad +import Niv.GitHub +import Niv.Update +import qualified Data.HashMap.Strict as HMS + +test_githubInitsProperly :: IO () +test_githubInitsProperly = do + actualState <- evalUpdate initialState $ proc () -> + githubUpdate prefetch latestRev ghRepo -< () + unless ((snd <$> actualState) == expectedState) $ + error $ "State mismatch: " <> show actualState + where + prefetch _ _ = pure "some-sha" + latestRev _ _ _ = pure "some-rev" + ghRepo _ _ = pure GithubRepo + { repoDescription = Just "some-descr" + , repoHomepage = Just "some-homepage" + , repoDefaultBranch = Just "master" + } + initialState = HMS.fromList + [ ("owner", (Free, "nmattia")) + , ("repo", (Free, "niv")) ] + expectedState = HMS.fromList + [ ("owner", "nmattia") + , ("repo", "niv") + , ("homepage", "some-homepage") + , ("description", "some-descr") + , ("branch", "master") + , ("url", "https://github.com/nmattia/niv/archive/some-rev.tar.gz") + , ("rev", "some-rev") + , ("sha256", "some-sha") + , ("type", "tarball") + , ("url_template", "https://github.com///archive/.tar.gz") + ] + +test_githubUpdates :: IO () +test_githubUpdates = do + actualState <- evalUpdate initialState $ proc () -> + githubUpdate prefetch latestRev ghRepo -< () + unless ((snd <$> actualState) == expectedState) $ + error $ "State mismatch: " <> show actualState + where + prefetch _ _ = 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") + ] + +test_githubDoesntOverrideRev :: IO () +test_githubDoesntOverrideRev = do + actualState <- evalUpdate initialState $ proc () -> + githubUpdate prefetch latestRev ghRepo -< () + unless ((snd <$> actualState) == expectedState) $ + error $ "State mismatch: " <> show actualState + where + prefetch _ _ = pure "new-sha" + latestRev _ _ _ = error "shouldn't fetch rev" + ghRepo _ _ = error "shouldn't fetch repo" + 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", (Locked, "custom-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/custom-rev.tar.gz") + , ("rev", "custom-rev") + , ("sha256", "new-sha") + , ("type", "tarball") + , ("url_template", "https://github.com///archive/.tar.gz") + ] + +-- TODO: HMS diff for test output +test_githubURLFallback :: IO () +test_githubURLFallback = do + actualState <- evalUpdate initialState $ proc () -> + githubUpdate prefetch latestRev ghRepo -< () + unless ((snd <$> actualState) == expectedState) $ + error $ "State mismatch: " <> show actualState + where + prefetch _ _ = pure "some-sha" + latestRev _ _ _ = error "shouldn't fetch rev" + ghRepo _ _ = error "shouldn't fetch repo" + initialState = HMS.fromList + [ ("url_template", (Free, "https://foo.com/.tar.gz")) + , ("baz", (Free, "tarball")) + ] + expectedState = HMS.fromList + [ ("url_template", "https://foo.com/.tar.gz") + , ("baz", "tarball") + , ("url", "https://foo.com/tarball.tar.gz") + , ("sha256", "some-sha") + , ("type", "tarball") + ] diff --git a/src/Niv/Test.hs b/src/Niv/Test.hs new file mode 100644 --- /dev/null +++ b/src/Niv/Test.hs @@ -0,0 +1,29 @@ +module Niv.Test (tests, test) where + +import Niv.GitHub.Test +import Niv.Update.Test +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as Tasty + +test :: IO () +test = Tasty.defaultMain tests + +tests :: Tasty.TestTree +tests = Tasty.testGroup "niv" + [ Tasty.testGroup "update" + [ Tasty.testCase "simply runs" simplyRuns + , Tasty.testCase "picks first" picksFirst + , Tasty.testCase "loads" loads + , Tasty.testCase "survives checks" survivesChecks + , Tasty.testCase "isn't too eager" isNotTooEager + , Tasty.testCase "dirty forces update" dirtyForcesUpdate + , Tasty.testCase "should run when no changes" shouldNotRunWhenNoChanges + , Tasty.testCase "templates expand" templatesExpand + ] + , Tasty.testGroup "github" + [ Tasty.testCase "inits properly" test_githubInitsProperly + , Tasty.testCase "updates" test_githubUpdates + , 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 new file mode 100644 --- /dev/null +++ b/src/Niv/Update.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Niv.Update where + +import Control.Applicative +import Control.Arrow +import Data.Aeson (FromJSON, ToJSON, Value) +import Data.String +import UnliftIO +import qualified Control.Category as Cat +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T + +type Attrs = HMS.HashMap T.Text (Freedom, Value) + +data Update b c where + Id :: Update a a + Compose :: (Compose b c) -> Update b c + Arr :: (b -> c) -> Update b c + First :: Update b c -> Update (b, d) (c, d) + Zero :: Update b c + Plus :: Update b c -> Update b c -> Update b c + Check :: (a -> Bool) -> Update (Box a) () + Load :: T.Text -> Update () (Box Value) + UseOrSet :: T.Text -> Update (Box Value) (Box Value) + Update :: T.Text -> Update (Box Value) (Box Value) + Run :: (a -> IO b) -> Update (Box a) (Box b) + Template :: Update (Box T.Text) (Box T.Text) + +instance ArrowZero Update where + zeroArrow = Zero + +instance ArrowPlus Update where + (<+>) = Plus + +instance Arrow Update where + arr = Arr + first = First + +instance Cat.Category Update where + id = Id + f . g = Compose (Compose' f g) + +instance Show (Update b c) where + show = \case + Id -> "Id" + Compose (Compose' f g)-> "(" <> show f <> " . " <> show g <> ")" + Arr _f -> "Arr" + First a -> "First " <> show a + Zero -> "Zero" + Plus l r -> "(" <> show l <> " + " <> show r <> ")" + Check _ch -> "Check" + Load k -> "Load " <> T.unpack k + UseOrSet k -> "UseOrSet " <> T.unpack k + Update k -> "Update " <> T.unpack k + Run _act -> "Io" + Template -> "Template" + +data Compose a c = forall b. Compose' (Update b c) (Update a b) + +-- | Run an 'Update' and return the new attributes and result. +runUpdate :: Attrs -> Update () a -> IO (Attrs, a) +runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed + where + feed = \case + UpdateReady res -> hndl res + UpdateNeedMore next -> next (()) >>= hndl + hndl = \case + UpdateSuccess f v -> (,v) <$> unboxAttrs f + UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e) + prettyFail :: UpdateFailed -> T.Text + prettyFail = \case + FailNoSuchKey k -> "Key could not be found: " <> k + FailZero -> T.unlines + [ "A dead end was reached during evaluation." + , "This is a bug. Please create a ticket:" + , " https://github.com/nmattia/niv/issues/new" + , "Thanks! I'll buy you a beer." + ] + FailCheck -> "A check failed during update" + FailTemplate tpl keys -> T.unlines + [ "Could not render template " <> tpl + , "with keys: " <> T.intercalate ", " keys + ] + +execUpdate :: Attrs -> Update () a -> IO a +execUpdate attrs a = snd <$> runUpdate attrs a + +evalUpdate :: Attrs -> Update () a -> IO Attrs +evalUpdate attrs a = fst <$> runUpdate attrs a + +tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs) +tryEvalUpdate attrs upd = tryAny (evalUpdate attrs upd) + +type JSON a = (ToJSON a, FromJSON a) + +data UpdateFailed + = FailNoSuchKey T.Text + | FailZero + | FailCheck + | FailTemplate T.Text [T.Text] + deriving Show + +data UpdateRes a b + = UpdateReady (UpdateReady b) + | UpdateNeedMore (a -> IO (UpdateReady b)) + deriving Functor + +data UpdateReady b + = UpdateSuccess BoxedAttrs b + | UpdateFailed UpdateFailed + deriving Functor + +runBox :: Box a -> IO a +runBox = boxOp + +data Box a = Box + { boxNew :: Bool + -- ^ Whether the value is new or was retrieved (or derived) from old + -- attributes + , boxOp :: IO a + } + deriving Functor + +instance Applicative Box where + pure x = Box { boxNew = False, boxOp = pure x } + f <*> v = Box + { boxNew = (||) (boxNew f) (boxNew v) + , boxOp = boxOp f <*> boxOp v + } + +instance Semigroup a => Semigroup (Box a) where + (<>) = liftA2 (<>) + +instance IsString (Box T.Text) where + fromString str = Box { boxNew = False, boxOp = pure $ T.pack str } + +type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value) + +unboxAttrs :: BoxedAttrs -> IO Attrs +unboxAttrs = traverse (\(fr, v) -> (fr,) <$> runBox v) + +boxAttrs :: Attrs -> BoxedAttrs +boxAttrs = fmap (\(fr, v) -> (fr, + case fr of + -- TODO: explain why hacky + Locked -> (pure v) { boxNew = True } -- XXX: somewhat hacky + Free -> pure v + )) + +data Freedom + = Locked + | Free + deriving (Eq, Show) + +-- | Runs an update, trying to evaluate the 'Box'es as little as possible. +-- This is a hairy piece of code, apologies ¯\_(ツ)_/¯ +-- In most cases I just picked the first implementation that compiled +runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b) +runUpdate' attrs = \case + Id -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs + Arr f -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs . f + Zero -> pure $ UpdateReady (UpdateFailed FailZero) + Plus l r -> runUpdate' attrs l >>= \case + UpdateReady (UpdateFailed{}) -> runUpdate' attrs r + UpdateReady (UpdateSuccess f v) -> pure $ UpdateReady (UpdateSuccess f v) + UpdateNeedMore next -> pure $ UpdateNeedMore $ \v -> next v >>= \case + UpdateSuccess f res -> pure $ UpdateSuccess f res + UpdateFailed {} -> runUpdate' attrs r >>= \case + UpdateReady res -> pure res + UpdateNeedMore next' -> next' v + Load k -> pure $ UpdateReady $ do + case HMS.lookup k attrs of + Just (_, v') -> UpdateSuccess attrs v' + Nothing -> UpdateFailed $ FailNoSuchKey k + First a -> do + runUpdate' attrs a >>= \case + UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e + UpdateReady (UpdateSuccess fo ba) -> pure $ UpdateNeedMore $ \gtt -> do + pure $ UpdateSuccess fo (ba, snd gtt) + UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do + next (fst gtt) >>= \case + UpdateFailed e -> pure $ UpdateFailed e + UpdateSuccess f res -> do + pure $ UpdateSuccess f (res, snd gtt) + Run act -> pure (UpdateNeedMore $ \gtt -> do + pure $ UpdateSuccess attrs $ Box (boxNew gtt) (act =<< runBox gtt)) + Check ch -> pure (UpdateNeedMore $ \gtt -> do + v <- runBox gtt + if ch v + then pure $ UpdateSuccess attrs () + else pure $ UpdateFailed FailCheck) + UseOrSet k -> pure $ case HMS.lookup k attrs of + Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v + Just (Free, v) -> UpdateReady $ UpdateSuccess attrs v + Nothing -> UpdateNeedMore $ \gtt -> do + let attrs' = HMS.singleton k (Locked, gtt) <> attrs + pure $ UpdateSuccess attrs' gtt + Update k -> pure $ case HMS.lookup k attrs of + 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 + Nothing -> UpdateNeedMore $ \gtt -> do + pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt + Compose (Compose' f g) -> runUpdate' attrs g >>= \case + UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e + UpdateReady (UpdateSuccess attrs' act) -> runUpdate' attrs' f >>= \case + UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e + UpdateReady (UpdateSuccess attrs'' act') -> pure $ UpdateReady $ UpdateSuccess attrs'' act' + UpdateNeedMore next -> UpdateReady <$> next act + UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do + next gtt >>= \case + UpdateFailed e -> pure $ UpdateFailed e + UpdateSuccess attrs' act -> runUpdate' attrs' f >>= \case + UpdateReady ready -> pure ready + UpdateNeedMore next' -> next' act + Template -> pure $ UpdateNeedMore $ \v -> do + v' <- runBox v + case renderTemplate + (\k -> + ((decodeBox $ "When rendering template " <> v') . snd) <$> + HMS.lookup k attrs) v' of + Nothing -> pure $ UpdateFailed $ FailTemplate v' (HMS.keys attrs) + Just v'' -> pure $ UpdateSuccess attrs (v'' <* v) -- carries over v's newness + +decodeBox :: FromJSON a => T.Text -> Box Value -> Box a +decodeBox msg v = v { boxOp = boxOp v >>= decodeValue msg } + +decodeValue :: FromJSON a => T.Text -> Value -> IO a +decodeValue msg v = case Aeson.fromJSON v of + Aeson.Success x -> pure x + Aeson.Error str -> + error $ T.unpack msg <> ": Could not decode: " <> show v <> ": " <> str + +-- | Renders the template. Returns 'Nothing' if some of the attributes are +-- missing. +-- renderTemplate ("foo" -> "bar") "" -> pure (Just "bar") +-- renderTemplate ("foo" -> "bar") "" -> pure Nothing +renderTemplate :: (T.Text -> Maybe (Box T.Text)) -> T.Text -> Maybe (Box T.Text) +renderTemplate vals = \case + (T.uncons -> Just ('<', str)) -> do + case T.span (/= '>') str of + (key, T.uncons -> Just ('>', rest)) -> do + let v = vals key + (liftA2 (<>) v) (renderTemplate vals rest) + _ -> Nothing + (T.uncons -> Just (c, str)) -> fmap (T.cons c) <$> renderTemplate vals str + (T.uncons -> Nothing) -> Just $ pure T.empty + -- XXX: isn't this redundant? + _ -> Just $ pure T.empty + +template :: Update (Box T.Text) (Box T.Text) +template = Template + +check :: (a -> Bool) -> Update (Box a) () +check = Check + +load :: FromJSON a => T.Text -> Update () (Box a) +load k = Load k >>> arr (decodeBox $ "When loading key " <> k) + +-- TODO: should input really be Box? +useOrSet :: JSON a => T.Text -> Update (Box a) (Box a) +useOrSet k = + arr (fmap Aeson.toJSON) >>> + UseOrSet k >>> + arr (decodeBox $ "When trying to use or set key " <> k) + +update :: JSON a => T.Text -> Update (Box a) (Box a) +update k = + arr (fmap Aeson.toJSON) >>> + Update k >>> + arr (decodeBox $ "When updating key " <> k) + +run :: (a -> IO b) -> Update (Box a) (Box b) +run = Run + +-- | Like 'run' but forces evaluation +run' :: (a -> IO b) -> Update (Box a) (Box b) +run' act = Run act >>> dirty + +dirty :: Update (Box a) (Box a) +dirty = arr (\v -> v { boxNew = True }) diff --git a/src/Niv/Update/Test.hs b/src/Niv/Update/Test.hs new file mode 100644 --- /dev/null +++ b/src/Niv/Update/Test.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Niv.Update.Test where + +import Control.Arrow +import Control.Monad +import Niv.Update +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T + +simplyRuns :: IO () +simplyRuns = + void $ runUpdate attrs $ proc () -> do + returnA -< () + where + attrs = HMS.empty + +picksFirst :: IO () +picksFirst = do + v <- execUpdate HMS.empty $ + let + l = proc () -> do returnA -< 2 + r = proc () -> do returnA -< 3 + in l <+> r + unless (v == (2::Int)) (error "bad value") + +loads :: IO () +loads = do + v <- execUpdate attrs $ load "foo" + v' <- runBox v + unless (v' == ("bar" :: T.Text)) (error "bad value") + where + attrs = HMS.singleton "foo" (Locked, "bar") + +survivesChecks :: IO () +survivesChecks = do + v <- execUpdate attrs $ proc () -> do + (sawLeft <+> sawRight) -< () + load "res" -< () + v' <- runBox v + unless (v' == ("I saw right" :: T.Text)) (error "bad value") + where + attrs = HMS.singleton "val" (Locked, "right") + sawLeft :: Update () () + sawLeft = proc () -> do + val <- load "val" -< () + check (== "left") -< (val :: Box T.Text) + useOrSet "res" -< "I saw left" :: Box T.Text + returnA -< () + sawRight :: Update () () + sawRight = proc () -> do + val <- load "val" -< () + check (== "right") -< (val :: Box T.Text) + useOrSet "res" -< "I saw right" :: Box T.Text + returnA -< () + +isNotTooEager :: IO () +isNotTooEager = do + let f = constBox () >>> + run (const $ error "IO is too eager (f)") >>> + useOrSet "foo" + let f1 = proc () -> do + run (const $ error "IO is too eager (f1)") -< pure () + useOrSet "foo" -< "foo" + void $ (execUpdate attrs f :: IO (Box T.Text)) + void $ (execUpdate attrs f1 :: IO (Box T.Text)) + where + attrs = HMS.singleton "foo" (Locked, "right") + +dirtyForcesUpdate :: IO () +dirtyForcesUpdate = do + let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello" + attrs' <- evalUpdate attrs f + unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $ + error $ "bad value for hello: " <> show attrs' + where + attrs = HMS.singleton "hello" (Free, "foo") + +shouldNotRunWhenNoChanges :: IO () +shouldNotRunWhenNoChanges = do + let f = proc () -> do + update "hello" -< ("world" :: Box T.Text) + run (\() -> error "io shouldn't be run") -< pure () + attrs <- evalUpdate HMS.empty f + unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $ + error $ "bad value for hello: " <> show attrs + let f' = proc () -> do + run (\() -> error "io shouldn't be run") -< pure () + update "hello" -< ("world" :: Box T.Text) + attrs' <- evalUpdate HMS.empty f' + unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $ + error $ "bad value for hello: " <> show attrs' + v3 <- execUpdate + (HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))]) $ + proc () -> do + v1 <- update "hello" -< "world" + v2 <- run (\_ -> error "io shouldn't be run") -< (v1 :: Box T.Text) + v3 <- update "bar" -< (v2 :: Box T.Text) + returnA -< v3 + v3' <- runBox v3 + unless (v3' == "baz") $ error "bad value" + +templatesExpand :: IO () +templatesExpand = do + v3 <- execUpdate attrs $ proc () -> template -< "-" + v3' <- runBox v3 + unless (v3' == "hello-world") $ error "bad value" + where + attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))] + +constBox :: a -> Update () (Box a) +constBox a = arr (const (pure a))