niv 0.2.14 → 0.2.15
raw patch · 21 files changed
+1620/−1296 lines, 21 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Niv.Sources: V19 :: SourcesNixVersion
+ Niv.Update: mkBox :: Box a -> IO (Box a)
+ Niv.Update: singleton :: MVar (Maybe a) -> IO a -> IO a
- Niv.Update: boxAttrs :: Attrs -> BoxedAttrs
+ Niv.Update: boxAttrs :: Attrs -> IO BoxedAttrs
Files
- README.md +54/−5
- niv.cabal +2/−2
- nix/sources.nix +11/−1
- src/Data/Aeson/Extended.hs +5/−4
- src/Data/HashMap/Strict/Extended.hs +25/−26
- src/Data/Text/Extended.hs +4/−4
- src/Niv/Cli.hs +389/−351
- src/Niv/Cmd.hs +10/−9
- src/Niv/Git/Cmd.hs +131/−107
- src/Niv/Git/Test.hs +107/−41
- src/Niv/GitHub.hs +30/−25
- src/Niv/GitHub/API.hs +92/−86
- src/Niv/GitHub/Cmd.hs +116/−93
- src/Niv/GitHub/Test.hs +165/−145
- src/Niv/Local/Cmd.hs +31/−28
- src/Niv/Logger.hs +70/−54
- src/Niv/Sources.hs +130/−111
- src/Niv/Sources/Test.hs +4/−4
- src/Niv/Test.hs +28/−23
- src/Niv/Update.hs +156/−123
- src/Niv/Update/Test.hs +60/−54
README.md view
@@ -17,11 +17,15 @@ ## Install -`niv` is available in [`nixpkgs`](https://github.com/NixOS/nixpkgs) on the-`master` branch as `niv`. It is also available on the `release-19.09` branch as-`haskellPackages.niv`. Otherwise, run:+`niv` is available in [`nixpkgs`](https://github.com/NixOS/nixpkgs) as `niv`: ``` bash+$ nix-env -iA nixpkgs.niv+```++Alternatively, run the following command to install the development version:++``` bash $ nix-env -iA niv -f https://github.com/nmattia/niv/tarball/master \ --substituters https://niv.cachix.org \ --trusted-public-keys niv.cachix.org-1:X32PCg2e/zAm3/uD1ScqW2z/K0LtDyNV7RdaxIuLgQM=@@ -212,7 +216,7 @@ ``` niv - dependency manager for Nix projects -version: 0.2.14+version: 0.2.15 Usage: niv [-s|--sources-file FILE] COMMAND @@ -379,8 +383,13 @@ ## Frequently Asked Questions -### Can you use private GitHub repositories?+* [Can I use private GitHub repositories?](#can-i-use-private-github-repositories)+* [How do I import a subpath of a source?](#how-do-i-import-a-subpath-of-a-source)+* [How do I import NixOS modules](#how-do-i-import-nixos-modules)+* [Can I use local packages?](#can-i-use-local-packages) +### Can I use private GitHub repositories?+ Yes. There are two ways: #### 1. Use the git protocol@@ -413,3 +422,43 @@ GITHUB_TOKEN=$YOUR_GITHUB_TOKEN niv add ... ``` +### How do I import a subpath of a source?++In order to use the directory `dir` of a `my-package`, use the following+pattern:++``` nix+let+ sources = import ./nix/sources.nix;+in sources.my-package + "/dir"+```++in this example, `sources.my-package` becomes `my-package`'s root directory, and `+ "/dir"` appends the+subdirectory.++### How do I import NixOS modules?++After the package containing the modules has been `niv add`ed, importing the+modules is straightforward:++``` nix+let+ sources = import ./nix/sources.nix;+in {+ imports = [ (sources.package + "/path/to/module") ];+}+```++### Can I use local packages?++If you need to use a local path as a source -- especially convenient when+modifying dependencies -- `niv` allows you to override the `sources.json` via+environment variables. To override a source `foo` with a local path+`./bar/baz`, set the environment variable `NIV_OVERRIDE_foo` to `./bar/baz`.++Generally, if the environment variable `NIV_OVERRIDE_<name>` is set _and_ you+have a source named `<name>` then `niv` will use the value of+`NIV_OVERRIDE_<name>` as the `outPath` of that source. All non-alphanumeric+characters in the source name are escaped to the character `_`; i.e. to+override the package `my package-foo` you need to set the environment variable+`NIV_OVERRIDE_my_package_foo`.
niv.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7f73602ea1ac16df6a54a599572573246b2d3260596b88111bc2971a028ac645+-- hash: 3d09896b8d2ffd774ff226e8260109ca00a5d8145dff676cbb30074895ef1579 name: niv-version: 0.2.14+version: 0.2.15 synopsis: Easy dependency management for Nix projects description: Easy dependency management for Nix projects. category: Development
nix/sources.nix view
@@ -73,6 +73,15 @@ else abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + # If the environment variable NIV_OVERRIDE_${name} is set, then use+ # the path directly as opposed to the fetched source.+ replace = name: drv:+ let+ saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;+ ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";+ in+ if ersatz == "" then drv else ersatz;+ # Ports of functions for older nix versions # a Nix version of mapAttrs if the built-in doesn't exist@@ -119,7 +128,7 @@ then abort "The values in sources.json should not have an 'outPath' attribute" else- spec // { outPath = fetch config.pkgs name spec; }+ spec // { outPath = replace name (fetch config.pkgs name spec); } ) config.sources; # The "config" used by the fetchers@@ -134,5 +143,6 @@ # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers inherit pkgs; };+ in mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }
src/Data/Aeson/Extended.hs view
@@ -11,7 +11,8 @@ encodeFilePretty :: (ToJSON a) => FilePath -> a -> IO () encodeFilePretty fp = BL.writeFile fp . AesonPretty.encodePretty' config where- config = AesonPretty.defConfig {- AesonPretty.confTrailingNewline = True,- AesonPretty.confCompare = compare- }+ config =+ AesonPretty.defConfig+ { AesonPretty.confTrailingNewline = True,+ AesonPretty.confCompare = compare+ }
src/Data/HashMap/Strict/Extended.hs view
@@ -1,40 +1,39 @@- module Data.HashMap.Strict.Extended where import Control.Monad-import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HMS+import Data.Hashable (Hashable) --- HashMap -forWithKeyM- :: (Eq k, Hashable k, Monad m)- => HMS.HashMap k v1- -> (k -> v1 -> m v2)- -> m (HMS.HashMap k v2)+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_ ::+ (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 ::+ (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+ 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_ ::+ (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+ forM_ (HMS.toList m) $ \(k, v) ->+ HMS.singleton k <$> f k v
src/Data/Text/Extended.hs view
@@ -2,10 +2,10 @@ module Data.Text.Extended where +import qualified Data.Text as T import Niv.Logger-import UnliftIO import System.Exit (exitFailure)-import qualified Data.Text as T+import UnliftIO tshow :: Show a => a -> T.Text tshow = T.pack . show@@ -13,5 +13,5 @@ -- not quite the perfect place for this abort :: MonadIO io => T.Text -> io a abort msg = do- tsay $ T.unwords [ tbold $ tred "FATAL:", msg ]- liftIO exitFailure+ tsay $ T.unwords [tbold $ tred "FATAL:", msg]+ liftIO exitFailure
src/Niv/Cli.hs view
@@ -12,34 +12,33 @@ import Control.Monad import Control.Monad.Reader import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8 import Data.Char (isSpace)+import qualified Data.HashMap.Strict as HMS import Data.HashMap.Strict.Extended import Data.Hashable (Hashable)+import qualified Data.Text as T import Data.Text.Extended import Data.Version (showVersion) import Niv.Cmd import Niv.Git.Cmd-import Niv.Local.Cmd import Niv.GitHub.Cmd+import Niv.Local.Cmd import Niv.Logger import Niv.Sources import Niv.Update-import System.Environment (getArgs)-import System.FilePath (takeDirectory)-import UnliftIO-import qualified Data.Aeson as Aeson-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as B8-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts-import qualified System.Directory as Dir- -- I died a little import Paths_niv (version)+import qualified System.Directory as Dir+import System.Environment (getArgs)+import System.FilePath (takeDirectory)+import UnliftIO -newtype NIO a = NIO { runNIO :: ReaderT FindSourcesJson IO a }+newtype NIO a = NIO {runNIO :: ReaderT FindSourcesJson IO a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader FindSourcesJson) instance MonadUnliftIO NIO where@@ -53,42 +52,48 @@ cli :: IO () cli = do- (fsj, nio) <- execParserPure' Opts.defaultPrefs opts <$> getArgs+ (fsj, nio) <-+ execParserPure' Opts.defaultPrefs opts <$> getArgs >>= Opts.handleParseResult- runReaderT (runNIO nio) fsj+ runReaderT (runNIO nio) fsj where- execParserPure' pprefs pinfo [] = Opts.Failure $- Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty+ execParserPure' pprefs pinfo [] =+ Opts.Failure $+ Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty execParserPure' pprefs pinfo args = Opts.execParserPure pprefs pinfo args opts = Opts.info ((,) <$> parseFindSourcesJson <*> (parseCommand <**> Opts.helper)) $ mconcat desc desc =- [ Opts.fullDesc- , Opts.headerDoc $ Just $- "niv - dependency manager for Nix projects" Opts.<$$>- "" Opts.<$$>- "version:" Opts.<+> Opts.text (showVersion version)+ [ Opts.fullDesc,+ Opts.headerDoc $ Just $+ "niv - dependency manager for Nix projects"+ Opts.<$$> ""+ Opts.<$$> "version:" Opts.<+> Opts.text (showVersion version) ] parseFindSourcesJson =- AtPath <$> Opts.strOption (- Opts.long "sources-file" <>- Opts.short 's' <>- Opts.metavar "FILE" <>- Opts.help "Use FILE instead of nix/sources.json"- ) <|> pure Auto-+ AtPath+ <$> Opts.strOption+ ( Opts.long "sources-file"+ <> Opts.short 's'+ <> Opts.metavar "FILE"+ <> Opts.help "Use FILE instead of nix/sources.json"+ )+ <|> pure Auto parseCommand :: Opts.Parser (NIO ())-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 )+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+ ) parsePackageName :: Opts.Parser PackageName-parsePackageName = PackageName <$>- Opts.argument Opts.str (Opts.metavar "PACKAGE")+parsePackageName =+ PackageName+ <$> Opts.argument Opts.str (Opts.metavar "PACKAGE") parsePackage :: Opts.Parser (PackageName, PackageSpec) parsePackage = (,) <$> parsePackageName <*> (parsePackageSpec githubCmd)@@ -120,95 +125,105 @@ [owner, reponame] -> Just (Nixpkgs owner reponame) _ -> Nothing parseNixpkgs =- Opts.flag' NoNixpkgs- (- Opts.long "no-nixpkgs" <>- Opts.help "Don't add a nixpkgs entry to sources.json."- ) <|>- (YesNixpkgs <$>- (Opts.strOption- (- Opts.long "nixpkgs-branch" <>- Opts.short 'b' <>- Opts.help "The nixpkgs branch to use." <>- Opts.showDefault <>- Opts.value defaultNixpkgsBranch+ Opts.flag'+ NoNixpkgs+ ( Opts.long "no-nixpkgs"+ <> Opts.help "Don't add a nixpkgs entry to sources.json." )- ) <*> Opts.option customNixpkgsReader- (- Opts.long "nixpkgs" <>- Opts.showDefault <>- Opts.help "Use a custom nixpkgs repository from GitHub." <>- Opts.metavar "OWNER/REPO" <>- Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo)- ))+ <|> ( YesNixpkgs+ <$> ( Opts.strOption+ ( Opts.long "nixpkgs-branch"+ <> Opts.short 'b'+ <> Opts.help "The nixpkgs branch to use."+ <> Opts.showDefault+ <> Opts.value defaultNixpkgsBranch+ )+ )+ <*> Opts.option+ customNixpkgsReader+ ( Opts.long "nixpkgs"+ <> Opts.showDefault+ <> Opts.help "Use a custom nixpkgs repository from GitHub."+ <> Opts.metavar "OWNER/REPO"+ <> Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo)+ )+ ) desc =- [ Opts.fullDesc- , Opts.progDesc+ [ Opts.fullDesc,+ Opts.progDesc "Initialize a Nix project. Existing files won't be modified." ] cmdInit :: FetchNixpkgs -> NIO () cmdInit nixpkgs = do- job "Initializing" $ do- fsj <- getFindSourcesJson-- -- 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+ job "Initializing" $ do+ fsj <- getFindSourcesJson+ -- 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" li $ B.writeFile path initNixSourcesNixContent else say "Not updating sources.nix"- )- , ( pathNixSourcesJson fsj- , \path -> do- createFile path initNixSourcesJsonContent- -- Imports @niv@ and @nixpkgs@- say "Importing 'niv' ..."- cmdAdd (updateCmd githubCmd) (PackageName "niv")- (specToFreeAttrs $ PackageSpec $ HMS.fromList- [ "owner" .= ("nmattia" :: T.Text)- , "repo" .= ("niv" :: T.Text)- ]- )- case nixpkgs of- NoNixpkgs -> say "Not importing 'nixpkgs'."- YesNixpkgs branch nixpkgs' -> do- say "Importing 'nixpkgs' ..."- let (owner, repo) = case nixpkgs' of- Nixpkgs o r -> (o,r)- cmdAdd (updateCmd githubCmd) (PackageName "nixpkgs")- (specToFreeAttrs $ PackageSpec $ HMS.fromList- [ "owner" .= owner- , "repo" .= repo- , "branch" .= branch- ]- )- , \path _content -> dontCreateFile path)- ] $ \(path, onCreate, onUpdate) -> do- exists <- li $ Dir.doesFileExist path- if exists then li (B.readFile path) >>= onUpdate path else onCreate path- case fsj of- Auto -> pure ()- AtPath fp ->- tsay $ T.unlines+ ),+ ( pathNixSourcesJson fsj,+ \path -> do+ createFile path initNixSourcesJsonContent+ -- Imports @niv@ and @nixpkgs@+ say "Importing 'niv' ..."+ cmdAdd+ (updateCmd githubCmd)+ (PackageName "niv")+ ( specToFreeAttrs $ PackageSpec $+ HMS.fromList+ [ "owner" .= ("nmattia" :: T.Text),+ "repo" .= ("niv" :: T.Text)+ ]+ )+ case nixpkgs of+ NoNixpkgs -> say "Not importing 'nixpkgs'."+ YesNixpkgs branch nixpkgs' -> do+ say "Importing 'nixpkgs' ..."+ let (owner, repo) = case nixpkgs' of+ Nixpkgs o r -> (o, r)+ cmdAdd+ (updateCmd githubCmd)+ (PackageName "nixpkgs")+ ( specToFreeAttrs $ PackageSpec $+ HMS.fromList+ [ "owner" .= owner,+ "repo" .= repo,+ "branch" .= branch+ ]+ ),+ \path _content -> dontCreateFile path+ )+ ]+ $ \(path, onCreate, onUpdate) -> do+ exists <- li $ Dir.doesFileExist path+ if exists then li (B.readFile path) >>= onUpdate path else onCreate path+ case fsj of+ Auto -> pure ()+ AtPath fp ->+ tsay $+ T.unlines [ T.unwords- [ tbold $ tblue "INFO:"- , "You are using a custom path for sources.json."- ]- , " You need to configure the sources.nix to use " <> tbold (T.pack fp) <> ":"- , tbold " import sources.nix { sourcesFile = PATH ; }; "- , T.unwords- [ " where", tbold "PATH", "is the relative path from sources.nix to"- , tbold (T.pack fp) <> "." ]+ [ tbold $ tblue "INFO:",+ "You are using a custom path for sources.json."+ ],+ " You need to configure the sources.nix to use " <> tbold (T.pack fp) <> ":",+ tbold " import sources.nix { sourcesFile = PATH ; }; ",+ T.unwords+ [ " where",+ tbold "PATH",+ "is the relative path from sources.nix to",+ tbold (T.pack fp) <> "."+ ] ]-- where createFile :: FilePath -> B.ByteString -> NIO () createFile path content = li $ do@@ -225,9 +240,9 @@ parseCmdAdd :: Opts.ParserInfo (NIO ()) parseCmdAdd =- Opts.info- ((parseCommands <|> parseShortcuts) <**> Opts.helper) $- (description githubCmd)+ Opts.info+ ((parseCommands <|> parseShortcuts) <**> Opts.helper)+ $ (description githubCmd) where -- XXX: this should parse many shortcuts (github, git). Right now we only -- parse GitHub because the git interface is still experimental. note to@@ -242,12 +257,13 @@ Opts.info (parseCmd localCmd <**> Opts.helper) (description localCmd) parseCmdAddGitHub = Opts.info (parseCmd githubCmd <**> Opts.helper) (description githubCmd)- parseCommands = Opts.subparser- ( Opts.hidden <>- Opts.commandGroup "Experimental commands:" <>- Opts.command "git" parseCmdAddGit <>- Opts.command "github" parseCmdAddGitHub <>- Opts.command "local" parseCmdAddLocal+ parseCommands =+ Opts.subparser+ ( Opts.hidden+ <> Opts.commandGroup "Experimental commands:"+ <> Opts.command "git" parseCmdAddGit+ <> Opts.command "github" parseCmdAddGitHub+ <> Opts.command "local" parseCmdAddLocal ) -- | only used in shortcuts (niv add foo/bar ...) because PACKAGE is NOT@@ -261,17 +277,20 @@ ((_, spec), Just pname') -> (pname', PackageSpec spec) ((pname', spec), Nothing) -> (pname', PackageSpec spec) parseNameAndShortcut =- (,) <$>- Opts.argument+ (,)+ <$> Opts.argument (Opts.maybeReader (parseCmdShortcut cmd . T.pack))- (Opts.metavar "PACKAGE") <*>- optName- optName = Opts.optional $ PackageName <$> Opts.strOption- ( Opts.long "name" <>- Opts.short 'n' <>- Opts.metavar "NAME" <>- Opts.help "Set the package name to <NAME>"- )+ (Opts.metavar "PACKAGE")+ <*> optName+ optName =+ Opts.optional $+ PackageName+ <$> Opts.strOption+ ( Opts.long "name"+ <> Opts.short 'n'+ <> Opts.metavar "NAME"+ <> Opts.help "Set the package name to <NAME>"+ ) -- | only used in command (niv add <cmd> ...) because PACKAGE is optional parseCmdArgs :: Cmd -> Opts.Parser (PackageName, Attrs)@@ -285,35 +304,38 @@ (Nothing, Just pname') -> (pname', PackageSpec HMS.empty) (Nothing, Nothing) -> (PackageName "unnamed", PackageSpec HMS.empty) parseNameAndShortcut =- (,) <$>- Opts.optional (Opts.argument- (Opts.maybeReader (parseCmdShortcut cmd . T.pack))- (Opts.metavar "PACKAGE")) <*>- optName- optName = Opts.optional $ PackageName <$> Opts.strOption- ( Opts.long "name" <>- Opts.short 'n' <>- Opts.metavar "NAME" <>- Opts.help "Set the package name to <NAME>"- )+ (,)+ <$> Opts.optional+ ( Opts.argument+ (Opts.maybeReader (parseCmdShortcut cmd . T.pack))+ (Opts.metavar "PACKAGE")+ )+ <*> optName+ optName =+ Opts.optional $+ PackageName+ <$> Opts.strOption+ ( Opts.long "name"+ <> Opts.short 'n'+ <> Opts.metavar "NAME"+ <> Opts.help "Set the package name to <NAME>"+ ) cmdAdd :: Update () a -> PackageName -> Attrs -> NIO () cmdAdd updateFunc packageName attrs = do- job ("Adding package " <> T.unpack (unPackageName packageName)) $ do- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- when (HMS.member packageName sources) $- li $ abortCannotAddPackageExists packageName-- eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc)-- case eFinalSpec of- Left e -> li (abortUpdateFailed [(packageName, e)])- Right finalSpec -> do- say $ "Writing new sources file"- li $ setSources fsj $ Sources $- HMS.insert packageName finalSpec sources+ job ("Adding package " <> T.unpack (unPackageName packageName)) $ do+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ when (HMS.member packageName sources)+ $ li+ $ abortCannotAddPackageExists packageName+ eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc)+ case eFinalSpec of+ Left e -> li (abortUpdateFailed [(packageName, e)])+ Right finalSpec -> do+ say $ "Writing new sources file"+ li $ setSources fsj $ Sources $+ HMS.insert packageName finalSpec sources ------------------------------------------------------------------------------- -- SHOW@@ -321,34 +343,32 @@ parseCmdShow :: Opts.ParserInfo (NIO ()) parseCmdShow =- Opts.info- ((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper)- Opts.fullDesc+ Opts.info+ ((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper)+ Opts.fullDesc -- TODO: nicer output cmdShow :: Maybe PackageName -> NIO () cmdShow = \case- Just packageName -> do- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- case HMS.lookup packageName sources of- Just pspec -> showPackage packageName pspec- Nothing -> li $ abortCannotShowNoSuchPackage packageName-- Nothing -> do- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)- forWithKeyM_ sources $ showPackage+ Just packageName -> do+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ case HMS.lookup packageName sources of+ Just pspec -> showPackage packageName pspec+ Nothing -> li $ abortCannotShowNoSuchPackage packageName+ Nothing -> do+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ forWithKeyM_ sources $ showPackage showPackage :: MonadIO io => PackageName -> PackageSpec -> io () showPackage (PackageName pname) (PackageSpec spec) = do- tsay $ tbold pname- forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do- let attrValue = case attrValValue of- Aeson.String str -> str- _ -> tfaint "<barabajagal>"- tsay $ " " <> attrName <> ": " <> attrValue+ tsay $ tbold pname+ forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do+ let attrValue = case attrValValue of+ Aeson.String str -> str+ _ -> tfaint "<barabajagal>"+ tsay $ " " <> attrName <> ": " <> attrValue ------------------------------------------------------------------------------- -- UPDATE@@ -356,21 +376,21 @@ parseCmdUpdate :: Opts.ParserInfo (NIO ()) parseCmdUpdate =- Opts.info- ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $- mconcat desc+ Opts.info+ ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper)+ $ mconcat desc where desc =- [ Opts.fullDesc- , Opts.progDesc "Update dependencies"- , Opts.headerDoc $ Just $ Opts.nest 2 $- "Examples:" Opts.<$$>- "" Opts.<$$>- Opts.vcat- [ Opts.fill 30 "niv update" Opts.<+> "# update all packages",- Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs",- Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\""- ]+ [ Opts.fullDesc,+ Opts.progDesc "Update dependencies",+ Opts.headerDoc $ Just $ Opts.nest 2 $+ "Examples:"+ Opts.<$$> ""+ Opts.<$$> Opts.vcat+ [ Opts.fill 30 "niv update" Opts.<+> "# update all packages",+ Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs",+ Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\""+ ] ] specToFreeAttrs :: PackageSpec -> Attrs@@ -381,64 +401,65 @@ cmdUpdate :: Maybe (PackageName, PackageSpec) -> NIO () cmdUpdate = \case- Just (packageName, cliSpec) ->- job ("Update " <> T.unpack (unPackageName packageName)) $ do- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- eFinalSpec <- case HMS.lookup packageName sources of- Just defaultSpec -> do- -- lookup the "type" to find a Cmd to run, defaulting to legacy- -- github- let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of- Just "git" -> gitCmd- Just "local" -> localCmd- _ -> githubCmd- fmap attrsToSpec <$> li (tryEvalUpdate- (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)- (updateCmd cmd))-- Nothing -> li $ abortCannotUpdateNoSuchPackage packageName-- case eFinalSpec of- Left e -> li $ abortUpdateFailed [(packageName, e)]- Right finalSpec ->- li $ setSources fsj $ Sources $- HMS.insert packageName finalSpec sources-- Nothing -> job "Updating all packages" $ do+ Just (packageName, cliSpec) ->+ job ("Update " <> T.unpack (unPackageName packageName)) $ do fsj <- getFindSourcesJson sources <- unSources <$> li (getSources fsj)-- esources' <- forWithKeyM sources $- \packageName defaultSpec -> do- tsay $ "Package: " <> unPackageName packageName- let initialSpec = specToFreeAttrs defaultSpec+ eFinalSpec <- case HMS.lookup packageName sources of+ Just defaultSpec -> do -- lookup the "type" to find a Cmd to run, defaulting to legacy -- github let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of Just "git" -> gitCmd Just "local" -> localCmd _ -> githubCmd- finalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate- initialSpec- (updateCmd cmd))- pure finalSpec-- let (failed, sources') = partitionEithersHMS esources'-- unless (HMS.null failed) $- li $ abortUpdateFailed (HMS.toList failed)-- li $ setSources fsj $ Sources sources'+ fmap attrsToSpec+ <$> li+ ( tryEvalUpdate+ (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)+ (updateCmd cmd)+ )+ Nothing -> li $ abortCannotUpdateNoSuchPackage packageName+ case eFinalSpec of+ Left e -> li $ abortUpdateFailed [(packageName, e)]+ Right finalSpec ->+ li $ setSources fsj $ Sources $+ HMS.insert packageName finalSpec sources+ Nothing -> job "Updating all packages" $ do+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ esources' <- forWithKeyM sources $+ \packageName defaultSpec -> do+ tsay $ "Package: " <> unPackageName packageName+ let initialSpec = specToFreeAttrs defaultSpec+ -- lookup the "type" to find a Cmd to run, defaulting to legacy+ -- github+ let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of+ Just "git" -> gitCmd+ Just "local" -> localCmd+ _ -> githubCmd+ finalSpec <-+ fmap attrsToSpec+ <$> li+ ( tryEvalUpdate+ initialSpec+ (updateCmd cmd)+ )+ pure finalSpec+ let (failed, sources') = partitionEithersHMS esources'+ unless (HMS.null failed)+ $ li+ $ abortUpdateFailed (HMS.toList failed)+ li $ setSources fsj $ Sources sources' -partitionEithersHMS- :: (Eq k, Hashable k)- => HMS.HashMap k (Either a b) -> (HMS.HashMap k a, HMS.HashMap k b)+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)+ 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@@ -446,43 +467,45 @@ parseCmdModify :: Opts.ParserInfo (NIO ()) parseCmdModify =- Opts.info- ((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper) $- mconcat desc+ Opts.info+ ((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper)+ $ mconcat desc where desc =- [ Opts.fullDesc- , Opts.progDesc "Modify dependency attributes without performing an update"- , Opts.headerDoc $ Just $- "Examples:" Opts.<$$>- "" Opts.<$$>- " niv modify nixpkgs -v beta-0.2" Opts.<$$>- " niv modify nixpkgs -a branch=nixpkgs-unstable"+ [ Opts.fullDesc,+ Opts.progDesc "Modify dependency attributes without performing an update",+ Opts.headerDoc $ Just $+ "Examples:"+ Opts.<$$> ""+ Opts.<$$> " niv modify nixpkgs -v beta-0.2"+ Opts.<$$> " niv modify nixpkgs -a branch=nixpkgs-unstable" ]- optName = Opts.optional $ PackageName <$> Opts.strOption- ( Opts.long "name" <>- Opts.short 'n' <>- Opts.metavar "NAME" <>- Opts.help "Set the package name to <NAME>"- )+ optName =+ Opts.optional $+ PackageName+ <$> Opts.strOption+ ( Opts.long "name"+ <> Opts.short 'n'+ <> Opts.metavar "NAME"+ <> Opts.help "Set the package name to <NAME>"+ ) cmdModify :: PackageName -> Maybe PackageName -> PackageSpec -> NIO () cmdModify packageName mNewName cliSpec = do- tsay $ "Modifying package: " <> unPackageName packageName- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- finalSpec <- case HMS.lookup packageName sources of- Just defaultSpec -> pure $ attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)- Nothing -> li $ abortCannotModifyNoSuchPackage packageName-- case mNewName of- Just newName -> do- when (HMS.member newName sources) $- li $ abortCannotAddPackageExists newName- li $ setSources fsj $ Sources $ HMS.insert newName finalSpec $ HMS.delete packageName sources- Nothing ->- li $ setSources fsj $ Sources $ HMS.insert packageName finalSpec sources+ tsay $ "Modifying package: " <> unPackageName packageName+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ finalSpec <- case HMS.lookup packageName sources of+ Just defaultSpec -> pure $ attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)+ Nothing -> li $ abortCannotModifyNoSuchPackage packageName+ case mNewName of+ Just newName -> do+ when (HMS.member newName sources)+ $ li+ $ abortCannotAddPackageExists newName+ li $ setSources fsj $ Sources $ HMS.insert newName finalSpec $ HMS.delete packageName sources+ Nothing ->+ li $ setSources fsj $ Sources $ HMS.insert packageName finalSpec sources ------------------------------------------------------------------------------- -- DROP@@ -490,51 +513,52 @@ parseCmdDrop :: Opts.ParserInfo (NIO ()) parseCmdDrop =- Opts.info- ((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**>- Opts.helper) $- mconcat desc+ 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"+ [ 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")+ parseDropAttributes =+ many $+ Opts.argument Opts.str (Opts.metavar "ATTRIBUTE") cmdDrop :: PackageName -> [T.Text] -> NIO () cmdDrop packageName = \case- [] -> do- tsay $ "Dropping package: " <> unPackageName packageName- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- when (not $ HMS.member packageName sources) $- li $ abortCannotDropNoSuchPackage packageName-- li $ setSources fsj $ Sources $- HMS.delete packageName sources- attrs -> do- tsay $ "Dropping attributes :" <> T.intercalate " " attrs- tsay $ "In package: " <> unPackageName packageName- fsj <- getFindSourcesJson- sources <- unSources <$> li (getSources fsj)-- packageSpec <- case HMS.lookup packageName sources of- Nothing ->- li $ abortCannotAttributesDropNoSuchPackage packageName- Just (PackageSpec packageSpec) -> pure $ PackageSpec $+ [] -> do+ tsay $ "Dropping package: " <> unPackageName packageName+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ when (not $ HMS.member packageName sources)+ $ li+ $ abortCannotDropNoSuchPackage packageName+ li $ setSources fsj $ Sources $+ HMS.delete packageName sources+ attrs -> do+ tsay $ "Dropping attributes: " <> T.intercalate " " attrs+ tsay $ "In package: " <> unPackageName packageName+ fsj <- getFindSourcesJson+ sources <- unSources <$> li (getSources fsj)+ packageSpec <- case HMS.lookup packageName sources of+ Nothing ->+ li $ abortCannotAttributesDropNoSuchPackage packageName+ Just (PackageSpec packageSpec) ->+ pure $ PackageSpec $ HMS.mapMaybeWithKey- (\k v -> if k `elem` attrs then Nothing else Just v) packageSpec-- li $ setSources fsj $ Sources $- HMS.insert packageName packageSpec sources+ (\k v -> if k `elem` attrs then Nothing else Just v)+ packageSpec+ li $ setSources fsj $ Sources $+ HMS.insert packageName packageSpec sources ------------------------------------------------------------------------------- -- Files and their content@@ -544,15 +568,15 @@ -- a comment line with @niv: no_update@ shouldUpdateNixSourcesNix :: B.ByteString -> Bool shouldUpdateNixSourcesNix content =- content /= initNixSourcesNixContent &&- not (any lineForbids (B8.lines 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 "niv:" (B8.dropWhile isSpace rest) of Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of- Just{} -> True+ Just {} -> True _ -> False _ -> False _ -> False@@ -562,53 +586,67 @@ ------------------------------------------------------------------------------- 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 <> " --attribute foo=bar"- , "to update the package's attributes."- ]+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 <> " --attribute 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."- ]+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."- ]+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."- ]+abortCannotDropNoSuchPackage (PackageName n) =+ abort $+ T.unlines+ [ "Cannot drop package " <> n <> ".",+ "The package doesn't exist."+ ] abortCannotShowNoSuchPackage :: PackageName -> IO a-abortCannotShowNoSuchPackage (PackageName n) = abort $ T.unlines- [ "Cannot show package " <> n <> "."- , "The package doesn't exist."- ]+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 <> "."- , "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+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
src/Niv/Cmd.hs view
@@ -2,17 +2,18 @@ module Niv.Cmd where -import Niv.Sources-import Niv.Update import qualified Data.Aeson as Aeson import qualified Data.Text as T+import Niv.Sources+import Niv.Update import qualified Options.Applicative as Opts -- TODO: add filter-data Cmd = Cmd- { description :: forall a. Opts.InfoMod a- , parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object)- , parsePackageSpec :: Opts.Parser PackageSpec- , updateCmd :: Update () ()- , name :: T.Text- }+data Cmd+ = Cmd+ { description :: forall a. Opts.InfoMod a,+ parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object),+ parsePackageSpec :: Opts.Parser PackageSpec,+ updateCmd :: Update () (),+ name :: T.Text+ }
src/Niv/Git/Cmd.hs view
@@ -1,42 +1,43 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Arrows #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-} module Niv.Git.Cmd where import Control.Applicative import Control.Arrow+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Char8 as B8+import qualified Data.HashMap.Strict as HMS import Data.Maybe+import qualified Data.Text as T import Data.Text.Extended as T import Niv.Cmd import Niv.Logger import Niv.Sources import Niv.Update-import System.Exit (ExitCode(ExitSuccess))-import System.Process (readProcessWithExitCode)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Char8 as B8-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts+import System.Exit (ExitCode (ExitSuccess))+import System.Process (readProcessWithExitCode) gitCmd :: Cmd-gitCmd = Cmd- { description = describeGit- , parseCmdShortcut = parseGitShortcut- , parsePackageSpec = parseGitPackageSpec- , updateCmd = gitUpdate'- , name = "git"- }+gitCmd =+ Cmd+ { description = describeGit,+ parseCmdShortcut = parseGitShortcut,+ parsePackageSpec = parseGitPackageSpec,+ updateCmd = gitUpdate',+ name = "git"+ } parseGitShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =- -- basic heuristics for figuring out if something is a git repo- if isGitURL+ -- basic heuristics for figuring out if something is a git repo+ if isGitURL then case T.splitOn "/" txt of [] -> Nothing (last -> w) -> case T.stripSuffix ".git" w of@@ -45,77 +46,85 @@ else Nothing where isGitURL =- ".git" `T.isSuffixOf` txt ||- "git@" `T.isPrefixOf` txt ||- "ssh://" `T.isPrefixOf` txt+ ".git" `T.isSuffixOf` txt+ || "git@" `T.isPrefixOf` txt+ || "ssh://" `T.isPrefixOf` txt parseGitPackageSpec :: Opts.Parser PackageSpec parseGitPackageSpec =- (PackageSpec . HMS.fromList) <$>- many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr)+ (PackageSpec . HMS.fromList)+ <$> many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr) where parseRepo =- ("repo", ) . Aeson.String <$> Opts.strOption- ( Opts.long "repo" <>- Opts.metavar "URL"- )+ ("repo",) . Aeson.String+ <$> Opts.strOption+ ( Opts.long "repo"+ <> Opts.metavar "URL"+ ) parseRev =- ("rev", ) . Aeson.String <$> Opts.strOption- ( Opts.long "rev" <>- Opts.metavar "SHA"- )+ ("rev",) . Aeson.String+ <$> Opts.strOption+ ( Opts.long "rev"+ <> Opts.metavar "SHA"+ ) parseRef =- ("ref", ) . Aeson.String <$> Opts.strOption- ( Opts.long "ref" <>- Opts.metavar "REF"- )+ ("ref",) . Aeson.String+ <$> Opts.strOption+ ( Opts.long "ref"+ <> Opts.metavar "REF"+ ) parseAttr =- Opts.option (Opts.maybeReader parseKeyValJSON)- ( Opts.long "attribute" <>- Opts.short 'a' <>- Opts.metavar "KEY=VAL" <>- Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."+ Opts.option+ (Opts.maybeReader parseKeyValJSON)+ ( Opts.long "attribute"+ <> Opts.short 'a'+ <> Opts.metavar "KEY=VAL"+ <> Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON." ) parseSAttr =- Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON))- ( Opts.long "string-attribute" <>- Opts.short 's' <>- Opts.metavar "KEY=VAL" <>- Opts.help "Set the package spec attribute <KEY> to <VAL>."+ Opts.option+ (Opts.maybeReader (parseKeyVal Aeson.toJSON))+ ( Opts.long "string-attribute"+ <> Opts.short 's'+ <> Opts.metavar "KEY=VAL"+ <> Opts.help "Set the package spec attribute <KEY> to <VAL>." )- parseKeyValJSON = parseKeyVal $ \x -> fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x))- -- Parse "key=val" into ("key", val)- parseKeyVal- :: (String -> Aeson.Value) -- ^ how to convert to JSON- -> String -> Maybe (T.Text, Aeson.Value)+ parseKeyVal ::+ -- | how to convert to JSON+ (String -> Aeson.Value) ->+ String ->+ Maybe (T.Text, Aeson.Value) parseKeyVal toJSON str = case span (/= '=') str of- (key, '=':val) -> Just (T.pack key, toJSON val)+ (key, '=' : val) -> Just (T.pack key, toJSON val) _ -> Nothing describeGit :: Opts.InfoMod a-describeGit = mconcat- [ Opts.fullDesc- , Opts.progDesc "Add a git dependency. Experimental."- , Opts.headerDoc $ Just $- "Examples:" Opts.<$$>- "" Opts.<$$>- " niv add git git@github.com:stedolan/jq" Opts.<$$>- " niv add git ssh://git@github.com/stedolan/jq --rev deadb33f" Opts.<$$>- " niv add git https://github.com/stedolan/jq.git" Opts.<$$>- " niv add git --repo /my/custom/repo --name custom --ref foobar"- ]+describeGit =+ mconcat+ [ Opts.fullDesc,+ Opts.progDesc "Add a git dependency. Experimental.",+ Opts.headerDoc $ Just $+ "Examples:"+ Opts.<$$> ""+ Opts.<$$> " niv add git git@github.com:stedolan/jq"+ Opts.<$$> " niv add git ssh://git@github.com/stedolan/jq --rev deadb33f"+ Opts.<$$> " niv add git https://github.com/stedolan/jq.git"+ Opts.<$$> " niv add git --repo /my/custom/repo --name custom --ref foobar"+ ] -gitUpdate- :: (T.Text -> T.Text -> IO T.Text) -- ^ latest rev- -> (T.Text -> IO (T.Text, T.Text)) -- ^ latest rev and default ref- -> Update () ()+gitUpdate ::+ -- | latest rev+ (T.Text -> T.Text -> IO T.Text) ->+ -- | latest rev and default ref+ (T.Text -> IO (T.Text, T.Text)) ->+ Update () () gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do- useOrSet "type" -< ("git" :: Box T.Text)- repository <- load "repo" -< ()- discoverRev <+> discoverRefAndRev -< repository+ useOrSet "type" -< ("git" :: Box T.Text)+ repository <- load "repo" -< ()+ discoverRev <+> discoverRefAndRev -< repository where discoverRefAndRev = proc repository -> do refAndRev <- run defaultRefAndHEAD' -< repository@@ -132,38 +141,46 @@ gitUpdate' :: Update () () gitUpdate' = gitUpdate latestRev defaultRefAndHEAD -latestRev- :: T.Text -- ^ the repository- -> T.Text -- ^ the ref/branch- -> IO T.Text+latestRev ::+ -- | the repository+ T.Text ->+ -- | the ref/branch+ T.Text ->+ IO T.Text latestRev repo ref = do- let gitArgs = [ "ls-remote", repo, "refs/heads/" <> ref ]- sout <- runGit gitArgs- case sout of- ls@(_:_:_) -> abortTooMuchOutput gitArgs ls- (l1:[]) -> parseRev gitArgs l1- [] -> abortNoOutput gitArgs+ let gitArgs = ["ls-remote", repo, "refs/heads/" <> ref]+ sout <- runGit gitArgs+ case sout of+ ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls+ (l1 : []) -> parseRev gitArgs l1+ [] -> abortNoOutput gitArgs where parseRev args l = maybe (abortNoRev args l) pure $ do checkRev $ T.takeWhile (/= '\t') l checkRev t = if isRev t then Just t else Nothing- abortNoOutput args = abortGitFailure args- "Git didn't produce any output."- abortTooMuchOutput args ls = abortGitFailure args $ T.unlines $- [ "Git produced too much output:" ] <> map (" " <>) ls+ abortNoOutput args =+ abortGitFailure+ args+ "Git didn't produce any output."+ abortTooMuchOutput args ls =+ abortGitFailure args $ T.unlines $+ ["Git produced too much output:"] <> map (" " <>) ls -defaultRefAndHEAD- :: T.Text -- ^ the repository- -> IO (T.Text, T.Text)+defaultRefAndHEAD ::+ -- | the repository+ T.Text ->+ IO (T.Text, T.Text) defaultRefAndHEAD repo = do- sout <- runGit args- case sout of- (l1:l2:_) -> (,) <$> parseRef l1 <*> parseRev l2- _ -> abortGitFailure args $ T.unlines $+ sout <- runGit args+ case sout of+ (l1 : l2 : _) -> (,) <$> parseRef l1 <*> parseRev l2+ _ ->+ abortGitFailure args $ T.unlines $ [ "Could not read reference and revision from stdout:"- ] <> sout+ ]+ <> sout where- args = [ "ls-remote", "--symref", repo, "HEAD" ]+ args = ["ls-remote", "--symref", repo, "HEAD"] parseRef l = maybe (abortNoRef args l) pure $ do -- ref: refs/head/master\tHEAD -> master\tHEAD refAndSym <- T.stripPrefix "ref: refs/heads/" l@@ -175,29 +192,36 @@ abortNoRev :: [T.Text] -> T.Text -> IO a abortNoRev args l = abortGitFailure args $ "Could not read revision from: " <> l+ abortNoRef :: [T.Text] -> T.Text -> IO a abortNoRef args l = abortGitFailure args $ "Could not read reference from: " <> l -- | Run the "git" executable runGit :: [T.Text] -> IO [T.Text] runGit args = do- (exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) ""- case (exitCode, lines sout) of- (ExitSuccess, ls) -> pure $ T.pack <$> ls- _ -> abortGitFailure args $ T.unlines- [ T.unwords [ "stdout:" , T.pack sout ]- , T.unwords [ "stderr:" , T.pack serr ]- ]+ (exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) ""+ case (exitCode, lines sout) of+ (ExitSuccess, ls) -> pure $ T.pack <$> ls+ _ ->+ abortGitFailure args $+ T.unlines+ [ T.unwords ["stdout:", T.pack sout],+ T.unwords ["stderr:", T.pack serr]+ ] isRev :: T.Text -> Bool isRev t = -- commit hashes are comprised of abcdef0123456789- T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t &&- -- commit _should_ be 40 chars long, but to be sure we pick 7- T.length t >= 7+ T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t+ &&+ -- commit _should_ be 40 chars long, but to be sure we pick 7+ T.length t >= 7 abortGitFailure :: [T.Text] -> T.Text -> IO a-abortGitFailure args msg = abort $ bug $ T.unlines- [ "Could not read the output of 'git'."- , T.unwords ("command:":"git":args)- , msg ]+abortGitFailure args msg =+ abort $ bug $+ T.unlines+ [ "Could not read the output of 'git'.",+ T.unwords ("command:" : "git" : args),+ msg+ ]
src/Niv/Git/Test.hs view
@@ -1,63 +1,129 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-}+{-# LANGUAGE OverloadedStrings #-} -module Niv.Git.Test (tests) where+module Niv.Git.Test+ ( tests,+ )+where import Control.Monad import Data.Bifunctor+import qualified Data.HashMap.Strict as HMS+import Data.IORef import Niv.Git.Cmd import Niv.Sources import Niv.Update-import Test.Tasty.HUnit ((@=?))-import qualified Data.HashMap.Strict as HMS import qualified Test.Tasty as Tasty+import Test.Tasty.HUnit ((@=?)) import qualified Test.Tasty.HUnit as Tasty tests :: [Tasty.TestTree]-tests = [ test_repositoryParse , test_gitUpdates ]+tests = [test_repositoryParse, test_gitUpdates] test_repositoryParse :: Tasty.TestTree-test_repositoryParse = Tasty.testGroup "repository parse"- [ Tasty.testCase "goo" $- parseGitShortcut "goo" @=? Nothing- , Tasty.testCase "git@github.com:nmattia/niv" $- parseGitShortcut "git@github.com:nmattia/niv" @=? Just- (PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv")- , Tasty.testCase "ssh://git@github.com/stedolan/jq" $- parseGitShortcut "ssh://git@github.com/stedolan/jq" @=? Just- (PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq")- , Tasty.testCase "https://github.com/stedolan/jq.git" $- parseGitShortcut "https://github.com/stedolan/jq.git" @=? Just- (PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git")- , Tasty.testCase "https://github.com/stedolan/jq" $- parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing- , Tasty.testCase "~/path/to/repo.git" $- parseGitShortcut "~/path/to/repo.git" @=? Just- (PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git")- ]+test_repositoryParse =+ Tasty.testGroup+ "repository parse"+ [ Tasty.testCase "goo" $+ parseGitShortcut "goo" @=? Nothing,+ Tasty.testCase "git@github.com:nmattia/niv" $+ parseGitShortcut "git@github.com:nmattia/niv"+ @=? Just+ (PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv"),+ Tasty.testCase "ssh://git@github.com/stedolan/jq" $+ parseGitShortcut "ssh://git@github.com/stedolan/jq"+ @=? Just+ (PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq"),+ Tasty.testCase "https://github.com/stedolan/jq.git" $+ parseGitShortcut "https://github.com/stedolan/jq.git"+ @=? Just+ (PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git"),+ Tasty.testCase "https://github.com/stedolan/jq" $+ parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing,+ Tasty.testCase "~/path/to/repo.git" $+ parseGitShortcut "~/path/to/repo.git"+ @=? Just+ (PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git")+ ] test_gitUpdates :: Tasty.TestTree-test_gitUpdates = Tasty.testGroup "updates"- [ Tasty.testCase "rev is updated" test_gitUpdateRev- ]+test_gitUpdates =+ Tasty.testGroup+ "updates"+ [ Tasty.testCase "rev is updated" test_gitUpdateRev,+ Tasty.testCase "git is called once" test_gitCalledOnce+ ] test_gitUpdateRev :: IO () test_gitUpdateRev = do- interState <- evalUpdate initialState $ proc () ->- gitUpdate (error "should be def") defaultRefAndHEAD' -< ()- let interState' = HMS.map (first (\_ -> Free)) interState- actualState <- evalUpdate interState' $ proc () ->- gitUpdate latestRev' (error "should update") -< ()- unless ((snd <$> actualState) == expectedState) $- error $ "State mismatch: " <> show actualState+ interState <- evalUpdate initialState $ proc () ->+ gitUpdate (error "should be def") defaultRefAndHEAD' -< ()+ let interState' = HMS.map (first (\_ -> Free)) interState+ actualState <- evalUpdate interState' $ proc () ->+ gitUpdate latestRev' (error "should update") -< ()+ unless ((snd <$> actualState) == expectedState)+ $ error+ $ "State mismatch: " <> show actualState where latestRev' _ _ = pure "some-other-rev" defaultRefAndHEAD' _ = pure ("some-ref", "some-rev")- initialState = HMS.fromList- [ ("repo", (Free, "git@github.com:nmattia/niv")) ]- expectedState = HMS.fromList- [ ("repo", "git@github.com:nmattia/niv")- , ("ref", "some-ref")- , ("rev", "some-other-rev")- , ("type", "git")- ]+ initialState =+ HMS.fromList+ [("repo", (Free, "git@github.com:nmattia/niv"))]+ expectedState =+ HMS.fromList+ [ ("repo", "git@github.com:nmattia/niv"),+ ("ref", "some-ref"),+ ("rev", "some-other-rev"),+ ("type", "git")+ ]++once1 :: (b -> IO a) -> IO (b -> IO a)+once1 f = do+ used <- newIORef False+ pure $ \x -> do+ used' <- readIORef used+ if used'+ then error "already used"+ else do+ writeIORef used True+ f x++once2 :: (a -> b -> IO c) -> IO (a -> b -> IO c)+once2 f = do+ used <- newIORef False+ pure $ \x y -> do+ used' <- readIORef used+ if used'+ then error "already used"+ else do+ writeIORef used True+ f x y++-- | This tests that we don't run the same git operations several times during+-- the update+test_gitCalledOnce :: IO ()+test_gitCalledOnce = do+ defaultRefAndHEAD'' <- once1 defaultRefAndHEAD'+ latestRev'' <- once2 latestRev'+ interState <- evalUpdate initialState $ proc () ->+ gitUpdate (error "should be def") defaultRefAndHEAD'' -< ()+ let interState' = HMS.map (first (\_ -> Free)) interState+ actualState <- evalUpdate interState' $ proc () ->+ gitUpdate latestRev'' (error "should update") -< ()+ unless ((snd <$> actualState) == expectedState)+ $ error+ $ "State mismatch: " <> show actualState+ where+ latestRev' _ _ = pure "some-other-rev"+ defaultRefAndHEAD' _ = pure ("some-ref", "some-rev")+ initialState =+ HMS.fromList+ [("repo", (Free, "git@github.com:nmattia/niv"))]+ expectedState =+ HMS.fromList+ [ ("repo", "git@github.com:nmattia/niv"),+ ("ref", "some-ref"),+ ("rev", "some-other-rev"),+ ("type", "git")+ ]
src/Niv/GitHub.hs view
@@ -1,18 +1,18 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} module Niv.GitHub where import Control.Arrow import Data.Bool import Data.Maybe+import qualified Data.Text as T import Niv.GitHub.API import Niv.Update-import qualified Data.Text as T -- | The GitHub update function -- TODO: fetchers for:@@ -20,39 +20,44 @@ -- * 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+ (Bool -> T.Text -> IO T.Text) ->+ -- | latest revision+ (T.Text -> T.Text -> T.Text -> IO T.Text) ->+ -- | get repo+ (T.Text -> T.Text -> IO GithubRepo) ->+ Update () () githubUpdate prefetch latestRev ghRepo = proc () -> do- urlTemplate <- template <<<- (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<+ urlTemplate <-+ template+ <<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -< ()- url <- update "url" -< urlTemplate- let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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 -< ()+ url <- update "url" -< urlTemplate+ let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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+ 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+ _ <-+ update "rev" <<< run' (\(a, b, c) -> latestRev a b c) -<+ (,,) <$> owner <*> repo <*> branch returnA -< pure githubURLTemplate githubURLTemplate :: T.Text githubURLTemplate =- (if githubSecure then "https://" else "http://") <>- githubHost <> githubPath <> "<owner>/<repo>/archive/<rev>.tar.gz"+ (if githubSecure then "https://" else "http://")+ <> githubHost+ <> githubPath+ <> "<owner>/<repo>/archive/<rev>.tar.gz"
src/Niv/GitHub/API.hs view
@@ -1,64 +1,67 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} module Niv.GitHub.API where +import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Char8 as BS8 import Data.Functor+import qualified Data.HashMap.Strict as HMS import Data.Maybe import Data.String.QQ (s)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Text.Extended+import qualified Network.HTTP.Simple as HTTP import System.Environment (lookupEnv) import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Char8 as BS8-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Simple as HTTP -- Bunch of GitHub helpers -data GithubRepo = GithubRepo- { repoDescription :: Maybe T.Text- , repoHomepage :: Maybe T.Text- , repoDefaultBranch :: Maybe T.Text- }+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"+ 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)+ (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+ putStrLn $ unlines [line1, line2, T.unpack line3]+ exitFailure where line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo- line2 = [s|+ 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:@@ -72,52 +75,55 @@ Make sure the repository exists. |]- line3 = T.unwords [ "(Error was:", e, ")" ]+ 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+ let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts)+ mtoken <- lookupEnv "GITHUB_TOKEN"+ pure+ $ ( flip (maybe id) mtoken $ \token ->+ HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token)+ )+ $ HTTP.setRequestPath path+ $ HTTP.addRequestHeader "user-agent" "niv"+ $ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json"+ $ HTTP.setRequestSecure githubSecure+ $ HTTP.setRequestHost (T.encodeUtf8 githubApiHost)+ $ HTTP.setRequestPort githubApiPort+ $ HTTP.defaultRequest -- | Get the latest revision for owner, repo and branch. -- TODO: explain no error handling-githubLatestRev- :: T.Text- -- ^ owner- -> T.Text- -- ^ repo- -> T.Text- -- ^ branch- -> IO T.Text+githubLatestRev ::+ -- | owner+ T.Text ->+ -- | repo+ T.Text ->+ -- | branch+ T.Text ->+ IO T.Text githubLatestRev owner repo branch = do- request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&>- HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha"- resp <- HTTP.httpBS request- case HTTP.getResponseStatusCode resp of- 200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp- _ -> abortCouldNotGetRev owner repo branch resp+ 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 ]+abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [line1, line2, line3] where- line1 = T.unwords- [ "Cannot get latest revision for branch"- , "'" <> branch <> "'"- , "(" <> owner <> "/" <> repo <> ")"- ]+ line1 =+ T.unwords+ [ "Cannot get latest revision for branch",+ "'" <> branch <> "'",+ "(" <> owner <> "/" <> repo <> ")"+ ] line2 = "The request failed: " <> tshow resp- line3 = [s|+ line3 =+ [s| NOTE: You may want to retry with an authentication token: GITHUB_TOKEN=... niv <cmd>@@ -130,31 +136,31 @@ githubHost :: T.Text githubHost = unsafePerformIO $ do- lookupEnv "GITHUB_HOST" >>= \case- Just (T.pack -> x) -> pure x- Nothing -> pure "github.com"+ 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+ 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"+ 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+ 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 "/"+ lookupEnv "GITHUB_PATH" >>= \case+ Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/"+ Nothing -> pure "/"
src/Niv/GitHub/Cmd.hs view
@@ -1,133 +1,153 @@ {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -module Niv.GitHub.Cmd (githubCmd) where+module Niv.GitHub.Cmd+ ( githubCmd,+ )+where import Control.Applicative import Data.Aeson ((.=))+import qualified Data.Aeson as Aeson import Data.Bifunctor+import qualified Data.ByteString.Char8 as B8 import Data.Char (isAlphaNum)+import qualified Data.HashMap.Strict as HMS import Data.Maybe import Data.String.QQ (s)+import qualified Data.Text as T import Data.Text.Extended import Niv.Cmd import Niv.GitHub import Niv.GitHub.API import Niv.Sources import Niv.Update-import System.Exit (ExitCode(ExitSuccess))-import System.Process (readProcessWithExitCode)-import qualified Data.Aeson as Aeson-import qualified Data.ByteString.Char8 as B8-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts+import System.Exit (ExitCode (ExitSuccess))+import System.Process (readProcessWithExitCode) githubCmd :: Cmd-githubCmd = Cmd- { description = describeGitHub- , parseCmdShortcut = parseAddShortcutGitHub- , parsePackageSpec = parseGitHubPackageSpec- , updateCmd = githubUpdate'- , name = "github"- -- TODO: here filter by type == tarball or file or builtin-- }+githubCmd =+ Cmd+ { description = describeGitHub,+ parseCmdShortcut = parseAddShortcutGitHub,+ parsePackageSpec = parseGitHubPackageSpec,+ updateCmd = githubUpdate',+ name = "github"+ -- TODO: here filter by type == tarball or file or builtin-+ } parseGitHubPackageSpec :: Opts.Parser PackageSpec parseGitHubPackageSpec =- (PackageSpec . HMS.fromList) <$>- many parseAttribute+ (PackageSpec . HMS.fromList)+ <$> many parseAttribute where parseAttribute :: Opts.Parser (T.Text, Aeson.Value) parseAttribute =- Opts.option (Opts.maybeReader parseKeyValJSON)- ( Opts.long "attribute" <>- Opts.short 'a' <>- Opts.metavar "KEY=VAL" <>- Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."- ) <|>- Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON))- ( Opts.long "string-attribute" <>- Opts.short 's' <>- Opts.metavar "KEY=VAL" <>- Opts.help "Set the package spec attribute <KEY> to <VAL>."- ) <|>- shortcutAttributes <|>- ((("url_template",) . Aeson.String) <$> Opts.strOption- ( Opts.long "template" <>- Opts.short 't' <>- Opts.metavar "URL" <>- Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."- )) <|>- ((("type",) . Aeson.String) <$> 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."- ))-+ Opts.option+ (Opts.maybeReader parseKeyValJSON)+ ( Opts.long "attribute"+ <> Opts.short 'a'+ <> Opts.metavar "KEY=VAL"+ <> Opts.help "Set the package spec attribute <KEY> to <VAL>, where <VAL> may be JSON."+ )+ <|> Opts.option+ (Opts.maybeReader (parseKeyVal Aeson.toJSON))+ ( Opts.long "string-attribute"+ <> Opts.short 's'+ <> Opts.metavar "KEY=VAL"+ <> Opts.help "Set the package spec attribute <KEY> to <VAL>."+ )+ <|> shortcutAttributes+ <|> ( (("url_template",) . Aeson.String)+ <$> Opts.strOption+ ( Opts.long "template"+ <> Opts.short 't'+ <> Opts.metavar "URL"+ <> Opts.help "Used during 'update' when building URL. Occurrences of <foo> are replaced with attribute 'foo'."+ )+ )+ <|> ( (("type",) . Aeson.String)+ <$> 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."+ )+ ) parseKeyValJSON = parseKeyVal $ \x -> fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x))- -- Parse "key=val" into ("key", val)- parseKeyVal- :: (String -> Aeson.Value) -- ^ how to convert to JSON- -> String -> Maybe (T.Text, Aeson.Value)+ parseKeyVal ::+ -- | how to convert to JSON+ (String -> Aeson.Value) ->+ String ->+ Maybe (T.Text, Aeson.Value) parseKeyVal toJSON str = case span (/= '=') str of- (key, '=':val) -> Just (T.pack key, toJSON val)+ (key, '=' : val) -> Just (T.pack key, toJSON val) _ -> Nothing- -- Shortcuts for common attributes shortcutAttributes :: Opts.Parser (T.Text, Aeson.Value)- shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>- [ "branch", "owner", "repo", "version" ]-+ shortcutAttributes =+ foldr (<|>) empty $+ mkShortcutAttribute+ <$> ["branch", "owner", "repo", "version"] -- TODO: infer those shortcuts from 'Update' keys mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, Aeson.Value) mkShortcutAttribute = \case- attr@(T.uncons -> Just (c,_)) -> fmap (second Aeson.String) $ (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) <> ">"- )- )+ attr@(T.uncons -> Just (c, _)) ->+ fmap (second Aeson.String) $+ (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 describeGitHub :: Opts.InfoMod a-describeGitHub = mconcat- [ Opts.fullDesc- , Opts.progDesc "Add a GitHub dependency"- , Opts.headerDoc $ Just $- "Examples:" Opts.<$$>- "" Opts.<$$>- " niv add stedolan/jq" Opts.<$$>- " niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable" Opts.<$$>- " niv add my-package -v alpha-0.1 -t http://example.com/archive/<version>.zip"- ]+describeGitHub =+ mconcat+ [ Opts.fullDesc,+ Opts.progDesc "Add a GitHub dependency",+ Opts.headerDoc $ Just $+ "Examples:"+ Opts.<$$> ""+ Opts.<$$> " niv add stedolan/jq"+ Opts.<$$> " niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable"+ Opts.<$$> " niv add my-package -v alpha-0.1 -t http://example.com/archive/<version>.zip"+ ] -- parse a github shortcut of the form "owner/repo" parseAddShortcutGitHub :: T.Text -> Maybe (PackageName, Aeson.Object) parseAddShortcutGitHub str =- -- parses a string "owner/repo" into package name (repo) and spec (owner +- -- repo)- case T.span (/= '/') str of- (owner@(T.null -> False)- , T.uncons -> Just ('/', repo@(T.null -> False))) -> Just- ( PackageName repo- , HMS.fromList [ "owner" .= owner, "repo" .= repo ])- -- XXX: this should be "Nothing" but for the time being we keep- -- backwards compatibility with "niv add foo" adding "foo" as a- -- package name.- _ -> Just (PackageName str, HMS.empty)+ -- parses a string "owner/repo" into package name (repo) and spec (owner ++ -- repo)+ case T.span (/= '/') str of+ ( owner@(T.null -> False),+ T.uncons -> Just ('/', repo@(T.null -> False))+ ) ->+ Just+ ( PackageName repo,+ HMS.fromList ["owner" .= owner, "repo" .= repo]+ )+ -- XXX: this should be "Nothing" but for the time being we keep+ -- backwards compatibility with "niv add foo" adding "foo" as a+ -- package name.+ _ -> Just (PackageName str, HMS.empty) -- | The IO (real) github update githubUpdate' :: Update () ()@@ -135,12 +155,12 @@ nixPrefetchURL :: Bool -> T.Text -> IO T.Text nixPrefetchURL unpack turl@(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)+ (exitCode, sout, serr) <- runNixPrefetch+ case (exitCode, lines sout) of+ (ExitSuccess, l : _) -> pure $ T.pack l+ _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) where- args = (if unpack then ["--unpack"] else []) <> [ url, "--name", sanitizeName basename]+ args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename] runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" sanitizeName = T.unpack . T.filter isOk basename = last $ T.splitOn "/" turl@@ -150,12 +170,15 @@ -- (note: we assume they don't begin with a period) isOk = \c -> isAlphaNum c || T.any (c ==) "+-._?=" -abortNixPrefetchExpectedOutput :: T.Text -> T.Text -> IO a-abortNixPrefetchExpectedOutput sout serr = abort $ [s|+abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a+abortNixPrefetchExpectedOutput args 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.-|] <> T.unlines ["stdout: ", sout, "stderr: ", serr]+|]+ <> T.unlines ["command: ", "nix-prefetch-url" <> T.unwords args, "stdout: ", sout, "stderr: ", serr]
src/Niv/GitHub/Test.hs view
@@ -5,156 +5,172 @@ module Niv.GitHub.Test where import Control.Monad-import Data.IORef import Data.Bifunctor+import qualified Data.HashMap.Strict as HMS+import Data.IORef import Niv.GitHub import Niv.GitHub.API 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+ 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/<owner>/<repo>/archive/<rev>.tar.gz")- ]+ 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/<owner>/<repo>/archive/<rev>.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+ 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/<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")- ]+ 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")+ ] test_githubDoesntOverrideRev :: IO () test_githubDoesntOverrideRev = do- actualState <- evalUpdate initialState $ proc () ->- githubUpdate prefetch latestRev ghRepo -< ()- unless ((snd <$> actualState) == expectedState) $- error $ "State mismatch: " <> show actualState+ 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/<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/custom-rev.tar.gz")- , ("rev", "custom-rev")- , ("sha256", "new-sha")- , ("type", "tarball")- , ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")- ]+ 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/<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/custom-rev.tar.gz"),+ ("rev", "custom-rev"),+ ("sha256", "new-sha"),+ ("type", "tarball"),+ ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.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+ 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/<baz>.tar.gz"))- , ("baz", (Free, "tarball"))- ]- expectedState = HMS.fromList- [ ("url_template", "https://foo.com/<baz>.tar.gz")- , ("baz", "tarball")- , ("url", "https://foo.com/tarball.tar.gz")- , ("sha256", "some-sha")- , ("type", "tarball")- ]+ initialState =+ HMS.fromList+ [ ("url_template", (Free, "https://foo.com/<baz>.tar.gz")),+ ("baz", (Free, "tarball"))+ ]+ expectedState =+ HMS.fromList+ [ ("url_template", "https://foo.com/<baz>.tar.gz"),+ ("baz", "tarball"),+ ("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+ 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@@ -163,32 +179,36 @@ 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")- ]+ 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/Local/Cmd.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -8,32 +8,34 @@ module Niv.Local.Cmd where -import Niv.Cmd import Control.Arrow-import Niv.Sources-import Niv.Update import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T+import Niv.Cmd+import Niv.Sources+import Niv.Update import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts localCmd :: Cmd-localCmd = Cmd- { description = describeLocal- , parseCmdShortcut = parseLocalShortcut- , parsePackageSpec = parseLocalPackageSpec- , updateCmd = proc () -> do- useOrSet "type" -< ("local" :: Box T.Text)- returnA -< ()- , name = "local"- }+localCmd =+ Cmd+ { description = describeLocal,+ parseCmdShortcut = parseLocalShortcut,+ parsePackageSpec = parseLocalPackageSpec,+ updateCmd = proc () -> do+ useOrSet "type" -< ("local" :: Box T.Text)+ returnA -< (),+ name = "local"+ } parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) parseLocalShortcut txt =- if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt ) then do+ if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt)+ then do let n = last $ T.splitOn "/" txt- Just (PackageName n, HMS.fromList [ ("path", Aeson.String txt) ])+ Just (PackageName n, HMS.fromList [("path", Aeson.String txt)]) else Nothing parseLocalPackageSpec :: Opts.Parser PackageSpec@@ -41,19 +43,20 @@ where parseParams :: Opts.Parser [(T.Text, Aeson.Value)] parseParams = maybe [] pure <$> Opts.optional parsePath- parsePath =- ("path", ) . Aeson.String <$> Opts.strOption- ( Opts.long "path" <>- Opts.metavar "PATH"- )+ ("path",) . Aeson.String+ <$> Opts.strOption+ ( Opts.long "path"+ <> Opts.metavar "PATH"+ ) describeLocal :: Opts.InfoMod a-describeLocal = mconcat- [ Opts.fullDesc- , Opts.progDesc "Add a local dependency. Experimental."- , Opts.headerDoc $ Just $- "Examples:" Opts.<$$>- "" Opts.<$$>- " niv add local ./foo/bar"- ]+describeLocal =+ mconcat+ [ Opts.fullDesc,+ Opts.progDesc "Add a local dependency. Experimental.",+ Opts.headerDoc $ Just $+ "Examples:"+ Opts.<$$> ""+ Opts.<$$> " niv add local ./foo/bar"+ ]
src/Niv/Logger.hs view
@@ -1,47 +1,55 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module Niv.Logger- ( job- , bug- , tsay- , say- , green, tgreen- , red, tred- , blue, tblue- , yellow, tyellow- , bold, tbold- , faint, tfaint- ) where+ ( job,+ bug,+ tsay,+ say,+ green,+ tgreen,+ red,+ tred,+ blue,+ tblue,+ yellow,+ tyellow,+ bold,+ tbold,+ faint,+ tfaint,+ )+where import Control.Monad import Data.List import Data.Profunctor+import qualified Data.Text as T+import qualified System.Console.ANSI as ANSI import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO)-import qualified Data.Text as T import UnliftIO-import qualified System.Console.ANSI as ANSI type S = String -> String+ type T = T.Text -> T.Text -- XXX: this assumes as single thread job :: (MonadUnliftIO io, MonadIO io) => 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- liftIO exitFailure+ 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+ liftIO exitFailure where indent = void $ atomicModifyIORef jobStack (\x -> (x + 1, undefined)) deindent = void $ atomicModifyIORef jobStack (\x -> (x - 1, undefined))@@ -51,6 +59,7 @@ jobStack :: IORef Int jobStack = unsafePerformIO $ newIORef 0+ {-# NOINLINE jobStackSize #-} tsay :: MonadIO io => T.Text -> io ()@@ -58,61 +67,67 @@ say :: MonadIO io => String -> io () say msg = do- stackSize <- jobStackSize- let indent = replicate (stackSize * 2) ' '- -- we use `intercalate "\n"` because `unlines` prints an extra newline at- -- the end- liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg+ stackSize <- jobStackSize+ let indent = replicate (stackSize * 2) ' '+ -- we use `intercalate "\n"` because `unlines` prints an extra newline at+ -- the end+ liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg green :: S green str =- ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>- ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] <>- str <> ANSI.setSGRCode [ANSI.Reset]+ ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]+ <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tgreen :: T tgreen = t green yellow :: S yellow str =- ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>- ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow] <>- str <> ANSI.setSGRCode [ANSI.Reset]+ ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]+ <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tyellow :: T tyellow = t yellow blue :: S blue str =- ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>- ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue] <>- str <> ANSI.setSGRCode [ANSI.Reset]+ ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]+ <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tblue :: T tblue = t blue red :: S red str =- ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] <>- str <> ANSI.setSGRCode [ANSI.Reset]+ ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tred :: T tred = t red bold :: S bold str =- ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <>- ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <>- str <> ANSI.setSGRCode [ANSI.Reset]+ ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity]+ <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tbold :: T tbold = t bold 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]+ ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity]+ <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White]+ <> str+ <> ANSI.setSGRCode [ANSI.Reset] tfaint :: T tfaint = t faint@@ -121,9 +136,10 @@ t = dimap T.unpack T.pack bug :: T.Text -> T.Text-bug txt = T.unlines- [ txt- , "This is a bug. Please create a ticket:"- , " https://github.com/nmattia/niv/issues/new"- , "Thanks! I'll buy you a beer."- ]+bug txt =+ T.unlines+ [ txt,+ "This is a bug. Please create a ticket:",+ " https://github.com/nmattia/niv/issues/new",+ "Thanks! I'll buy you a beer."+ ]
src/Niv/Sources.hs view
@@ -1,31 +1,31 @@ {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} module Niv.Sources where import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)-import Data.FileEmbed (embedFile)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Extended as Aeson import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.Char8 as BL8+import qualified Data.Digest.Pure.MD5 as MD5+import Data.FileEmbed (embedFile)+import qualified Data.HashMap.Strict as HMS import Data.Hashable (Hashable) import Data.List import Data.String.QQ (s)+import qualified Data.Text as T import Data.Text.Extended import Niv.Logger import Niv.Update+import qualified System.Directory as Dir import System.FilePath ((</>)) import UnliftIO-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Extended as Aeson-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy.Char8 as BL8-import qualified Data.Digest.Pure.MD5 as MD5-import qualified Data.HashMap.Strict as HMS-import qualified Data.Text as T-import qualified System.Directory as Dir ------------------------------------------------------------------------------- -- sources.json related@@ -33,57 +33,65 @@ -- | Where to find the sources.json data FindSourcesJson- = Auto -- ^ use the default (nix/sources.json)- | AtPath FilePath -- ^ use the specified file path+ = -- | use the default (nix/sources.json)+ Auto+ | -- | use the specified file path+ AtPath FilePath data SourcesError = SourcesDoesntExist | SourceIsntJSON | SpecIsntAMap -newtype Sources = Sources- { unSources :: HMS.HashMap PackageName PackageSpec }+newtype Sources+ = Sources+ {unSources :: HMS.HashMap PackageName PackageSpec} deriving newtype (FromJSON, ToJSON) getSourcesEither :: FindSourcesJson -> IO (Either SourcesError Sources) getSourcesEither fsj = do- Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case- False -> pure $ Left SourcesDoesntExist- True ->- Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case- Just value -> case valueToSources value of- Nothing -> pure $ Left SpecIsntAMap- Just srcs -> pure $ Right srcs- Nothing -> pure $ Left SourceIsntJSON+ Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case+ False -> pure $ Left SourcesDoesntExist+ True ->+ Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case+ Just value -> case valueToSources value of+ Nothing -> pure $ Left SpecIsntAMap+ Just srcs -> pure $ Right srcs+ Nothing -> pure $ Left SourceIsntJSON where valueToSources :: Aeson.Value -> Maybe Sources valueToSources = \case- Aeson.Object obj -> fmap (Sources . mapKeys PackageName) $ traverse- (\case- Aeson.Object obj' -> Just (PackageSpec obj')- _ -> Nothing- ) obj- _ -> Nothing+ Aeson.Object obj ->+ fmap (Sources . mapKeys PackageName) $+ traverse+ ( \case+ Aeson.Object obj' -> Just (PackageSpec obj')+ _ -> Nothing+ )+ obj+ _ -> Nothing mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v mapKeys f = HMS.fromList . map (first f) . HMS.toList getSources :: FindSourcesJson -> IO Sources getSources fsj = do- warnIfOutdated- getSourcesEither fsj >>= either- (\case- SourcesDoesntExist -> (abortSourcesDoesntExist fsj)- SourceIsntJSON -> (abortSourcesIsntJSON fsj)- SpecIsntAMap -> (abortSpecIsntAMap fsj)- ) pure+ warnIfOutdated+ getSourcesEither fsj+ >>= either+ ( \case+ SourcesDoesntExist -> (abortSourcesDoesntExist fsj)+ SourceIsntJSON -> (abortSourcesIsntJSON fsj)+ SpecIsntAMap -> (abortSpecIsntAMap fsj)+ )+ pure setSources :: FindSourcesJson -> Sources -> IO () setSources fsj sources = Aeson.encodeFilePretty (pathNixSourcesJson fsj) sources -newtype PackageName = PackageName { unPackageName :: T.Text }+newtype PackageName = PackageName {unPackageName :: T.Text} deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) -newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object }+newtype PackageSpec = PackageSpec {unPackageSpec :: Aeson.Object} deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) -- | Simply discards the 'Freedom'@@ -93,32 +101,34 @@ -- | @nix/sources.json@ or pointed at by 'FindSourcesJson' pathNixSourcesJson :: FindSourcesJson -> FilePath pathNixSourcesJson = \case- Auto -> "nix" </> "sources.json"- AtPath f -> f+ Auto -> "nix" </> "sources.json"+ AtPath f -> f -- -- ABORT messages -- abortSourcesDoesntExist :: FindSourcesJson -> IO a-abortSourcesDoesntExist fsj = abort $ T.unlines [ line1, line2 ]+abortSourcesDoesntExist fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj)- line2 = [s|+ line2 =+ [s| The sources file does not exist! You may need to run 'niv init'. |] abortSourcesIsntJSON :: FindSourcesJson -> IO a-abortSourcesIsntJSON fsj = abort $ T.unlines [ line1, line2 ]+abortSourcesIsntJSON fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj) line2 = "The sources file should be JSON." abortSpecIsntAMap :: FindSourcesJson -> IO a-abortSpecIsntAMap fsj = abort $ T.unlines [ line1, line2 ]+abortSpecIsntAMap fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj)- line2 = [s|+ line2 =+ [s| The package specifications in the sources file should be JSON maps from attribute name to attribute value, e.g.: { "nixpkgs": { "foo": "bar" } }@@ -128,7 +138,6 @@ -- sources.nix related ------------------------------------------------------------------------------- - -- | All the released versions of nix/sources.nix data SourcesNixVersion = V1@@ -148,32 +157,35 @@ | V15 | V16 | V17- -- prettify derivation name- -- add 'local' type of sources- | V18+ | -- prettify derivation name+ -- add 'local' type of sources+ V18+ | -- add NIV_OVERRIDE_{name}+ V19 deriving stock (Bounded, Enum, Eq) -- | A user friendly version sourcesVersionToText :: SourcesNixVersion -> T.Text sourcesVersionToText = \case- V1 -> "1"- V2 -> "2"- V3 -> "3"- V4 -> "4"- V5 -> "5"- V6 -> "6"- V7 -> "7"- V8 -> "8"- V9 -> "9"- V10 -> "10"- V11 -> "11"- V12 -> "12"- V13 -> "13"- V14 -> "14"- V15 -> "15"- V16 -> "16"- V17 -> "17"- V18 -> "18"+ V1 -> "1"+ V2 -> "2"+ V3 -> "3"+ V4 -> "4"+ V5 -> "5"+ V6 -> "6"+ V7 -> "7"+ V8 -> "8"+ V9 -> "9"+ V10 -> "10"+ V11 -> "11"+ V12 -> "12"+ V13 -> "13"+ V14 -> "14"+ V15 -> "15"+ V16 -> "16"+ V17 -> "17"+ V18 -> "18"+ V19 -> "19" latestVersionMD5 :: T.Text latestVersionMD5 = sourcesVersionToMD5 maxBound@@ -181,29 +193,30 @@ -- | Find a version based on the md5 of the nix/sources.nix md5ToSourcesVersion :: T.Text -> Maybe SourcesNixVersion md5ToSourcesVersion md5 =- find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound]+ find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound] -- | The MD5 sum of a particular version sourcesVersionToMD5 :: SourcesNixVersion -> T.Text sourcesVersionToMD5 = \case- V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5"- V2 -> "24cc0719fa744420a04361e23a3598d0"- V3 -> "e01ed051e2c416e0fc7355fc72aeee3d"- V4 -> "f754fe0e661b61abdcd32cb4062f5014"- V5 -> "c34523590ff7dec7bf0689f145df29d1"- V6 -> "8143f1db1e209562faf80a998be4929a"- V7 -> "00a02cae76d30bbef96f001cabeed96f"- V8 -> "e8b860753dd7fa1fd7b805dd836eb607"- V9 -> "87149616c1b3b1e5aa73178f91c20b53"- V10 -> "d8625c0a03dd935e1c79f46407faa8d3"- V11 -> "8a95b7d93b16f7c7515d98f49b0ec741"- V12 -> "2f9629ad9a8f181ed71d2a59b454970c"- V13 -> "5e23c56b92eaade4e664cb16dcac1e0a"- V14 -> "b470e235e7bcbf106d243fea90b6cfc9"- V15 -> "dc11af910773ec9b4e505e0f49ebcfd2"- V16 -> "2d93c52cab8e960e767a79af05ca572a"- V17 -> "149b8907f7b08dc1c28164dfa55c7fad"- V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33"+ V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5"+ V2 -> "24cc0719fa744420a04361e23a3598d0"+ V3 -> "e01ed051e2c416e0fc7355fc72aeee3d"+ V4 -> "f754fe0e661b61abdcd32cb4062f5014"+ V5 -> "c34523590ff7dec7bf0689f145df29d1"+ V6 -> "8143f1db1e209562faf80a998be4929a"+ V7 -> "00a02cae76d30bbef96f001cabeed96f"+ V8 -> "e8b860753dd7fa1fd7b805dd836eb607"+ V9 -> "87149616c1b3b1e5aa73178f91c20b53"+ V10 -> "d8625c0a03dd935e1c79f46407faa8d3"+ V11 -> "8a95b7d93b16f7c7515d98f49b0ec741"+ V12 -> "2f9629ad9a8f181ed71d2a59b454970c"+ V13 -> "5e23c56b92eaade4e664cb16dcac1e0a"+ V14 -> "b470e235e7bcbf106d243fea90b6cfc9"+ V15 -> "dc11af910773ec9b4e505e0f49ebcfd2"+ V16 -> "2d93c52cab8e960e767a79af05ca572a"+ V17 -> "149b8907f7b08dc1c28164dfa55c7fad"+ V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33"+ V19 -> "543621698065cfc6a4a7985af76df718" -- | The MD5 sum of ./nix/sources.nix sourcesNixMD5 :: IO T.Text@@ -215,30 +228,36 @@ warnIfOutdated :: IO () warnIfOutdated = do- tryAny (BL8.readFile pathNixSourcesNix) >>= \case- Left e -> tsay $ T.unlines -- warn with tsay- [ T.unwords [ tyellow "WARNING:", "Could not read" , T.pack pathNixSourcesNix ]- , T.unwords [ " ", "(", tshow e, ")" ]- ]- Right content -> do- case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of- -- This is a custom or newer version, we don't do anything- Nothing -> pure ()- Just v- -- The file is the latest- | v == maxBound -> pure ()- -- The file is older than than latest- | otherwise -> do- tsay $ T.unlines- [ T.unwords- [ tbold $ tblue "INFO:"- , "new sources.nix available:"- , sourcesVersionToText v, "->", sourcesVersionToText maxBound- ]- , " Please run 'niv init' or add the following line in the " <>- T.pack pathNixSourcesNix <> " file:"- , " # niv: no_update"- ]+ tryAny (BL8.readFile pathNixSourcesNix) >>= \case+ Left e ->+ tsay $+ T.unlines -- warn with tsay+ [ T.unwords [tyellow "WARNING:", "Could not read", T.pack pathNixSourcesNix],+ T.unwords [" ", "(", tshow e, ")"]+ ]+ Right content -> do+ case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of+ -- This is a custom or newer version, we don't do anything+ Nothing -> pure ()+ Just v+ -- The file is the latest+ | v == maxBound -> pure ()+ -- The file is older than than latest+ | otherwise -> do+ tsay $+ T.unlines+ [ T.unwords+ [ tbold $ tblue "INFO:",+ "new sources.nix available:",+ sourcesVersionToText v,+ "->",+ sourcesVersionToText maxBound+ ],+ " Please run 'niv init' or add the following line in the "+ <> T.pack pathNixSourcesNix+ <> " file:",+ " # niv: no_update"+ ] -- | Glue code between nix and sources.json initNixSourcesNixContent :: B.ByteString
src/Niv/Sources/Test.hs view
@@ -1,13 +1,13 @@ module Niv.Sources.Test where -import Niv.Sources-import Test.Tasty.HUnit ((@=?)) import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.Text as T+import Niv.Sources+import Test.Tasty.HUnit ((@=?)) -- | Ensure that the sources.nix we ship is tracked as the latest version test_shippedSourcesNixIsLatest :: IO () test_shippedSourcesNixIsLatest =- latestVersionMD5 @=?- (T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent)+ latestVersionMD5+ @=? (T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent)
src/Niv/Test.hs view
@@ -1,9 +1,9 @@ module Niv.Test (tests, test) where -import Niv.Sources.Test+import qualified Niv.Git.Test as Git import Niv.GitHub.Test+import Niv.Sources.Test import Niv.Update.Test-import qualified Niv.Git.Test as Git import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty @@ -11,26 +11,31 @@ 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 "updates once" test_githubUpdatesOnce- , Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev- , Tasty.testCase "falls back to URL" test_githubURLFallback- ]- , Tasty.testGroup "sources.nix"+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 "updates once" test_githubUpdatesOnce,+ Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev,+ Tasty.testCase "falls back to URL" test_githubURLFallback+ ],+ Tasty.testGroup+ "sources.nix" [ Tasty.testCase "has latest version" test_shippedSourcesNixIsLatest- ]- , Tasty.testGroup "git" Git.tests+ ],+ Tasty.testGroup "git" Git.tests ]
src/Niv/Update.hs view
@@ -12,14 +12,14 @@ import Control.Applicative import Control.Arrow-import Data.Aeson (FromJSON, ToJSON, Value)-import Data.String-import Niv.Logger-import UnliftIO import qualified Control.Category as Cat+import Data.Aeson (FromJSON, ToJSON, Value) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HMS+import Data.String import qualified Data.Text as T+import Niv.Logger+import UnliftIO type Attrs = HMS.HashMap T.Text (Freedom, Value) @@ -34,27 +34,27 @@ 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)+ Run :: (a -> IO b) -> Update (Box a) (Box b) Template :: Update (Box T.Text) (Box T.Text) instance ArrowZero Update where- zeroArrow = Zero+ zeroArrow = Zero instance ArrowPlus Update where- (<+>) = Plus+ (<+>) = Plus instance Arrow Update where- arr = Arr- first = First+ arr = Arr+ first = First instance Cat.Category Update where- id = Id- f . g = Compose (Compose' f g)+ 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 <> ")"+ Compose (Compose' f g) -> "(" <> show f <> " . " <> show g <> ")" Arr _f -> "Arr" First a -> "First " <> show a Zero -> "Zero"@@ -70,7 +70,7 @@ -- | 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+runUpdate (attrs) a = boxAttrs attrs >>= flip runUpdate' a >>= feed where feed = \case UpdateReady res -> hndl res@@ -83,10 +83,11 @@ FailNoSuchKey k -> "Key could not be found: " <> k FailZero -> bug "A dead end was reached during evaluation." FailCheck -> "A check failed during update"- FailTemplate tpl keys -> T.unlines- [ "Could not render template " <> tpl- , "with keys: " <> T.intercalate ", " keys- ]+ 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@@ -104,54 +105,75 @@ | FailZero | FailCheck | FailTemplate T.Text [T.Text]- deriving Show+ deriving (Show) data UpdateRes a b = UpdateReady (UpdateReady b) | UpdateNeedMore (a -> IO (UpdateReady b))- deriving Functor+ deriving (Functor) data UpdateReady b = UpdateSuccess BoxedAttrs b | UpdateFailed UpdateFailed- deriving Functor+ 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+data Box a+ = Box+ { -- | Whether the value is new or was retrieved (or derived) from old+ -- attributes+ boxNew :: Bool,+ boxOp :: IO a+ }+ deriving (Functor) +mkBox :: Box a -> IO (Box a)+mkBox b = do+ mvar <- newMVar Nothing+ pure b {boxOp = singleton mvar (boxOp b)}++singleton :: MVar (Maybe a) -> IO a -> IO a+singleton mvar def = do+ modifyMVar mvar $ \case+ Just a -> pure (Just a, a)+ Nothing -> do+ a <- def+ pure (Just a, a)+ 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- }+ 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 }+ 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- ))+boxAttrs :: Attrs -> IO BoxedAttrs+boxAttrs =+ mapM+ ( \(fr, v) -> do+ box <- mkBox (pure v)+ pure+ ( fr,+ case fr of+ -- TODO: explain why hacky+ Locked -> box {boxNew = True} -- XXX: somewhat hacky+ Free -> box+ )+ ) data Freedom = Locked@@ -163,84 +185,95 @@ -- 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)+ 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+ box <- mkBox $ Box (boxNew gtt) (act =<< runBox gtt)+ pure $ UpdateSuccess attrs box+ )+ 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 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' }+ 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+ 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) -> 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+ 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 }+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@@ -254,16 +287,16 @@ -- renderTemplate ("foo" -> "bar") "<baz>" -> 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+ (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@@ -277,15 +310,15 @@ -- 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)+ 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)+ arr (fmap Aeson.toJSON)+ >>> Update k+ >>> arr (decodeBox $ "When updating key " <> k) run :: (a -> IO b) -> Update (Box a) (Box b) run = Run@@ -295,4 +328,4 @@ run' act = Run act >>> dirty dirty :: Update (Box a) (Box a)-dirty = arr (\v -> v { boxNew = True })+dirty = arr (\v -> v {boxNew = True})
src/Niv/Update/Test.hs view
@@ -1,46 +1,48 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} 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+import Niv.Update simplyRuns :: IO () simplyRuns =- void $ runUpdate attrs $ proc () -> do- returnA -< ()+ 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")+ 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")+ 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")+ 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 () ()@@ -58,55 +60,59 @@ 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))+ 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'+ 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"+ 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 -< "<v1>-<v2>"- v3' <- runBox v3- unless (v3' == "hello-world") $ error "bad value"+ v3 <- execUpdate attrs $ proc () -> template -< "<v1>-<v2>"+ v3' <- runBox v3+ unless (v3' == "hello-world") $ error "bad value" where attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]