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

Finish update and add logic

This commit is contained in:
Nicolas Mattia 2019-01-27 21:18:10 +01:00
parent 7628070e98
commit e5e65efd09
2 changed files with 202 additions and 149 deletions

334
Main.hs
View File

@ -10,24 +10,23 @@
import Control.Monad
import Control.Monad.State
import Control.Applicative
import Data.Aeson
import Data.Bifunctor
import Data.Char (toUpper)
import Data.Hashable (Hashable)
import Data.Maybe (mapMaybe)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Semigroup ((<>))
import Data.String
import GHC.Exts (toList)
import Options.Applicative
import System.Directory
import System.FilePath
import System.Process (readProcess)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as HMap
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified GitHub as GH
import qualified GitHub.Data.Name as GH
import qualified Options.Applicative as Opts
fileFetchNix :: FilePath
fileFetchNix = "nix" </> "fetch.nix"
@ -38,7 +37,6 @@ fileFetchNixContent :: String
fileFetchNixContent = unlines
[
]
fileVersionsJson :: FilePath
@ -58,9 +56,9 @@ getVersionsSpec :: IO VersionsSpec
getVersionsSpec = do
putStrLn $ "Reading versions file"
decodeFileStrict fileVersionsJson >>= \case
Just (Object v) ->
Just (Object obj) ->
fmap (VersionsSpec . mconcat) $
forM (HMap.toList v) $ \(k, v) ->
forM (HMap.toList obj) $ \(k, v) ->
case v of
Object v' ->
pure $ HMap.singleton (PackageName (T.unpack k)) (PackageSpec v')
@ -68,26 +66,30 @@ getVersionsSpec = do
Just _ -> error "foo"
Nothing -> error "Cannot decode versions"
setVersionsSpec :: VersionsSpec -> IO ()
setVersionsSpec versionsSpec = encodeFile fileVersionsJson versionsSpec
newtype PackageName = PackageName { unPackageName :: String }
deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show)
parsePackageName :: Parser PackageName
parsePackageName = PackageName <$> argument str (metavar "PACKAGE")
parsePackageName :: Opts.Parser PackageName
parsePackageName = PackageName <$>
Opts.argument Opts.str (Opts.metavar "PACKAGE")
newtype PackageSpec = PackageSpec { unPackageSpec :: Object }
deriving newtype (FromJSON, ToJSON, Show)
parsePackageSpec :: Parser PackageSpec
parsePackageSpec :: Opts.Parser PackageSpec
parsePackageSpec =
(PackageSpec . HMap.fromList . fmap fixupAttributes) <$>
many parseAttribute
where
parseAttribute :: Parser (String, String)
parseAttribute :: Opts.Parser (String, String)
parseAttribute = shortcutAttributes <|>
option (maybeReader parseKeyVal)
( long "attribute" <>
short 'a' <>
metavar "KEY=VAL"
Opts.option (Opts.maybeReader parseKeyVal)
( Opts.long "attribute" <>
Opts.short 'a' <>
Opts.metavar "KEY=VAL"
)
-- Parse "key=val" into ("key", "val")
@ -97,69 +99,136 @@ parsePackageSpec =
_ -> Nothing
-- Shortcuts for common attributes
shortcutAttributes :: Parser (String, String)
shortcutAttributes :: Opts.Parser (String, String)
shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$>
[ "branch", "name", "owner", "repo" ]
[ "branch", "owner", "repo" ]
mkShortcutAttribute :: String -> Parser (String, String)
mkShortcutAttribute attr@(c:_) = (attr,) <$> strOption
( long attr <> short c <> metavar (toUpper <$> attr) )
mkShortcutAttribute :: String -> Opts.Parser (String, String)
mkShortcutAttribute = \case
attr@(c:_) -> (attr,) <$> Opts.strOption
( Opts.long attr <> Opts.short c <> Opts.metavar (toUpper <$> attr) )
_ -> error "The attribute name should not be an empty string"
fixupAttributes :: (String, String) -> (T.Text, Value)
fixupAttributes (k, v) = (T.pack k, String (T.pack v))
parsePackage :: Parser (PackageName, PackageSpec)
parsePackage :: Opts.Parser (PackageName, PackageSpec)
parsePackage = (,) <$> parsePackageName <*> parsePackageSpec
-------------------------------------------------------------------------------
-- PACKAGE SPEC OPS
-------------------------------------------------------------------------------
updatePackageSpec :: PackageSpec -> IO PackageSpec
updatePackageSpec = execStateT $ do
-- Figures out the URL from the template
withPackageSpecAttr "url_template" (\case
String (T.unpack -> template) -> do
packageSpec <- get
let stringValues = packageSpecStringValues packageSpec
case renderTemplate stringValues template of
Just renderedURL ->
setPackageSpecAttr "url" (String $ T.pack renderedURL)
Nothing -> pure ()
_ -> pure ()
)
-- Updates the sha256 based on the URL contents
withPackageSpecAttr "url" (\case
String (T.unpack -> url) -> do
sha256 <- liftIO $ nixPrefetchURL url
setPackageSpecAttr "sha256" (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 (String owner), Just (String repo)) -> do
liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
>>= \case
Left _ -> pure ()
Right ghRepo -> do
-- Description
whenNotSet "description" $ case GH.repoDescription ghRepo of
Just descr -> setPackageSpecAttr "description" (String descr)
Nothing -> pure ()
-- Branch and rev
whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
Just branch -> setPackageSpecAttr "branch" (String branch)
Nothing -> pure ()
withPackageSpecAttr "branch" (\case
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" (String rev)
_ -> pure ()
_ -> pure ()
)
(_,_) -> pure ()
-- Figures out the URL template
whenNotSet "url_template" $
setPackageSpecAttr "url_template" (String $ T.pack githubURLTemplate)
where
githubURLTemplate :: String
githubURLTemplate =
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
-------------------------------------------------------------------------------
-- PackageSpec State helpers
-------------------------------------------------------------------------------
whenNotSet
:: T.Text
-> StateT (PackageName, PackageSpec) IO ()
-> StateT (PackageName, PackageSpec) IO ()
-> StateT PackageSpec IO ()
-> StateT PackageSpec IO ()
whenNotSet attrName act = getPackageSpecAttr attrName >>= \case
Just _ -> pure ()
Nothing -> act
withPackageSpecAttr
:: T.Text
-> (Value -> StateT (PackageName, PackageSpec) IO ())
-> StateT (PackageName, PackageSpec) IO ()
-> (Value -> StateT PackageSpec IO ())
-> StateT PackageSpec IO ()
withPackageSpecAttr attrName act = getPackageSpecAttr attrName >>= \case
Just v -> act v
Nothing -> pure ()
getPackageSpecAttr
:: T.Text
-> StateT (PackageName, PackageSpec) IO (Maybe Value)
-> StateT PackageSpec IO (Maybe Value)
getPackageSpecAttr attrName = do
(_, PackageSpec obj) <- get
PackageSpec obj <- get
pure $ HMap.lookup attrName obj
setPackageSpecAttr
:: T.Text -> Value
-> StateT (PackageName, PackageSpec) IO ()
-> StateT PackageSpec IO ()
setPackageSpecAttr attrName attrValue = do
(packageName, PackageSpec obj) <- get
PackageSpec obj <- get
let obj' = HMap.insert attrName attrValue obj
put (packageName, PackageSpec obj')
setPackageName
:: String -> StateT (PackageName, PackageSpec) IO ()
setPackageName packageName = do
(_, spec) <- get
put (PackageName packageName, spec)
put (PackageSpec obj')
hasPackageSpecAttrs
:: [String]
-> StateT (PackageName, PackageSpec) IO Bool
-> StateT PackageSpec IO Bool
hasPackageSpecAttrs attrNames = do
(_, PackageSpec obj) <- get
PackageSpec obj <- get
pure $ all (\k -> HMap.member (T.pack k) obj) attrNames
packageSpecStringValues :: PackageSpec -> [(String, String)]
packageSpecStringValues (PackageSpec m) = mapMaybe toVal (HMap.toList m)
where
@ -172,8 +241,8 @@ packageSpecStringValues (PackageSpec m) = mapMaybe toVal (HMap.toList m)
-- INIT
-------------------------------------------------------------------------------
parseCmdInit :: ParserInfo (IO ())
parseCmdInit = (info (pure cmdInit <**> helper)) fullDesc
parseCmdInit :: Opts.ParserInfo (IO ())
parseCmdInit = (Opts.info (pure cmdInit <**> Opts.helper)) Opts.fullDesc
cmdInit :: IO ()
cmdInit = do
@ -206,87 +275,53 @@ cmdInit = do
-- ADD
-------------------------------------------------------------------------------
parseCmdAdd :: ParserInfo (IO ())
parseCmdAdd = (info ((cmdAdd <$> parsePackage) <**> helper)) fullDesc
parseCmdAdd :: Opts.ParserInfo (IO ())
parseCmdAdd =
Opts.info ((cmdAdd <$> parsePackage <*> optName) <**> Opts.helper)
Opts.fullDesc
where
optName :: Opts.Parser (Maybe PackageName)
optName = Opts.optional $ PackageName <$> Opts.strOption
( Opts.long "name" <>
Opts.short 'n' <>
Opts.metavar "NAME"
)
cmdAdd :: (PackageName, PackageSpec) -> IO ()
cmdAdd package = do
(packageName, packageSpec) <- addCompletePackageSpec package
versionsSpec <- HMap.insert packageName packageSpec . unVersionsSpec <$>
getVersionsSpec
putStrLn $ "Writing new versions file"
print versionsSpec
-- encodeFile fileVersionsJson fileVersionsValue'
addCompletePackageSpec
:: (PackageName, PackageSpec)
-> IO (PackageName, PackageSpec)
addCompletePackageSpec x@(PackageName str, _) = flip execStateT x $ do
cmdAdd :: (PackageName, PackageSpec) -> Maybe PackageName -> IO ()
cmdAdd (PackageName str, spec) mPackageName = do
-- Figures out the owner and repo
case span (/= '/') str of
(packageName, spec') <- flip runStateT spec $ case span (/= '/') str of
(owner@(_:_), '/':repo@(_:_)) -> do
whenNotSet "owner" $
setPackageSpecAttr "owner" (String $ T.pack owner)
whenNotSet "repo" $ do
setPackageSpecAttr "repo" (String $ T.pack repo)
setPackageName repo
_ -> pure ()
pure (PackageName repo)
_ -> pure (PackageName str)
-- In case we have @owner@ and @repo@, pull some data from GitHub
(,) <$> getPackageSpecAttr "owner" <*> getPackageSpecAttr "repo" >>= \case
(Just (String owner), Just (String repo)) -> do
liftIO (GH.executeRequest' $ GH.repositoryR (GH.N owner) (GH.N repo))
>>= \case
Right ghRepo -> do
VersionsSpec versionsSpec <- getVersionsSpec
-- Description
whenNotSet "description" $ case GH.repoDescription ghRepo of
Just descr -> setPackageSpecAttr "description" (String descr)
Nothing -> pure ()
let packageName' = fromMaybe packageName mPackageName
-- Branch and rev
whenNotSet "branch" $ case GH.repoDefaultBranch ghRepo of
Just branch -> do
setPackageSpecAttr "branch" (String branch)
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" (String rev)
_ -> pure ()
Nothing -> pure ()
when (HMap.member packageName' versionsSpec) $ do
error $ unlines
[ "Use niv drop <package> and then niv add"
, "Or use nix update --attr foo bar to update"
]
-- Figures out the URL template
whenNotSet "url_template" $
setPackageSpecAttr "url_template" (String $ T.pack githubURLTemplate)
spec'' <- updatePackageSpec =<< completePackageSpec spec'
-- Figures out the URL from the template
withPackageSpecAttr "url_template" (\case
String (T.unpack -> template) -> do
(_, packageSpec) <- get
let stringValues = packageSpecStringValues packageSpec
case renderTemplate stringValues template of
Just renderedURL ->
setPackageSpecAttr "url" (String $ T.pack renderedURL)
Nothing -> pure ()
_ -> pure ()
)
where
githubURLTemplate :: String
githubURLTemplate =
"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
putStrLn $ "Writing new versions file"
setVersionsSpec $ VersionsSpec $
HMap.insert packageName' spec'' versionsSpec
-------------------------------------------------------------------------------
-- SHOW
-------------------------------------------------------------------------------
parseCmdShow :: ParserInfo (IO ())
parseCmdShow = info (pure cmdShow <**> helper) fullDesc
parseCmdShow :: Opts.ParserInfo (IO ())
parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc
cmdShow :: IO ()
cmdShow = do
@ -306,46 +341,80 @@ cmdShow = do
-- UPDATE
-------------------------------------------------------------------------------
parseCmdUpdate :: ParserInfo (IO ())
parseCmdUpdate = info ((cmdUpdate <$> parsePackage) <**> helper) fullDesc
parseCmdUpdate :: Opts.ParserInfo (IO ())
parseCmdUpdate =
Opts.info
((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper)
Opts.fullDesc
cmdUpdate :: (PackageName, PackageSpec) -> IO ()
cmdUpdate pkgs = do
putStrLn $ "Updating versions file"
cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO ()
cmdUpdate = \case
Just (packageName, packageSpec) -> do
putStrLn $ "Updating single package: " <> unPackageName packageName
VersionsSpec versionsSpec <- getVersionsSpec
VersionsSpec fileVersionsValue <- getVersionsSpec
packageSpec' <- case HMap.lookup packageName versionsSpec of
Just packageSpec' -> do
updatePackageSpec $ PackageSpec $ HMap.union
(unPackageSpec packageSpec)
(unPackageSpec packageSpec')
Nothing -> error $ "Package not found: " <> unPackageName packageName
fileVersionsValue' <- forWithKeyM fileVersionsValue $ \key spec -> do
putStrLn $ "Package: " <> unPackageName key
setVersionsSpec $ VersionsSpec $
HMap.insert packageName packageSpec' versionsSpec
-- TODO: use StateT
-- let packageUrl <- renderTemplate
Nothing -> do
VersionsSpec versionsSpec <- getVersionsSpec
-- putStrLn $ " URL: " <> packageUrl
versionsSpec' <- forWithKeyM versionsSpec $
\packageName packageSpec -> do
putStrLn $ "Package: " <> unPackageName packageName
updatePackageSpec packageSpec
-- sha256 <- nixPrefetchURL packageUrl
setVersionsSpec $ VersionsSpec versionsSpec'
-- putStrLn $ " SHA256: " <> sha256
-------------------------------------------------------------------------------
-- DROP
-------------------------------------------------------------------------------
putStrLn $ "Writing new versions file"
encodeFile fileVersionsJson fileVersionsValue'
parseCmdDrop :: Opts.ParserInfo (IO ())
parseCmdDrop =
Opts.info
((cmdDrop <$> parsePackageName) <**> Opts.helper)
Opts.fullDesc
parseCommand :: Parser (IO ())
parseCommand = subparser (
command "init" parseCmdInit <>
command "add" parseCmdAdd <>
command "show" parseCmdShow <>
command "update" parseCmdUpdate )
cmdDrop :: PackageName -> IO ()
cmdDrop packageName = do
putStrLn $ "Dropping package: " <> unPackageName packageName
VersionsSpec versionsSpec <- getVersionsSpec
when (not $ HMap.member packageName versionsSpec) $
error $ "No such package: " <> unPackageName packageName
setVersionsSpec $ VersionsSpec $
HMap.delete packageName versionsSpec
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 )
main :: IO ()
main = join $ execParser opts
main = join $ Opts.execParser opts
where
opts = info (parseCommand <**> helper)
( fullDesc
<> header "NIV - Nix Version manager" )
opts = Opts.info (parseCommand <**> Opts.helper)
( Opts.fullDesc
<> Opts.header "NIV - Nix Version manager" )
nixPrefetchURL :: String -> IO String
nixPrefetchURL = pure
nixPrefetchURL url =
lines <$> readProcess "nix-prefetch-url" ["--unpack", url] "" >>=
\case
(l:_) -> pure l
_ -> error "Expected at least one line from nix-prefetch-url"
-------------------------------------------------------------------------------
-- Aux
@ -385,7 +454,6 @@ forWithKeyM_
-> m ()
forWithKeyM_ = flip mapWithKeyM_
mapWithKeyM
:: (Eq k, Hashable k, Monad m)
=> (k -> v1 -> m v2)
@ -415,6 +483,6 @@ renderTemplate vals = \case
case span (/= '>') str of
(key, '>':rest) ->
liftA2 (<>) (lookup key vals) (renderTemplate vals rest)
_ -> Nothing
c:str -> (c:) <$> renderTemplate vals str
[] -> Just []

View File

@ -1,16 +1 @@
{
"nixpkgs": {
"owner": "NixOS",
"repo": "nixpkgs-channels",
"branch": "nixos-18.09",
"rev": "c2950341d038995bf46a7b72db961bb3d3e9ac12",
"sha256": "1adpvp20b3zwxchnvkag8d0m7qlnwxv3l9z1lg96kr5ffwk37prv"
},
"snack": {
"owner": "nmattia",
"repo": "snack",
"branch": "master",
"rev": "9754f4120d28ce25888a608606deddef9f490654",
"sha256": "1a2gcap2z41vk3d7cqydj880lwcpxljd49w6srb3gplciipha6zv"
}
}
{"nixpkgs":{"url":"https://github.com/NixOS/nixpkgs-channels/archive/138f2cc707d7ee13d93c86db3285460e244c402c.tar.gz","owner":"NixOS","branch":"nixos-18.03","url_template":"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz","repo":"nixpkgs-channels","sha256":"0h49j1cbnccqx996x80z7na9p7slnj9liz646s73s55am8wc9q8q","description":"Nixpkgs/NixOS branches that track the Nixpkgs/NixOS channels","rev":"138f2cc707d7ee13d93c86db3285460e244c402c"},"snack":{"url":"https://github.com/nmattia/snack/archive/88f6a410291b4332d65481fcca593a5555a605e7.tar.gz","owner":"nmattia","branch":"master","url_template":"https://github.com/<owner>/<repo>/archive/<rev>.tar.gz","repo":"snack","sha256":"1z6dph28372ffwwp2xhrkhg4gjx27h0my3cs5gy3p5qgkh682cb7","description":"Nix-based incremental build tool for Haskell projects","rev":"88f6a410291b4332d65481fcca593a5555a605e7"}}