From 6513755670892983db88a6633b8c1ea6019c03d1 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Fri, 15 Nov 2024 14:55:37 -0500 Subject: Re-namespace some stuff to Omni I was getting confused about what is a product and what is internal infrastructure; I think it is good to keep those things separate. So I moved a bunch of stuff to an Omni namespace, actually most stuff went there. Only things that are explicitly external products are still in the Biz namespace. --- Biz/Bild/Deps.hs | 694 ------------------------------------------------------- 1 file changed, 694 deletions(-) delete mode 100644 Biz/Bild/Deps.hs (limited to 'Biz/Bild/Deps.hs') diff --git a/Biz/Bild/Deps.hs b/Biz/Bild/Deps.hs deleted file mode 100644 index e268a74..0000000 --- a/Biz/Bild/Deps.hs +++ /dev/null @@ -1,694 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - --- | A specific-purpose dependency manager. --- --- : out deps -module Biz.Bild.Deps where - -import Alpha hiding (map, packageName, str, tshow) -import Data.Aeson ((.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Key as K -import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.HashMap.Strict as HMS -import Data.HashMap.Strict.Extended -import qualified Data.Text as T -import Data.Text.Extended -import GHC.Show -import qualified Network.HTTP.Simple as HTTP -import Niv.Cmd (Cmd, description, extraLogs, parseCmdShortcut, parsePackageSpec, updateCmd) -import Niv.Git.Cmd -import Niv.GitHub.Cmd -import Niv.Local.Cmd -import Niv.Logger -import Niv.Sources -import Niv.Update -import qualified Options.Applicative as Opts -import qualified Options.Applicative.Help.Pretty as Opts -import qualified System.Directory as Dir -import System.Environment (getEnv) -import System.FilePath (takeDirectory, ()) -import UnliftIO -import Prelude - -newtype NIO a = NIO {runNIO :: ReaderT FindSourcesJson IO a} - deriving (Functor, Applicative, Monad, MonadIO, MonadReader FindSourcesJson) - -instance MonadUnliftIO NIO where - withRunInIO = wrappedWithRunInIO NIO runNIO - -getFindSourcesJson :: NIO FindSourcesJson --- getFindSourcesJson = ask -getFindSourcesJson = do - root <- li <| getEnv "CODEROOT" - pure <| AtPath <| root "Biz/Bild/Sources.json" - -li :: (MonadIO io) => IO a -> io a -li = liftIO - -main :: IO () -main = - getArgs +> \case - ["test"] -> pure () - args -> cli args - -cli :: [String] -> IO () -cli args = do - ((fsj, colors), nio) <- - pure args +> Opts.handleParseResult <. execParserPure' Opts.defaultPrefs opts - setColors colors - runReaderT (runNIO nio) fsj - where - execParserPure' pprefs pinfo [] = - Opts.Failure - <| Opts.parserFailure pprefs pinfo (Opts.ShowHelpText Nothing) mempty - execParserPure' pprefs pinfo args_ = Opts.execParserPure pprefs pinfo args_ - opts = Opts.info ((,) parseColors) <*> (parseCommand <**> Opts.helper)) <| mconcat desc - desc = - [ Opts.fullDesc, - Opts.headerDoc - <| Just - <| "deps - specific-purpose dependency manager" - ] - parseFindSourcesJson = - AtPath - Opts.short 's' - <> Opts.metavar "FILE" - <> Opts.help "Use FILE instead of Biz/Bild/Sources.json" - ) - <|> pure Auto - parseColors = - (\case True -> Never; False -> Always) - Opts.help "Don't use colors in output" - ) - -parseCommand :: Opts.Parser (NIO ()) -parseCommand = - Opts.subparser - ( Opts.command "init" parseCmdInit - <> Opts.command "add" parseCmdAdd - <> Opts.command "show" parseCmdShow - <> Opts.command "update" parseCmdUpdate - <> Opts.command "modify" parseCmdModify - <> Opts.command "drop" parseCmdDrop - ) - -parsePackageName :: Opts.Parser PackageName -parsePackageName = - PackageName - parsePackageSpec githubCmd - -------------------------------------------------------------------------------- --- INIT -------------------------------------------------------------------------------- - --- | Whether or not to fetch nixpkgs -data FetchNixpkgs - = NoNixpkgs - | NixpkgsFast -- Pull latest known nixpkgs - | NixpkgsCustom T.Text Nixpkgs -- branch, nixpkgs - deriving (Show) - -data Nixpkgs = Nixpkgs T.Text T.Text -- owner, repo - -instance Show Nixpkgs where - show (Nixpkgs o r) = T.unpack o <> "/" <> T.unpack r - -parseCmdInit :: Opts.ParserInfo (NIO ()) -parseCmdInit = Opts.info (cmdInit Opts.helper) <| mconcat desc - where - desc = - [ Opts.fullDesc, - Opts.progDesc - "Initialize a Nix project. Existing files won't be modified." - ] - -parseNixpkgs :: Opts.Parser FetchNixpkgs -parseNixpkgs = parseNixpkgsFast <|> parseNixpkgsLatest <|> parseNixpkgsCustom <|> parseNoNixpkgs <|> pure NixpkgsFast - where - parseNixpkgsFast = - Opts.flag' - NixpkgsFast - ( Opts.long "fast" - <> Opts.help "Use the latest nixpkgs cached at 'https://github.com/nmattia/niv/blob/master/data/nixpkgs.json'. This is the default." - ) - parseNixpkgsLatest = - Opts.flag' - (NixpkgsCustom "master" (Nixpkgs "NixOS" "nixpkgs")) - ( Opts.long "latest" - <> Opts.help "Pull the latest unstable nixpkgs from NixOS/nixpkgs." - ) - parseNixpkgsCustom = - flip NixpkgsCustom - Opts.showDefault - <> Opts.help "Use a custom nixpkgs repository from GitHub." - <> Opts.metavar "OWNER/REPO" - ) - <*> Opts.strOption - ( Opts.long "nixpkgs-branch" - <> Opts.short 'b' - <> Opts.help "The nixpkgs branch when using --nixpkgs ...." - <> Opts.showDefault - ) - parseNoNixpkgs = - Opts.flag' - NoNixpkgs - ( Opts.long "no-nixpkgs" - <> Opts.help "Don't add a nixpkgs entry to Sources.json." - ) - customNixpkgsReader = - Opts.maybeReader <| \(T.pack -> repo) -> case T.splitOn "/" repo of - [owner, reponame] -> Just (Nixpkgs owner reponame) - _ -> Nothing - -cmdInit :: FetchNixpkgs -> NIO () -cmdInit nixpkgs = do - job "Initializing" <| do - fsj <- getFindSourcesJson - -- 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 - say "Updating sources.nix" - li <| B.writeFile path initNixSourcesNixContent - else say "Not updating sources.nix" - ), - ( pathNixSourcesJson fsj, - \path -> do - createFile path initNixSourcesJsonContent - - -- Import nixpkgs, if necessary - initNixpkgs nixpkgs, - \path _content -> dontCreateFile path - ) - ] - <| \(path, onCreate, onUpdate) -> do - exists <- li <| Dir.doesFileExist path - if exists then li (B.readFile path) +> onUpdate path else onCreate path - case fsj of - Auto -> pure () - AtPath fp -> - tsay - <| T.unlines - [ T.unwords - [ tbold <| tblue "INFO:", - "You are using a custom path for sources.json." - ], - " You need to configure the sources.nix to use " <> tbold (T.pack fp) <> ":", - tbold " import sources.nix { sourcesFile = PATH ; }; ", - T.unwords - [ " where", - tbold "PATH", - "is the relative path from sources.nix to", - tbold (T.pack fp) <> "." - ] - ] - where - createFile :: FilePath -> B.ByteString -> NIO () - createFile path content = - li <| do - let dir = takeDirectory path - Dir.createDirectoryIfMissing True dir - say <| "Creating " <> path - B.writeFile path content - dontCreateFile :: FilePath -> NIO () - dontCreateFile path = say <| "Not creating " <> path - -initNixpkgs :: FetchNixpkgs -> NIO () -initNixpkgs nixpkgs = - case nixpkgs of - NoNixpkgs -> say "Not importing 'nixpkgs'." - NixpkgsFast -> do - say "Using known 'nixpkgs' ..." - packageSpec <- HTTP.getResponseBody do - say "Importing 'nixpkgs' ..." - let (owner, repo) = case nixpkgs' of - Nixpkgs o r -> (o, r) - cmdAdd - githubCmd - (PackageName "nixpkgs") - ( specToFreeAttrs - <| PackageSpec - <| KM.fromList - [ "owner" .= owner, - "repo" .= repo, - "branch" .= branch - ] - ) - -------------------------------------------------------------------------------- --- ADD -------------------------------------------------------------------------------- - -parseCmdAdd :: Opts.ParserInfo (NIO ()) -parseCmdAdd = - Opts.info - ((parseCommands <|> parseShortcuts) <**> Opts.helper) - <| description githubCmd - where - -- XXX: this should parse many shortcuts (github, git). Right now we only - -- parse GitHub because the git interface is still experimental. note to - -- implementer: it'll be tricky to have the correct arguments show up - -- without repeating "PACKAGE PACKAGE PACKAGE" for every package type. - parseShortcuts = parseShortcut githubCmd - parseShortcut cmd = uncurry (cmdAdd cmd) Opts.helper) (description gitCmd) - parseCmdAddLocal = - Opts.info (parseCmd localCmd <**> Opts.helper) (description localCmd) - parseCmdAddGitHub = - Opts.info (parseCmd githubCmd <**> Opts.helper) (description githubCmd) - parseCommands = - Opts.subparser - ( Opts.hidden - <> Opts.commandGroup "Experimental commands:" - <> Opts.command "git" parseCmdAddGit - <> Opts.command "github" parseCmdAddGitHub - <> Opts.command "local" parseCmdAddLocal - ) - --- | only used in shortcuts (niv add foo/bar ...) because PACKAGE is NOT --- optional -parseShortcutArgs :: Cmd -> Opts.Parser (PackageName, Attrs) -parseShortcutArgs cmd = collapse parsePackageSpec cmd - where - collapse specAndName pspec = (pname, specToLockedAttrs <| pspec <> baseSpec) - where - (pname, baseSpec) = case specAndName of - ((_, spec), Just pname') -> (pname', PackageSpec spec) - ((pname', spec), Nothing) -> (pname', PackageSpec spec) - parseNameAndShortcut = - (,) - optName - optName = - Opts.optional - <| PackageName - Opts.short 'n' - <> Opts.metavar "NAME" - <> Opts.help "Set the package name to " - ) - --- | only used in command (niv add ...) because PACKAGE is optional -parseCmdArgs :: Cmd -> Opts.Parser (PackageName, Attrs) -parseCmdArgs cmd = collapse parsePackageSpec cmd - where - collapse specAndName pspec = (pname, specToLockedAttrs <| pspec <> baseSpec) - where - (pname, baseSpec) = case specAndName of - (Just (_, spec), Just pname') -> (pname', PackageSpec spec) - (Just (pname', spec), Nothing) -> (pname', PackageSpec spec) - (Nothing, Just pname') -> (pname', PackageSpec KM.empty) - (Nothing, Nothing) -> (PackageName "unnamed", PackageSpec KM.empty) - parseNameAndShortcut = - (,) - optName - optName = - Opts.optional - <| PackageName - Opts.short 'n' - <> Opts.metavar "NAME" - <> Opts.help "Set the package name to " - ) - -cmdAdd :: Cmd -> PackageName -> Attrs -> NIO () -cmdAdd cmd packageName attrs = do - job ("Adding package " <> T.unpack (unPackageName packageName)) <| do - fsj <- getFindSourcesJson - sources <- unSources li (abortUpdateFailed [(packageName, e)]) - Right finalSpec -> do - say <| "Writing new sources file" - li - <| setSources fsj - <| Sources - <| HMS.insert packageName finalSpec sources - -------------------------------------------------------------------------------- --- SHOW -------------------------------------------------------------------------------- - -parseCmdShow :: Opts.ParserInfo (NIO ()) -parseCmdShow = - Opts.info - ((cmdShow Opts.helper) - <| Opts.progDesc "Show information about a dependency in human-readable format" - -cmdShow :: Maybe PackageName -> NIO () -cmdShow = \case - Just packageName -> do - fsj <- getFindSourcesJson - sources <- unSources showPackage packageName pspec - Nothing -> li <| abortCannotShowNoSuchPackage packageName - Nothing -> do - fsj <- getFindSourcesJson - sources <- unSources PackageName -> PackageSpec -> io () -showPackage (PackageName pname) (PackageSpec spec) = do - tsay <| tbold pname - forM_ (KM.toList spec) <| \(attrName, attrValValue) -> do - let attrValue = case attrValValue of - Aeson.String str -> str - _ -> tfaint "" - tsay <| " " <> K.toText attrName <> ": " <> attrValue - -------------------------------------------------------------------------------- --- UPDATE -------------------------------------------------------------------------------- - -parseCmdUpdate :: Opts.ParserInfo (NIO ()) -parseCmdUpdate = - Opts.info - ((cmdUpdate Opts.helper) - <| mconcat desc - where - desc = - [ Opts.fullDesc, - Opts.progDesc "Update dependencies", - Opts.headerDoc - <| Just - <| Opts.nest 2 - <| Opts.vcat - [ "Examples:", - Opts.fill 30 "deps update" Opts.<+> "# update all packages", - Opts.fill 30 "deps update nixpkgs" Opts.<+> "# update nixpkgs", - Opts.fill 30 "deps update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\"" - ] - ] - -specToFreeAttrs :: PackageSpec -> Attrs -specToFreeAttrs = KM.toHashMapText <. fmap (Free,) <. unPackageSpec - -specToLockedAttrs :: PackageSpec -> Attrs -specToLockedAttrs = KM.toHashMapText <. fmap (Locked,) <. unPackageSpec - -cmdUpdate :: Maybe (PackageName, PackageSpec) -> NIO () -cmdUpdate = \case - Just (packageName, cliSpec) -> - job ("Update " <> T.unpack (unPackageName packageName)) <| do - fsj <- getFindSourcesJson - sources <- unSources do - -- lookup the "type" to find a Cmd to run, defaulting to legacy - -- github - let cmd = case KM.lookup "type" (unPackageSpec defaultSpec) of - Just "git" -> gitCmd - Just "local" -> localCmd - _ -> githubCmd - spec = specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec - fmap attrsToSpec li <| abortCannotUpdateNoSuchPackage packageName - case eFinalSpec of - Left e -> li <| abortUpdateFailed [(packageName, e)] - Right finalSpec -> - li - <| setSources fsj - <| Sources - <| HMS.insert packageName finalSpec sources - Nothing -> - job "Updating all packages" <| do - fsj <- getFindSourcesJson - sources <- unSources do - tsay <| "Package: " <> unPackageName packageName - let initialSpec = specToFreeAttrs defaultSpec - -- lookup the "type" to find a Cmd to run, defaulting to legacy - -- github - let cmd = case KM.lookup "type" (unPackageSpec defaultSpec) of - Just "git" -> gitCmd - Just "local" -> localCmd - _ -> githubCmd - fmap attrsToSpec Cmd -> IO (Either SomeException Attrs) -doUpdate attrs cmd = do - forM_ (extraLogs cmd attrs) <| tsay - tryEvalUpdate attrs (updateCmd cmd) - -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) - -------------------------------------------------------------------------------- --- MODIFY -------------------------------------------------------------------------------- - -parseCmdModify :: Opts.ParserInfo (NIO ()) -parseCmdModify = - Opts.info - ((cmdModify optName <*> parsePackageSpec githubCmd) <**> Opts.helper) - <| mconcat desc - where - desc = - [ Opts.fullDesc, - Opts.progDesc "Modify dependency attributes without performing an update", - Opts.headerDoc - <| Just - <| Opts.vcat - [ "Examples:", - "", - " niv modify nixpkgs -v beta-0.2", - " niv modify nixpkgs -a branch=nixpkgs-unstable" - ] - ] - optName = - Opts.optional - <| PackageName - Opts.short 'n' - <> Opts.metavar "NAME" - <> Opts.help "Set the package name to " - ) - -cmdModify :: PackageName -> Maybe PackageName -> PackageSpec -> NIO () -cmdModify packageName mNewName cliSpec = do - tsay <| "Modifying package: " <> unPackageName packageName - fsj <- getFindSourcesJson - sources <- unSources pure <| attrsToSpec (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) - Nothing -> li <| abortCannotModifyNoSuchPackage packageName - case mNewName of - Just newName -> do - when (HMS.member newName sources) - <| li - <| abortCannotAddPackageExists newName - li <| setSources fsj <| Sources <| HMS.insert newName finalSpec <| HMS.delete packageName sources - Nothing -> - li <| setSources fsj <| Sources <| HMS.insert packageName finalSpec sources - -------------------------------------------------------------------------------- --- DROP -------------------------------------------------------------------------------- - -parseCmdDrop :: Opts.ParserInfo (NIO ()) -parseCmdDrop = - Opts.info - ( (cmdDrop parseDropAttributes) - <**> Opts.helper - ) - <| mconcat desc - where - desc = - [ Opts.fullDesc, - Opts.progDesc "Drop dependency", - Opts.headerDoc - <| Just - <| Opts.vcat - [ "Examples:", - "", - " niv drop jq", - " niv drop my-package version" - ] - ] - parseDropAttributes :: Opts.Parser [T.Text] - parseDropAttributes = - many - <| Opts.argument Opts.str (Opts.metavar "ATTRIBUTE") - -cmdDrop :: PackageName -> [T.Text] -> NIO () -cmdDrop packageName = \case - [] -> do - tsay <| "Dropping package: " <> unPackageName packageName - fsj <- getFindSourcesJson - sources <- unSources do - tsay <| "Dropping attributes: " <> T.intercalate " " attrs - tsay <| "In package: " <> unPackageName packageName - fsj <- getFindSourcesJson - sources <- unSources - li <| abortCannotAttributesDropNoSuchPackage packageName - Just (PackageSpec packageSpec) -> - pure - <| PackageSpec - <| KM.mapMaybeWithKey - (\k v -> if K.toText k `elem` attrs then Nothing else Just v) - packageSpec - li - <| setSources fsj - <| Sources - <| HMS.insert packageName packageSpec sources - -------------------------------------------------------------------------------- --- 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 - -------------------------------------------------------------------------------- --- Abort -------------------------------------------------------------------------------- - -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 <> " --attribute 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." - ] - -abortCannotModifyNoSuchPackage :: PackageName -> IO a -abortCannotModifyNoSuchPackage (PackageName n) = - abort - <| T.unlines - [ "Cannot modify 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." - ] - -abortCannotShowNoSuchPackage :: PackageName -> IO a -abortCannotShowNoSuchPackage (PackageName n) = - abort - <| T.unlines - [ "Cannot show 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 -- cgit v1.2.3