1
1
mirror of https://github.com/nmattia/niv.git synced 2024-11-07 22:36:53 +03:00

Fight cabal

This commit is contained in:
Nicolas Mattia 2019-06-12 15:58:10 +02:00
parent cd066313ca
commit 7bc9e797f8
7 changed files with 665 additions and 656 deletions

View File

@ -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 <KEY> to <VAL>"
) <|> shortcutAttributes <|>
(("url_template",) <$> 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",) <$> 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 <NAME>"
)
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/<version>.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
_ -> "<barabajagal>"
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 <package>
niv add <package-without-typo>
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

6
app/NivTest.hs Normal file
View File

@ -0,0 +1,6 @@
module NivTest where
import Niv.Test
main :: IO ()
main = Niv.Test.test

View File

@ -1,8 +0,0 @@
module Main where
import Niv.Test
import qualified Test.Tasty as Tasty
main :: IO ()
main = Tasty.defaultMain $ Niv.Test.tests

View File

@ -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:"

View File

@ -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

634
src/Niv/Cli.hs Normal file
View File

@ -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 <KEY> to <VAL>"
) <|> shortcutAttributes <|>
(("url_template",) <$> 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",) <$> 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 <NAME>"
)
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/<version>.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
_ -> "<barabajagal>"
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 <package>
niv add <package-without-typo>
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

View File

@ -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"