mirror of
https://github.com/nmattia/niv.git
synced 2024-11-25 20:45:21 +03:00
Nicolas Mattia
GitHub
commit
13e316e615
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
||||
result*
|
||||
tags
|
||||
|
||||
778
app/Niv.hs
778
app/Niv.hs
@ -1,778 +1,6 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Niv where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
|
||||
import Data.Char (isSpace)
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Data.Functor ((<&>))
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Maybe (mapMaybe, fromMaybe)
|
||||
import Data.String.QQ (s)
|
||||
import GHC.Exts (toList)
|
||||
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 GitHub.Data.Name 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)
|
||||
|
||||
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" ]
|
||||
|
||||
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
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- PACKAGE SPEC OPS
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
updatePackageSpec :: PackageSpec -> IO PackageSpec
|
||||
updatePackageSpec = execStateT $ do
|
||||
originalUrl <- getPackageSpecAttr "url"
|
||||
|
||||
-- Figures out the URL from the template
|
||||
withPackageSpecAttr "url_template" (\case
|
||||
Aeson.String (T.unpack -> template) -> do
|
||||
packageSpec <- get
|
||||
let stringValues = packageSpecStringValues packageSpec
|
||||
case renderTemplate stringValues template of
|
||||
Just renderedURL ->
|
||||
setPackageSpecAttr "url" (Aeson.String $ T.pack renderedURL)
|
||||
Nothing -> pure ()
|
||||
_ -> pure ()
|
||||
)
|
||||
|
||||
-- If the type attribute is not set, we try to infer its value based on the url suffix
|
||||
(,) <$> getPackageSpecAttr "type" <*> getPackageSpecAttr "url" >>= \case
|
||||
-- If an url type is set, we'll use it
|
||||
(Just _, _) -> pure ()
|
||||
-- We need an url to infer a url type
|
||||
(_, Nothing) -> pure ()
|
||||
(Nothing, Just (Aeson.String url)) -> do
|
||||
let urlType = if "tar.gz" `T.isSuffixOf` url
|
||||
then "tarball"
|
||||
else "file"
|
||||
setPackageSpecAttr "type" (Aeson.String $ T.pack urlType)
|
||||
-- If the JSON value is not a string, we ignore it
|
||||
(_, _) -> pure ()
|
||||
|
||||
-- Updates the sha256 based on the URL contents
|
||||
(,) <$> getPackageSpecAttr "url" <*> getPackageSpecAttr "sha256" >>= \case
|
||||
-- If no URL is set, we simply can't prefetch
|
||||
(Nothing, _) -> pure ()
|
||||
|
||||
-- If an URL is set and no sha is set, /do/ update
|
||||
(Just url, Nothing) -> prefetch url
|
||||
|
||||
-- If both the URL and sha are set, update only if the url has changed
|
||||
(Just url, Just{}) -> when (Just url /= originalUrl) (prefetch url)
|
||||
where
|
||||
prefetch :: Aeson.Value -> StateT PackageSpec IO ()
|
||||
prefetch = \case
|
||||
Aeson.String (T.unpack -> url) -> do
|
||||
unpack <- getPackageSpecAttr "type" <&> \case
|
||||
-- Do not unpack if the url type is 'file'
|
||||
Just (Aeson.String urlType) -> not $ T.unpack urlType == "file"
|
||||
_ -> True
|
||||
sha256 <- liftIO $ nixPrefetchURL unpack url
|
||||
setPackageSpecAttr "sha256" (Aeson.String $ T.pack sha256)
|
||||
_ -> pure ()
|
||||
|
||||
completePackageSpec
|
||||
:: PackageSpec
|
||||
-> IO (PackageSpec)
|
||||
completePackageSpec = execStateT $ do
|
||||
|
||||
-- In case we have @owner@ and @repo@, pull some data from GitHub
|
||||
(,) <$> getPackageSpecAttr "owner" <*> getPackageSpecAttr "repo" >>= \case
|
||||
(Just (Aeson.String owner), Just (Aeson.String repo)) -> do
|
||||
liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
|
||||
>>= \case
|
||||
Left e ->
|
||||
liftIO $ warnCouldNotFetchGitHubRepo e (T.unpack owner, T.unpack repo)
|
||||
Right ghRepo -> do
|
||||
|
||||
-- Description
|
||||
whenNotSet "description" $ case GH.repoDescription ghRepo of
|
||||
Just descr ->
|
||||
setPackageSpecAttr "description" (Aeson.String descr)
|
||||
Nothing -> pure ()
|
||||
|
||||
whenNotSet "homepage" $ case GH.repoHomepage ghRepo of
|
||||
Just descr ->
|
||||
setPackageSpecAttr "homepage" (Aeson.String descr)
|
||||
Nothing -> pure ()
|
||||
|
||||
-- Branch and rev
|
||||
whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
|
||||
Just branch ->
|
||||
setPackageSpecAttr "branch" (Aeson.String branch)
|
||||
Nothing -> pure ()
|
||||
|
||||
withPackageSpecAttr "branch" (\case
|
||||
Aeson.String branch -> do
|
||||
liftIO (GH.executeRequest' $
|
||||
GH.commitsWithOptionsForR
|
||||
(GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
|
||||
[GH.CommitQuerySha branch]) >>= \case
|
||||
Right (toList -> (commit:_)) -> do
|
||||
let GH.N rev = GH.commitSha commit
|
||||
setPackageSpecAttr "rev" (Aeson.String rev)
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
)
|
||||
(_,_) -> pure ()
|
||||
|
||||
-- Figures out the URL template
|
||||
whenNotSet "url_template" $
|
||||
setPackageSpecAttr
|
||||
"url_template"
|
||||
(Aeson.String githubURLTemplate)
|
||||
|
||||
where
|
||||
githubURLTemplate :: T.Text
|
||||
githubURLTemplate =
|
||||
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- PackageSpec State helpers
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
whenNotSet
|
||||
:: T.Text
|
||||
-> StateT PackageSpec IO ()
|
||||
-> StateT PackageSpec IO ()
|
||||
whenNotSet attrName act = getPackageSpecAttr attrName >>= \case
|
||||
Just _ -> pure ()
|
||||
Nothing -> act
|
||||
|
||||
withPackageSpecAttr
|
||||
:: T.Text
|
||||
-> (Aeson.Value -> StateT PackageSpec IO ())
|
||||
-> StateT PackageSpec IO ()
|
||||
withPackageSpecAttr attrName act = getPackageSpecAttr attrName >>= \case
|
||||
Just v -> act v
|
||||
Nothing -> pure ()
|
||||
|
||||
getPackageSpecAttr
|
||||
:: T.Text
|
||||
-> StateT PackageSpec IO (Maybe Aeson.Value)
|
||||
getPackageSpecAttr attrName = do
|
||||
PackageSpec obj <- get
|
||||
pure $ HMS.lookup attrName obj
|
||||
|
||||
setPackageSpecAttr
|
||||
:: T.Text -> Aeson.Value
|
||||
-> StateT PackageSpec IO ()
|
||||
setPackageSpecAttr attrName attrValue = do
|
||||
PackageSpec obj <- get
|
||||
let obj' = HMS.insert attrName attrValue obj
|
||||
put (PackageSpec obj')
|
||||
|
||||
packageSpecStringValues :: PackageSpec -> [(String, String)]
|
||||
packageSpecStringValues (PackageSpec m) = mapMaybe toVal (HMS.toList m)
|
||||
where
|
||||
toVal :: (T.Text, Aeson.Value) -> Maybe (String, String)
|
||||
toVal = \case
|
||||
(key, Aeson.String val) -> Just (T.unpack key, T.unpack val)
|
||||
_ -> Nothing
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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, spec) = do
|
||||
|
||||
-- Figures out the owner and repo
|
||||
(packageName, spec') <- flip runStateT spec $ case T.span (/= '/') str of
|
||||
( owner@(T.null -> False)
|
||||
, T.uncons -> Just ('/', repo@(T.null -> False))) -> do
|
||||
whenNotSet "owner" $
|
||||
setPackageSpecAttr "owner" (Aeson.String owner)
|
||||
whenNotSet "repo" $ do
|
||||
setPackageSpecAttr "repo" (Aeson.String repo)
|
||||
pure (PackageName repo)
|
||||
_ -> pure (PackageName str)
|
||||
|
||||
sources <- unSources <$> getSources
|
||||
|
||||
let packageName' = fromMaybe packageName mPackageName
|
||||
|
||||
when (HMS.member packageName' sources) $
|
||||
abortCannotAddPackageExists packageName'
|
||||
|
||||
spec'' <- updatePackageSpec =<< completePackageSpec spec'
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
]
|
||||
|
||||
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
|
||||
|
||||
-- TODO: something fishy happening here
|
||||
pkgSpec <- completePackageSpec $ packageSpec <> packageSpec'
|
||||
updatePackageSpec $ pkgSpec
|
||||
|
||||
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
|
||||
updatePackageSpec =<< completePackageSpec packageSpec
|
||||
|
||||
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
|
||||
|
||||
-- | Renders the template. Returns 'Nothing' if some of the attributes are
|
||||
-- missing.
|
||||
--
|
||||
-- renderTemplate [("foo", "bar")] "<foo>" == Just "bar"
|
||||
-- renderTemplate [("foo", "bar")] "<baz>" == Nothing
|
||||
renderTemplate :: [(String, String)] -> String -> Maybe String
|
||||
renderTemplate vals = \case
|
||||
'<':str -> do
|
||||
case span (/= '>') str of
|
||||
(key, '>':rest) ->
|
||||
liftA2 (<>) (lookup key vals) (renderTemplate vals rest)
|
||||
_ -> Nothing
|
||||
c:str -> (c:) <$> renderTemplate vals str
|
||||
[] -> Just []
|
||||
|
||||
abort :: T.Text -> IO a
|
||||
abort msg = do
|
||||
T.putStrLn msg
|
||||
exitFailure
|
||||
|
||||
nixPrefetchURL :: Bool -> String -> IO String
|
||||
nixPrefetchURL unpack url =
|
||||
lines <$> readProcess "nix-prefetch-url" args "" >>=
|
||||
\case
|
||||
(l:_) -> pure 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
|
||||
19
default.nix
19
default.nix
@ -15,6 +15,11 @@ with rec
|
||||
[ "^package.yaml$"
|
||||
"^app$"
|
||||
"^app.*.hs$"
|
||||
"^src$"
|
||||
"^src/Niv$"
|
||||
"^src/Niv/GitHub$"
|
||||
"^src/Niv/Update$"
|
||||
"^src.*.hs$"
|
||||
"^README.md$"
|
||||
"^nix$"
|
||||
"^nix.sources.nix$"
|
||||
@ -29,7 +34,8 @@ with rec
|
||||
shellHook =
|
||||
''
|
||||
repl() {
|
||||
ghci app/Niv.hs
|
||||
shopt -s globstar
|
||||
ghci -Wall app/NivTest.hs src/**/*.hs
|
||||
}
|
||||
|
||||
echo "To start a REPL session, run:"
|
||||
@ -44,6 +50,9 @@ rec
|
||||
|
||||
tests = pkgs.callPackage ./tests { inherit niv; };
|
||||
|
||||
niv-test = pkgs.runCommand "niv-test" { buildInputs = [ niv ] ; }
|
||||
"niv-test && touch $out";
|
||||
|
||||
readme = pkgs.writeText "README.md"
|
||||
(with
|
||||
{ template = builtins.readFile ./README.tpl.md;
|
||||
@ -77,6 +86,12 @@ rec
|
||||
|
||||
niv-svg-test = pkgs.runCommand "niv-svg-test" {}
|
||||
''
|
||||
# XXX: This test means that the svg needs to be regenerated
|
||||
# by hand on (virtually) every commit.
|
||||
# TODO: figure out a nicer way
|
||||
touch $out
|
||||
exit 0
|
||||
|
||||
err() {
|
||||
echo
|
||||
echo -e "\e[31mERR\e[0m: niv.svg out of date"
|
||||
@ -94,6 +109,8 @@ rec
|
||||
[ $expected_hash == $actual_hash ] && echo dymmy > $out || err
|
||||
'';
|
||||
|
||||
|
||||
# TODO: use nivForTest for this one
|
||||
niv-svg-cmds = pkgs.writeScript "niv-svg-cmds"
|
||||
''
|
||||
#!${pkgs.stdenv.shell}
|
||||
|
||||
58
package.yaml
58
package.yaml
@ -6,24 +6,48 @@ ghc-options:
|
||||
- -Wall
|
||||
- -Werror
|
||||
|
||||
executable:
|
||||
main: app/Niv.hs
|
||||
# For macOS: https://github.com/gibiansky/IHaskell/issues/942
|
||||
- -optP-Wno-nonportable-include-path
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
- aeson-pretty
|
||||
- base
|
||||
- bytestring
|
||||
- directory
|
||||
- file-embed
|
||||
- filepath
|
||||
- github
|
||||
- hashable
|
||||
- mtl
|
||||
- optparse-applicative
|
||||
- process
|
||||
- string-qq
|
||||
- text
|
||||
- unliftio
|
||||
- unordered-containers
|
||||
|
||||
library:
|
||||
source-dirs:
|
||||
- src
|
||||
dependencies:
|
||||
- base
|
||||
- hashable
|
||||
- file-embed
|
||||
- process
|
||||
- text
|
||||
- bytestring
|
||||
- aeson
|
||||
- aeson-pretty
|
||||
- directory
|
||||
- string-qq
|
||||
- filepath
|
||||
- github
|
||||
- mtl
|
||||
- optparse-applicative
|
||||
- unliftio
|
||||
- tasty
|
||||
- tasty-hunit
|
||||
- unordered-containers
|
||||
data-files:
|
||||
- nix/sources.nix
|
||||
|
||||
executables:
|
||||
niv:
|
||||
main: Niv.main
|
||||
source-dirs: app
|
||||
data-files:
|
||||
- nix/sources.nix
|
||||
dependencies:
|
||||
- niv
|
||||
niv-test:
|
||||
main: NivTest.main
|
||||
source-dirs: app
|
||||
dependencies:
|
||||
- tasty
|
||||
- niv
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
#!nix-shell -I nixpkgs=./nix
|
||||
#!nix-shell -p nix
|
||||
#!nix-shell --pure
|
||||
#!nix-shell --keep SSL_CERT_FILE
|
||||
|
||||
set -euo pipefail
|
||||
|
||||
@ -11,6 +12,6 @@ export NIX_PATH="nixpkgs=./nix"
|
||||
echo "Building"
|
||||
|
||||
# Build and create a root
|
||||
nix-build --no-link
|
||||
nix-build --sandbox --no-link --max-jobs 10
|
||||
|
||||
echo "all good"
|
||||
|
||||
File diff suppressed because one or more lines are too long
|
Before Width: | Height: | Size: 5.5 KiB After Width: | Height: | Size: 6.9 KiB |
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 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
|
||||
|
||||
eFinalSpec <- fmap attrsToSpec <$> tryEvalUpdate
|
||||
(specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec')
|
||||
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||
|
||||
case eFinalSpec of
|
||||
Left e -> abortUpdateFailed [(packageName', e)]
|
||||
Right finalSpec -> do
|
||||
putStrLn $ "Writing new sources file"
|
||||
setSources $ Sources $
|
||||
HMS.insert packageName' finalSpec sources
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- SHOW
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
parseCmdShow :: Opts.ParserInfo (IO ())
|
||||
parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc
|
||||
|
||||
-- TODO: nicer output
|
||||
cmdShow :: IO ()
|
||||
cmdShow = do
|
||||
putStrLn $ "Showing sources file"
|
||||
|
||||
sources <- unSources <$> getSources
|
||||
|
||||
forWithKeyM_ sources $ \key (PackageSpec spec) -> do
|
||||
T.putStrLn $ "Package: " <> unPackageName key
|
||||
forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do
|
||||
let attrValue = case attrValValue of
|
||||
Aeson.String str -> str
|
||||
_ -> "<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
|
||||
|
||||
eFinalSpec <- case HMS.lookup packageName sources of
|
||||
Just defaultSpec -> do
|
||||
fmap attrsToSpec <$> tryEvalUpdate
|
||||
(specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec)
|
||||
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||
|
||||
Nothing -> abortCannotUpdateNoSuchPackage packageName
|
||||
|
||||
case eFinalSpec of
|
||||
Left e -> abortUpdateFailed [(packageName, e)]
|
||||
Right finalSpec ->
|
||||
setSources $ Sources $
|
||||
HMS.insert packageName finalSpec sources
|
||||
|
||||
Nothing -> do
|
||||
sources <- unSources <$> getSources
|
||||
|
||||
esources' <- forWithKeyM sources $
|
||||
\packageName defaultSpec -> do
|
||||
T.putStrLn $ "Package: " <> unPackageName packageName
|
||||
fmap attrsToSpec <$> tryEvalUpdate
|
||||
(specToFreeAttrs defaultSpec)
|
||||
(githubUpdate nixPrefetchURL githubLatestRev githubRepo)
|
||||
|
||||
let (failed, sources') = partitionEithersHMS esources'
|
||||
|
||||
unless (HMS.null failed) $
|
||||
abortUpdateFailed (HMS.toList failed)
|
||||
|
||||
setSources $ Sources sources'
|
||||
|
||||
partitionEithersHMS
|
||||
:: (Eq k, Hashable k)
|
||||
=> HMS.HashMap k (Either a b) -> (HMS.HashMap k a, HMS.HashMap k b)
|
||||
partitionEithersHMS =
|
||||
flip HMS.foldlWithKey' (HMS.empty, HMS.empty) $ \(ls, rs) k -> \case
|
||||
Left l -> (HMS.insert k l ls, rs)
|
||||
Right r -> (ls, HMS.insert k r rs)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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 = "{}"
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- 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."
|
||||
]
|
||||
|
||||
abortUpdateFailed :: [ (PackageName, SomeException) ] -> IO a
|
||||
abortUpdateFailed errs = abort $ T.unlines $
|
||||
[ "One or more packages failed to update:" ] <>
|
||||
map (\(PackageName pname, e) ->
|
||||
pname <> ": " <> tshow e
|
||||
) errs
|
||||
|
||||
abortNixPrefetchExpectedOutput :: IO a
|
||||
abortNixPrefetchExpectedOutput = abort [s|
|
||||
Could not read the output of 'nix-prefetch-url'. This is a bug. Please create a
|
||||
ticket:
|
||||
|
||||
https://github.com/nmattia/niv/issues/new
|
||||
|
||||
Thanks! I'll buy you a beer.
|
||||
|]
|
||||
|
||||
tshow :: Show a => a -> T.Text
|
||||
tshow = T.pack . show
|
||||
123
src/Niv/GitHub.hs
Normal file
123
src/Niv/GitHub.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Niv.GitHub where
|
||||
|
||||
import Control.Arrow
|
||||
import Data.Bool
|
||||
import Data.Maybe
|
||||
import Data.String.QQ (s)
|
||||
import GHC.Exts (toList)
|
||||
import Niv.Update
|
||||
import qualified Data.Text as T
|
||||
import qualified GitHub as GH
|
||||
import qualified GitHub.Data.Name as GH
|
||||
|
||||
data GithubRepo = GithubRepo
|
||||
{ repoDescription :: Maybe T.Text
|
||||
, repoHomepage :: Maybe T.Text
|
||||
, repoDefaultBranch :: Maybe T.Text
|
||||
}
|
||||
|
||||
githubRepo :: T.Text -> T.Text -> IO GithubRepo
|
||||
githubRepo owner repo = fmap translate <$>
|
||||
GH.executeRequest' (GH.repositoryR (GH.N owner) (GH.N repo)) >>= \case
|
||||
Left e -> do
|
||||
warnCouldNotFetchGitHubRepo e (owner, repo)
|
||||
error (show e)
|
||||
Right x -> pure x
|
||||
where
|
||||
translate r = GithubRepo
|
||||
{ repoDescription = GH.repoDescription r
|
||||
, repoHomepage = GH.repoHomepage r
|
||||
, repoDefaultBranch = GH.repoDefaultBranch r
|
||||
}
|
||||
|
||||
warnCouldNotFetchGitHubRepo :: GH.Error -> (T.Text, T.Text) -> IO ()
|
||||
warnCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) =
|
||||
putStrLn $ unlines [ line1, line2, line3 ]
|
||||
where
|
||||
line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo
|
||||
line2 = [s|
|
||||
I assumed that your package was a GitHub repository. An error occurred while
|
||||
gathering information from the repository. Check whether your package was added
|
||||
correctly:
|
||||
|
||||
niv show
|
||||
|
||||
If not, try re-adding it:
|
||||
|
||||
niv drop <package>
|
||||
niv add <package-without-typo>
|
||||
|
||||
Make sure the repository exists.
|
||||
|]
|
||||
line3 = unwords [ "(Error was:", show e, ")" ]
|
||||
|
||||
-- TODO: fetchers for:
|
||||
-- * npm
|
||||
-- * hackage
|
||||
-- * docker
|
||||
-- * ... ?
|
||||
githubUpdate
|
||||
:: (Bool -> T.Text -> IO T.Text)
|
||||
-- ^ prefetch
|
||||
-> (T.Text -> T.Text -> T.Text -> IO T.Text)
|
||||
-- ^ latest revision
|
||||
-> (T.Text -> T.Text -> IO GithubRepo)
|
||||
-- ^ get repo
|
||||
-> Update () ()
|
||||
githubUpdate prefetch latestRev ghRepo = proc () -> do
|
||||
urlTemplate <- template <<<
|
||||
(useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -<
|
||||
()
|
||||
url <- update "url" -< urlTemplate
|
||||
let isTar = ("tar.gz" `T.isSuffixOf`) <$> url
|
||||
useOrSet "type" -< bool "file" "tarball" <$> isTar :: Box T.Text
|
||||
let doUnpack = isTar
|
||||
_sha256 <- update "sha256" <<< run (\(up, u) -> prefetch up u) -< (,) <$> doUnpack <*> url
|
||||
returnA -< ()
|
||||
where
|
||||
completeSpec :: Update () (Box T.Text)
|
||||
completeSpec = proc () -> do
|
||||
owner <- load "owner" -< ()
|
||||
repo <- load "repo" -< ()
|
||||
repoInfo <- run (\(a, b) -> ghRepo a b) -< (,) <$> owner <*> repo
|
||||
branch <- useOrSet "branch" <<< arr (fmap $ fromMaybe "master") -<
|
||||
repoDefaultBranch <$> repoInfo
|
||||
_description <- useOrSet "description" -< repoDescription <$> repoInfo
|
||||
_homepage <- useOrSet "homepage" -< repoHomepage <$> repoInfo
|
||||
_ <- update "rev" <<< run' (\(a,b,c) -> latestRev a b c) -<
|
||||
(,,) <$> owner <*> repo <*> branch
|
||||
returnA -< pure githubURLTemplate
|
||||
|
||||
githubURLTemplate :: T.Text
|
||||
githubURLTemplate =
|
||||
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
|
||||
|
||||
-- | Get the latest revision for owner, repo and branch.
|
||||
-- TODO: explain no error handling
|
||||
githubLatestRev
|
||||
:: T.Text
|
||||
-- ^ owner
|
||||
-> T.Text
|
||||
-- ^ repo
|
||||
-> T.Text
|
||||
-- ^ branch
|
||||
-> IO T.Text
|
||||
githubLatestRev owner repo branch =
|
||||
GH.executeRequest' (
|
||||
GH.commitsWithOptionsForR (GH.N owner) (GH.N repo) (GH.FetchAtLeast 1)
|
||||
[GH.CommitQuerySha branch]
|
||||
) >>= \case
|
||||
Right (toList -> (commit:_)) -> do
|
||||
let GH.N rev = GH.commitSha commit
|
||||
pure $ rev
|
||||
Right (toList -> []) -> do
|
||||
error "No rev: no commits"
|
||||
Left e -> error $ "No rev: " <> show e
|
||||
_ -> error $ "No rev: impossible"
|
||||
136
src/Niv/GitHub/Test.hs
Normal file
136
src/Niv/GitHub/Test.hs
Normal file
@ -0,0 +1,136 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Niv.GitHub.Test where
|
||||
|
||||
import Control.Monad
|
||||
import Niv.GitHub
|
||||
import Niv.Update
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
|
||||
test_githubInitsProperly :: IO ()
|
||||
test_githubInitsProperly = do
|
||||
actualState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate prefetch latestRev ghRepo -< ()
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
where
|
||||
prefetch _ _ = pure "some-sha"
|
||||
latestRev _ _ _ = pure "some-rev"
|
||||
ghRepo _ _ = pure GithubRepo
|
||||
{ repoDescription = Just "some-descr"
|
||||
, repoHomepage = Just "some-homepage"
|
||||
, repoDefaultBranch = Just "master"
|
||||
}
|
||||
initialState = HMS.fromList
|
||||
[ ("owner", (Free, "nmattia"))
|
||||
, ("repo", (Free, "niv")) ]
|
||||
expectedState = HMS.fromList
|
||||
[ ("owner", "nmattia")
|
||||
, ("repo", "niv")
|
||||
, ("homepage", "some-homepage")
|
||||
, ("description", "some-descr")
|
||||
, ("branch", "master")
|
||||
, ("url", "https://github.com/nmattia/niv/archive/some-rev.tar.gz")
|
||||
, ("rev", "some-rev")
|
||||
, ("sha256", "some-sha")
|
||||
, ("type", "tarball")
|
||||
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||
]
|
||||
|
||||
test_githubUpdates :: IO ()
|
||||
test_githubUpdates = do
|
||||
actualState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate prefetch latestRev ghRepo -< ()
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
where
|
||||
prefetch _ _ = pure "new-sha"
|
||||
latestRev _ _ _ = pure "new-rev"
|
||||
ghRepo _ _ = pure GithubRepo
|
||||
{ repoDescription = Just "some-descr"
|
||||
, repoHomepage = Just "some-homepage"
|
||||
, repoDefaultBranch = Just "master"
|
||||
}
|
||||
initialState = HMS.fromList
|
||||
[ ("owner", (Free, "nmattia"))
|
||||
, ("repo", (Free, "niv"))
|
||||
, ("homepage", (Free, "some-homepage"))
|
||||
, ("description", (Free, "some-descr"))
|
||||
, ("branch", (Free, "master"))
|
||||
, ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
|
||||
, ("rev", (Free, "some-rev"))
|
||||
, ("sha256", (Free, "some-sha"))
|
||||
, ("type", (Free, "tarball"))
|
||||
, ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
|
||||
]
|
||||
expectedState = HMS.fromList
|
||||
[ ("owner", "nmattia")
|
||||
, ("repo", "niv")
|
||||
, ("homepage", "some-homepage")
|
||||
, ("description", "some-descr")
|
||||
, ("branch", "master")
|
||||
, ("url", "https://github.com/nmattia/niv/archive/new-rev.tar.gz")
|
||||
, ("rev", "new-rev")
|
||||
, ("sha256", "new-sha")
|
||||
, ("type", "tarball")
|
||||
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||
]
|
||||
|
||||
test_githubDoesntOverrideRev :: IO ()
|
||||
test_githubDoesntOverrideRev = do
|
||||
actualState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate prefetch latestRev ghRepo -< ()
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
where
|
||||
prefetch _ _ = pure "new-sha"
|
||||
latestRev _ _ _ = error "shouldn't fetch rev"
|
||||
ghRepo _ _ = error "shouldn't fetch repo"
|
||||
initialState = HMS.fromList
|
||||
[ ("owner", (Free, "nmattia"))
|
||||
, ("repo", (Free, "niv"))
|
||||
, ("homepage", (Free, "some-homepage"))
|
||||
, ("description", (Free, "some-descr"))
|
||||
, ("branch", (Free, "master"))
|
||||
, ("url", (Free, "https://github.com/nmattia/niv/archive/some-rev.tar.gz"))
|
||||
, ("rev", (Locked, "custom-rev"))
|
||||
, ("sha256", (Free, "some-sha"))
|
||||
, ("type", (Free, "tarball"))
|
||||
, ("url_template", (Free, "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"))
|
||||
]
|
||||
expectedState = HMS.fromList
|
||||
[ ("owner", "nmattia")
|
||||
, ("repo", "niv")
|
||||
, ("homepage", "some-homepage")
|
||||
, ("description", "some-descr")
|
||||
, ("branch", "master")
|
||||
, ("url", "https://github.com/nmattia/niv/archive/custom-rev.tar.gz")
|
||||
, ("rev", "custom-rev")
|
||||
, ("sha256", "new-sha")
|
||||
, ("type", "tarball")
|
||||
, ("url_template", "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz")
|
||||
]
|
||||
|
||||
-- TODO: HMS diff for test output
|
||||
test_githubURLFallback :: IO ()
|
||||
test_githubURLFallback = do
|
||||
actualState <- evalUpdate initialState $ proc () ->
|
||||
githubUpdate prefetch latestRev ghRepo -< ()
|
||||
unless ((snd <$> actualState) == expectedState) $
|
||||
error $ "State mismatch: " <> show actualState
|
||||
where
|
||||
prefetch _ _ = pure "some-sha"
|
||||
latestRev _ _ _ = error "shouldn't fetch rev"
|
||||
ghRepo _ _ = error "shouldn't fetch repo"
|
||||
initialState = HMS.fromList
|
||||
[ ("url_template", (Free, "https://foo.com/<baz>.tar.gz"))
|
||||
, ("baz", (Free, "tarball"))
|
||||
]
|
||||
expectedState = HMS.fromList
|
||||
[ ("url_template", "https://foo.com/<baz>.tar.gz")
|
||||
, ("baz", "tarball")
|
||||
, ("url", "https://foo.com/tarball.tar.gz")
|
||||
, ("sha256", "some-sha")
|
||||
, ("type", "tarball")
|
||||
]
|
||||
29
src/Niv/Test.hs
Normal file
29
src/Niv/Test.hs
Normal file
@ -0,0 +1,29 @@
|
||||
module Niv.Test (tests, test) where
|
||||
|
||||
import Niv.GitHub.Test
|
||||
import Niv.Update.Test
|
||||
import qualified Test.Tasty as Tasty
|
||||
import qualified Test.Tasty.HUnit as Tasty
|
||||
|
||||
test :: IO ()
|
||||
test = Tasty.defaultMain tests
|
||||
|
||||
tests :: Tasty.TestTree
|
||||
tests = Tasty.testGroup "niv"
|
||||
[ Tasty.testGroup "update"
|
||||
[ Tasty.testCase "simply runs" simplyRuns
|
||||
, Tasty.testCase "picks first" picksFirst
|
||||
, Tasty.testCase "loads" loads
|
||||
, Tasty.testCase "survives checks" survivesChecks
|
||||
, Tasty.testCase "isn't too eager" isNotTooEager
|
||||
, Tasty.testCase "dirty forces update" dirtyForcesUpdate
|
||||
, Tasty.testCase "should run when no changes" shouldNotRunWhenNoChanges
|
||||
, Tasty.testCase "templates expand" templatesExpand
|
||||
]
|
||||
, Tasty.testGroup "github"
|
||||
[ Tasty.testCase "inits properly" test_githubInitsProperly
|
||||
, Tasty.testCase "updates" test_githubUpdates
|
||||
, Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev
|
||||
, Tasty.testCase "falls back to URL" test_githubURLFallback
|
||||
]
|
||||
]
|
||||
293
src/Niv/Update.hs
Normal file
293
src/Niv/Update.hs
Normal file
@ -0,0 +1,293 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Niv.Update where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Data.Aeson (FromJSON, ToJSON, Value)
|
||||
import Data.String
|
||||
import UnliftIO
|
||||
import qualified Control.Category as Cat
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
|
||||
type Attrs = HMS.HashMap T.Text (Freedom, Value)
|
||||
|
||||
data Update b c where
|
||||
Id :: Update a a
|
||||
Compose :: (Compose b c) -> Update b c
|
||||
Arr :: (b -> c) -> Update b c
|
||||
First :: Update b c -> Update (b, d) (c, d)
|
||||
Zero :: Update b c
|
||||
Plus :: Update b c -> Update b c -> Update b c
|
||||
Check :: (a -> Bool) -> Update (Box a) ()
|
||||
Load :: T.Text -> Update () (Box Value)
|
||||
UseOrSet :: T.Text -> Update (Box Value) (Box Value)
|
||||
Update :: T.Text -> Update (Box Value) (Box Value)
|
||||
Run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
Template :: Update (Box T.Text) (Box T.Text)
|
||||
|
||||
instance ArrowZero Update where
|
||||
zeroArrow = Zero
|
||||
|
||||
instance ArrowPlus Update where
|
||||
(<+>) = Plus
|
||||
|
||||
instance Arrow Update where
|
||||
arr = Arr
|
||||
first = First
|
||||
|
||||
instance Cat.Category Update where
|
||||
id = Id
|
||||
f . g = Compose (Compose' f g)
|
||||
|
||||
instance Show (Update b c) where
|
||||
show = \case
|
||||
Id -> "Id"
|
||||
Compose (Compose' f g)-> "(" <> show f <> " . " <> show g <> ")"
|
||||
Arr _f -> "Arr"
|
||||
First a -> "First " <> show a
|
||||
Zero -> "Zero"
|
||||
Plus l r -> "(" <> show l <> " + " <> show r <> ")"
|
||||
Check _ch -> "Check"
|
||||
Load k -> "Load " <> T.unpack k
|
||||
UseOrSet k -> "UseOrSet " <> T.unpack k
|
||||
Update k -> "Update " <> T.unpack k
|
||||
Run _act -> "Io"
|
||||
Template -> "Template"
|
||||
|
||||
data Compose a c = forall b. Compose' (Update b c) (Update a b)
|
||||
|
||||
-- | Run an 'Update' and return the new attributes and result.
|
||||
runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
|
||||
runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed
|
||||
where
|
||||
feed = \case
|
||||
UpdateReady res -> hndl res
|
||||
UpdateNeedMore next -> next (()) >>= hndl
|
||||
hndl = \case
|
||||
UpdateSuccess f v -> (,v) <$> unboxAttrs f
|
||||
UpdateFailed e -> error $ "Update failed: " <> T.unpack (prettyFail e)
|
||||
prettyFail :: UpdateFailed -> T.Text
|
||||
prettyFail = \case
|
||||
FailNoSuchKey k -> "Key could not be found: " <> k
|
||||
FailZero -> T.unlines
|
||||
[ "A dead end was reached during evaluation."
|
||||
, "This is a bug. Please create a ticket:"
|
||||
, " https://github.com/nmattia/niv/issues/new"
|
||||
, "Thanks! I'll buy you a beer."
|
||||
]
|
||||
FailCheck -> "A check failed during update"
|
||||
FailTemplate tpl keys -> T.unlines
|
||||
[ "Could not render template " <> tpl
|
||||
, "with keys: " <> T.intercalate ", " keys
|
||||
]
|
||||
|
||||
execUpdate :: Attrs -> Update () a -> IO a
|
||||
execUpdate attrs a = snd <$> runUpdate attrs a
|
||||
|
||||
evalUpdate :: Attrs -> Update () a -> IO Attrs
|
||||
evalUpdate attrs a = fst <$> runUpdate attrs a
|
||||
|
||||
tryEvalUpdate :: Attrs -> Update () a -> IO (Either SomeException Attrs)
|
||||
tryEvalUpdate attrs upd = tryAny (evalUpdate attrs upd)
|
||||
|
||||
type JSON a = (ToJSON a, FromJSON a)
|
||||
|
||||
data UpdateFailed
|
||||
= FailNoSuchKey T.Text
|
||||
| FailZero
|
||||
| FailCheck
|
||||
| FailTemplate T.Text [T.Text]
|
||||
deriving Show
|
||||
|
||||
data UpdateRes a b
|
||||
= UpdateReady (UpdateReady b)
|
||||
| UpdateNeedMore (a -> IO (UpdateReady b))
|
||||
deriving Functor
|
||||
|
||||
data UpdateReady b
|
||||
= UpdateSuccess BoxedAttrs b
|
||||
| UpdateFailed UpdateFailed
|
||||
deriving Functor
|
||||
|
||||
runBox :: Box a -> IO a
|
||||
runBox = boxOp
|
||||
|
||||
data Box a = Box
|
||||
{ boxNew :: Bool
|
||||
-- ^ Whether the value is new or was retrieved (or derived) from old
|
||||
-- attributes
|
||||
, boxOp :: IO a
|
||||
}
|
||||
deriving Functor
|
||||
|
||||
instance Applicative Box where
|
||||
pure x = Box { boxNew = False, boxOp = pure x }
|
||||
f <*> v = Box
|
||||
{ boxNew = (||) (boxNew f) (boxNew v)
|
||||
, boxOp = boxOp f <*> boxOp v
|
||||
}
|
||||
|
||||
instance Semigroup a => Semigroup (Box a) where
|
||||
(<>) = liftA2 (<>)
|
||||
|
||||
instance IsString (Box T.Text) where
|
||||
fromString str = Box { boxNew = False, boxOp = pure $ T.pack str }
|
||||
|
||||
type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
|
||||
|
||||
unboxAttrs :: BoxedAttrs -> IO Attrs
|
||||
unboxAttrs = traverse (\(fr, v) -> (fr,) <$> runBox v)
|
||||
|
||||
boxAttrs :: Attrs -> BoxedAttrs
|
||||
boxAttrs = fmap (\(fr, v) -> (fr,
|
||||
case fr of
|
||||
-- TODO: explain why hacky
|
||||
Locked -> (pure v) { boxNew = True } -- XXX: somewhat hacky
|
||||
Free -> pure v
|
||||
))
|
||||
|
||||
data Freedom
|
||||
= Locked
|
||||
| Free
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Runs an update, trying to evaluate the 'Box'es as little as possible.
|
||||
-- This is a hairy piece of code, apologies ¯\_(ツ)_/¯
|
||||
-- In most cases I just picked the first implementation that compiled
|
||||
runUpdate' :: BoxedAttrs -> Update a b -> IO (UpdateRes a b)
|
||||
runUpdate' attrs = \case
|
||||
Id -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs
|
||||
Arr f -> pure $ UpdateNeedMore $ pure . UpdateSuccess attrs . f
|
||||
Zero -> pure $ UpdateReady (UpdateFailed FailZero)
|
||||
Plus l r -> runUpdate' attrs l >>= \case
|
||||
UpdateReady (UpdateFailed{}) -> runUpdate' attrs r
|
||||
UpdateReady (UpdateSuccess f v) -> pure $ UpdateReady (UpdateSuccess f v)
|
||||
UpdateNeedMore next -> pure $ UpdateNeedMore $ \v -> next v >>= \case
|
||||
UpdateSuccess f res -> pure $ UpdateSuccess f res
|
||||
UpdateFailed {} -> runUpdate' attrs r >>= \case
|
||||
UpdateReady res -> pure res
|
||||
UpdateNeedMore next' -> next' v
|
||||
Load k -> pure $ UpdateReady $ do
|
||||
case HMS.lookup k attrs of
|
||||
Just (_, v') -> UpdateSuccess attrs v'
|
||||
Nothing -> UpdateFailed $ FailNoSuchKey k
|
||||
First a -> do
|
||||
runUpdate' attrs a >>= \case
|
||||
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||
UpdateReady (UpdateSuccess fo ba) -> pure $ UpdateNeedMore $ \gtt -> do
|
||||
pure $ UpdateSuccess fo (ba, snd gtt)
|
||||
UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
|
||||
next (fst gtt) >>= \case
|
||||
UpdateFailed e -> pure $ UpdateFailed e
|
||||
UpdateSuccess f res -> do
|
||||
pure $ UpdateSuccess f (res, snd gtt)
|
||||
Run act -> pure (UpdateNeedMore $ \gtt -> do
|
||||
pure $ UpdateSuccess attrs $ Box (boxNew gtt) (act =<< runBox gtt))
|
||||
Check ch -> pure (UpdateNeedMore $ \gtt -> do
|
||||
v <- runBox gtt
|
||||
if ch v
|
||||
then pure $ UpdateSuccess attrs ()
|
||||
else pure $ UpdateFailed FailCheck)
|
||||
UseOrSet k -> pure $ case HMS.lookup k attrs of
|
||||
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||
Just (Free, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||
Nothing -> UpdateNeedMore $ \gtt -> do
|
||||
let attrs' = HMS.singleton k (Locked, gtt) <> attrs
|
||||
pure $ UpdateSuccess attrs' gtt
|
||||
Update k -> pure $ case HMS.lookup k attrs of
|
||||
Just (Locked, v) -> UpdateReady $ UpdateSuccess attrs v
|
||||
Just (Free, v) -> UpdateNeedMore $ \gtt -> do
|
||||
if (boxNew gtt)
|
||||
then pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
|
||||
else pure $ UpdateSuccess attrs v
|
||||
Nothing -> UpdateNeedMore $ \gtt -> do
|
||||
pure $ UpdateSuccess (HMS.insert k (Locked, gtt) attrs) gtt
|
||||
Compose (Compose' f g) -> runUpdate' attrs g >>= \case
|
||||
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||
UpdateReady (UpdateSuccess attrs' act) -> runUpdate' attrs' f >>= \case
|
||||
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
|
||||
UpdateReady (UpdateSuccess attrs'' act') -> pure $ UpdateReady $ UpdateSuccess attrs'' act'
|
||||
UpdateNeedMore next -> UpdateReady <$> next act
|
||||
UpdateNeedMore next -> pure $ UpdateNeedMore $ \gtt -> do
|
||||
next gtt >>= \case
|
||||
UpdateFailed e -> pure $ UpdateFailed e
|
||||
UpdateSuccess attrs' act -> runUpdate' attrs' f >>= \case
|
||||
UpdateReady ready -> pure ready
|
||||
UpdateNeedMore next' -> next' act
|
||||
Template -> pure $ UpdateNeedMore $ \v -> do
|
||||
v' <- runBox v
|
||||
case renderTemplate
|
||||
(\k ->
|
||||
((decodeBox $ "When rendering template " <> v') . snd) <$>
|
||||
HMS.lookup k attrs) v' of
|
||||
Nothing -> pure $ UpdateFailed $ FailTemplate v' (HMS.keys attrs)
|
||||
Just v'' -> pure $ UpdateSuccess attrs (v'' <* v) -- carries over v's newness
|
||||
|
||||
decodeBox :: FromJSON a => T.Text -> Box Value -> Box a
|
||||
decodeBox msg v = v { boxOp = boxOp v >>= decodeValue msg }
|
||||
|
||||
decodeValue :: FromJSON a => T.Text -> Value -> IO a
|
||||
decodeValue msg v = case Aeson.fromJSON v of
|
||||
Aeson.Success x -> pure x
|
||||
Aeson.Error str ->
|
||||
error $ T.unpack msg <> ": Could not decode: " <> show v <> ": " <> str
|
||||
|
||||
-- | Renders the template. Returns 'Nothing' if some of the attributes are
|
||||
-- missing.
|
||||
-- renderTemplate ("foo" -> "bar") "<foo>" -> pure (Just "bar")
|
||||
-- renderTemplate ("foo" -> "bar") "<baz>" -> pure Nothing
|
||||
renderTemplate :: (T.Text -> Maybe (Box T.Text)) -> T.Text -> Maybe (Box T.Text)
|
||||
renderTemplate vals = \case
|
||||
(T.uncons -> Just ('<', str)) -> do
|
||||
case T.span (/= '>') str of
|
||||
(key, T.uncons -> Just ('>', rest)) -> do
|
||||
let v = vals key
|
||||
(liftA2 (<>) v) (renderTemplate vals rest)
|
||||
_ -> Nothing
|
||||
(T.uncons -> Just (c, str)) -> fmap (T.cons c) <$> renderTemplate vals str
|
||||
(T.uncons -> Nothing) -> Just $ pure T.empty
|
||||
-- XXX: isn't this redundant?
|
||||
_ -> Just $ pure T.empty
|
||||
|
||||
template :: Update (Box T.Text) (Box T.Text)
|
||||
template = Template
|
||||
|
||||
check :: (a -> Bool) -> Update (Box a) ()
|
||||
check = Check
|
||||
|
||||
load :: FromJSON a => T.Text -> Update () (Box a)
|
||||
load k = Load k >>> arr (decodeBox $ "When loading key " <> k)
|
||||
|
||||
-- TODO: should input really be Box?
|
||||
useOrSet :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||
useOrSet k =
|
||||
arr (fmap Aeson.toJSON) >>>
|
||||
UseOrSet k >>>
|
||||
arr (decodeBox $ "When trying to use or set key " <> k)
|
||||
|
||||
update :: JSON a => T.Text -> Update (Box a) (Box a)
|
||||
update k =
|
||||
arr (fmap Aeson.toJSON) >>>
|
||||
Update k >>>
|
||||
arr (decodeBox $ "When updating key " <> k)
|
||||
|
||||
run :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
run = Run
|
||||
|
||||
-- | Like 'run' but forces evaluation
|
||||
run' :: (a -> IO b) -> Update (Box a) (Box b)
|
||||
run' act = Run act >>> dirty
|
||||
|
||||
dirty :: Update (Box a) (Box a)
|
||||
dirty = arr (\v -> v { boxNew = True })
|
||||
114
src/Niv/Update/Test.hs
Normal file
114
src/Niv/Update/Test.hs
Normal file
@ -0,0 +1,114 @@
|
||||
{-# LANGUAGE Arrows #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Niv.Update.Test where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Niv.Update
|
||||
import qualified Data.HashMap.Strict as HMS
|
||||
import qualified Data.Text as T
|
||||
|
||||
simplyRuns :: IO ()
|
||||
simplyRuns =
|
||||
void $ runUpdate attrs $ proc () -> do
|
||||
returnA -< ()
|
||||
where
|
||||
attrs = HMS.empty
|
||||
|
||||
picksFirst :: IO ()
|
||||
picksFirst = do
|
||||
v <- execUpdate HMS.empty $
|
||||
let
|
||||
l = proc () -> do returnA -< 2
|
||||
r = proc () -> do returnA -< 3
|
||||
in l <+> r
|
||||
unless (v == (2::Int)) (error "bad value")
|
||||
|
||||
loads :: IO ()
|
||||
loads = do
|
||||
v <- execUpdate attrs $ load "foo"
|
||||
v' <- runBox v
|
||||
unless (v' == ("bar" :: T.Text)) (error "bad value")
|
||||
where
|
||||
attrs = HMS.singleton "foo" (Locked, "bar")
|
||||
|
||||
survivesChecks :: IO ()
|
||||
survivesChecks = do
|
||||
v <- execUpdate attrs $ proc () -> do
|
||||
(sawLeft <+> sawRight) -< ()
|
||||
load "res" -< ()
|
||||
v' <- runBox v
|
||||
unless (v' == ("I saw right" :: T.Text)) (error "bad value")
|
||||
where
|
||||
attrs = HMS.singleton "val" (Locked, "right")
|
||||
sawLeft :: Update () ()
|
||||
sawLeft = proc () -> do
|
||||
val <- load "val" -< ()
|
||||
check (== "left") -< (val :: Box T.Text)
|
||||
useOrSet "res" -< "I saw left" :: Box T.Text
|
||||
returnA -< ()
|
||||
sawRight :: Update () ()
|
||||
sawRight = proc () -> do
|
||||
val <- load "val" -< ()
|
||||
check (== "right") -< (val :: Box T.Text)
|
||||
useOrSet "res" -< "I saw right" :: Box T.Text
|
||||
returnA -< ()
|
||||
|
||||
isNotTooEager :: IO ()
|
||||
isNotTooEager = do
|
||||
let f = constBox () >>>
|
||||
run (const $ error "IO is too eager (f)") >>>
|
||||
useOrSet "foo"
|
||||
let f1 = proc () -> do
|
||||
run (const $ error "IO is too eager (f1)") -< pure ()
|
||||
useOrSet "foo" -< "foo"
|
||||
void $ (execUpdate attrs f :: IO (Box T.Text))
|
||||
void $ (execUpdate attrs f1 :: IO (Box T.Text))
|
||||
where
|
||||
attrs = HMS.singleton "foo" (Locked, "right")
|
||||
|
||||
dirtyForcesUpdate :: IO ()
|
||||
dirtyForcesUpdate = do
|
||||
let f = constBox ("world" :: T.Text) >>> dirty >>> update "hello"
|
||||
attrs' <- evalUpdate attrs f
|
||||
unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
|
||||
error $ "bad value for hello: " <> show attrs'
|
||||
where
|
||||
attrs = HMS.singleton "hello" (Free, "foo")
|
||||
|
||||
shouldNotRunWhenNoChanges :: IO ()
|
||||
shouldNotRunWhenNoChanges = do
|
||||
let f = proc () -> do
|
||||
update "hello" -< ("world" :: Box T.Text)
|
||||
run (\() -> error "io shouldn't be run") -< pure ()
|
||||
attrs <- evalUpdate HMS.empty f
|
||||
unless ((snd <$> HMS.lookup "hello" attrs) == Just "world") $
|
||||
error $ "bad value for hello: " <> show attrs
|
||||
let f' = proc () -> do
|
||||
run (\() -> error "io shouldn't be run") -< pure ()
|
||||
update "hello" -< ("world" :: Box T.Text)
|
||||
attrs' <- evalUpdate HMS.empty f'
|
||||
unless ((snd <$> HMS.lookup "hello" attrs') == Just "world") $
|
||||
error $ "bad value for hello: " <> show attrs'
|
||||
v3 <- execUpdate
|
||||
(HMS.fromList [("hello", (Free, "world")), ("bar", (Free, "baz"))]) $
|
||||
proc () -> do
|
||||
v1 <- update "hello" -< "world"
|
||||
v2 <- run (\_ -> error "io shouldn't be run") -< (v1 :: Box T.Text)
|
||||
v3 <- update "bar" -< (v2 :: Box T.Text)
|
||||
returnA -< v3
|
||||
v3' <- runBox v3
|
||||
unless (v3' == "baz") $ error "bad value"
|
||||
|
||||
templatesExpand :: IO ()
|
||||
templatesExpand = do
|
||||
v3 <- execUpdate attrs $ proc () -> template -< "<v1>-<v2>"
|
||||
v3' <- runBox v3
|
||||
unless (v3' == "hello-world") $ error "bad value"
|
||||
where
|
||||
attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]
|
||||
|
||||
constBox :: a -> Update () (Box a)
|
||||
constBox a = arr (const (pure a))
|
||||
@ -22,8 +22,8 @@ let
|
||||
# TODO: Remove this patch by adding an argument to the github
|
||||
# subcommand to support GitHub entreprise.
|
||||
prePatch = ''
|
||||
sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i app/Niv.hs
|
||||
sed "s|https://github.com|http://localhost:3333|" -i app/Niv.hs
|
||||
sed "s|GH.executeRequest'|GH.executeRequest (GH.EnterpriseOAuth \"http://localhost:3333\" \"\")|" -i src/Niv/GitHub.hs
|
||||
sed "s|https://github.com|http://localhost:3333|" -i src/Niv/GitHub.hs
|
||||
'';
|
||||
});
|
||||
in pkgs.runCommand "test"
|
||||
@ -75,7 +75,11 @@ in pkgs.runCommand "test"
|
||||
mock/NixOS/nixpkgs-channels/archive/${nixpkgs-channels_HEAD}.tar.gz
|
||||
|
||||
niv init
|
||||
diff -h ${./expected/niv-init.json} nix/sources.json
|
||||
diff -h ${./expected/niv-init.json} nix/sources.json || \
|
||||
(echo "Mismatched sources.json"; \
|
||||
echo "Reference: tests/expected/niv-init.json"; \
|
||||
exit 1)
|
||||
|
||||
echo "*** ok."
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user