From 7789b951246140603f0f57fa3f3086c11d3b4d2d Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Sun, 9 Jun 2019 22:42:35 +0200 Subject: [PATCH] New update mechanism --- app/Niv.hs | 185 ++++++------------------ default.nix | 10 +- package.yaml | 51 ++++--- script/test | 2 +- site/niv.svg | 6 +- src/Niv/GitHub.hs | 97 +++++++++++++ src/Niv/GitHub/Test.hs | 136 ++++++++++++++++++ src/Niv/Test.hs | 26 ++++ src/Niv/Update.hs | 269 +++++++++++++++++++++++++++++++++++ src/Niv/Update/Test.hs | 114 +++++++++++++++ tests/default.nix | 10 +- tests/expected/niv-init.json | 1 + 12 files changed, 738 insertions(+), 169 deletions(-) create mode 100644 src/Niv/GitHub.hs create mode 100644 src/Niv/GitHub/Test.hs create mode 100644 src/Niv/Test.hs create mode 100644 src/Niv/Update.hs create mode 100644 src/Niv/Update/Test.hs diff --git a/app/Niv.hs b/app/Niv.hs index 6c54e2c..22790fd 100644 --- a/app/Niv.hs +++ b/app/Niv.hs @@ -7,17 +7,20 @@ {-# 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.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 Niv.GitHub +import Niv.Test +import Niv.Update import System.Exit (exitFailure) import System.FilePath ((), takeDirectory) import System.Process (readProcess) @@ -31,10 +34,10 @@ 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 qualified Test.Tasty as Tasty main :: IO () main = join $ Opts.execParser opts @@ -86,9 +89,13 @@ parsePackageName :: Opts.Parser PackageName parsePackageName = PackageName <$> Opts.argument Opts.str (Opts.metavar "PACKAGE") -newtype PackageSpec = PackageSpec { _unPackageSpec :: Aeson.Object } +newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) +-- | Simply discards the 'Freedom' +attrsToSpec :: Attrs -> PackageSpec +attrsToSpec = PackageSpec . fmap snd + parsePackageSpec :: Opts.Parser PackageSpec parsePackageSpec = (PackageSpec . HMS.fromList . fmap fixupAttributes) <$> @@ -126,6 +133,7 @@ parsePackageSpec = 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 @@ -150,113 +158,8 @@ 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///archive/.tar.gz" +test :: IO () +test = Tasty.defaultMain $ Niv.Test.tests ------------------------------------------------------------------------------- -- PackageSpec State helpers @@ -382,18 +285,14 @@ parseCmdAdd = ] cmdAdd :: Maybe PackageName -> (PackageName, PackageSpec) -> IO () -cmdAdd mPackageName (PackageName str, spec) = do +cmdAdd mPackageName (PackageName str, cliSpec) = do -- Figures out the owner and repo - (packageName, spec') <- flip runStateT spec $ case T.span (/= '/') str of + let (packageName, defaultSpec) = 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) + (PackageName repo, HMS.fromList [ "owner" .= owner, "repo" .= repo ]) + _ -> (PackageName str, HMS.empty) sources <- unSources <$> getSources @@ -402,7 +301,11 @@ cmdAdd mPackageName (PackageName str, spec) = do when (HMS.member packageName' sources) $ abortCannotAddPackageExists packageName' - spec'' <- updatePackageSpec =<< completePackageSpec spec' + let defaultSpec' = PackageSpec $ defaultSpec + + spec'' <- attrsToSpec <$> evalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec') + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) putStrLn $ "Writing new sources file" setSources $ Sources $ @@ -415,6 +318,7 @@ cmdAdd mPackageName (PackageName str, spec) = do parseCmdShow :: Opts.ParserInfo (IO ()) parseCmdShow = Opts.info (pure cmdShow <**> Opts.helper) Opts.fullDesc +-- TODO: nicer output cmdShow :: IO () cmdShow = do putStrLn $ "Showing sources file" @@ -450,6 +354,13 @@ parseCmdUpdate = " niv update my-package -v beta-0.2" ] +specToFreeAttrs :: PackageSpec -> Attrs +specToFreeAttrs = fmap (Free,) . unPackageSpec + +specToLockedAttrs :: PackageSpec -> Attrs +specToLockedAttrs = fmap (Locked,) . unPackageSpec + +-- TODO: sexy logging + concurrent updates cmdUpdate :: Maybe (PackageName, PackageSpec) -> IO () cmdUpdate = \case Just (packageName, packageSpec) -> do @@ -458,10 +369,9 @@ cmdUpdate = \case packageSpec' <- case HMS.lookup packageName sources of Just packageSpec' -> do - - -- TODO: something fishy happening here - pkgSpec <- completePackageSpec $ packageSpec <> packageSpec' - updatePackageSpec $ pkgSpec + attrsToSpec <$> evalUpdate + (specToLockedAttrs packageSpec <> specToFreeAttrs packageSpec') + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) Nothing -> abortCannotUpdateNoSuchPackage packageName @@ -474,7 +384,9 @@ cmdUpdate = \case sources' <- forWithKeyM sources $ \packageName packageSpec -> do T.putStrLn $ "Package: " <> unPackageName packageName - updatePackageSpec =<< completePackageSpec packageSpec + attrsToSpec <$> evalUpdate + (specToFreeAttrs packageSpec) + (githubUpdate nixPrefetchURL githubLatestRev githubRepo) setSources $ Sources sources' @@ -587,31 +499,16 @@ 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")] "" == Just "bar" --- renderTemplate [("foo", "bar")] "" == 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 = +nixPrefetchURL :: Bool -> T.Text -> IO T.Text +nixPrefetchURL unpack (T.unpack -> url) = lines <$> readProcess "nix-prefetch-url" args "" >>= \case - (l:_) -> pure l + (l:_) -> pure (T.pack l) _ -> abortNixPrefetchExpectedOutput where args = if unpack then ["--unpack", url] else [url] diff --git a/default.nix b/default.nix index 59faee8..988c1ba 100644 --- a/default.nix +++ b/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/**/*.hs src/**/*.hs } echo "To start a REPL session, run:" @@ -94,6 +100,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} diff --git a/package.yaml b/package.yaml index 3a7c28b..f3c3ebb 100644 --- a/package.yaml +++ b/package.yaml @@ -6,24 +6,41 @@ ghc-options: - -Wall - -Werror -executable: - main: app/Niv.hs +dependencies: + - base + - text + - mtl + - unliftio + +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: + source-dirs: + - app + main: Niv.main + data-files: + - nix/sources.nix + dependencies: + - aeson + - aeson-pretty + - bytestring + - directory + - filepath + - github + - hashable + - file-embed + - niv + - optparse-applicative + - process + - string-qq + - tasty + - unordered-containers diff --git a/script/test b/script/test index ed24efd..710ac1d 100755 --- a/script/test +++ b/script/test @@ -11,6 +11,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" diff --git a/site/niv.svg b/site/niv.svg index c972f48..7a633a6 100644 --- a/site/niv.svg +++ b/site/niv.svg @@ -1,10 +1,10 @@ - +