mirror of
https://github.com/nmattia/niv.git
synced 2024-07-08 20:16:30 +03:00
Fight cabal
This commit is contained in:
Nicolas Mattia
parent
cd066313ca
commit
7bc9e797f8
634
app/Niv.hs
634
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 <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
6
app/NivTest.hs
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
module NivTest where
|
||||
|
||||
import Niv.Test
|
||||
|
||||
main :: IO ()
|
||||
main = Niv.Test.test
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
module Main where
|
||||
|
||||
import Niv.Test
|
||||
import qualified Test.Tasty as Tasty
|
||||
|
||||
main :: IO ()
|
||||
main = Tasty.defaultMain $ Niv.Test.tests
|
||||
|
||||
|
|
@ -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:"
|
||||
|
|
|
|||
32
package.yaml
32
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
|
||||
|
|
|
|||
634
src/Niv/Cli.hs
Normal file
634
src/Niv/Cli.hs
Normal 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
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user