From e0bfb5d007887b906d40e6232e80af2f67675d3f Mon Sep 17 00:00:00 2001 From: Nicolas Mattia Date: Thu, 23 Jul 2020 16:24:16 +0200 Subject: [PATCH] Run Ormolu --- src/Data/Aeson/Extended.hs | 9 +- src/Data/HashMap/Strict/Extended.hs | 51 +- src/Data/Text/Extended.hs | 10 +- src/Niv/Cli.hs | 742 +++++++++++++++------------- src/Niv/Cmd.hs | 19 +- src/Niv/Git/Cmd.hs | 238 +++++---- src/Niv/Git/Test.hs | 96 ++-- src/Niv/GitHub.hs | 55 ++- src/Niv/GitHub/API.hs | 178 +++---- src/Niv/GitHub/Cmd.hs | 207 ++++---- src/Niv/GitHub/Test.hs | 310 ++++++------ src/Niv/Local/Cmd.hs | 59 +-- src/Niv/Logger.hs | 124 +++-- src/Niv/Sources.hs | 239 ++++----- src/Niv/Sources/Test.hs | 8 +- src/Niv/Test.hs | 53 +- src/Niv/Update.hs | 259 +++++----- src/Niv/Update/Test.hs | 114 +++-- 18 files changed, 1482 insertions(+), 1289 deletions(-) diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 822f83c..47b9c5a 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -11,7 +11,8 @@ import qualified Data.ByteString.Lazy as BL encodeFilePretty :: (ToJSON a) => FilePath -> a -> IO () encodeFilePretty fp = BL.writeFile fp . AesonPretty.encodePretty' config where - config = AesonPretty.defConfig { - AesonPretty.confTrailingNewline = True, - AesonPretty.confCompare = compare - } + config = + AesonPretty.defConfig + { AesonPretty.confTrailingNewline = True, + AesonPretty.confCompare = compare + } diff --git a/src/Data/HashMap/Strict/Extended.hs b/src/Data/HashMap/Strict/Extended.hs index 2833b5c..bbf6976 100644 --- a/src/Data/HashMap/Strict/Extended.hs +++ b/src/Data/HashMap/Strict/Extended.hs @@ -1,40 +1,39 @@ - module Data.HashMap.Strict.Extended where import Control.Monad -import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HMS +import Data.Hashable (Hashable) --- HashMap -forWithKeyM - :: (Eq k, Hashable k, Monad m) - => HMS.HashMap k v1 - -> (k -> v1 -> m v2) - -> m (HMS.HashMap k v2) +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_ :: + (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 :: + (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 + 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_ :: + (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 + forM_ (HMS.toList m) $ \(k, v) -> + HMS.singleton k <$> f k v diff --git a/src/Data/Text/Extended.hs b/src/Data/Text/Extended.hs index f8e7c2d..cc4c2b4 100644 --- a/src/Data/Text/Extended.hs +++ b/src/Data/Text/Extended.hs @@ -2,10 +2,10 @@ module Data.Text.Extended where -import Niv.Logger -import UnliftIO -import System.Exit (exitFailure) import qualified Data.Text as T +import Niv.Logger +import System.Exit (exitFailure) +import UnliftIO tshow :: Show a => a -> T.Text tshow = T.pack . show @@ -13,5 +13,5 @@ tshow = T.pack . show -- not quite the perfect place for this abort :: MonadIO io => T.Text -> io a abort msg = do - tsay $ T.unwords [ tbold $ tred "FATAL:", msg ] - liftIO exitFailure + tsay $ T.unwords [tbold $ tred "FATAL:", msg] + liftIO exitFailure diff --git a/src/Niv/Cli.hs b/src/Niv/Cli.hs index 7952492..f4f7091 100644 --- a/src/Niv/Cli.hs +++ b/src/Niv/Cli.hs @@ -12,34 +12,33 @@ import Control.Applicative import Control.Monad import Control.Monad.Reader import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import Data.Char (isSpace) +import qualified Data.HashMap.Strict as HMS import Data.HashMap.Strict.Extended import Data.Hashable (Hashable) +import qualified Data.Text as T import Data.Text.Extended import Data.Version (showVersion) import Niv.Cmd import Niv.Git.Cmd -import Niv.Local.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 +-- I died a little +import Paths_niv (version) +import qualified System.Directory as Dir import System.Environment (getArgs) import System.FilePath (takeDirectory) import UnliftIO -import qualified Data.Aeson as Aeson -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.HashMap.Strict as HMS -import qualified Data.Text as T -import qualified Options.Applicative as Opts -import qualified Options.Applicative.Help.Pretty as Opts -import qualified System.Directory as Dir --- I died a little -import Paths_niv (version) - -newtype NIO a = NIO { runNIO :: ReaderT FindSourcesJson IO a } +newtype NIO a = NIO {runNIO :: ReaderT FindSourcesJson IO a} deriving (Functor, Applicative, Monad, MonadIO, MonadReader FindSourcesJson) instance MonadUnliftIO NIO where @@ -53,42 +52,48 @@ li = liftIO cli :: IO () cli = do - (fsj, nio) <- execParserPure' Opts.defaultPrefs opts <$> getArgs + (fsj, nio) <- + execParserPure' Opts.defaultPrefs opts <$> getArgs >>= Opts.handleParseResult - runReaderT (runNIO nio) fsj + runReaderT (runNIO nio) fsj where - execParserPure' pprefs pinfo [] = Opts.Failure $ - Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty + execParserPure' pprefs pinfo [] = + Opts.Failure $ + Opts.parserFailure pprefs pinfo Opts.ShowHelpText mempty execParserPure' pprefs pinfo args = Opts.execParserPure pprefs pinfo args opts = Opts.info ((,) <$> parseFindSourcesJson <*> (parseCommand <**> Opts.helper)) $ mconcat desc desc = - [ Opts.fullDesc - , Opts.headerDoc $ Just $ - "niv - dependency manager for Nix projects" Opts.<$$> - "" Opts.<$$> - "version:" Opts.<+> Opts.text (showVersion version) + [ Opts.fullDesc, + Opts.headerDoc $ Just $ + "niv - dependency manager for Nix projects" + Opts.<$$> "" + Opts.<$$> "version:" Opts.<+> Opts.text (showVersion version) ] parseFindSourcesJson = - AtPath <$> Opts.strOption ( - Opts.long "sources-file" <> - Opts.short 's' <> - Opts.metavar "FILE" <> - Opts.help "Use FILE instead of nix/sources.json" - ) <|> pure Auto - + AtPath + <$> Opts.strOption + ( Opts.long "sources-file" + <> Opts.short 's' + <> Opts.metavar "FILE" + <> Opts.help "Use FILE instead of nix/sources.json" + ) + <|> pure Auto 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 ) +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 <$> - Opts.argument Opts.str (Opts.metavar "PACKAGE") +parsePackageName = + PackageName + <$> Opts.argument Opts.str (Opts.metavar "PACKAGE") parsePackage :: Opts.Parser (PackageName, PackageSpec) parsePackage = (,) <$> parsePackageName <*> (parsePackageSpec githubCmd) @@ -120,95 +125,105 @@ parseCmdInit = Opts.info (cmdInit <$> parseNixpkgs <**> Opts.helper) $ mconcat d [owner, reponame] -> Just (Nixpkgs owner reponame) _ -> Nothing parseNixpkgs = - Opts.flag' NoNixpkgs - ( - Opts.long "no-nixpkgs" <> - Opts.help "Don't add a nixpkgs entry to sources.json." - ) <|> - (YesNixpkgs <$> - (Opts.strOption - ( - Opts.long "nixpkgs-branch" <> - Opts.short 'b' <> - Opts.help "The nixpkgs branch to use." <> - Opts.showDefault <> - Opts.value defaultNixpkgsBranch + Opts.flag' + NoNixpkgs + ( Opts.long "no-nixpkgs" + <> Opts.help "Don't add a nixpkgs entry to sources.json." ) - ) <*> Opts.option customNixpkgsReader - ( - Opts.long "nixpkgs" <> - Opts.showDefault <> - Opts.help "Use a custom nixpkgs repository from GitHub." <> - Opts.metavar "OWNER/REPO" <> - Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo) - )) + <|> ( YesNixpkgs + <$> ( Opts.strOption + ( Opts.long "nixpkgs-branch" + <> Opts.short 'b' + <> Opts.help "The nixpkgs branch to use." + <> Opts.showDefault + <> Opts.value defaultNixpkgsBranch + ) + ) + <*> Opts.option + customNixpkgsReader + ( Opts.long "nixpkgs" + <> Opts.showDefault + <> Opts.help "Use a custom nixpkgs repository from GitHub." + <> Opts.metavar "OWNER/REPO" + <> Opts.value (Nixpkgs defaultNixpkgsUser defaultNixpkgsRepo) + ) + ) desc = - [ Opts.fullDesc - , Opts.progDesc + [ Opts.fullDesc, + Opts.progDesc "Initialize a Nix project. Existing files won't be modified." ] 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 + 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 - -- Imports @niv@ and @nixpkgs@ - say "Importing 'niv' ..." - cmdAdd (updateCmd githubCmd) (PackageName "niv") - (specToFreeAttrs $ PackageSpec $ HMS.fromList - [ "owner" .= ("nmattia" :: T.Text) - , "repo" .= ("niv" :: T.Text) - ] - ) - case nixpkgs of - NoNixpkgs -> say "Not importing 'nixpkgs'." - YesNixpkgs branch nixpkgs' -> do - say "Importing 'nixpkgs' ..." - let (owner, repo) = case nixpkgs' of - Nixpkgs o r -> (o,r) - cmdAdd (updateCmd githubCmd) (PackageName "nixpkgs") - (specToFreeAttrs $ PackageSpec $ HMS.fromList - [ "owner" .= owner - , "repo" .= repo - , "branch" .= branch - ] - ) - , \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 + ), + ( pathNixSourcesJson fsj, + \path -> do + createFile path initNixSourcesJsonContent + -- Imports @niv@ and @nixpkgs@ + say "Importing 'niv' ..." + cmdAdd + (updateCmd githubCmd) + (PackageName "niv") + ( specToFreeAttrs $ PackageSpec $ + HMS.fromList + [ "owner" .= ("nmattia" :: T.Text), + "repo" .= ("niv" :: T.Text) + ] + ) + case nixpkgs of + NoNixpkgs -> say "Not importing 'nixpkgs'." + YesNixpkgs branch nixpkgs' -> do + say "Importing 'nixpkgs' ..." + let (owner, repo) = case nixpkgs' of + Nixpkgs o r -> (o, r) + cmdAdd + (updateCmd githubCmd) + (PackageName "nixpkgs") + ( specToFreeAttrs $ PackageSpec $ + HMS.fromList + [ "owner" .= owner, + "repo" .= repo, + "branch" .= branch + ] + ), + \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) <> "." ] + [ 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 @@ -225,9 +240,9 @@ cmdInit nixpkgs = do parseCmdAdd :: Opts.ParserInfo (NIO ()) parseCmdAdd = - Opts.info - ((parseCommands <|> parseShortcuts) <**> Opts.helper) $ - (description githubCmd) + 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 @@ -242,12 +257,13 @@ parseCmdAdd = 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 + 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 @@ -261,17 +277,20 @@ parseShortcutArgs cmd = collapse <$> parseNameAndShortcut <*> parsePackageSpec c ((_, spec), Just pname') -> (pname', PackageSpec spec) ((pname', spec), Nothing) -> (pname', PackageSpec spec) parseNameAndShortcut = - (,) <$> - Opts.argument + (,) + <$> Opts.argument (Opts.maybeReader (parseCmdShortcut cmd . T.pack)) - (Opts.metavar "PACKAGE") <*> - optName - optName = Opts.optional $ PackageName <$> Opts.strOption - ( Opts.long "name" <> - Opts.short 'n' <> - Opts.metavar "NAME" <> - Opts.help "Set the package name to " - ) + (Opts.metavar "PACKAGE") + <*> optName + optName = + Opts.optional $ + PackageName + <$> Opts.strOption + ( Opts.long "name" + <> 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) @@ -285,35 +304,38 @@ parseCmdArgs cmd = collapse <$> parseNameAndShortcut <*> parsePackageSpec cmd (Nothing, Just pname') -> (pname', PackageSpec HMS.empty) (Nothing, Nothing) -> (PackageName "unnamed", PackageSpec HMS.empty) parseNameAndShortcut = - (,) <$> - Opts.optional (Opts.argument - (Opts.maybeReader (parseCmdShortcut cmd . T.pack)) - (Opts.metavar "PACKAGE")) <*> - optName - optName = Opts.optional $ PackageName <$> Opts.strOption - ( Opts.long "name" <> - Opts.short 'n' <> - Opts.metavar "NAME" <> - Opts.help "Set the package name to " - ) + (,) + <$> Opts.optional + ( Opts.argument + (Opts.maybeReader (parseCmdShortcut cmd . T.pack)) + (Opts.metavar "PACKAGE") + ) + <*> optName + optName = + Opts.optional $ + PackageName + <$> Opts.strOption + ( Opts.long "name" + <> Opts.short 'n' + <> Opts.metavar "NAME" + <> Opts.help "Set the package name to " + ) cmdAdd :: Update () a -> PackageName -> Attrs -> NIO () cmdAdd updateFunc packageName attrs = do - job ("Adding package " <> T.unpack (unPackageName packageName)) $ do - fsj <- getFindSourcesJson - sources <- unSources <$> li (getSources fsj) - - when (HMS.member packageName sources) $ - li $ abortCannotAddPackageExists packageName - - eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc) - - case eFinalSpec of - Left e -> li (abortUpdateFailed [(packageName, e)]) - Right finalSpec -> do - say $ "Writing new sources file" - li $ setSources fsj $ Sources $ - HMS.insert packageName finalSpec sources + job ("Adding package " <> T.unpack (unPackageName packageName)) $ do + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + when (HMS.member packageName sources) + $ li + $ abortCannotAddPackageExists packageName + eFinalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate attrs updateFunc) + case eFinalSpec of + Left e -> li (abortUpdateFailed [(packageName, e)]) + Right finalSpec -> do + say $ "Writing new sources file" + li $ setSources fsj $ Sources $ + HMS.insert packageName finalSpec sources ------------------------------------------------------------------------------- -- SHOW @@ -321,34 +343,32 @@ cmdAdd updateFunc packageName attrs = do parseCmdShow :: Opts.ParserInfo (NIO ()) parseCmdShow = - Opts.info - ((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper) - Opts.fullDesc + Opts.info + ((cmdShow <$> Opts.optional parsePackageName) <**> Opts.helper) + Opts.fullDesc -- TODO: nicer output cmdShow :: Maybe PackageName -> NIO () cmdShow = \case - Just packageName -> do - fsj <- getFindSourcesJson - sources <- unSources <$> li (getSources fsj) - - case HMS.lookup packageName sources of - Just pspec -> showPackage packageName pspec - Nothing -> li $ abortCannotShowNoSuchPackage packageName - - Nothing -> do - fsj <- getFindSourcesJson - sources <- unSources <$> li (getSources fsj) - forWithKeyM_ sources $ showPackage + Just packageName -> do + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + case HMS.lookup packageName sources of + Just pspec -> showPackage packageName pspec + Nothing -> li $ abortCannotShowNoSuchPackage packageName + Nothing -> do + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + forWithKeyM_ sources $ showPackage showPackage :: MonadIO io => PackageName -> PackageSpec -> io () showPackage (PackageName pname) (PackageSpec spec) = do - tsay $ tbold pname - forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do - let attrValue = case attrValValue of - Aeson.String str -> str - _ -> tfaint "" - tsay $ " " <> attrName <> ": " <> attrValue + tsay $ tbold pname + forM_ (HMS.toList spec) $ \(attrName, attrValValue) -> do + let attrValue = case attrValValue of + Aeson.String str -> str + _ -> tfaint "" + tsay $ " " <> attrName <> ": " <> attrValue ------------------------------------------------------------------------------- -- UPDATE @@ -356,21 +376,21 @@ showPackage (PackageName pname) (PackageSpec spec) = do parseCmdUpdate :: Opts.ParserInfo (NIO ()) parseCmdUpdate = - Opts.info - ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) $ - mconcat desc + Opts.info + ((cmdUpdate <$> Opts.optional parsePackage) <**> Opts.helper) + $ mconcat desc where desc = - [ Opts.fullDesc - , Opts.progDesc "Update dependencies" - , Opts.headerDoc $ Just $ Opts.nest 2 $ - "Examples:" Opts.<$$> - "" Opts.<$$> - Opts.vcat - [ Opts.fill 30 "niv update" Opts.<+> "# update all packages", - Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs", - Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\"" - ] + [ Opts.fullDesc, + Opts.progDesc "Update dependencies", + Opts.headerDoc $ Just $ Opts.nest 2 $ + "Examples:" + Opts.<$$> "" + Opts.<$$> Opts.vcat + [ Opts.fill 30 "niv update" Opts.<+> "# update all packages", + Opts.fill 30 "niv update nixpkgs" Opts.<+> "# update nixpkgs", + Opts.fill 30 "niv update my-package -v beta-0.2" Opts.<+> "# update my-package to version \"beta-0.2\"" + ] ] specToFreeAttrs :: PackageSpec -> Attrs @@ -381,64 +401,65 @@ specToLockedAttrs = fmap (Locked,) . unPackageSpec cmdUpdate :: Maybe (PackageName, PackageSpec) -> NIO () cmdUpdate = \case - Just (packageName, cliSpec) -> - job ("Update " <> T.unpack (unPackageName packageName)) $ do - fsj <- getFindSourcesJson - sources <- unSources <$> li (getSources fsj) - - eFinalSpec <- case HMS.lookup packageName sources of - Just defaultSpec -> do - -- lookup the "type" to find a Cmd to run, defaulting to legacy - -- github - let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of - Just "git" -> gitCmd - Just "local" -> localCmd - _ -> githubCmd - fmap attrsToSpec <$> li (tryEvalUpdate - (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) - (updateCmd cmd)) - - Nothing -> 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 + Just (packageName, cliSpec) -> + job ("Update " <> T.unpack (unPackageName packageName)) $ do fsj <- getFindSourcesJson sources <- unSources <$> li (getSources fsj) - - esources' <- forWithKeyM sources $ - \packageName defaultSpec -> do - tsay $ "Package: " <> unPackageName packageName - let initialSpec = specToFreeAttrs defaultSpec + eFinalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> do -- lookup the "type" to find a Cmd to run, defaulting to legacy -- github let cmd = case HMS.lookup "type" (unPackageSpec defaultSpec) of Just "git" -> gitCmd Just "local" -> localCmd _ -> githubCmd - finalSpec <- fmap attrsToSpec <$> li (tryEvalUpdate - initialSpec - (updateCmd cmd)) - pure finalSpec + fmap attrsToSpec + <$> li + ( tryEvalUpdate + (specToLockedAttrs cliSpec <> specToFreeAttrs defaultSpec) + (updateCmd cmd) + ) + Nothing -> 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 <$> li (getSources fsj) + esources' <- forWithKeyM sources $ + \packageName defaultSpec -> 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 HMS.lookup "type" (unPackageSpec defaultSpec) of + Just "git" -> gitCmd + Just "local" -> localCmd + _ -> githubCmd + finalSpec <- + fmap attrsToSpec + <$> li + ( tryEvalUpdate + initialSpec + (updateCmd cmd) + ) + pure finalSpec + let (failed, sources') = partitionEithersHMS esources' + unless (HMS.null failed) + $ li + $ abortUpdateFailed (HMS.toList failed) + li $ setSources fsj $ Sources sources' - let (failed, sources') = partitionEithersHMS esources' - - unless (HMS.null failed) $ - li $ abortUpdateFailed (HMS.toList failed) - - li $ setSources fsj $ Sources sources' - -partitionEithersHMS - :: (Eq k, Hashable k) - => HMS.HashMap k (Either a b) -> (HMS.HashMap k a, HMS.HashMap k b) +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) + 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 @@ -446,43 +467,45 @@ partitionEithersHMS = parseCmdModify :: Opts.ParserInfo (NIO ()) parseCmdModify = - Opts.info - ((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper) $ - mconcat desc + Opts.info + ((cmdModify <$> parsePackageName <*> optName <*> parsePackageSpec githubCmd) <**> Opts.helper) + $ mconcat desc where desc = - [ Opts.fullDesc - , Opts.progDesc "Modify dependency attributes without performing an update" - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv modify nixpkgs -v beta-0.2" Opts.<$$> - " niv modify nixpkgs -a branch=nixpkgs-unstable" + [ Opts.fullDesc, + Opts.progDesc "Modify dependency attributes without performing an update", + Opts.headerDoc $ Just $ + "Examples:" + Opts.<$$> "" + Opts.<$$> " niv modify nixpkgs -v beta-0.2" + Opts.<$$> " niv modify nixpkgs -a branch=nixpkgs-unstable" ] - optName = Opts.optional $ PackageName <$> Opts.strOption - ( Opts.long "name" <> - Opts.short 'n' <> - Opts.metavar "NAME" <> - Opts.help "Set the package name to " - ) + optName = + Opts.optional $ + PackageName + <$> Opts.strOption + ( Opts.long "name" + <> 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 <$> li (getSources fsj) - - finalSpec <- case HMS.lookup packageName sources of - Just defaultSpec -> 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 + tsay $ "Modifying package: " <> unPackageName packageName + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + finalSpec <- case HMS.lookup packageName sources of + Just defaultSpec -> 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 @@ -490,51 +513,52 @@ cmdModify packageName mNewName cliSpec = do parseCmdDrop :: Opts.ParserInfo (NIO ()) parseCmdDrop = - Opts.info - ((cmdDrop <$> parsePackageName <*> parseDropAttributes) <**> - Opts.helper) $ - mconcat desc + 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" + [ 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") + 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 <$> li (getSources fsj) - - when (not $ HMS.member packageName sources) $ - li $ abortCannotDropNoSuchPackage packageName - - li $ setSources fsj $ Sources $ - HMS.delete packageName sources - attrs -> do - tsay $ "Dropping attributes: " <> T.intercalate " " attrs - tsay $ "In package: " <> unPackageName packageName - fsj <- getFindSourcesJson - sources <- unSources <$> li (getSources fsj) - - packageSpec <- case HMS.lookup packageName sources of - Nothing -> - li $ abortCannotAttributesDropNoSuchPackage packageName - Just (PackageSpec packageSpec) -> pure $ PackageSpec $ + [] -> do + tsay $ "Dropping package: " <> unPackageName packageName + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + when (not $ HMS.member packageName sources) + $ li + $ abortCannotDropNoSuchPackage packageName + li $ setSources fsj $ Sources $ + HMS.delete packageName sources + attrs -> do + tsay $ "Dropping attributes: " <> T.intercalate " " attrs + tsay $ "In package: " <> unPackageName packageName + fsj <- getFindSourcesJson + sources <- unSources <$> li (getSources fsj) + packageSpec <- case HMS.lookup packageName sources of + Nothing -> + li $ abortCannotAttributesDropNoSuchPackage packageName + Just (PackageSpec packageSpec) -> + pure $ PackageSpec $ HMS.mapMaybeWithKey - (\k v -> if k `elem` attrs then Nothing else Just v) packageSpec - - li $ setSources fsj $ Sources $ - HMS.insert packageName packageSpec sources + (\k v -> if k `elem` attrs then Nothing else Just v) + packageSpec + li $ setSources fsj $ Sources $ + HMS.insert packageName packageSpec sources ------------------------------------------------------------------------------- -- Files and their content @@ -544,15 +568,15 @@ cmdDrop packageName = \case -- a comment line with @niv: no_update@ shouldUpdateNixSourcesNix :: B.ByteString -> Bool shouldUpdateNixSourcesNix content = - content /= initNixSourcesNixContent && - not (any lineForbids (B8.lines 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 "niv:" (B8.dropWhile isSpace rest) of Just rest' -> case B8.stripPrefix "no_update" (B8.dropWhile isSpace rest') of - Just{} -> True + Just {} -> True _ -> False _ -> False _ -> False @@ -562,53 +586,67 @@ shouldUpdateNixSourcesNix content = ------------------------------------------------------------------------------- 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." - ] +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." - ] +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." - ] +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." - ] +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." - ] +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 +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 diff --git a/src/Niv/Cmd.hs b/src/Niv/Cmd.hs index 5769ba4..74f843e 100644 --- a/src/Niv/Cmd.hs +++ b/src/Niv/Cmd.hs @@ -2,17 +2,18 @@ module Niv.Cmd where -import Niv.Sources -import Niv.Update import qualified Data.Aeson as Aeson import qualified Data.Text as T +import Niv.Sources +import Niv.Update import qualified Options.Applicative as Opts -- TODO: add filter -data Cmd = Cmd - { description :: forall a. Opts.InfoMod a - , parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) - , parsePackageSpec :: Opts.Parser PackageSpec - , updateCmd :: Update () () - , name :: T.Text - } +data Cmd + = Cmd + { description :: forall a. Opts.InfoMod a, + parseCmdShortcut :: T.Text -> Maybe (PackageName, Aeson.Object), + parsePackageSpec :: Opts.Parser PackageSpec, + updateCmd :: Update () (), + name :: T.Text + } diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs index df4ae08..87ae027 100644 --- a/src/Niv/Git/Cmd.hs +++ b/src/Niv/Git/Cmd.hs @@ -1,42 +1,43 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Niv.Git.Cmd where import Control.Applicative import Control.Arrow +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as B8 +import qualified Data.HashMap.Strict as HMS import Data.Maybe +import qualified Data.Text as T import Data.Text.Extended as T import Niv.Cmd import Niv.Logger import Niv.Sources import Niv.Update -import System.Exit (ExitCode(ExitSuccess)) -import System.Process (readProcessWithExitCode) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as B8 -import qualified Data.HashMap.Strict as HMS -import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) gitCmd :: Cmd -gitCmd = Cmd - { description = describeGit - , parseCmdShortcut = parseGitShortcut - , parsePackageSpec = parseGitPackageSpec - , updateCmd = gitUpdate' - , name = "git" - } +gitCmd = + Cmd + { description = describeGit, + parseCmdShortcut = parseGitShortcut, + parsePackageSpec = parseGitPackageSpec, + updateCmd = gitUpdate', + name = "git" + } parseGitShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) = - -- basic heuristics for figuring out if something is a git repo - if isGitURL + -- basic heuristics for figuring out if something is a git repo + if isGitURL then case T.splitOn "/" txt of [] -> Nothing (last -> w) -> case T.stripSuffix ".git" w of @@ -45,77 +46,85 @@ parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) = else Nothing where isGitURL = - ".git" `T.isSuffixOf` txt || - "git@" `T.isPrefixOf` txt || - "ssh://" `T.isPrefixOf` txt + ".git" `T.isSuffixOf` txt + || "git@" `T.isPrefixOf` txt + || "ssh://" `T.isPrefixOf` txt parseGitPackageSpec :: Opts.Parser PackageSpec parseGitPackageSpec = - (PackageSpec . HMS.fromList) <$> - many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr) + (PackageSpec . HMS.fromList) + <$> many (parseRepo <|> parseRef <|> parseRev <|> parseAttr <|> parseSAttr) where parseRepo = - ("repo", ) . Aeson.String <$> Opts.strOption - ( Opts.long "repo" <> - Opts.metavar "URL" - ) + ("repo",) . Aeson.String + <$> Opts.strOption + ( Opts.long "repo" + <> Opts.metavar "URL" + ) parseRev = - ("rev", ) . Aeson.String <$> Opts.strOption - ( Opts.long "rev" <> - Opts.metavar "SHA" - ) + ("rev",) . Aeson.String + <$> Opts.strOption + ( Opts.long "rev" + <> Opts.metavar "SHA" + ) parseRef = - ("ref", ) . Aeson.String <$> Opts.strOption - ( Opts.long "ref" <> - Opts.metavar "REF" - ) + ("ref",) . Aeson.String + <$> Opts.strOption + ( Opts.long "ref" + <> Opts.metavar "REF" + ) parseAttr = - Opts.option (Opts.maybeReader parseKeyValJSON) - ( Opts.long "attribute" <> - Opts.short 'a' <> - Opts.metavar "KEY=VAL" <> - Opts.help "Set the package spec attribute to , where may be JSON." + Opts.option + (Opts.maybeReader parseKeyValJSON) + ( Opts.long "attribute" + <> Opts.short 'a' + <> Opts.metavar "KEY=VAL" + <> Opts.help "Set the package spec attribute to , where may be JSON." ) parseSAttr = - Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON)) - ( Opts.long "string-attribute" <> - Opts.short 's' <> - Opts.metavar "KEY=VAL" <> - Opts.help "Set the package spec attribute to ." + Opts.option + (Opts.maybeReader (parseKeyVal Aeson.toJSON)) + ( Opts.long "string-attribute" + <> Opts.short 's' + <> Opts.metavar "KEY=VAL" + <> Opts.help "Set the package spec attribute to ." ) - parseKeyValJSON = parseKeyVal $ \x -> fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x)) - -- Parse "key=val" into ("key", val) - parseKeyVal - :: (String -> Aeson.Value) -- ^ how to convert to JSON - -> String -> Maybe (T.Text, Aeson.Value) + parseKeyVal :: + -- | how to convert to JSON + (String -> Aeson.Value) -> + String -> + Maybe (T.Text, Aeson.Value) parseKeyVal toJSON str = case span (/= '=') str of - (key, '=':val) -> Just (T.pack key, toJSON val) + (key, '=' : val) -> Just (T.pack key, toJSON val) _ -> Nothing describeGit :: Opts.InfoMod a -describeGit = mconcat - [ Opts.fullDesc - , Opts.progDesc "Add a git dependency. Experimental." - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv add git git@github.com:stedolan/jq" Opts.<$$> - " niv add git ssh://git@github.com/stedolan/jq --rev deadb33f" Opts.<$$> - " niv add git https://github.com/stedolan/jq.git" Opts.<$$> - " niv add git --repo /my/custom/repo --name custom --ref foobar" - ] +describeGit = + mconcat + [ Opts.fullDesc, + Opts.progDesc "Add a git dependency. Experimental.", + Opts.headerDoc $ Just $ + "Examples:" + Opts.<$$> "" + Opts.<$$> " niv add git git@github.com:stedolan/jq" + Opts.<$$> " niv add git ssh://git@github.com/stedolan/jq --rev deadb33f" + Opts.<$$> " niv add git https://github.com/stedolan/jq.git" + Opts.<$$> " niv add git --repo /my/custom/repo --name custom --ref foobar" + ] -gitUpdate - :: (T.Text -> T.Text -> IO T.Text) -- ^ latest rev - -> (T.Text -> IO (T.Text, T.Text)) -- ^ latest rev and default ref - -> Update () () +gitUpdate :: + -- | latest rev + (T.Text -> T.Text -> IO T.Text) -> + -- | latest rev and default ref + (T.Text -> IO (T.Text, T.Text)) -> + Update () () gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do - useOrSet "type" -< ("git" :: Box T.Text) - repository <- load "repo" -< () - discoverRev <+> discoverRefAndRev -< repository + useOrSet "type" -< ("git" :: Box T.Text) + repository <- load "repo" -< () + discoverRev <+> discoverRefAndRev -< repository where discoverRefAndRev = proc repository -> do refAndRev <- run defaultRefAndHEAD' -< repository @@ -132,38 +141,46 @@ gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do gitUpdate' :: Update () () gitUpdate' = gitUpdate latestRev defaultRefAndHEAD -latestRev - :: T.Text -- ^ the repository - -> T.Text -- ^ the ref/branch - -> IO T.Text +latestRev :: + -- | the repository + T.Text -> + -- | the ref/branch + T.Text -> + IO T.Text latestRev repo ref = do - let gitArgs = [ "ls-remote", repo, "refs/heads/" <> ref ] - sout <- runGit gitArgs - case sout of - ls@(_:_:_) -> abortTooMuchOutput gitArgs ls - (l1:[]) -> parseRev gitArgs l1 - [] -> abortNoOutput gitArgs + let gitArgs = ["ls-remote", repo, "refs/heads/" <> ref] + sout <- runGit gitArgs + case sout of + ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls + (l1 : []) -> parseRev gitArgs l1 + [] -> abortNoOutput gitArgs where parseRev args l = maybe (abortNoRev args l) pure $ do checkRev $ T.takeWhile (/= '\t') l checkRev t = if isRev t then Just t else Nothing - abortNoOutput args = abortGitFailure args - "Git didn't produce any output." - abortTooMuchOutput args ls = abortGitFailure args $ T.unlines $ - [ "Git produced too much output:" ] <> map (" " <>) ls + abortNoOutput args = + abortGitFailure + args + "Git didn't produce any output." + abortTooMuchOutput args ls = + abortGitFailure args $ T.unlines $ + ["Git produced too much output:"] <> map (" " <>) ls -defaultRefAndHEAD - :: T.Text -- ^ the repository - -> IO (T.Text, T.Text) +defaultRefAndHEAD :: + -- | the repository + T.Text -> + IO (T.Text, T.Text) defaultRefAndHEAD repo = do - sout <- runGit args - case sout of - (l1:l2:_) -> (,) <$> parseRef l1 <*> parseRev l2 - _ -> abortGitFailure args $ T.unlines $ + sout <- runGit args + case sout of + (l1 : l2 : _) -> (,) <$> parseRef l1 <*> parseRev l2 + _ -> + abortGitFailure args $ T.unlines $ [ "Could not read reference and revision from stdout:" - ] <> sout + ] + <> sout where - args = [ "ls-remote", "--symref", repo, "HEAD" ] + args = ["ls-remote", "--symref", repo, "HEAD"] parseRef l = maybe (abortNoRef args l) pure $ do -- ref: refs/head/master\tHEAD -> master\tHEAD refAndSym <- T.stripPrefix "ref: refs/heads/" l @@ -175,29 +192,36 @@ defaultRefAndHEAD repo = do abortNoRev :: [T.Text] -> T.Text -> IO a abortNoRev args l = abortGitFailure args $ "Could not read revision from: " <> l + abortNoRef :: [T.Text] -> T.Text -> IO a abortNoRef args l = abortGitFailure args $ "Could not read reference from: " <> l -- | Run the "git" executable runGit :: [T.Text] -> IO [T.Text] runGit args = do - (exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) "" - case (exitCode, lines sout) of - (ExitSuccess, ls) -> pure $ T.pack <$> ls - _ -> abortGitFailure args $ T.unlines - [ T.unwords [ "stdout:" , T.pack sout ] - , T.unwords [ "stderr:" , T.pack serr ] - ] + (exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) "" + case (exitCode, lines sout) of + (ExitSuccess, ls) -> pure $ T.pack <$> ls + _ -> + abortGitFailure args $ + T.unlines + [ T.unwords ["stdout:", T.pack sout], + T.unwords ["stderr:", T.pack serr] + ] isRev :: T.Text -> Bool isRev t = -- commit hashes are comprised of abcdef0123456789 - T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t && - -- commit _should_ be 40 chars long, but to be sure we pick 7 - T.length t >= 7 + T.all (\c -> (c >= 'a' && c <= 'f') || (c >= '0' && c <= '9')) t + && + -- commit _should_ be 40 chars long, but to be sure we pick 7 + T.length t >= 7 abortGitFailure :: [T.Text] -> T.Text -> IO a -abortGitFailure args msg = abort $ bug $ T.unlines - [ "Could not read the output of 'git'." - , T.unwords ("command:":"git":args) - , msg ] +abortGitFailure args msg = + abort $ bug $ + T.unlines + [ "Could not read the output of 'git'.", + T.unwords ("command:" : "git" : args), + msg + ] diff --git a/src/Niv/Git/Test.hs b/src/Niv/Git/Test.hs index fa9a429..0f21d8f 100644 --- a/src/Niv/Git/Test.hs +++ b/src/Niv/Git/Test.hs @@ -1,63 +1,77 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE OverloadedStrings #-} -module Niv.Git.Test (tests) where +module Niv.Git.Test + ( tests, + ) +where import Control.Monad import Data.Bifunctor +import qualified Data.HashMap.Strict as HMS import Niv.Git.Cmd import Niv.Sources import Niv.Update -import Test.Tasty.HUnit ((@=?)) -import qualified Data.HashMap.Strict as HMS import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@=?)) import qualified Test.Tasty.HUnit as Tasty tests :: [Tasty.TestTree] -tests = [ test_repositoryParse , test_gitUpdates ] +tests = [test_repositoryParse, test_gitUpdates] test_repositoryParse :: Tasty.TestTree -test_repositoryParse = Tasty.testGroup "repository parse" - [ Tasty.testCase "goo" $ - parseGitShortcut "goo" @=? Nothing - , Tasty.testCase "git@github.com:nmattia/niv" $ - parseGitShortcut "git@github.com:nmattia/niv" @=? Just - (PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv") - , Tasty.testCase "ssh://git@github.com/stedolan/jq" $ - parseGitShortcut "ssh://git@github.com/stedolan/jq" @=? Just - (PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq") - , Tasty.testCase "https://github.com/stedolan/jq.git" $ - parseGitShortcut "https://github.com/stedolan/jq.git" @=? Just - (PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git") - , Tasty.testCase "https://github.com/stedolan/jq" $ - parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing - , Tasty.testCase "~/path/to/repo.git" $ - parseGitShortcut "~/path/to/repo.git" @=? Just - (PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git") - ] +test_repositoryParse = + Tasty.testGroup + "repository parse" + [ Tasty.testCase "goo" $ + parseGitShortcut "goo" @=? Nothing, + Tasty.testCase "git@github.com:nmattia/niv" $ + parseGitShortcut "git@github.com:nmattia/niv" + @=? Just + (PackageName "niv", HMS.singleton "repo" "git@github.com:nmattia/niv"), + Tasty.testCase "ssh://git@github.com/stedolan/jq" $ + parseGitShortcut "ssh://git@github.com/stedolan/jq" + @=? Just + (PackageName "jq", HMS.singleton "repo" "ssh://git@github.com/stedolan/jq"), + Tasty.testCase "https://github.com/stedolan/jq.git" $ + parseGitShortcut "https://github.com/stedolan/jq.git" + @=? Just + (PackageName "jq", HMS.singleton "repo" "https://github.com/stedolan/jq.git"), + Tasty.testCase "https://github.com/stedolan/jq" $ + parseGitShortcut "https://github.com/stedolan/jq" @=? Nothing, + Tasty.testCase "~/path/to/repo.git" $ + parseGitShortcut "~/path/to/repo.git" + @=? Just + (PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git") + ] test_gitUpdates :: Tasty.TestTree -test_gitUpdates = Tasty.testGroup "updates" - [ Tasty.testCase "rev is updated" test_gitUpdateRev - ] +test_gitUpdates = + Tasty.testGroup + "updates" + [ Tasty.testCase "rev is updated" test_gitUpdateRev + ] test_gitUpdateRev :: IO () test_gitUpdateRev = do - interState <- evalUpdate initialState $ proc () -> - gitUpdate (error "should be def") defaultRefAndHEAD' -< () - let interState' = HMS.map (first (\_ -> Free)) interState - actualState <- evalUpdate interState' $ proc () -> - gitUpdate latestRev' (error "should update") -< () - unless ((snd <$> actualState) == expectedState) $ - error $ "State mismatch: " <> show actualState + interState <- evalUpdate initialState $ proc () -> + gitUpdate (error "should be def") defaultRefAndHEAD' -< () + let interState' = HMS.map (first (\_ -> Free)) interState + actualState <- evalUpdate interState' $ proc () -> + gitUpdate latestRev' (error "should update") -< () + unless ((snd <$> actualState) == expectedState) + $ error + $ "State mismatch: " <> show actualState where latestRev' _ _ = pure "some-other-rev" defaultRefAndHEAD' _ = pure ("some-ref", "some-rev") - initialState = HMS.fromList - [ ("repo", (Free, "git@github.com:nmattia/niv")) ] - expectedState = HMS.fromList - [ ("repo", "git@github.com:nmattia/niv") - , ("ref", "some-ref") - , ("rev", "some-other-rev") - , ("type", "git") - ] + initialState = + HMS.fromList + [("repo", (Free, "git@github.com:nmattia/niv"))] + expectedState = + HMS.fromList + [ ("repo", "git@github.com:nmattia/niv"), + ("ref", "some-ref"), + ("rev", "some-other-rev"), + ("type", "git") + ] diff --git a/src/Niv/GitHub.hs b/src/Niv/GitHub.hs index 1adcbb0..ad4407e 100644 --- a/src/Niv/GitHub.hs +++ b/src/Niv/GitHub.hs @@ -1,18 +1,18 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Niv.GitHub where import Control.Arrow import Data.Bool import Data.Maybe +import qualified Data.Text as T import Niv.GitHub.API import Niv.Update -import qualified Data.Text as T -- | The GitHub update function -- TODO: fetchers for: @@ -20,39 +20,44 @@ import qualified Data.Text as T -- * 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 + (Bool -> T.Text -> IO T.Text) -> + -- | latest revision + (T.Text -> T.Text -> T.Text -> IO T.Text) -> + -- | get repo + (T.Text -> T.Text -> IO GithubRepo) -> + Update () () githubUpdate prefetch latestRev ghRepo = proc () -> do - urlTemplate <- template <<< - (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -< + urlTemplate <- + template + <<< (useOrSet "url_template" <<< completeSpec) <+> (load "url_template") -< () - url <- update "url" -< urlTemplate - let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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 -< () + url <- update "url" -< urlTemplate + let isTar = (\u -> "tar.gz" `T.isSuffixOf` u || ".tgz" `T.isSuffixOf` u) <$> 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 + 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 + _ <- + update "rev" <<< run' (\(a, b, c) -> latestRev a b c) -< + (,,) <$> owner <*> repo <*> branch returnA -< pure githubURLTemplate githubURLTemplate :: T.Text githubURLTemplate = - (if githubSecure then "https://" else "http://") <> - githubHost <> githubPath <> "//archive/.tar.gz" + (if githubSecure then "https://" else "http://") + <> githubHost + <> githubPath + <> "//archive/.tar.gz" diff --git a/src/Niv/GitHub/API.hs b/src/Niv/GitHub/API.hs index e5bbe55..6d710fc 100644 --- a/src/Niv/GitHub/API.hs +++ b/src/Niv/GitHub/API.hs @@ -1,64 +1,67 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} module Niv.GitHub.API where +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS8 import Data.Functor +import qualified Data.HashMap.Strict as HMS import Data.Maybe import Data.String.QQ (s) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Text.Extended +import qualified Network.HTTP.Simple as HTTP import System.Environment (lookupEnv) import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.HashMap.Strict as HMS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.HTTP.Simple as HTTP -- Bunch of GitHub helpers -data GithubRepo = GithubRepo - { repoDescription :: Maybe T.Text - , repoHomepage :: Maybe T.Text - , repoDefaultBranch :: Maybe T.Text - } +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 = do - request <- defaultRequest ["repos", owner, repo] - -- we don't use httpJSONEither because it adds an "Accept: - -- application/json" header that GitHub chokes on - resp0 <- HTTP.httpBS request - let resp = fmap Aeson.eitherDecodeStrict resp0 - case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of - (200, Right (Aeson.Object m)) -> do - let lookupText k = case HMS.lookup k m of - Just (Aeson.String t) -> Just t - _ -> Nothing - pure GithubRepo - { repoDescription = lookupText "description" - , repoHomepage = lookupText "homepage" - , repoDefaultBranch = lookupText "default_branch" + request <- defaultRequest ["repos", owner, repo] + -- we don't use httpJSONEither because it adds an "Accept: + -- application/json" header that GitHub chokes on + resp0 <- HTTP.httpBS request + let resp = fmap Aeson.eitherDecodeStrict resp0 + case (HTTP.getResponseStatusCode resp, HTTP.getResponseBody resp) of + (200, Right (Aeson.Object m)) -> do + let lookupText k = case HMS.lookup k m of + Just (Aeson.String t) -> Just t + _ -> Nothing + pure + GithubRepo + { repoDescription = lookupText "description", + repoHomepage = lookupText "homepage", + repoDefaultBranch = lookupText "default_branch" } - (200, Right v) -> do - error $ "expected object, got " <> show v - (200, Left e) -> do - error $ "github didn't return JSON: " <> show e - _ -> abortCouldNotFetchGitHubRepo (tshow (request,resp0)) (owner, repo) + (200, Right v) -> do + error $ "expected object, got " <> show v + (200, Left e) -> do + error $ "github didn't return JSON: " <> show e + _ -> abortCouldNotFetchGitHubRepo (tshow (request, resp0)) (owner, repo) -- | TODO: Error instead of T.Text? abortCouldNotFetchGitHubRepo :: T.Text -> (T.Text, T.Text) -> IO a abortCouldNotFetchGitHubRepo e (T.unpack -> owner, T.unpack -> repo) = do - putStrLn $ unlines [ line1, line2, T.unpack line3 ] - exitFailure + putStrLn $ unlines [line1, line2, T.unpack line3] + exitFailure where line1 = "WARNING: Could not read from GitHub repo: " <> owner <> "/" <> repo - line2 = [s| + 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: @@ -72,52 +75,55 @@ If not, try re-adding it: Make sure the repository exists. |] - line3 = T.unwords [ "(Error was:", e, ")" ] + line3 = T.unwords ["(Error was:", e, ")"] defaultRequest :: [T.Text] -> IO HTTP.Request defaultRequest (map T.encodeUtf8 -> parts) = do - let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts) - mtoken <- lookupEnv "GITHUB_TOKEN" - pure $ - (flip (maybe id) mtoken $ \token -> - HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token) - ) $ - HTTP.setRequestPath path $ - HTTP.addRequestHeader "user-agent" "niv" $ - HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" $ - HTTP.setRequestSecure githubSecure $ - HTTP.setRequestHost (T.encodeUtf8 githubApiHost) $ - HTTP.setRequestPort githubApiPort $ - HTTP.defaultRequest + let path = T.encodeUtf8 githubPath <> BS8.intercalate "/" (parts) + mtoken <- lookupEnv "GITHUB_TOKEN" + pure + $ ( flip (maybe id) mtoken $ \token -> + HTTP.addRequestHeader "authorization" ("token " <> BS8.pack token) + ) + $ HTTP.setRequestPath path + $ HTTP.addRequestHeader "user-agent" "niv" + $ HTTP.addRequestHeader "accept" "application/vnd.github.v3+json" + $ HTTP.setRequestSecure githubSecure + $ HTTP.setRequestHost (T.encodeUtf8 githubApiHost) + $ HTTP.setRequestPort githubApiPort + $ HTTP.defaultRequest -- | 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 + T.Text -> + -- | repo + T.Text -> + -- | branch + T.Text -> + IO T.Text githubLatestRev owner repo branch = do - request <- defaultRequest [ "repos", owner, repo, "commits", branch ] <&> - HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha" - resp <- HTTP.httpBS request - case HTTP.getResponseStatusCode resp of - 200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp - _ -> abortCouldNotGetRev owner repo branch resp + request <- + defaultRequest ["repos", owner, repo, "commits", branch] + <&> HTTP.addRequestHeader "accept" "application/vnd.github.v3.sha" + resp <- HTTP.httpBS request + case HTTP.getResponseStatusCode resp of + 200 -> pure $ T.decodeUtf8 $ HTTP.getResponseBody resp + _ -> abortCouldNotGetRev owner repo branch resp abortCouldNotGetRev :: T.Text -> T.Text -> T.Text -> HTTP.Response BS8.ByteString -> IO a -abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [ line1, line2, line3 ] +abortCouldNotGetRev owner repo branch resp = abort $ T.unlines [line1, line2, line3] where - line1 = T.unwords - [ "Cannot get latest revision for branch" - , "'" <> branch <> "'" - , "(" <> owner <> "/" <> repo <> ")" - ] + line1 = + T.unwords + [ "Cannot get latest revision for branch", + "'" <> branch <> "'", + "(" <> owner <> "/" <> repo <> ")" + ] line2 = "The request failed: " <> tshow resp - line3 = [s| + line3 = + [s| NOTE: You may want to retry with an authentication token: GITHUB_TOKEN=... niv @@ -130,31 +136,31 @@ For more information on rate-limiting, see githubHost :: T.Text githubHost = unsafePerformIO $ do - lookupEnv "GITHUB_HOST" >>= \case - Just (T.pack -> x) -> pure x - Nothing -> pure "github.com" + lookupEnv "GITHUB_HOST" >>= \case + Just (T.pack -> x) -> pure x + Nothing -> pure "github.com" githubApiPort :: Int githubApiPort = unsafePerformIO $ do - lookupEnv "GITHUB_API_PORT" >>= \case - Just (readMaybe -> Just x) -> pure x - _ -> pure $ if githubSecure then 443 else 80 + lookupEnv "GITHUB_API_PORT" >>= \case + Just (readMaybe -> Just x) -> pure x + _ -> pure $ if githubSecure then 443 else 80 githubApiHost :: T.Text githubApiHost = unsafePerformIO $ do - lookupEnv "GITHUB_API_HOST" >>= \case - Just (T.pack -> x) -> pure x - Nothing -> pure "api.github.com" + lookupEnv "GITHUB_API_HOST" >>= \case + Just (T.pack -> x) -> pure x + Nothing -> pure "api.github.com" githubSecure :: Bool githubSecure = unsafePerformIO $ do - lookupEnv "GITHUB_INSECURE" >>= \case - Just "" -> pure True - Just _ -> pure False - Nothing -> pure True + lookupEnv "GITHUB_INSECURE" >>= \case + Just "" -> pure True + Just _ -> pure False + Nothing -> pure True githubPath :: T.Text githubPath = unsafePerformIO $ do - lookupEnv "GITHUB_PATH" >>= \case - Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/" - Nothing -> pure "/" + lookupEnv "GITHUB_PATH" >>= \case + Just (T.pack -> x) -> pure $ fromMaybe x (T.stripSuffix "/" x) <> "/" + Nothing -> pure "/" diff --git a/src/Niv/GitHub/Cmd.hs b/src/Niv/GitHub/Cmd.hs index 74d6b12..0906fe7 100644 --- a/src/Niv/GitHub/Cmd.hs +++ b/src/Niv/GitHub/Cmd.hs @@ -1,133 +1,153 @@ {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -module Niv.GitHub.Cmd (githubCmd) where +module Niv.GitHub.Cmd + ( githubCmd, + ) +where import Control.Applicative import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson import Data.Bifunctor +import qualified Data.ByteString.Char8 as B8 import Data.Char (isAlphaNum) +import qualified Data.HashMap.Strict as HMS import Data.Maybe import Data.String.QQ (s) +import qualified Data.Text as T import Data.Text.Extended import Niv.Cmd import Niv.GitHub import Niv.GitHub.API import Niv.Sources import Niv.Update -import System.Exit (ExitCode(ExitSuccess)) -import System.Process (readProcessWithExitCode) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Char8 as B8 -import qualified Data.HashMap.Strict as HMS -import qualified Data.Text as T import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts +import System.Exit (ExitCode (ExitSuccess)) +import System.Process (readProcessWithExitCode) githubCmd :: Cmd -githubCmd = Cmd - { description = describeGitHub - , parseCmdShortcut = parseAddShortcutGitHub - , parsePackageSpec = parseGitHubPackageSpec - , updateCmd = githubUpdate' - , name = "github" - -- TODO: here filter by type == tarball or file or builtin- - } +githubCmd = + Cmd + { description = describeGitHub, + parseCmdShortcut = parseAddShortcutGitHub, + parsePackageSpec = parseGitHubPackageSpec, + updateCmd = githubUpdate', + name = "github" + -- TODO: here filter by type == tarball or file or builtin- + } parseGitHubPackageSpec :: Opts.Parser PackageSpec parseGitHubPackageSpec = - (PackageSpec . HMS.fromList) <$> - many parseAttribute + (PackageSpec . HMS.fromList) + <$> many parseAttribute where parseAttribute :: Opts.Parser (T.Text, Aeson.Value) parseAttribute = - Opts.option (Opts.maybeReader parseKeyValJSON) - ( Opts.long "attribute" <> - Opts.short 'a' <> - Opts.metavar "KEY=VAL" <> - Opts.help "Set the package spec attribute to , where may be JSON." - ) <|> - Opts.option (Opts.maybeReader (parseKeyVal Aeson.toJSON)) - ( Opts.long "string-attribute" <> - Opts.short 's' <> - Opts.metavar "KEY=VAL" <> - Opts.help "Set the package spec attribute to ." - ) <|> - shortcutAttributes <|> - ((("url_template",) . Aeson.String) <$> Opts.strOption - ( Opts.long "template" <> - Opts.short 't' <> - Opts.metavar "URL" <> - Opts.help "Used during 'update' when building URL. Occurrences of are replaced with attribute 'foo'." - )) <|> - ((("type",) . Aeson.String) <$> 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." - )) - + Opts.option + (Opts.maybeReader parseKeyValJSON) + ( Opts.long "attribute" + <> Opts.short 'a' + <> Opts.metavar "KEY=VAL" + <> Opts.help "Set the package spec attribute to , where may be JSON." + ) + <|> Opts.option + (Opts.maybeReader (parseKeyVal Aeson.toJSON)) + ( Opts.long "string-attribute" + <> Opts.short 's' + <> Opts.metavar "KEY=VAL" + <> Opts.help "Set the package spec attribute to ." + ) + <|> shortcutAttributes + <|> ( (("url_template",) . Aeson.String) + <$> Opts.strOption + ( Opts.long "template" + <> Opts.short 't' + <> Opts.metavar "URL" + <> Opts.help "Used during 'update' when building URL. Occurrences of are replaced with attribute 'foo'." + ) + ) + <|> ( (("type",) . Aeson.String) + <$> 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." + ) + ) parseKeyValJSON = parseKeyVal $ \x -> fromMaybe (Aeson.toJSON x) (Aeson.decodeStrict (B8.pack x)) - -- Parse "key=val" into ("key", val) - parseKeyVal - :: (String -> Aeson.Value) -- ^ how to convert to JSON - -> String -> Maybe (T.Text, Aeson.Value) + parseKeyVal :: + -- | how to convert to JSON + (String -> Aeson.Value) -> + String -> + Maybe (T.Text, Aeson.Value) parseKeyVal toJSON str = case span (/= '=') str of - (key, '=':val) -> Just (T.pack key, toJSON val) + (key, '=' : val) -> Just (T.pack key, toJSON val) _ -> Nothing - -- Shortcuts for common attributes shortcutAttributes :: Opts.Parser (T.Text, Aeson.Value) - shortcutAttributes = foldr (<|>) empty $ mkShortcutAttribute <$> - [ "branch", "owner", "repo", "version" ] - + shortcutAttributes = + foldr (<|>) empty $ + mkShortcutAttribute + <$> ["branch", "owner", "repo", "version"] -- TODO: infer those shortcuts from 'Update' keys mkShortcutAttribute :: T.Text -> Opts.Parser (T.Text, Aeson.Value) mkShortcutAttribute = \case - attr@(T.uncons -> Just (c,_)) -> fmap (second Aeson.String) $ (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) <> ">" - ) - ) + attr@(T.uncons -> Just (c, _)) -> + fmap (second Aeson.String) $ + (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 describeGitHub :: Opts.InfoMod a -describeGitHub = mconcat - [ Opts.fullDesc - , Opts.progDesc "Add a GitHub dependency" - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv add stedolan/jq" Opts.<$$> - " niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable" Opts.<$$> - " niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip" - ] +describeGitHub = + mconcat + [ Opts.fullDesc, + Opts.progDesc "Add a GitHub dependency", + Opts.headerDoc $ Just $ + "Examples:" + Opts.<$$> "" + Opts.<$$> " niv add stedolan/jq" + Opts.<$$> " niv add NixOS/nixpkgs -n nixpkgs -b nixpkgs-unstable" + Opts.<$$> " niv add my-package -v alpha-0.1 -t http://example.com/archive/.zip" + ] -- parse a github shortcut of the form "owner/repo" parseAddShortcutGitHub :: T.Text -> Maybe (PackageName, Aeson.Object) parseAddShortcutGitHub str = - -- parses a string "owner/repo" into package name (repo) and spec (owner + - -- repo) - case T.span (/= '/') str of - (owner@(T.null -> False) - , T.uncons -> Just ('/', repo@(T.null -> False))) -> Just - ( PackageName repo - , HMS.fromList [ "owner" .= owner, "repo" .= repo ]) - -- XXX: this should be "Nothing" but for the time being we keep - -- backwards compatibility with "niv add foo" adding "foo" as a - -- package name. - _ -> Just (PackageName str, HMS.empty) + -- parses a string "owner/repo" into package name (repo) and spec (owner + + -- repo) + case T.span (/= '/') str of + ( owner@(T.null -> False), + T.uncons -> Just ('/', repo@(T.null -> False)) + ) -> + Just + ( PackageName repo, + HMS.fromList ["owner" .= owner, "repo" .= repo] + ) + -- XXX: this should be "Nothing" but for the time being we keep + -- backwards compatibility with "niv add foo" adding "foo" as a + -- package name. + _ -> Just (PackageName str, HMS.empty) -- | The IO (real) github update githubUpdate' :: Update () () @@ -135,12 +155,12 @@ githubUpdate' = githubUpdate nixPrefetchURL githubLatestRev githubRepo nixPrefetchURL :: Bool -> T.Text -> IO T.Text nixPrefetchURL unpack turl@(T.unpack -> url) = do - (exitCode, sout, serr) <- runNixPrefetch - case (exitCode, lines sout) of - (ExitSuccess, l:_) -> pure $ T.pack l - _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) + (exitCode, sout, serr) <- runNixPrefetch + case (exitCode, lines sout) of + (ExitSuccess, l : _) -> pure $ T.pack l + _ -> abortNixPrefetchExpectedOutput (T.pack <$> args) (T.pack sout) (T.pack serr) where - args = (if unpack then ["--unpack"] else []) <> [ url, "--name", sanitizeName basename] + args = (if unpack then ["--unpack"] else []) <> [url, "--name", sanitizeName basename] runNixPrefetch = readProcessWithExitCode "nix-prefetch-url" args "" sanitizeName = T.unpack . T.filter isOk basename = last $ T.splitOn "/" turl @@ -151,11 +171,14 @@ nixPrefetchURL unpack turl@(T.unpack -> url) = do isOk = \c -> isAlphaNum c || T.any (c ==) "+-._?=" abortNixPrefetchExpectedOutput :: [T.Text] -> T.Text -> T.Text -> IO a -abortNixPrefetchExpectedOutput args sout serr = abort $ [s| +abortNixPrefetchExpectedOutput args sout serr = + 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. -|] <> T.unlines ["command: ", "nix-prefetch-url" <> T.unwords args, "stdout: ", sout, "stderr: ", serr] +|] + <> T.unlines ["command: ", "nix-prefetch-url" <> T.unwords args, "stdout: ", sout, "stderr: ", serr] diff --git a/src/Niv/GitHub/Test.hs b/src/Niv/GitHub/Test.hs index 9ee3aee..493632d 100644 --- a/src/Niv/GitHub/Test.hs +++ b/src/Niv/GitHub/Test.hs @@ -5,156 +5,172 @@ module Niv.GitHub.Test where import Control.Monad -import Data.IORef import Data.Bifunctor +import qualified Data.HashMap.Strict as HMS +import Data.IORef import Niv.GitHub import Niv.GitHub.API 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 + 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///archive/.tar.gz") - ] + 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///archive/.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 + 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///archive/.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///archive/.tar.gz") - ] + 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///archive/.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///archive/.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 + 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///archive/.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///archive/.tar.gz") - ] + 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///archive/.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///archive/.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 + 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/.tar.gz")) - , ("baz", (Free, "tarball")) - ] - expectedState = HMS.fromList - [ ("url_template", "https://foo.com/.tar.gz") - , ("baz", "tarball") - , ("url", "https://foo.com/tarball.tar.gz") - , ("sha256", "some-sha") - , ("type", "tarball") - ] + initialState = + HMS.fromList + [ ("url_template", (Free, "https://foo.com/.tar.gz")), + ("baz", (Free, "tarball")) + ] + expectedState = + HMS.fromList + [ ("url_template", "https://foo.com/.tar.gz"), + ("baz", "tarball"), + ("url", "https://foo.com/tarball.tar.gz"), + ("sha256", "some-sha"), + ("type", "tarball") + ] test_githubUpdatesOnce :: IO () test_githubUpdatesOnce = do - ioref <- newIORef False - tmpState <- evalUpdate initialState $ proc () -> - githubUpdate (prefetch ioref) latestRev ghRepo -< () - - unless ((snd <$> tmpState) == expectedState) $ - error $ "State mismatch: " <> show tmpState - - -- Set everything free - let tmpState' = HMS.map (first (\_ -> Free)) tmpState - actualState <- evalUpdate tmpState' $ proc () -> - githubUpdate (prefetch ioref) latestRev ghRepo -< () - - unless ((snd <$> actualState) == expectedState) $ - error $ "State mismatch: " <> show actualState + ioref <- newIORef False + tmpState <- evalUpdate initialState $ proc () -> + githubUpdate (prefetch ioref) latestRev ghRepo -< () + unless ((snd <$> tmpState) == expectedState) + $ error + $ "State mismatch: " <> show tmpState + -- Set everything free + let tmpState' = HMS.map (first (\_ -> Free)) tmpState + actualState <- evalUpdate tmpState' $ proc () -> + githubUpdate (prefetch ioref) latestRev ghRepo -< () + unless ((snd <$> actualState) == expectedState) + $ error + $ "State mismatch: " <> show actualState where prefetch ioref _ _ = do readIORef ioref >>= \case @@ -163,32 +179,36 @@ test_githubUpdatesOnce = do writeIORef ioref True 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///archive/.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///archive/.tar.gz") - ] + 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///archive/.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///archive/.tar.gz") + ] diff --git a/src/Niv/Local/Cmd.hs b/src/Niv/Local/Cmd.hs index 385c803..6517198 100644 --- a/src/Niv/Local/Cmd.hs +++ b/src/Niv/Local/Cmd.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,32 +8,34 @@ module Niv.Local.Cmd where -import Niv.Cmd import Control.Arrow -import Niv.Sources -import Niv.Update import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HMS import qualified Data.Text as T +import Niv.Cmd +import Niv.Sources +import Niv.Update import qualified Options.Applicative as Opts import qualified Options.Applicative.Help.Pretty as Opts localCmd :: Cmd -localCmd = Cmd - { description = describeLocal - , parseCmdShortcut = parseLocalShortcut - , parsePackageSpec = parseLocalPackageSpec - , updateCmd = proc () -> do - useOrSet "type" -< ("local" :: Box T.Text) - returnA -< () - , name = "local" - } +localCmd = + Cmd + { description = describeLocal, + parseCmdShortcut = parseLocalShortcut, + parsePackageSpec = parseLocalPackageSpec, + updateCmd = proc () -> do + useOrSet "type" -< ("local" :: Box T.Text) + returnA -< (), + name = "local" + } parseLocalShortcut :: T.Text -> Maybe (PackageName, Aeson.Object) parseLocalShortcut txt = - if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt ) then do + if (T.isPrefixOf "./" txt || T.isPrefixOf "/" txt) + then do let n = last $ T.splitOn "/" txt - Just (PackageName n, HMS.fromList [ ("path", Aeson.String txt) ]) + Just (PackageName n, HMS.fromList [("path", Aeson.String txt)]) else Nothing parseLocalPackageSpec :: Opts.Parser PackageSpec @@ -41,19 +43,20 @@ parseLocalPackageSpec = PackageSpec . HMS.fromList <$> parseParams where parseParams :: Opts.Parser [(T.Text, Aeson.Value)] parseParams = maybe [] pure <$> Opts.optional parsePath - parsePath = - ("path", ) . Aeson.String <$> Opts.strOption - ( Opts.long "path" <> - Opts.metavar "PATH" - ) + ("path",) . Aeson.String + <$> Opts.strOption + ( Opts.long "path" + <> Opts.metavar "PATH" + ) describeLocal :: Opts.InfoMod a -describeLocal = mconcat - [ Opts.fullDesc - , Opts.progDesc "Add a local dependency. Experimental." - , Opts.headerDoc $ Just $ - "Examples:" Opts.<$$> - "" Opts.<$$> - " niv add local ./foo/bar" - ] +describeLocal = + mconcat + [ Opts.fullDesc, + Opts.progDesc "Add a local dependency. Experimental.", + Opts.headerDoc $ Just $ + "Examples:" + Opts.<$$> "" + Opts.<$$> " niv add local ./foo/bar" + ] diff --git a/src/Niv/Logger.hs b/src/Niv/Logger.hs index 951a26a..a5e6b78 100644 --- a/src/Niv/Logger.hs +++ b/src/Niv/Logger.hs @@ -1,47 +1,55 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Niv.Logger - ( job - , bug - , tsay - , say - , green, tgreen - , red, tred - , blue, tblue - , yellow, tyellow - , bold, tbold - , faint, tfaint - ) where + ( job, + bug, + tsay, + say, + green, + tgreen, + red, + tred, + blue, + tblue, + yellow, + tyellow, + bold, + tbold, + faint, + tfaint, + ) +where import Control.Monad import Data.List import Data.Profunctor +import qualified Data.Text as T +import qualified System.Console.ANSI as ANSI import System.Exit (exitFailure) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Text as T import UnliftIO -import qualified System.Console.ANSI as ANSI type S = String -> String + type T = T.Text -> T.Text -- XXX: this assumes as single thread job :: (MonadUnliftIO io, MonadIO io) => String -> io () -> io () job str act = do - say (bold str) - indent - tryAny act <* deindent >>= \case - Right () -> say $ green "Done" <> ": " <> str - Left e -> do - -- don't wrap if the error ain't too long - let showErr = do - let se = show e - (if length se > 40 then ":\n" else ": ") <> se - say $ red "ERROR" <> showErr - liftIO exitFailure + say (bold str) + indent + tryAny act <* deindent >>= \case + Right () -> say $ green "Done" <> ": " <> str + Left e -> do + -- don't wrap if the error ain't too long + let showErr = do + let se = show e + (if length se > 40 then ":\n" else ": ") <> se + say $ red "ERROR" <> showErr + liftIO exitFailure where indent = void $ atomicModifyIORef jobStack (\x -> (x + 1, undefined)) deindent = void $ atomicModifyIORef jobStack (\x -> (x - 1, undefined)) @@ -51,6 +59,7 @@ jobStackSize = readIORef jobStack jobStack :: IORef Int jobStack = unsafePerformIO $ newIORef 0 + {-# NOINLINE jobStackSize #-} tsay :: MonadIO io => T.Text -> io () @@ -58,61 +67,67 @@ tsay = say . T.unpack say :: MonadIO io => String -> io () say msg = do - stackSize <- jobStackSize - let indent = replicate (stackSize * 2) ' ' - -- we use `intercalate "\n"` because `unlines` prints an extra newline at - -- the end - liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg + stackSize <- jobStackSize + let indent = replicate (stackSize * 2) ' ' + -- we use `intercalate "\n"` because `unlines` prints an extra newline at + -- the end + liftIO $ putStrLn $ intercalate "\n" $ (indent <>) <$> lines msg green :: S green str = - ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tgreen :: T tgreen = t green yellow :: S yellow str = - ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Yellow] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tyellow :: T tyellow = t yellow blue :: S blue str = - ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Blue] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tblue :: T tblue = t blue red :: S red str = - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tred :: T tred = t red bold :: S bold str = - ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] <> - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.BoldIntensity] + <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tbold :: T tbold = t bold faint :: String -> String faint str = - ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity] <> - ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] <> - str <> ANSI.setSGRCode [ANSI.Reset] + ANSI.setSGRCode [ANSI.SetConsoleIntensity ANSI.FaintIntensity] + <> ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.White] + <> str + <> ANSI.setSGRCode [ANSI.Reset] tfaint :: T tfaint = t faint @@ -121,9 +136,10 @@ t :: (String -> String) -> T.Text -> T.Text t = dimap T.unpack T.pack bug :: T.Text -> T.Text -bug txt = T.unlines - [ txt - , "This is a bug. Please create a ticket:" - , " https://github.com/nmattia/niv/issues/new" - , "Thanks! I'll buy you a beer." - ] +bug txt = + T.unlines + [ txt, + "This is a bug. Please create a ticket:", + " https://github.com/nmattia/niv/issues/new", + "Thanks! I'll buy you a beer." + ] diff --git a/src/Niv/Sources.hs b/src/Niv/Sources.hs index dff9eaa..33c46e4 100644 --- a/src/Niv/Sources.hs +++ b/src/Niv/Sources.hs @@ -1,31 +1,31 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Niv.Sources where import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import Data.FileEmbed (embedFile) -import Data.Bifunctor (first) -import Data.Hashable (Hashable) -import Data.List -import Data.String.QQ (s) -import Data.Text.Extended -import Niv.Logger -import Niv.Update -import System.FilePath (()) -import UnliftIO import qualified Data.Aeson as Aeson import qualified Data.Aeson.Extended as Aeson +import Data.Bifunctor (first) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.Digest.Pure.MD5 as MD5 +import Data.FileEmbed (embedFile) import qualified Data.HashMap.Strict as HMS +import Data.Hashable (Hashable) +import Data.List +import Data.String.QQ (s) import qualified Data.Text as T +import Data.Text.Extended +import Niv.Logger +import Niv.Update import qualified System.Directory as Dir +import System.FilePath (()) +import UnliftIO ------------------------------------------------------------------------------- -- sources.json related @@ -33,57 +33,65 @@ import qualified System.Directory as Dir -- | Where to find the sources.json data FindSourcesJson - = Auto -- ^ use the default (nix/sources.json) - | AtPath FilePath -- ^ use the specified file path + = -- | use the default (nix/sources.json) + Auto + | -- | use the specified file path + AtPath FilePath data SourcesError = SourcesDoesntExist | SourceIsntJSON | SpecIsntAMap -newtype Sources = Sources - { unSources :: HMS.HashMap PackageName PackageSpec } +newtype Sources + = Sources + {unSources :: HMS.HashMap PackageName PackageSpec} deriving newtype (FromJSON, ToJSON) getSourcesEither :: FindSourcesJson -> IO (Either SourcesError Sources) getSourcesEither fsj = do - Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case - False -> pure $ Left SourcesDoesntExist - True -> - Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case - Just value -> case valueToSources value of - Nothing -> pure $ Left SpecIsntAMap - Just srcs -> pure $ Right srcs - Nothing -> pure $ Left SourceIsntJSON + Dir.doesFileExist (pathNixSourcesJson fsj) >>= \case + False -> pure $ Left SourcesDoesntExist + True -> + Aeson.decodeFileStrict (pathNixSourcesJson fsj) >>= \case + Just value -> case valueToSources value of + Nothing -> pure $ Left SpecIsntAMap + Just srcs -> pure $ Right srcs + Nothing -> pure $ Left SourceIsntJSON where valueToSources :: Aeson.Value -> Maybe Sources valueToSources = \case - Aeson.Object obj -> fmap (Sources . mapKeys PackageName) $ traverse - (\case - Aeson.Object obj' -> Just (PackageSpec obj') - _ -> Nothing - ) obj - _ -> Nothing + Aeson.Object obj -> + fmap (Sources . mapKeys PackageName) $ + traverse + ( \case + Aeson.Object obj' -> Just (PackageSpec obj') + _ -> Nothing + ) + obj + _ -> Nothing mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> HMS.HashMap k1 v -> HMS.HashMap k2 v mapKeys f = HMS.fromList . map (first f) . HMS.toList getSources :: FindSourcesJson -> IO Sources getSources fsj = do - warnIfOutdated - getSourcesEither fsj >>= either - (\case - SourcesDoesntExist -> (abortSourcesDoesntExist fsj) - SourceIsntJSON -> (abortSourcesIsntJSON fsj) - SpecIsntAMap -> (abortSpecIsntAMap fsj) - ) pure + warnIfOutdated + getSourcesEither fsj + >>= either + ( \case + SourcesDoesntExist -> (abortSourcesDoesntExist fsj) + SourceIsntJSON -> (abortSourcesIsntJSON fsj) + SpecIsntAMap -> (abortSpecIsntAMap fsj) + ) + pure setSources :: FindSourcesJson -> Sources -> IO () setSources fsj sources = Aeson.encodeFilePretty (pathNixSourcesJson fsj) sources -newtype PackageName = PackageName { unPackageName :: T.Text } +newtype PackageName = PackageName {unPackageName :: T.Text} deriving newtype (Eq, Hashable, FromJSONKey, ToJSONKey, Show) -newtype PackageSpec = PackageSpec { unPackageSpec :: Aeson.Object } +newtype PackageSpec = PackageSpec {unPackageSpec :: Aeson.Object} deriving newtype (FromJSON, ToJSON, Show, Semigroup, Monoid) -- | Simply discards the 'Freedom' @@ -93,32 +101,34 @@ attrsToSpec = PackageSpec . fmap snd -- | @nix/sources.json@ or pointed at by 'FindSourcesJson' pathNixSourcesJson :: FindSourcesJson -> FilePath pathNixSourcesJson = \case - Auto -> "nix" "sources.json" - AtPath f -> f + Auto -> "nix" "sources.json" + AtPath f -> f -- -- ABORT messages -- abortSourcesDoesntExist :: FindSourcesJson -> IO a -abortSourcesDoesntExist fsj = abort $ T.unlines [ line1, line2 ] +abortSourcesDoesntExist fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj) - line2 = [s| + line2 = + [s| The sources file does not exist! You may need to run 'niv init'. |] abortSourcesIsntJSON :: FindSourcesJson -> IO a -abortSourcesIsntJSON fsj = abort $ T.unlines [ line1, line2 ] +abortSourcesIsntJSON fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj) line2 = "The sources file should be JSON." abortSpecIsntAMap :: FindSourcesJson -> IO a -abortSpecIsntAMap fsj = abort $ T.unlines [ line1, line2 ] +abortSpecIsntAMap fsj = abort $ T.unlines [line1, line2] where line1 = "Cannot use " <> T.pack (pathNixSourcesJson fsj) - line2 = [s| + line2 = + [s| The package specifications in the sources file should be JSON maps from attribute name to attribute value, e.g.: { "nixpkgs": { "foo": "bar" } } @@ -128,7 +138,6 @@ attribute name to attribute value, e.g.: -- sources.nix related ------------------------------------------------------------------------------- - -- | All the released versions of nix/sources.nix data SourcesNixVersion = V1 @@ -148,32 +157,32 @@ data SourcesNixVersion | V15 | V16 | V17 - -- prettify derivation name - -- add 'local' type of sources - | V18 + | -- prettify derivation name + -- add 'local' type of sources + V18 deriving stock (Bounded, Enum, Eq) -- | A user friendly version sourcesVersionToText :: SourcesNixVersion -> T.Text sourcesVersionToText = \case - V1 -> "1" - V2 -> "2" - V3 -> "3" - V4 -> "4" - V5 -> "5" - V6 -> "6" - V7 -> "7" - V8 -> "8" - V9 -> "9" - V10 -> "10" - V11 -> "11" - V12 -> "12" - V13 -> "13" - V14 -> "14" - V15 -> "15" - V16 -> "16" - V17 -> "17" - V18 -> "18" + V1 -> "1" + V2 -> "2" + V3 -> "3" + V4 -> "4" + V5 -> "5" + V6 -> "6" + V7 -> "7" + V8 -> "8" + V9 -> "9" + V10 -> "10" + V11 -> "11" + V12 -> "12" + V13 -> "13" + V14 -> "14" + V15 -> "15" + V16 -> "16" + V17 -> "17" + V18 -> "18" latestVersionMD5 :: T.Text latestVersionMD5 = sourcesVersionToMD5 maxBound @@ -181,29 +190,29 @@ latestVersionMD5 = sourcesVersionToMD5 maxBound -- | Find a version based on the md5 of the nix/sources.nix md5ToSourcesVersion :: T.Text -> Maybe SourcesNixVersion md5ToSourcesVersion md5 = - find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound] + find (\snv -> sourcesVersionToMD5 snv == md5) [minBound .. maxBound] -- | The MD5 sum of a particular version sourcesVersionToMD5 :: SourcesNixVersion -> T.Text sourcesVersionToMD5 = \case - V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5" - V2 -> "24cc0719fa744420a04361e23a3598d0" - V3 -> "e01ed051e2c416e0fc7355fc72aeee3d" - V4 -> "f754fe0e661b61abdcd32cb4062f5014" - V5 -> "c34523590ff7dec7bf0689f145df29d1" - V6 -> "8143f1db1e209562faf80a998be4929a" - V7 -> "00a02cae76d30bbef96f001cabeed96f" - V8 -> "e8b860753dd7fa1fd7b805dd836eb607" - V9 -> "87149616c1b3b1e5aa73178f91c20b53" - V10 -> "d8625c0a03dd935e1c79f46407faa8d3" - V11 -> "8a95b7d93b16f7c7515d98f49b0ec741" - V12 -> "2f9629ad9a8f181ed71d2a59b454970c" - V13 -> "5e23c56b92eaade4e664cb16dcac1e0a" - V14 -> "b470e235e7bcbf106d243fea90b6cfc9" - V15 -> "dc11af910773ec9b4e505e0f49ebcfd2" - V16 -> "2d93c52cab8e960e767a79af05ca572a" - V17 -> "149b8907f7b08dc1c28164dfa55c7fad" - V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33" + V1 -> "a7d3532c70fea66ffa25d6bc7ee49ad5" + V2 -> "24cc0719fa744420a04361e23a3598d0" + V3 -> "e01ed051e2c416e0fc7355fc72aeee3d" + V4 -> "f754fe0e661b61abdcd32cb4062f5014" + V5 -> "c34523590ff7dec7bf0689f145df29d1" + V6 -> "8143f1db1e209562faf80a998be4929a" + V7 -> "00a02cae76d30bbef96f001cabeed96f" + V8 -> "e8b860753dd7fa1fd7b805dd836eb607" + V9 -> "87149616c1b3b1e5aa73178f91c20b53" + V10 -> "d8625c0a03dd935e1c79f46407faa8d3" + V11 -> "8a95b7d93b16f7c7515d98f49b0ec741" + V12 -> "2f9629ad9a8f181ed71d2a59b454970c" + V13 -> "5e23c56b92eaade4e664cb16dcac1e0a" + V14 -> "b470e235e7bcbf106d243fea90b6cfc9" + V15 -> "dc11af910773ec9b4e505e0f49ebcfd2" + V16 -> "2d93c52cab8e960e767a79af05ca572a" + V17 -> "149b8907f7b08dc1c28164dfa55c7fad" + V18 -> "bc5e6aefcaa6f9e0b2155ca4f44e5a33" -- | The MD5 sum of ./nix/sources.nix sourcesNixMD5 :: IO T.Text @@ -215,30 +224,36 @@ pathNixSourcesNix = "nix" "sources.nix" warnIfOutdated :: IO () warnIfOutdated = do - tryAny (BL8.readFile pathNixSourcesNix) >>= \case - Left e -> tsay $ T.unlines -- warn with tsay - [ T.unwords [ tyellow "WARNING:", "Could not read" , T.pack pathNixSourcesNix ] - , T.unwords [ " ", "(", tshow e, ")" ] - ] - Right content -> do - case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of - -- This is a custom or newer version, we don't do anything - Nothing -> pure () - Just v - -- The file is the latest - | v == maxBound -> pure () - -- The file is older than than latest - | otherwise -> do - tsay $ T.unlines - [ T.unwords - [ tbold $ tblue "INFO:" - , "new sources.nix available:" - , sourcesVersionToText v, "->", sourcesVersionToText maxBound - ] - , " Please run 'niv init' or add the following line in the " <> - T.pack pathNixSourcesNix <> " file:" - , " # niv: no_update" - ] + tryAny (BL8.readFile pathNixSourcesNix) >>= \case + Left e -> + tsay $ + T.unlines -- warn with tsay + [ T.unwords [tyellow "WARNING:", "Could not read", T.pack pathNixSourcesNix], + T.unwords [" ", "(", tshow e, ")"] + ] + Right content -> do + case md5ToSourcesVersion (T.pack $ show $ MD5.md5 content) of + -- This is a custom or newer version, we don't do anything + Nothing -> pure () + Just v + -- The file is the latest + | v == maxBound -> pure () + -- The file is older than than latest + | otherwise -> do + tsay $ + T.unlines + [ T.unwords + [ tbold $ tblue "INFO:", + "new sources.nix available:", + sourcesVersionToText v, + "->", + sourcesVersionToText maxBound + ], + " Please run 'niv init' or add the following line in the " + <> T.pack pathNixSourcesNix + <> " file:", + " # niv: no_update" + ] -- | Glue code between nix and sources.json initNixSourcesNixContent :: B.ByteString diff --git a/src/Niv/Sources/Test.hs b/src/Niv/Sources/Test.hs index 22f5bfe..6d96caf 100644 --- a/src/Niv/Sources/Test.hs +++ b/src/Niv/Sources/Test.hs @@ -1,13 +1,13 @@ module Niv.Sources.Test where -import Niv.Sources -import Test.Tasty.HUnit ((@=?)) import qualified Data.ByteString.Lazy as BL import qualified Data.Digest.Pure.MD5 as MD5 import qualified Data.Text as T +import Niv.Sources +import Test.Tasty.HUnit ((@=?)) -- | Ensure that the sources.nix we ship is tracked as the latest version test_shippedSourcesNixIsLatest :: IO () test_shippedSourcesNixIsLatest = - latestVersionMD5 @=? - (T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent) + latestVersionMD5 + @=? (T.pack . show . MD5.md5 . BL.fromStrict $ initNixSourcesNixContent) diff --git a/src/Niv/Test.hs b/src/Niv/Test.hs index 5f312b2..c656650 100644 --- a/src/Niv/Test.hs +++ b/src/Niv/Test.hs @@ -1,9 +1,9 @@ module Niv.Test (tests, test) where -import Niv.Sources.Test -import Niv.GitHub.Test -import Niv.Update.Test import qualified Niv.Git.Test as Git +import Niv.GitHub.Test +import Niv.Sources.Test +import Niv.Update.Test import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty @@ -11,26 +11,31 @@ 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 "updates once" test_githubUpdatesOnce - , Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev - , Tasty.testCase "falls back to URL" test_githubURLFallback - ] - , Tasty.testGroup "sources.nix" +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 "updates once" test_githubUpdatesOnce, + Tasty.testCase "doesn't override rev" test_githubDoesntOverrideRev, + Tasty.testCase "falls back to URL" test_githubURLFallback + ], + Tasty.testGroup + "sources.nix" [ Tasty.testCase "has latest version" test_shippedSourcesNixIsLatest - ] - , Tasty.testGroup "git" Git.tests + ], + Tasty.testGroup "git" Git.tests ] diff --git a/src/Niv/Update.hs b/src/Niv/Update.hs index a4b89aa..99b5500 100644 --- a/src/Niv/Update.hs +++ b/src/Niv/Update.hs @@ -12,14 +12,14 @@ module Niv.Update where import Control.Applicative import Control.Arrow -import Data.Aeson (FromJSON, ToJSON, Value) -import Data.String -import Niv.Logger -import UnliftIO import qualified Control.Category as Cat +import Data.Aeson (FromJSON, ToJSON, Value) import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HMS +import Data.String import qualified Data.Text as T +import Niv.Logger +import UnliftIO type Attrs = HMS.HashMap T.Text (Freedom, Value) @@ -34,27 +34,27 @@ data Update b c where 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) + Run :: (a -> IO b) -> Update (Box a) (Box b) Template :: Update (Box T.Text) (Box T.Text) instance ArrowZero Update where - zeroArrow = Zero + zeroArrow = Zero instance ArrowPlus Update where - (<+>) = Plus + (<+>) = Plus instance Arrow Update where - arr = Arr - first = First + arr = Arr + first = First instance Cat.Category Update where - id = Id - f . g = Compose (Compose' f g) + 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 <> ")" + Compose (Compose' f g) -> "(" <> show f <> " . " <> show g <> ")" Arr _f -> "Arr" First a -> "First " <> show a Zero -> "Zero" @@ -83,10 +83,11 @@ runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed FailNoSuchKey k -> "Key could not be found: " <> k FailZero -> bug "A dead end was reached during evaluation." FailCheck -> "A check failed during update" - FailTemplate tpl keys -> T.unlines - [ "Could not render template " <> tpl - , "with keys: " <> T.intercalate ", " keys - ] + 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 @@ -104,41 +105,43 @@ data UpdateFailed | FailZero | FailCheck | FailTemplate T.Text [T.Text] - deriving Show + deriving (Show) data UpdateRes a b = UpdateReady (UpdateReady b) | UpdateNeedMore (a -> IO (UpdateReady b)) - deriving Functor + deriving (Functor) data UpdateReady b = UpdateSuccess BoxedAttrs b | UpdateFailed UpdateFailed - deriving Functor + 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 +data Box a + = Box + { -- | Whether the value is new or was retrieved (or derived) from old + -- attributes + boxNew :: Bool, + 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 - } + 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 } + fromString str = Box {boxNew = False, boxOp = pure $ T.pack str} type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value) @@ -146,12 +149,16 @@ 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 - )) +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 @@ -163,84 +170,94 @@ data Freedom -- 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) + 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 do v' <- boxOp v gtt' <- boxOp gtt -- Here we compare the old and new values, flagging the new one as -- "boxNew" iff they differ. -- TODO: generalize this to all boxes - let gtt'' = if v' /= gtt' then gtt { boxNew = True, boxOp = pure gtt' } - else gtt { boxNew = False, boxOp = pure gtt' } + let gtt'' = + if v' /= gtt' + then gtt {boxNew = True, boxOp = pure gtt'} + else gtt {boxNew = False, boxOp = pure gtt'} pure $ UpdateSuccess (HMS.insert k (Locked, gtt'') attrs) gtt'' else do 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 + 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) -> 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 + 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 } +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 @@ -254,16 +271,16 @@ decodeValue msg v = case Aeson.fromJSON v of -- renderTemplate ("foo" -> "bar") "" -> 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 + (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 @@ -277,15 +294,15 @@ 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) + 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) + arr (fmap Aeson.toJSON) + >>> Update k + >>> arr (decodeBox $ "When updating key " <> k) run :: (a -> IO b) -> Update (Box a) (Box b) run = Run @@ -295,4 +312,4 @@ 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 }) +dirty = arr (\v -> v {boxNew = True}) diff --git a/src/Niv/Update/Test.hs b/src/Niv/Update/Test.hs index ad03f63..83444da 100644 --- a/src/Niv/Update/Test.hs +++ b/src/Niv/Update/Test.hs @@ -1,46 +1,48 @@ {-# LANGUAGE Arrows #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} 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 +import Niv.Update simplyRuns :: IO () simplyRuns = - void $ runUpdate attrs $ proc () -> do - returnA -< () + 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") + 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") + 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") + 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 () () @@ -58,55 +60,59 @@ survivesChecks = do 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)) + 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' + 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" + 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 -< "-" - v3' <- runBox v3 - unless (v3' == "hello-world") $ error "bad value" + v3 <- execUpdate attrs $ proc () -> template -< "-" + v3' <- runBox v3 + unless (v3' == "hello-world") $ error "bad value" where attrs = HMS.fromList [("v1", (Free, "hello")), ("v2", (Free, "world"))]