From 7bc9e797f819fa119dcc21e44497e49fd3d3e5c6 Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Wed, 12 Jun 2019 15:58:10 +0200 Subject: [PATCH] Fight cabal --- app/Niv.hs | 634 +----------------------------------------------- app/NivTest.hs | 6 + app/test.hs | 8 - default.nix | 2 +- package.yaml | 32 +-- src/Niv/Cli.hs | 634 ++++++++++++++++++++++++++++++++++++++++++++++++ src/Niv/Test.hs | 5 +- 7 files changed, 665 insertions(+), 656 deletions(-) create mode 100644 app/NivTest.hs delete mode 100644 app/test.hs create mode 100644 src/Niv/Cli.hs diff --git a/app/Niv.hs b/app/Niv.hs index 7ea9d1e..4ad832c 100644 --- a/app/Niv.hs +++ b/app/Niv.hs @@ -1,634 +1,6 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +module Niv where -module Main where - -import Control.Applicative -import Control.Monad -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=)) -import Data.Char (isSpace) -import Data.FileEmbed (embedFile) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) -import Data.String.QQ (s) -import Niv.GitHub -import Niv.Update -import System.Exit (exitFailure) -import System.FilePath ((), takeDirectory) -import System.Process (readProcess) -import UnliftIO -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Encode.Pretty as AesonPretty -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as L -import qualified Data.HashMap.Strict as HMS -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified GitHub as GH -import qualified Options.Applicative as Opts -import qualified Options.Applicative.Help.Pretty as Opts -import qualified System.Directory as Dir +import Niv.Cli main :: IO () -main = join $ Opts.execParser opts - where - opts = Opts.info (parseCommand <**> Opts.helper) $ mconcat desc - desc = - [ Opts.fullDesc - , Opts.header "NIV - Version manager for Nix projects" - ] - -parseCommand :: Opts.Parser (IO ()) -parseCommand = Opts.subparser ( - Opts.command "init" parseCmdInit <> - Opts.command "add" parseCmdAdd <> - Opts.command "show" parseCmdShow <> - Opts.command "update" parseCmdUpdate <> - Opts.command "drop" parseCmdDrop ) - -newtype Sources = Sources - { unSources :: HMS.HashMap PackageName PackageSpec } - deriving newtype (FromJSON, ToJSON) - -getSources :: IO Sources -getSources = do - exists <- Dir.doesFileExist pathNixSourcesJson - unless exists abortSourcesDoesntExist - - warnIfOutdated - -- TODO: if doesn't exist: run niv init - putStrLn $ "Reading sources file" - decodeFileStrict pathNixSourcesJson >>= \case - Just (Aeson.Object obj) -> - fmap (Sources . mconcat) $ - forM (HMS.toList obj) $ \(k, v) -> - case v of - Aeson.Object v' -> - pure $ HMS.singleton (PackageName k) (PackageSpec v') - _ -> abortAttributeIsntAMap - Just _ -> abortSourcesIsntAMap - Nothing -> abortSourcesIsntJSON - -setSources :: Sources -> IO () -setSources sources = encodeFile pathNixSourcesJson sources - -newtype PackageName = PackageName { unPackageName :: T.Text } - deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) - -parsePackageName :: Opts.Parser PackageName -parsePackageName = PackageName <$> - Opts.argument Opts.str (Opts.metavar "PACKAGE") - -newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } - deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) - --- | Simply discards the 'Freedom' -attrsToSpec :: Attrs -> PackageSpec -attrsToSpec = PackageSpec . dropNulls . fmap snd - where - dropNulls - :: HMS.HashMap T.Text Aeson.Value - -> HMS.HashMap T.Text Aeson.Value - dropNulls = HMS.mapMaybe $ \case - x@Aeson.Object{} -> Just x - x@Aeson.Array{} -> Just x - x@Aeson.String{} -> Just x - x@Aeson.Number{} -> Just x - x@Aeson.Bool{} -> Just x - Aeson.Null -> Nothing - - -parsePackageSpec :: Opts.Parser PackageSpec -parsePackageSpec = - (PackageSpec . HMS.fromList . fmap fixupAttributes) <$> - many parseAttribute - where - parseAttribute :: Opts.Parser (T.Text, T.Text) - parseAttribute = - Opts.option (Opts.maybeReader parseKeyVal) - ( Opts.long "attribute" <> - Opts.short 'a' <> - Opts.metavar "KEY=VAL" <> - Opts.help "Set the package spec attribute to " - ) <|> shortcutAttributes <|> - (("url_template",) <$> Opts.strOption - ( Opts.long "template" <> - Opts.short 't' <> - Opts.metavar "URL" <> - Opts.help "Used during 'update' when building URL. Occurrences of are replaced with attribute 'foo'." - )) <|> - (("type",) <$> Opts.strOption - ( Opts.long "type" <> - Opts.short 'T' <> - Opts.metavar "TYPE" <> - Opts.help "The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL." - )) - - -- Parse "key=val" into ("key", "val") - parseKeyVal :: String -> Maybe (T.Text, T.Text) - parseKeyVal str = case span (/= '=') str of - (key, '=':val) -> Just (T.pack key, T.pack val) - _ -> Nothing - - -- Shortcuts for common attributes - shortcutAttributes :: Opts.Parser (T.Text, T.Text) - shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$> - [ "branch", "owner", "repo", "version" ] - - -- TODO: infer those shortcuts from 'Update' keys - mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text) - mkShortcutAttribute = \case - attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption - ( Opts.long (T.unpack attr) <> - Opts.short c <> - Opts.metavar (T.unpack $ T.toUpper attr) <> - Opts.help - ( T.unpack $ - "Equivalent to --attribute " <> - attr <> "=<" <> (T.toUpper attr) <> ">" - ) - ) - _ -> empty - - fixupAttributes :: (T.Text, T.Text) -> (T.Text, Aeson.Value) - fixupAttributes (k, v) = (k, Aeson.String v) - -parsePackage :: Opts.Parser (PackageName, PackageSpec) -parsePackage = (,) <$> parsePackageName <*> parsePackageSpec - -------------------------------------------------------------------------------- --- INIT -------------------------------------------------------------------------------- - -parseCmdInit :: Opts.ParserInfo (IO ()) -parseCmdInit = Opts.info (pure cmdInit <**> Opts.helper) $ mconcat desc - where - desc = - [ Opts.fullDesc - , Opts.progDesc - "Initialize a Nix project. Existing files won't be modified." - ] - -cmdInit :: IO () -cmdInit = do - - -- Writes all the default files - -- a path, a "create" function and an update function for each file. - forM_ - [ ( pathNixSourcesNix - , (`createFile` initNixSourcesNixContent) - , \path content -> do - if shouldUpdateNixSourcesNix content - then do - putStrLn "Updating sources.nix" - B.writeFile path initNixSourcesNixContent - else putStrLn "Not updating sources.nix" - ) - , ( pathNixSourcesJson - , \path -> do - createFile path initNixSourcesJsonContent - -- Imports @niv@ and @nixpkgs@ (18.09) - putStrLn "Importing 'niv' ..." - cmdAdd Nothing (PackageName "nmattia/niv", PackageSpec HMS.empty) - putStrLn "Importing 'nixpkgs' ..." - cmdAdd - (Just (PackageName "nixpkgs")) - ( PackageName "NixOS/nixpkgs-channels" - , PackageSpec (HMS.singleton "branch" "nixos-18.09")) - , \path _content -> dontCreateFile path) - ] $ \(path, onCreate, onUpdate) -> do - exists <- Dir.doesFileExist path - if exists then B.readFile path >>= onUpdate path else onCreate path - where - createFile :: FilePath -> B.ByteString -> IO () - createFile path content = do - let dir = takeDirectory path - Dir.createDirectoryIfMissing True dir - putStrLn $ "Creating " <> path - B.writeFile path content - dontCreateFile :: FilePath -> IO () - dontCreateFile path = putStrLn $ "Not creating " <> path - -------------------------------------------------------------------------------- --- ADD -------------------------------------------------------------------------------- - -parseCmdAdd :: Opts.ParserInfo (IO ()) -parseCmdAdd = - Opts.info ((cmdAdd <$> optName <*> parsePackage) <**> Opts.helper) $ - mconcat desc - where - optName :: Opts.Parser (Maybe PackageName) - optName = Opts.optional $ PackageName <$> Opts.strOption - ( Opts.long "name" <> - Opts.short 'n' <> - Opts.metavar "NAME" <> - Opts.help "Set the package name to " - ) - desc = - [ Opts.fullDesc - , Opts.progDesc "Add dependency" - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv add stedolan/jq" Opts.<$$> - " niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09" Opts.<$$> - " niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip" - ] - -cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO () -cmdAdd mPackageName (PackageName str, cliSpec) = do - - -- Figures out the owner and repo - let (packageName, defaultSpec) = case T.span (/= '/') str of - ( owner@(T.null -> False) - , T.uncons -> Just ('/', repo@(T.null -> False))) -> do - (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ]) - _ -> (PackageName str, HMS.empty) - - sources <- unSources <$> getSources - - let packageName' = fromMaybe packageName mPackageName - - when (HMS.member packageName' sources) $ - abortCannotAddPackageExists packageName' - - let defaultSpec' = PackageSpec $ defaultSpec - - spec'' <- attrsToSpec <$> evalUpdate - (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec') - (githubUpdate nixPrefetchURL githubLatestRev githubRepo) - - putStrLn $ "Writing new sources file" - setSources $ Sources $ - HMS.insert packageName' spec'' sources - -------------------------------------------------------------------------------- --- SHOW -------------------------------------------------------------------------------- - -parseCmdShow :: Opts.ParserInfo (IO ()) -parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc - --- TODO: nicer output -cmdShow :: IO () -cmdShow = do - putStrLn $ "Showing sources file" - - sources <- unSources <$> getSources - - forWithKeyM_ sources $ \key (PackageSpec spec) -> do - T.putStrLn $ "Package: " <> unPackageName key - forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do - let attrValue = case attrValValue of - Aeson.String str -> str - _ -> "" - putStrLn $ " " <> T.unpack attrName <> ": " <> T.unpack attrValue - -------------------------------------------------------------------------------- --- UPDATE -------------------------------------------------------------------------------- - -parseCmdUpdate :: Opts.ParserInfo (IO ()) -parseCmdUpdate = - Opts.info - ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $ - mconcat desc - where - desc = - [ Opts.fullDesc - , Opts.progDesc "Update dependencies" - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv update" Opts.<$$> - " niv update nixpkgs" Opts.<$$> - " niv update my-package -v beta-0.2" - ] - -specToFreeAttrs :: PackageSpec -> Attrs -specToFreeAttrs = fmap (Free,) . unPackageSpec - -specToLockedAttrs :: PackageSpec -> Attrs -specToLockedAttrs = fmap (Locked,) . unPackageSpec - --- TODO: sexy logging + concurrent updates -cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO () -cmdUpdate = \case - Just (packageName, packageSpec) -> do - T.putStrLn $ "Updating single package: " <> unPackageName packageName - sources <- unSources <$> getSources - - packageSpec' <- case HMS.lookup packageName sources of - Just packageSpec' -> do - attrsToSpec <$> evalUpdate - (specToLockedAttrs packageSpec <> specToFreeAttrs packageSpec') - (githubUpdate nixPrefetchURL githubLatestRev githubRepo) - - Nothing -> abortCannotUpdateNoSuchPackage packageName - - setSources $ Sources $ - HMS.insert packageName packageSpec' sources - - Nothing -> do - sources <- unSources <$> getSources - - sources' <- forWithKeyM sources $ - \packageName packageSpec -> do - T.putStrLn $ "Package: " <> unPackageName packageName - attrsToSpec <$> evalUpdate - (specToFreeAttrs packageSpec) - (githubUpdate nixPrefetchURL githubLatestRev githubRepo) - - setSources $ Sources sources' - -------------------------------------------------------------------------------- --- DROP -------------------------------------------------------------------------------- - -parseCmdDrop :: Opts.ParserInfo (IO ()) -parseCmdDrop = - Opts.info - ((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**> - Opts.helper) $ - mconcat desc - where - desc = - [ Opts.fullDesc - , Opts.progDesc "Drop dependency" - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv drop jq" Opts.<$$> - " niv drop my-package version" - ] - parseDropAttributes :: Opts.Parser [T.Text] - parseDropAttributes = many $ - Opts.argument Opts.str (Opts.metavar "ATTRIBUTE") - -cmdDrop :: PackageName -> [T.Text] -> IO () -cmdDrop packageName = \case - [] -> do - T.putStrLn $ "Dropping package: " <> unPackageName packageName - sources <- unSources <$> getSources - - when (not $ HMS.member packageName sources) $ - abortCannotDropNoSuchPackage packageName - - setSources $ Sources $ - HMS.delete packageName sources - attrs -> do - putStrLn $ "Dropping attributes :" <> - (T.unpack (T.intercalate " " attrs)) - T.putStrLn $ "In package: " <> unPackageName packageName - sources <- unSources <$> getSources - - packageSpec <- case HMS.lookup packageName sources of - Nothing -> - abortCannotAttributesDropNoSuchPackage packageName - Just (PackageSpec packageSpec) -> pure $ PackageSpec $ - HMS.mapMaybeWithKey - (\k v -> if k `elem` attrs then Nothing else Just v) packageSpec - - setSources $ Sources $ - HMS.insert packageName packageSpec sources - -------------------------------------------------------------------------------- --- Aux -------------------------------------------------------------------------------- - ---- Aeson - --- | Efficiently deserialize a JSON value from a file. --- If this fails due to incomplete or invalid input, 'Nothing' is --- returned. --- --- The input file's content must consist solely of a JSON document, --- with no trailing data except for whitespace. --- --- This function parses immediately, but defers conversion. See --- 'json' for details. -decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) -decodeFileStrict = fmap Aeson.decodeStrict . B.readFile - --- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. -encodeFile :: (ToJSON a) => FilePath -> a -> IO () -encodeFile fp = L.writeFile fp . AesonPretty.encodePretty' config - where - config = AesonPretty.defConfig { AesonPretty.confTrailingNewline = True } - ---- HashMap - -forWithKeyM - :: (Eq k, Hashable k, Monad m) - => HMS.HashMap k v1 - -> (k -> v1 -> m v2) - -> m (HMS.HashMap k v2) -forWithKeyM = flip mapWithKeyM - -forWithKeyM_ - :: (Eq k, Hashable k, Monad m) - => HMS.HashMap k v1 - -> (k -> v1 -> m ()) - -> m () -forWithKeyM_ = flip mapWithKeyM_ - -mapWithKeyM - :: (Eq k, Hashable k, Monad m) - => (k -> v1 -> m v2) - -> HMS.HashMap k v1 - -> m (HMS.HashMap k v2) -mapWithKeyM f m = do - fmap mconcat $ forM (HMS.toList m) $ \(k, v) -> - HMS.singleton k <$> f k v - -mapWithKeyM_ - :: (Eq k, Hashable k, Monad m) - => (k -> v1 -> m ()) - -> HMS.HashMap k v1 - -> m () -mapWithKeyM_ f m = do - forM_ (HMS.toList m) $ \(k, v) -> - HMS.singleton k <$> f k v - -abort :: T.Text -> IO a -abort msg = do - T.putStrLn msg - exitFailure - -nixPrefetchURL :: Bool -> T.Text -> IO T.Text -nixPrefetchURL unpack (T.unpack -> url) = - lines <$> readProcess "nix-prefetch-url" args "" >>= - \case - (l:_) -> pure (T.pack l) - _ -> abortNixPrefetchExpectedOutput - where args = if unpack then ["--unpack", url] else [url] - -------------------------------------------------------------------------------- --- Files and their content -------------------------------------------------------------------------------- - --- | Checks if content is different than default and if it does /not/ contain --- a comment line with @niv: no_update@ -shouldUpdateNixSourcesNix :: B.ByteString -> Bool -shouldUpdateNixSourcesNix content = - content /= initNixSourcesNixContent && - not (any lineForbids (B8.lines content)) - where - lineForbids :: B8.ByteString -> Bool - lineForbids str = - case B8.uncons (B8.dropWhile isSpace str) of - Just ('#',rest) -> case B8.stripPrefix "niv:" (B8.dropWhile isSpace rest) of - Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of - Just{} -> True - _ -> False - _ -> False - _ -> False - -warnIfOutdated :: IO () -warnIfOutdated = do - tryAny (B.readFile pathNixSourcesNix) >>= \case - Left e -> T.putStrLn $ T.unlines - [ "Could not read " <> T.pack pathNixSourcesNix - , "Error: " <> tshow e - ] - Right content -> - if shouldUpdateNixSourcesNix content - then - T.putStrLn $ T.unlines - [ "WARNING: " <> T.pack pathNixSourcesNix <> " is out of date." - , "Please run" - , " niv init" - , "or add the following line in the " <> T.pack pathNixSourcesNix <> " file:" - , " # niv: no_update" - ] - else pure () - --- | @nix/sources.nix@ -pathNixSourcesNix :: FilePath -pathNixSourcesNix = "nix" "sources.nix" - --- | Glue code between nix and sources.json -initNixSourcesNixContent :: B.ByteString -initNixSourcesNixContent = $(embedFile "nix/sources.nix") - --- | @nix/sources.json" -pathNixSourcesJson :: FilePath -pathNixSourcesJson = "nix" "sources.json" - --- | Empty JSON map -initNixSourcesJsonContent :: B.ByteString -initNixSourcesJsonContent = "{}" - -------------------------------------------------------------------------------- --- Warn -------------------------------------------------------------------------------- - -warnCouldNotFetchGitHubRepo :: GH.Error -> (String, String) -> IO () -warnCouldNotFetchGitHubRepo e (owner, repo) = - putStrLn $ unlines [ line1, line2, line3 ] - where - line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo - line2 = [s| -I assumed that your package was a GitHub repository. An error occurred while -gathering information from the repository. Check whether your package was added -correctly: - - niv show - -If not, try re-adding it: - - niv drop - niv add - -Make sure the repository exists. -|] - line3 = unwords [ "(Error was:", show e, ")" ] - -------------------------------------------------------------------------------- --- Abort -------------------------------------------------------------------------------- - -abortSourcesDoesntExist :: IO a -abortSourcesDoesntExist = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = [s| -The sources file does not exist! You may need to run 'niv init'. -|] - -abortSourcesIsntAMap :: IO a -abortSourcesIsntAMap = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = [s| -The sources file should be a JSON map from package name to package -specification, e.g.: - { ... } -|] - -abortAttributeIsntAMap :: IO a -abortAttributeIsntAMap = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = [s| -The package specifications in the sources file should be JSON maps from -attribute name to attribute value, e.g.: - { "nixpkgs": { "foo": "bar" } } -|] - -abortSourcesIsntJSON :: IO a -abortSourcesIsntJSON = abort $ T.unlines [ line1, line2 ] - where - line1 = "Cannot use " <> T.pack pathNixSourcesJson - line2 = "The sources file should be JSON." - -abortCannotAddPackageExists :: PackageName -> IO a -abortCannotAddPackageExists (PackageName n) = abort $ T.unlines - [ "Cannot add package " <> n <> "." - , "The package already exists. Use" - , " niv drop " <> n - , "and then re-add the package. Alternatively use" - , " niv update " <> n <> " --attr foo=bar" - , "to update the package's attributes." - ] - -abortCannotUpdateNoSuchPackage :: PackageName -> IO a -abortCannotUpdateNoSuchPackage (PackageName n) = abort $ T.unlines - [ "Cannot update package " <> n <> "." - , "The package doesn't exist. Use" - , " niv add " <> n - , "to add the package." - ] - -abortCannotDropNoSuchPackage :: PackageName -> IO a -abortCannotDropNoSuchPackage (PackageName n) = abort $ T.unlines - [ "Cannot drop package " <> n <> "." - , "The package doesn't exist." - ] - -abortCannotAttributesDropNoSuchPackage :: PackageName -> IO a -abortCannotAttributesDropNoSuchPackage (PackageName n) = abort $ T.unlines - [ "Cannot drop attributes of package " <> n <> "." - , "The package doesn't exist." - ] - -abortNixPrefetchExpectedOutput :: IO a -abortNixPrefetchExpectedOutput = abort [s| -Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a -ticket: - - https://github.com/nmattia/niv/issues/new - -Thanks! I'll buy you a beer. -|] - -tshow :: Show a => a -> T.Text -tshow = T.pack . show +main = Niv.Cli.cli diff --git a/app/NivTest.hs b/app/NivTest.hs new file mode 100644 index 0000000..1dfa4f6 --- /dev/null +++ b/app/NivTest.hs @@ -0,0 +1,6 @@ +module NivTest where + +import Niv.Test + +main :: IO () +main = Niv.Test.test diff --git a/app/test.hs b/app/test.hs deleted file mode 100644 index 746c742..0000000 --- a/app/test.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Main where - -import Niv.Test -import qualified Test.Tasty as Tasty - -main :: IO () -main = Tasty.defaultMain $ Niv.Test.tests - diff --git a/default.nix b/default.nix index 74791b7..15fc84e 100644 --- a/default.nix +++ b/default.nix @@ -35,7 +35,7 @@ with rec '' repl() { shopt -s globstar - ghci -Wall app/**/*.hs src/**/*.hs + ghci -Wall app/NivTest.hs src/**/*.hs } echo "To start a REPL session, run:" diff --git a/package.yaml b/package.yaml index a524c37..3aff975 100644 --- a/package.yaml +++ b/package.yaml @@ -10,10 +10,22 @@ ghc-options: - -optP-Wno-nonportable-include-path dependencies: + - aeson + - aeson-pretty - base - - text + - bytestring + - directory + - file-embed + - filepath + - github + - hashable - mtl + - optparse-applicative + - process + - string-qq + - text - unliftio + - unordered-containers library: source-dirs: @@ -27,25 +39,15 @@ library: executables: niv: - main: app/niv.hs + main: Niv.main + source-dirs: app data-files: - nix/sources.nix dependencies: - - aeson - - aeson-pretty - - bytestring - - directory - - filepath - - github - - hashable - - file-embed - niv - - optparse-applicative - - process - - string-qq - - unordered-containers niv-test: - main: app/test.hs + main: NivTest.main + source-dirs: app dependencies: - tasty - niv diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs new file mode 100644 index 0000000..baa468d --- /dev/null +++ b/src/Niv/Cli.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Niv.Cli where + +import Control.Applicative +import Control.Monad +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.=)) +import Data.Char (isSpace) +import Data.FileEmbed (embedFile) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.String.QQ (s) +import Niv.GitHub +import Niv.Update +import System.Exit (exitFailure) +import System.FilePath ((), takeDirectory) +import System.Process (readProcess) +import UnliftIO +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as AesonPretty +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HMS +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified GitHub as GH +import qualified Options.Applicative as Opts +import qualified Options.Applicative.Help.Pretty as Opts +import qualified System.Directory as Dir + +cli :: IO () +cli = join $ Opts.execParser opts + where + opts = Opts.info (parseCommand <**> Opts.helper) $ mconcat desc + desc = + [ Opts.fullDesc + , Opts.header "NIV - Version manager for Nix projects" + ] + +parseCommand :: Opts.Parser (IO ()) +parseCommand = Opts.subparser ( + Opts.command "init" parseCmdInit <> + Opts.command "add" parseCmdAdd <> + Opts.command "show" parseCmdShow <> + Opts.command "update" parseCmdUpdate <> + Opts.command "drop" parseCmdDrop ) + +newtype Sources = Sources + { unSources :: HMS.HashMap PackageName PackageSpec } + deriving newtype (FromJSON, ToJSON) + +getSources :: IO Sources +getSources = do + exists <- Dir.doesFileExist pathNixSourcesJson + unless exists abortSourcesDoesntExist + + warnIfOutdated + -- TODO: if doesn't exist: run niv init + putStrLn $ "Reading sources file" + decodeFileStrict pathNixSourcesJson >>= \case + Just (Aeson.Object obj) -> + fmap (Sources . mconcat) $ + forM (HMS.toList obj) $ \(k, v) -> + case v of + Aeson.Object v' -> + pure $ HMS.singleton (PackageName k) (PackageSpec v') + _ -> abortAttributeIsntAMap + Just _ -> abortSourcesIsntAMap + Nothing -> abortSourcesIsntJSON + +setSources :: Sources -> IO () +setSources sources = encodeFile pathNixSourcesJson sources + +newtype PackageName = PackageName { unPackageName :: T.Text } + deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) + +parsePackageName :: Opts.Parser PackageName +parsePackageName = PackageName <$> + Opts.argument Opts.str (Opts.metavar "PACKAGE") + +newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } + deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) + +-- | Simply discards the 'Freedom' +attrsToSpec :: Attrs -> PackageSpec +attrsToSpec = PackageSpec . dropNulls . fmap snd + where + dropNulls + :: HMS.HashMap T.Text Aeson.Value + -> HMS.HashMap T.Text Aeson.Value + dropNulls = HMS.mapMaybe $ \case + x@Aeson.Object{} -> Just x + x@Aeson.Array{} -> Just x + x@Aeson.String{} -> Just x + x@Aeson.Number{} -> Just x + x@Aeson.Bool{} -> Just x + Aeson.Null -> Nothing + + +parsePackageSpec :: Opts.Parser PackageSpec +parsePackageSpec = + (PackageSpec . HMS.fromList . fmap fixupAttributes) <$> + many parseAttribute + where + parseAttribute :: Opts.Parser (T.Text, T.Text) + parseAttribute = + Opts.option (Opts.maybeReader parseKeyVal) + ( Opts.long "attribute" <> + Opts.short 'a' <> + Opts.metavar "KEY=VAL" <> + Opts.help "Set the package spec attribute to " + ) <|> shortcutAttributes <|> + (("url_template",) <$> Opts.strOption + ( Opts.long "template" <> + Opts.short 't' <> + Opts.metavar "URL" <> + Opts.help "Used during 'update' when building URL. Occurrences of are replaced with attribute 'foo'." + )) <|> + (("type",) <$> Opts.strOption + ( Opts.long "type" <> + Opts.short 'T' <> + Opts.metavar "TYPE" <> + Opts.help "The type of the URL target. The value can be either 'file' or 'tarball'. If not set, the value is inferred from the suffix of the URL." + )) + + -- Parse "key=val" into ("key", "val") + parseKeyVal :: String -> Maybe (T.Text, T.Text) + parseKeyVal str = case span (/= '=') str of + (key, '=':val) -> Just (T.pack key, T.pack val) + _ -> Nothing + + -- Shortcuts for common attributes + shortcutAttributes :: Opts.Parser (T.Text, T.Text) + shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$> + [ "branch", "owner", "repo", "version" ] + + -- TODO: infer those shortcuts from 'Update' keys + mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, T.Text) + mkShortcutAttribute = \case + attr@(T.uncons -> Just (c,_)) -> (attr,) <$> Opts.strOption + ( Opts.long (T.unpack attr) <> + Opts.short c <> + Opts.metavar (T.unpack $ T.toUpper attr) <> + Opts.help + ( T.unpack $ + "Equivalent to --attribute " <> + attr <> "=<" <> (T.toUpper attr) <> ">" + ) + ) + _ -> empty + + fixupAttributes :: (T.Text, T.Text) -> (T.Text, Aeson.Value) + fixupAttributes (k, v) = (k, Aeson.String v) + +parsePackage :: Opts.Parser (PackageName, PackageSpec) +parsePackage = (,) <$> parsePackageName <*> parsePackageSpec + +------------------------------------------------------------------------------- +-- INIT +------------------------------------------------------------------------------- + +parseCmdInit :: Opts.ParserInfo (IO ()) +parseCmdInit = Opts.info (pure cmdInit <**> Opts.helper) $ mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc + "Initialize a Nix project. Existing files won't be modified." + ] + +cmdInit :: IO () +cmdInit = do + + -- Writes all the default files + -- a path, a "create" function and an update function for each file. + forM_ + [ ( pathNixSourcesNix + , (`createFile` initNixSourcesNixContent) + , \path content -> do + if shouldUpdateNixSourcesNix content + then do + putStrLn "Updating sources.nix" + B.writeFile path initNixSourcesNixContent + else putStrLn "Not updating sources.nix" + ) + , ( pathNixSourcesJson + , \path -> do + createFile path initNixSourcesJsonContent + -- Imports @niv@ and @nixpkgs@ (18.09) + putStrLn "Importing 'niv' ..." + cmdAdd Nothing (PackageName "nmattia/niv", PackageSpec HMS.empty) + putStrLn "Importing 'nixpkgs' ..." + cmdAdd + (Just (PackageName "nixpkgs")) + ( PackageName "NixOS/nixpkgs-channels" + , PackageSpec (HMS.singleton "branch" "nixos-18.09")) + , \path _content -> dontCreateFile path) + ] $ \(path, onCreate, onUpdate) -> do + exists <- Dir.doesFileExist path + if exists then B.readFile path >>= onUpdate path else onCreate path + where + createFile :: FilePath -> B.ByteString -> IO () + createFile path content = do + let dir = takeDirectory path + Dir.createDirectoryIfMissing True dir + putStrLn $ "Creating " <> path + B.writeFile path content + dontCreateFile :: FilePath -> IO () + dontCreateFile path = putStrLn $ "Not creating " <> path + +------------------------------------------------------------------------------- +-- ADD +------------------------------------------------------------------------------- + +parseCmdAdd :: Opts.ParserInfo (IO ()) +parseCmdAdd = + Opts.info ((cmdAdd <$> optName <*> parsePackage) <**> Opts.helper) $ + mconcat desc + where + optName :: Opts.Parser (Maybe PackageName) + optName = Opts.optional $ PackageName <$> Opts.strOption + ( Opts.long "name" <> + Opts.short 'n' <> + Opts.metavar "NAME" <> + Opts.help "Set the package name to " + ) + desc = + [ Opts.fullDesc + , Opts.progDesc "Add dependency" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv add stedolan/jq" Opts.<$$> + " niv add NixOS/nixpkgs-channels -n nixpkgs -b nixos-18.09" Opts.<$$> + " niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip" + ] + +cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO () +cmdAdd mPackageName (PackageName str, cliSpec) = do + + -- Figures out the owner and repo + let (packageName, defaultSpec) = case T.span (/= '/') str of + ( owner@(T.null -> False) + , T.uncons -> Just ('/', repo@(T.null -> False))) -> do + (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ]) + _ -> (PackageName str, HMS.empty) + + sources <- unSources <$> getSources + + let packageName' = fromMaybe packageName mPackageName + + when (HMS.member packageName' sources) $ + abortCannotAddPackageExists packageName' + + let defaultSpec' = PackageSpec $ defaultSpec + + finalSpec <- attrsToSpec <$> evalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec') + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + putStrLn $ "Writing new sources file" + setSources $ Sources $ + HMS.insert packageName' finalSpec sources + +------------------------------------------------------------------------------- +-- SHOW +------------------------------------------------------------------------------- + +parseCmdShow :: Opts.ParserInfo (IO ()) +parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc + +-- TODO: nicer output +cmdShow :: IO () +cmdShow = do + putStrLn $ "Showing sources file" + + sources <- unSources <$> getSources + + forWithKeyM_ sources $ \key (PackageSpec spec) -> do + T.putStrLn $ "Package: " <> unPackageName key + forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do + let attrValue = case attrValValue of + Aeson.String str -> str + _ -> "" + putStrLn $ " " <> T.unpack attrName <> ": " <> T.unpack attrValue + +------------------------------------------------------------------------------- +-- UPDATE +------------------------------------------------------------------------------- + +parseCmdUpdate :: Opts.ParserInfo (IO ()) +parseCmdUpdate = + Opts.info + ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $ + mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc "Update dependencies" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv update" Opts.<$$> + " niv update nixpkgs" Opts.<$$> + " niv update my-package -v beta-0.2" + ] + +specToFreeAttrs :: PackageSpec -> Attrs +specToFreeAttrs = fmap (Free,) . unPackageSpec + +specToLockedAttrs :: PackageSpec -> Attrs +specToLockedAttrs = fmap (Locked,) . unPackageSpec + +-- TODO: sexy logging + concurrent updates +cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO () +cmdUpdate = \case + Just (packageName, cliSpec) -> do + T.putStrLn $ "Updating single package: " <> unPackageName packageName + sources <- unSources <$> getSources + + finalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> do + attrsToSpec <$> evalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + Nothing -> abortCannotUpdateNoSuchPackage packageName + + setSources $ Sources $ + HMS.insert packageName finalSpec sources + + Nothing -> do + sources <- unSources <$> getSources + + sources' <- forWithKeyM sources $ + \packageName defaultSpec -> do + T.putStrLn $ "Package: " <> unPackageName packageName + attrsToSpec <$> evalUpdate + (specToFreeAttrs defaultSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) + + setSources $ Sources sources' + +------------------------------------------------------------------------------- +-- DROP +------------------------------------------------------------------------------- + +parseCmdDrop :: Opts.ParserInfo (IO ()) +parseCmdDrop = + Opts.info + ((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**> + Opts.helper) $ + mconcat desc + where + desc = + [ Opts.fullDesc + , Opts.progDesc "Drop dependency" + , Opts.headerDoc $ Just $ + "Examples:" Opts.<$$> + "" Opts.<$$> + " niv drop jq" Opts.<$$> + " niv drop my-package version" + ] + parseDropAttributes :: Opts.Parser [T.Text] + parseDropAttributes = many $ + Opts.argument Opts.str (Opts.metavar "ATTRIBUTE") + +cmdDrop :: PackageName -> [T.Text] -> IO () +cmdDrop packageName = \case + [] -> do + T.putStrLn $ "Dropping package: " <> unPackageName packageName + sources <- unSources <$> getSources + + when (not $ HMS.member packageName sources) $ + abortCannotDropNoSuchPackage packageName + + setSources $ Sources $ + HMS.delete packageName sources + attrs -> do + putStrLn $ "Dropping attributes :" <> + (T.unpack (T.intercalate " " attrs)) + T.putStrLn $ "In package: " <> unPackageName packageName + sources <- unSources <$> getSources + + packageSpec <- case HMS.lookup packageName sources of + Nothing -> + abortCannotAttributesDropNoSuchPackage packageName + Just (PackageSpec packageSpec) -> pure $ PackageSpec $ + HMS.mapMaybeWithKey + (\k v -> if k `elem` attrs then Nothing else Just v) packageSpec + + setSources $ Sources $ + HMS.insert packageName packageSpec sources + +------------------------------------------------------------------------------- +-- Aux +------------------------------------------------------------------------------- + +--- Aeson + +-- | Efficiently deserialize a JSON value from a file. +-- If this fails due to incomplete or invalid input, 'Nothing' is +-- returned. +-- +-- The input file's content must consist solely of a JSON document, +-- with no trailing data except for whitespace. +-- +-- This function parses immediately, but defers conversion. See +-- 'json' for details. +decodeFileStrict :: (FromJSON a) => FilePath -> IO (Maybe a) +decodeFileStrict = fmap Aeson.decodeStrict . B.readFile + +-- | Efficiently serialize a JSON value as a lazy 'L.ByteString' and write it to a file. +encodeFile :: (ToJSON a) => FilePath -> a -> IO () +encodeFile fp = L.writeFile fp . AesonPretty.encodePretty' config + where + config = AesonPretty.defConfig { AesonPretty.confTrailingNewline = True } + +--- HashMap + +forWithKeyM + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m v2) + -> m (HMS.HashMap k v2) +forWithKeyM = flip mapWithKeyM + +forWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => HMS.HashMap k v1 + -> (k -> v1 -> m ()) + -> m () +forWithKeyM_ = flip mapWithKeyM_ + +mapWithKeyM + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m v2) + -> HMS.HashMap k v1 + -> m (HMS.HashMap k v2) +mapWithKeyM f m = do + fmap mconcat $ forM (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v + +mapWithKeyM_ + :: (Eq k, Hashable k, Monad m) + => (k -> v1 -> m ()) + -> HMS.HashMap k v1 + -> m () +mapWithKeyM_ f m = do + forM_ (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v + +abort :: T.Text -> IO a +abort msg = do + T.putStrLn msg + exitFailure + +nixPrefetchURL :: Bool -> T.Text -> IO T.Text +nixPrefetchURL unpack (T.unpack -> url) = + lines <$> readProcess "nix-prefetch-url" args "" >>= + \case + (l:_) -> pure (T.pack l) + _ -> abortNixPrefetchExpectedOutput + where args = if unpack then ["--unpack", url] else [url] + +------------------------------------------------------------------------------- +-- Files and their content +------------------------------------------------------------------------------- + +-- | Checks if content is different than default and if it does /not/ contain +-- a comment line with @niv: no_update@ +shouldUpdateNixSourcesNix :: B.ByteString -> Bool +shouldUpdateNixSourcesNix content = + content /= initNixSourcesNixContent && + not (any lineForbids (B8.lines content)) + where + lineForbids :: B8.ByteString -> Bool + lineForbids str = + case B8.uncons (B8.dropWhile isSpace str) of + Just ('#',rest) -> case B8.stripPrefix "niv:" (B8.dropWhile isSpace rest) of + Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of + Just{} -> True + _ -> False + _ -> False + _ -> False + +warnIfOutdated :: IO () +warnIfOutdated = do + tryAny (B.readFile pathNixSourcesNix) >>= \case + Left e -> T.putStrLn $ T.unlines + [ "Could not read " <> T.pack pathNixSourcesNix + , "Error: " <> tshow e + ] + Right content -> + if shouldUpdateNixSourcesNix content + then + T.putStrLn $ T.unlines + [ "WARNING: " <> T.pack pathNixSourcesNix <> " is out of date." + , "Please run" + , " niv init" + , "or add the following line in the " <> T.pack pathNixSourcesNix <> " file:" + , " # niv: no_update" + ] + else pure () + +-- | @nix/sources.nix@ +pathNixSourcesNix :: FilePath +pathNixSourcesNix = "nix" "sources.nix" + +-- | Glue code between nix and sources.json +initNixSourcesNixContent :: B.ByteString +initNixSourcesNixContent = $(embedFile "nix/sources.nix") + +-- | @nix/sources.json" +pathNixSourcesJson :: FilePath +pathNixSourcesJson = "nix" "sources.json" + +-- | Empty JSON map +initNixSourcesJsonContent :: B.ByteString +initNixSourcesJsonContent = "{}" + +------------------------------------------------------------------------------- +-- Warn +------------------------------------------------------------------------------- + +warnCouldNotFetchGitHubRepo :: GH.Error -> (String, String) -> IO () +warnCouldNotFetchGitHubRepo e (owner, repo) = + putStrLn $ unlines [ line1, line2, line3 ] + where + line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo + line2 = [s| +I assumed that your package was a GitHub repository. An error occurred while +gathering information from the repository. Check whether your package was added +correctly: + + niv show + +If not, try re-adding it: + + niv drop + niv add + +Make sure the repository exists. +|] + line3 = unwords [ "(Error was:", show e, ")" ] + +------------------------------------------------------------------------------- +-- Abort +------------------------------------------------------------------------------- + +abortSourcesDoesntExist :: IO a +abortSourcesDoesntExist = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The sources file does not exist! You may need to run 'niv init'. +|] + +abortSourcesIsntAMap :: IO a +abortSourcesIsntAMap = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The sources file should be a JSON map from package name to package +specification, e.g.: + { ... } +|] + +abortAttributeIsntAMap :: IO a +abortAttributeIsntAMap = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = [s| +The package specifications in the sources file should be JSON maps from +attribute name to attribute value, e.g.: + { "nixpkgs": { "foo": "bar" } } +|] + +abortSourcesIsntJSON :: IO a +abortSourcesIsntJSON = abort $ T.unlines [ line1, line2 ] + where + line1 = "Cannot use " <> T.pack pathNixSourcesJson + line2 = "The sources file should be JSON." + +abortCannotAddPackageExists :: PackageName -> IO a +abortCannotAddPackageExists (PackageName n) = abort $ T.unlines + [ "Cannot add package " <> n <> "." + , "The package already exists. Use" + , " niv drop " <> n + , "and then re-add the package. Alternatively use" + , " niv update " <> n <> " --attr foo=bar" + , "to update the package's attributes." + ] + +abortCannotUpdateNoSuchPackage :: PackageName -> IO a +abortCannotUpdateNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot update package " <> n <> "." + , "The package doesn't exist. Use" + , " niv add " <> n + , "to add the package." + ] + +abortCannotDropNoSuchPackage :: PackageName -> IO a +abortCannotDropNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot drop package " <> n <> "." + , "The package doesn't exist." + ] + +abortCannotAttributesDropNoSuchPackage :: PackageName -> IO a +abortCannotAttributesDropNoSuchPackage (PackageName n) = abort $ T.unlines + [ "Cannot drop attributes of package " <> n <> "." + , "The package doesn't exist." + ] + +abortNixPrefetchExpectedOutput :: IO a +abortNixPrefetchExpectedOutput = abort [s| +Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a +ticket: + + https://github.com/nmattia/niv/issues/new + +Thanks! I'll buy you a beer. +|] + +tshow :: Show a => a -> T.Text +tshow = T.pack . show diff --git a/src/Niv/Test.hs b/src/Niv/Test.hs index 27be54d..ee6c76d 100644 --- a/src/Niv/Test.hs +++ b/src/Niv/Test.hs @@ -1,10 +1,13 @@ -module Niv.Test (tests) where +module Niv.Test (tests, test) where import Niv.GitHub.Test import Niv.Update.Test import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty +test :: IO () +test = Tasty.defaultMain tests + tests :: Tasty.TestTree tests = Tasty.testGroup "niv" [ Tasty.testGroup "update"