From 784ba9f715a8a64603d1ec66336feb1a461bc119 Mon Sep 17 00:00:00 2001 From: zowoq <59103226+zowoq@users.noreply.github.com> Date: Wed, 3 Apr 2024 08:01:16 +1000 Subject: [PATCH] format --- app/Main.hs | 9 +-- src/CVE.hs | 2 +- src/Check.hs | 62 ++++++++--------- src/GH.hs | 62 +++++++++-------- src/Git.hs | 36 +++++----- src/NVDRules.hs | 20 +++--- src/Nix.hs | 65 +++++++++--------- src/NixpkgsReview.hs | 30 +++++---- src/OurPrelude.hs | 8 +-- src/Outpaths.hs | 37 +++++++---- src/Repology.hs | 10 ++- src/Rewrite.hs | 155 ++++++++++++++++++++++--------------------- src/Skiplist.hs | 6 +- src/Update.hs | 88 +++++++++++++----------- src/Utils.hs | 21 +++--- src/Version.hs | 44 ++++++------ test/CheckSpec.hs | 2 +- 17 files changed, 351 insertions(+), 306 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fa9e510f..3e1ce6b0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -71,9 +71,9 @@ deleteDoneParser = commandParser :: O.Parser Command commandParser = O.hsubparser - (O.command - "update" - (O.info (updateParser) (O.progDesc "Update one package")) + ( O.command + "update" + (O.info (updateParser) (O.progDesc "Update one package")) <> O.command "update-batch" (O.info (updateBatchParser) (O.progDesc "Update one package in batch mode.")) @@ -116,7 +116,8 @@ commandParser = checkVulnerable :: O.Parser Command checkVulnerable = - CheckVulnerable <$> O.strArgument (O.metavar "PRODUCT_ID") + CheckVulnerable + <$> O.strArgument (O.metavar "PRODUCT_ID") <*> O.strArgument (O.metavar "OLD_VERSION") <*> O.strArgument (O.metavar "NEW_VERSION") diff --git a/src/CVE.hs b/src/CVE.hs index 7cc797e3..f48be3d3 100644 --- a/src/CVE.hs +++ b/src/CVE.hs @@ -16,6 +16,7 @@ where import Data.Aeson ( FromJSON, + Key, Object, eitherDecode, parseJSON, @@ -23,7 +24,6 @@ import Data.Aeson (.!=), (.:), (.:!), - Key, ) import Data.Aeson.Types (Parser, prependFailure) import qualified Data.ByteString.Lazy.Char8 as BSL diff --git a/src/Check.hs b/src/Check.hs index fec33593..a7cbbf65 100644 --- a/src/Check.hs +++ b/src/Check.hs @@ -8,7 +8,7 @@ module Check ( result, -- exposed for testing: hasVersion, - versionWithoutPath + versionWithoutPath, ) where @@ -19,7 +19,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Language.Haskell.TH.Env (envQ) import OurPrelude -import System.Exit() +import System.Exit () import Text.Regex.Applicative.Text (RE', (=~)) import qualified Text.Regex.Applicative.Text as RE import Utils (UpdateEnv (..), nixBuildOptions) @@ -50,11 +50,11 @@ isNonWordCharacter c = not (isWordCharacter c) -- | Construct regex: /.*\b${version}\b.*/s versionRegex :: Text -> RE' () versionRegex version = - (\_ -> ()) <$> ( - (((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure "")) - *> (RE.string version) <* - ((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym))) - ) + (\_ -> ()) + <$> ( (((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure "")) + *> (RE.string version) + <* ((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym))) + ) hasVersion :: Text -> Text -> Bool hasVersion contents expectedVersion = @@ -63,10 +63,9 @@ hasVersion contents expectedVersion = checkTestsBuild :: Text -> IO Bool checkTestsBuild attrPath = do let timeout = "10m" - let - args = - [ T.unpack timeout, "nix-build" ] ++ - nixBuildOptions + let args = + [T.unpack timeout, "nix-build"] + ++ nixBuildOptions ++ [ "-E", "{ config }: (import ./. { inherit config; })." ++ (T.unpack attrPath) @@ -99,19 +98,19 @@ versionWithoutPath resultPath expectedVersion = -- This can be done with negative lookbehind e.g -- /^(? - -- no version in prefix, just match version - "\\Q" - <> T.unpack expectedVersion - <> "\\E" - (storePrefix, _) -> - "(? T.unpack storePrefix - <> "\\E)\\Q" - <> T.unpack expectedVersion - <> "\\E" + let storePath = fromMaybe (T.pack resultPath) $ T.stripPrefix "/nix/store/" (T.pack resultPath) + in case T.breakOn expectedVersion storePath of + (_, "") -> + -- no version in prefix, just match version + "\\Q" + <> T.unpack expectedVersion + <> "\\E" + (storePrefix, _) -> + "(? T.unpack storePrefix + <> "\\E)\\Q" + <> T.unpack expectedVersion + <> "\\E" foundVersionInOutputs :: Text -> String -> IO (Maybe Text) foundVersionInOutputs expectedVersion resultPath = @@ -140,7 +139,8 @@ foundVersionInFileNames expectedVersion resultPath = ( do (_, contents) <- shell ("find " <> resultPath) & ourReadProcessInterleaved - (contents =~ versionRegex expectedVersion) & hoistMaybe + (contents =~ versionRegex expectedVersion) + & hoistMaybe & noteT (T.pack "Expected version not found") return $ "- found " @@ -157,7 +157,8 @@ treeGist resultPath = ( do contents <- procTree [resultPath] & ourReadProcessInterleavedBS_ g <- - shell gistBin & setStdin (byteStringInput contents) + shell gistBin + & setStdin (byteStringInput contents) & ourReadProcessInterleaved_ return $ "- directory tree listing: " <> g <> "\n" ) @@ -169,7 +170,8 @@ duGist resultPath = ( do contents <- proc "du" [resultPath] & ourReadProcessInterleavedBS_ g <- - shell gistBin & setStdin (byteStringInput contents) + shell gistBin + & setStdin (byteStringInput contents) & ourReadProcessInterleaved_ return $ "- du listing: " <> g <> "\n" ) @@ -182,9 +184,9 @@ result updateEnv resultPath = someReports <- fromMaybe "" <$> foundVersionInOutputs expectedVersion resultPath - <> foundVersionInFileNames expectedVersion resultPath - <> treeGist resultPath - <> duGist resultPath + <> foundVersionInFileNames expectedVersion resultPath + <> treeGist resultPath + <> duGist resultPath return $ let testsBuildSummary = checkTestsBuildReport testsBuild in [interpolate| diff --git a/src/GH.hs b/src/GH.hs index 2ce4444a..7df2ae77 100644 --- a/src/GH.hs +++ b/src/GH.hs @@ -23,7 +23,7 @@ import Data.Aeson (FromJSON) import Data.Bitraversable (bitraverse) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Data.Time.Clock (getCurrentTime, addUTCTime) +import Data.Time.Clock (addUTCTime, getCurrentTime) import qualified Data.Vector as V import qualified Git import qualified GitHub as GH @@ -54,23 +54,25 @@ pr env title body prHead base = do tryPR `catchE` \case -- If creating the PR returns a 422, most likely cause is that the -- branch was deleted, so push it again and retry once. - GH.HTTPError (HttpExceptionRequest _ (StatusCodeException r _)) | statusCode (responseStatus r) == 422 -> - Git.push env >> withExceptT (T.pack . show) tryPR + GH.HTTPError (HttpExceptionRequest _ (StatusCodeException r _)) + | statusCode (responseStatus r) == 422 -> + Git.push env >> withExceptT (T.pack . show) tryPR e -> throwE . T.pack . show $ e where - tryPR = ExceptT $ - fmap ((False, ) . GH.getUrl . GH.pullRequestUrl) - <$> ( liftIO $ - ( GH.github - (authFrom env) - ( GH.createPullRequestR - (N "nixos") - (N "nixpkgs") - (GH.CreatePullRequest title body prHead base) + tryPR = + ExceptT $ + fmap ((False,) . GH.getUrl . GH.pullRequestUrl) + <$> ( liftIO $ + ( GH.github + (authFrom env) + ( GH.createPullRequestR + (N "nixos") + (N "nixpkgs") + (GH.CreatePullRequest title body prHead base) + ) ) ) - ) prUpdate :: forall m. MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m (Bool, Text) prUpdate env title body prHead base = do @@ -78,24 +80,25 @@ prUpdate env title body prHead base = do runRequest = ExceptT . fmap (first (T.pack . show)) . liftIO . GH.github (authFrom env) let inNixpkgs f = f (N "nixos") (N "nixpkgs") - prs <- runRequest $ - inNixpkgs GH.pullRequestsForR (GH.optionsHead prHead) GH.FetchAll + prs <- + runRequest $ + inNixpkgs GH.pullRequestsForR (GH.optionsHead prHead) GH.FetchAll case V.toList prs of [] -> pr env title body prHead base - - (_:_:_) -> throwE $ "Too many open PRs from " <> prHead - + (_ : _ : _) -> throwE $ "Too many open PRs from " <> prHead [thePR] -> do let withExistingPR :: (GH.Name GH.Owner -> GH.Name GH.Repo -> GH.IssueNumber -> a) -> a withExistingPR f = inNixpkgs f (GH.simplePullRequestNumber thePR) - _ <- runRequest $ - withExistingPR GH.updatePullRequestR $ - GH.EditPullRequest (Just title) Nothing Nothing Nothing Nothing + _ <- + runRequest $ + withExistingPR GH.updatePullRequestR $ + GH.EditPullRequest (Just title) Nothing Nothing Nothing Nothing - _ <- runRequest $ - withExistingPR GH.createCommentR body + _ <- + runRequest $ + withExistingPR GH.createCommentR body return (True, GH.getUrl $ GH.simplePullRequestUrl thePR) @@ -129,12 +132,18 @@ parseURLMaybe url = extension = RE.string ".zip" <|> RE.string ".tar.gz" toParts n o = URLParts (N n) (N o) regex = - ( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment + ( toParts + <$> (domain *> pathSegment) + <* slash + <*> pathSegment <*> (RE.string "/releases/download/" *> pathSegment) <* slash <* pathSegment ) - <|> ( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment + <|> ( toParts + <$> (domain *> pathSegment) + <* slash + <*> pathSegment <*> (RE.string "/archive/" *> pathSegment) <* extension ) @@ -187,7 +196,8 @@ commitIsOldEnoughToDelete auth ghUser sha = do refShouldBeDeleted :: GH.Auth -> GH.Name GH.Owner -> (Text, GH.Name GH.GitCommit) -> IO Bool refShouldBeDeleted auth ghUser (ref, sha) = - liftA2 (&&) + liftA2 + (&&) (either (const False) not <$> openPRWithAutoUpdateRefFrom auth ghUser ref) (commitIsOldEnoughToDelete auth ghUser sha) diff --git a/src/Git.hs b/src/Git.hs index 3daa921e..7dbb5ffb 100644 --- a/src/Git.hs +++ b/src/Git.hs @@ -18,7 +18,7 @@ module Git setupNixpkgs, Git.show, worktreeAdd, - worktreeRemove + worktreeRemove, ) where @@ -33,9 +33,9 @@ import Data.Time.Clock (addUTCTime, getCurrentTime) import qualified Data.Vector as V import Language.Haskell.TH.Env (envQ) import OurPrelude hiding (throw) -import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, getCurrentDirectory, setCurrentDirectory) +import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime, setCurrentDirectory) import System.Environment.XDG.BaseDir (getUserCacheDir) -import System.Exit() +import System.Exit () import System.IO.Error (tryIOError) import System.Posix.Env (setEnv) import Utils (Options (..), UpdateEnv (..), branchName, branchPrefix) @@ -57,8 +57,8 @@ worktreeRemove :: FilePath -> IO () worktreeRemove path = do exist <- doesDirectoryExist path if exist - then runProcessNoIndexIssue_IO $ silently $ procGit ["worktree", "remove", "--force", path] - else return () + then runProcessNoIndexIssue_IO $ silently $ procGit ["worktree", "remove", "--force", path] + else return () checkout :: Text -> Text -> ProcessConfig () () () checkout branch target = @@ -98,8 +98,9 @@ diff :: MonadIO m => Text -> ExceptT Text m Text diff branch = readProcessInterleavedNoIndexIssue_ $ procGit ["diff", T.unpack branch] diffFileNames :: MonadIO m => Text -> ExceptT Text m [Text] -diffFileNames branch = readProcessInterleavedNoIndexIssue_ (procGit ["diff", T.unpack branch, "--name-only"]) - & fmapRT T.lines +diffFileNames branch = + readProcessInterleavedNoIndexIssue_ (procGit ["diff", T.unpack branch, "--name-only"]) + & fmapRT T.lines staleFetchHead :: MonadIO m => m Bool staleFetchHead = @@ -121,7 +122,8 @@ fetchIfStale = whenM staleFetchHead fetch fetch :: MonadIO m => ExceptT Text m () fetch = runProcessNoIndexIssue_ $ - silently $ procGit ["fetch", "-q", "--prune", "--multiple", "upstream", "origin"] + silently $ + procGit ["fetch", "-q", "--prune", "--multiple", "upstream", "origin"] push :: MonadIO m => UpdateEnv -> ExceptT Text m () push updateEnv = @@ -210,7 +212,6 @@ deleteBranchesEverywhere branches = do Left error2 -> T.putStrLn $ tshow error2 Right success2 -> T.putStrLn $ tshow success2 - runProcessNoIndexIssue_IO :: ProcessConfig () () () -> IO () runProcessNoIndexIssue_IO config = go @@ -220,8 +221,8 @@ runProcessNoIndexIssue_IO config = go case code of ExitFailure 128 | "index.lock" `BS.isInfixOf` BSL.toStrict e -> do - threadDelay 100000 - go + threadDelay 100000 + go ExitSuccess -> return () ExitFailure _ -> throw $ ExitCodeException code config out e @@ -234,8 +235,8 @@ runProcessNoIndexIssue_ config = tryIOTextET go case code of ExitFailure 128 | "index.lock" `BS.isInfixOf` BSL.toStrict e -> do - threadDelay 100000 - go + threadDelay 100000 + go ExitSuccess -> return () ExitFailure _ -> throw $ ExitCodeException code config out e @@ -248,12 +249,11 @@ readProcessInterleavedNoIndexIssue_ config = tryIOTextET go case code of ExitFailure 128 | "index.lock" `BS.isInfixOf` BSL.toStrict out -> do - threadDelay 100000 - go + threadDelay 100000 + go ExitSuccess -> return $ bytestringToText out ExitFailure _ -> throw $ ExitCodeException code config out out - readProcessInterleavedNoIndexIssue_IO :: ProcessConfig () () () -> IO Text readProcessInterleavedNoIndexIssue_IO config = go @@ -263,7 +263,7 @@ readProcessInterleavedNoIndexIssue_IO config = go case code of ExitFailure 128 | "index.lock" `BS.isInfixOf` BSL.toStrict out -> do - threadDelay 100000 - go + threadDelay 100000 + go ExitSuccess -> return $ bytestringToText out ExitFailure _ -> throw $ ExitCodeException code config out out diff --git a/src/NVDRules.hs b/src/NVDRules.hs index 4d03f345..1e6d0f5a 100644 --- a/src/NVDRules.hs +++ b/src/NVDRules.hs @@ -15,15 +15,19 @@ filter _ cpeMatch "socat" v | cpeUpdatePresentAndNotPartOfVersion cpeMatch v = False -- TODO consider if this rule should be applied to all packages filter _ cpeMatch "uzbl" v | isNothing (v =~ yearRegex) - && "2009.12.22" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = - False + && "2009.12.22" + `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = + False | isNothing (v =~ yearRegex) - && "2010.04.03" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = - False + && "2010.04.03" + `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = + False filter _ cpeMatch "go" v - | "." `T.isInfixOf` v - && "-" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = - False + | "." + `T.isInfixOf` v + && "-" + `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = + False filter _ cpeMatch "terraform" _ | cpeTargetSoftware (cpeMatchCPE cpeMatch) == Just "aws" = False filter cve _ "tor" _ @@ -31,7 +35,7 @@ filter cve _ "tor" _ filter _ cpeMatch "arena" _ | cpeVendor (cpeMatchCPE cpeMatch) == Just "rockwellautomation" || cpeVendor (cpeMatchCPE cpeMatch) == Just "openforis" = - False + False filter _ cpeMatch "thrift" _ | cpeVendor (cpeMatchCPE cpeMatch) == Just "facebook" = False filter _ cpeMatch "kanboard" _ diff --git a/src/Nix.hs b/src/Nix.hs index 580fd5f7..037b7095 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -40,8 +40,8 @@ import qualified Data.Text.Lazy.Encoding as TL import qualified Git import Language.Haskell.TH.Env (envQ) import OurPrelude +import System.Exit () import qualified System.Process.Typed as TP -import System.Exit() import Utils (UpdateEnv (..), nixBuildOptions, nixCommonOptions, srcOrMain) import Prelude hiding (log) @@ -82,7 +82,7 @@ nixEvalApplyRaw applyFunc attrPath = nixEvalExpr :: MonadIO m => - Text -> + Text -> ExceptT Text m Text nixEvalExpr expr = ourReadProcess_ @@ -116,22 +116,23 @@ assertNewerVersion updateEnv = do lookupAttrPath :: MonadIO m => UpdateEnv -> ExceptT Text m Text lookupAttrPath updateEnv = -- lookup attrpath by nix-env - (proc - (binPath <> "/nix-env") - ( [ "-qa", - (packageName updateEnv <> "-" <> oldVersion updateEnv) & T.unpack, - "-f", - ".", - "--attr-path" - ] - <> nixCommonOptions - ) - & ourReadProcess_ - & fmapRT (fst >>> T.lines >>> head >>> T.words >>> head)) - <|> - -- if that fails, check by attrpath - (getAttrString "name" (packageName updateEnv)) - & fmapRT (const (packageName updateEnv)) + ( proc + (binPath <> "/nix-env") + ( [ "-qa", + (packageName updateEnv <> "-" <> oldVersion updateEnv) & T.unpack, + "-f", + ".", + "--attr-path" + ] + <> nixCommonOptions + ) + & ourReadProcess_ + & fmapRT (fst >>> T.lines >>> head >>> T.words >>> head) + ) + <|> + -- if that fails, check by attrpath + (getAttrString "name" (packageName updateEnv)) + & fmapRT (const (packageName updateEnv)) getDerivationFile :: MonadIO m => Text -> ExceptT Text m Text getDerivationFile attrPath = do @@ -143,10 +144,10 @@ getDerivationFile attrPath = do -- Get an attribute that can be evaluated off a derivation, as in: -- getAttr "cargoSha256" "ripgrep" -> 0lwz661rbm7kwkd6mallxym1pz8ynda5f03ynjfd16vrazy2dj21 getAttr :: MonadIO m => Text -> Text -> ExceptT Text m Text -getAttr attr = srcOrMain (nixEvalApply ("p: p."<> attr)) +getAttr attr = srcOrMain (nixEvalApply ("p: p." <> attr)) getAttrString :: MonadIO m => Text -> Text -> ExceptT Text m Text -getAttrString attr = srcOrMain (nixEvalApplyRaw ("p: p."<> attr)) +getAttrString attr = srcOrMain (nixEvalApplyRaw ("p: p." <> attr)) getHash :: MonadIO m => Text -> ExceptT Text m Text getHash = getAttrString "drvAttrs.outputHash" @@ -178,8 +179,9 @@ getHomepage :: MonadIO m => Text -> ExceptT Text m Text getHomepage = nixEvalApplyRaw "p: p.meta.homepage or \"\"" getSrcUrl :: MonadIO m => Text -> ExceptT Text m Text -getSrcUrl = srcOrMain - (nixEvalApplyRaw "p: builtins.elemAt p.drvAttrs.urls 0") +getSrcUrl = + srcOrMain + (nixEvalApplyRaw "p: builtins.elemAt p.drvAttrs.urls 0") buildCmd :: Text -> ProcessConfig () () () buildCmd attrPath = @@ -245,10 +247,9 @@ resultLink = fakeHashMatching :: Text -> Text fakeHashMatching oldHash = - if "sha512-" `T.isPrefixOf` oldHash then - "sha512-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==" - else - "sha256-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=" + if "sha512-" `T.isPrefixOf` oldHash + then "sha512-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==" + else "sha256-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=" -- fixed-output derivation produced path '/nix/store/fg2hz90z5bc773gpsx4gfxn3l6fl66nw-source' with sha256 hash '0q1lsgc1621czrg49nmabq6am9sgxa9syxrwzlksqqr4dyzw4nmf' instead of the expected hash '0bp22mzkjy48gncj5vm9b7whzrggcbs5pd4cnb6k8jpl9j02dhdv' getHashFromBuild :: MonadIO m => Text -> ExceptT Text m Text @@ -287,17 +288,19 @@ hasPatchNamed attrPath name = do return $ name `T.isInfixOf` ps hasUpdateScript :: MonadIO m => Text -> ExceptT Text m Bool -hasUpdateScript attrPath= do +hasUpdateScript attrPath = do nixEvalApply - "p: builtins.hasAttr \"updateScript\" p" attrPath + "p: builtins.hasAttr \"updateScript\" p" + attrPath & readNixBool runUpdateScript :: MonadIO m => Text -> ExceptT Text m (ExitCode, Text) runUpdateScript attrPath = do let timeout = "10m" :: Text - (exitCode, output) <- ourReadProcessInterleaved $ - TP.setStdin (TP.byteStringInput "\n") $ - proc "timeout" [T.unpack timeout, "nix-shell", "maintainers/scripts/update.nix", "--argstr", "package", T.unpack attrPath ] + (exitCode, output) <- + ourReadProcessInterleaved $ + TP.setStdin (TP.byteStringInput "\n") $ + proc "timeout" [T.unpack timeout, "nix-shell", "maintainers/scripts/update.nix", "--argstr", "package", T.unpack attrPath] case exitCode of ExitFailure 124 -> do return (exitCode, "updateScript for " <> attrPath <> " took longer than " <> timeout <> " and timed out. Other output: " <> output) diff --git a/src/NixpkgsReview.hs b/src/NixpkgsReview.hs index 9d770c68..34f914d7 100644 --- a/src/NixpkgsReview.hs +++ b/src/NixpkgsReview.hs @@ -33,20 +33,22 @@ run :: FilePath -> Text -> Sem r Text -run cache commit = let timeout = "45m" :: Text in do - -- TODO: probably just skip running nixpkgs-review if the directory - -- already exists - void $ - ourReadProcessInterleavedSem $ - proc "rm" ["-rf", revDir cache commit] - (exitCode, _nixpkgsReviewOutput) <- - ourReadProcessInterleavedSem $ - proc "timeout" [T.unpack timeout, (binPath <> "/nixpkgs-review"), "rev", T.unpack commit, "--no-shell"] - case exitCode of - ExitFailure 124 -> do - output $ "[check][nixpkgs-review] took longer than " <> timeout <> " and timed out" - return $ "nixpkgs-review took longer than " <> timeout <> " and timed out" - _ -> F.read $ (revDir cache commit) <> "/report.md" +run cache commit = + let timeout = "45m" :: Text + in do + -- TODO: probably just skip running nixpkgs-review if the directory + -- already exists + void $ + ourReadProcessInterleavedSem $ + proc "rm" ["-rf", revDir cache commit] + (exitCode, _nixpkgsReviewOutput) <- + ourReadProcessInterleavedSem $ + proc "timeout" [T.unpack timeout, (binPath <> "/nixpkgs-review"), "rev", T.unpack commit, "--no-shell"] + case exitCode of + ExitFailure 124 -> do + output $ "[check][nixpkgs-review] took longer than " <> timeout <> " and timed out" + return $ "nixpkgs-review took longer than " <> timeout <> " and timed out" + _ -> F.read $ (revDir cache commit) <> "/report.md" -- Assumes we are already in nixpkgs dir runReport :: (Text -> IO ()) -> Text -> IO Text diff --git a/src/OurPrelude.hs b/src/OurPrelude.hs index 76402def..552c2931 100644 --- a/src/OurPrelude.hs +++ b/src/OurPrelude.hs @@ -34,7 +34,6 @@ module OurPrelude ) where -import System.FilePath (()) import Control.Applicative ((<|>)) import Control.Category ((>>>)) import Control.Error @@ -57,6 +56,7 @@ import Polysemy import Polysemy.Error hiding (note, try, tryJust) import qualified Process as P import System.Exit +import System.FilePath (()) import System.Process.Typed interpolate :: QuasiQuoter @@ -82,16 +82,16 @@ ourReadProcessInterleavedBS_ = readProcessInterleaved_ >>> tryIOTextET ourReadProcess_ :: MonadIO m => - ProcessConfig stdin stdout stderr -> + ProcessConfig stdin stdout stderr -> ExceptT Text m (Text, Text) -ourReadProcess_ = readProcess_ >>> tryIOTextET >>> fmapRT (\(stdout,stderr) -> (bytestringToText stdout, bytestringToText stderr)) +ourReadProcess_ = readProcess_ >>> tryIOTextET >>> fmapRT (\(stdout, stderr) -> (bytestringToText stdout, bytestringToText stderr)) ourReadProcess_Sem :: Members '[P.Process] r => ProcessConfig stdin stdoutIgnored stderrIgnored -> Sem r (Text, Text) ourReadProcess_Sem = - P.read_ >>> fmap (\(stdout,stderr) -> (bytestringToText stdout, bytestringToText stderr)) + P.read_ >>> fmap (\(stdout, stderr) -> (bytestringToText stdout, bytestringToText stderr)) ourReadProcessInterleaved_ :: MonadIO m => diff --git a/src/Outpaths.hs b/src/Outpaths.hs index defd9bb4..aedb15ba 100644 --- a/src/Outpaths.hs +++ b/src/Outpaths.hs @@ -17,14 +17,14 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Vector as V -import qualified System.Posix.Files as F import qualified Git -import qualified Utils -import qualified System.Directory import OurPrelude +import qualified System.Directory +import qualified System.Posix.Files as F import Text.Parsec (parse) import Text.Parser.Char import Text.Parser.Combinators +import qualified Utils outPathsExpr :: Text outPathsExpr = @@ -94,14 +94,23 @@ outPath = do liftIO $ T.writeFile outpathFile outPathsExpr liftIO $ putStrLn "[outpaths] eval start" currentDir <- liftIO $ System.Directory.getCurrentDirectory - result <- ourReadProcessInterleaved_ $ proc "nix-env" [ - "-f", outpathFile, - "-qaP", - "--no-name", - "--out-path", - "--arg", "path", currentDir, - "--arg", "checkMeta", "true", - "--show-trace"] + result <- + ourReadProcessInterleaved_ $ + proc + "nix-env" + [ "-f", + outpathFile, + "-qaP", + "--no-name", + "--out-path", + "--arg", + "path", + currentDir, + "--arg", + "checkMeta", + "true", + "--show-trace" + ] liftIO $ putStrLn "[outpaths] eval end" pure result @@ -163,7 +172,8 @@ parseResults = S.fromList <$> parseResultLine `sepEndBy` newline parseResultLine :: CharParsing m => m ResultLine parseResultLine = - ResultLine <$> (T.dropWhileEnd (== '.') <$> parseAttrpath) + ResultLine + <$> (T.dropWhileEnd (== '.') <$> parseAttrpath) <*> parseArchitecture <* spaces <*> parseOutpaths @@ -182,7 +192,8 @@ parseOutpaths = V.fromList <$> (parseOutpath `sepBy1` char ';') parseOutpath :: CharParsing m => m Outpath parseOutpath = - Outpath <$> optional (try (T.pack <$> (many (noneOf "=\n") <* char '='))) + Outpath + <$> optional (try (T.pack <$> (many (noneOf "=\n") <* char '='))) <*> (T.pack <$> many (noneOf ";\n")) packageRebuilds :: Set ResultLine -> Vector Text diff --git a/src/Repology.hs b/src/Repology.hs index 6cc513d5..4fbb505e 100644 --- a/src/Repology.hs +++ b/src/Repology.hs @@ -16,7 +16,7 @@ import GHC.Generics import Network.HTTP.Client.TLS (newTlsManager) import OurPrelude import Servant.API -import Servant.Client (BaseUrl (..), mkClientEnv, ClientM, Scheme (..), client, runClientM) +import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM) import System.IO baseUrl :: BaseUrl @@ -35,9 +35,9 @@ type Project = Vector Package type Projects = HashMap Text Project type API = - "project" :> Capture "project_name" Text :> Get '[JSON] Project :<|> - "projects" :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects :<|> - "projects" :> Capture "name" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects + "project" :> Capture "project_name" Text :> Get '[JSON] Project + :<|> "projects" :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects + :<|> "projects" :> Capture "name" Text :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects data Package = Package { repo :: Text, @@ -56,12 +56,10 @@ api :: Proxy API api = Proxy project :: Text -> ClientM (Vector Package) - projects :: Maybe Text -> Maybe Bool -> ClientM Projects - projects' :: Text -> Maybe Text -> diff --git a/src/Rewrite.hs b/src/Rewrite.hs index 92a40351..4704e87e 100644 --- a/src/Rewrite.hs +++ b/src/Rewrite.hs @@ -22,7 +22,7 @@ import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types.Status (statusCode) import qualified Nix import OurPrelude -import System.Exit() +import System.Exit () import Utils (UpdateEnv (..)) import Prelude hiding (log) @@ -61,7 +61,7 @@ plan = ("golangModuleVersion", golangModuleVersion), ("npmDepsVersion", npmDepsVersion), ("updateScript", updateScript) - --("redirectedUrl", Rewrite.redirectedUrls) + -- ("redirectedUrl", Rewrite.redirectedUrls) ] runAll :: (Text -> IO ()) -> Args -> ExceptT Text IO [Text] @@ -81,15 +81,15 @@ version :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text) version log args@Args {..} = do if | Nix.numberOfFetchers derivationContents > 1 || Nix.numberOfHashes derivationContents > 1 -> do - lift $ log "generic version rewriter does not support multiple hashes" - return Nothing + lift $ log "generic version rewriter does not support multiple hashes" + return Nothing | hasUpdateScript -> do - lift $ log "skipping because derivation has updateScript" - return Nothing + lift $ log "skipping because derivation has updateScript" + return Nothing | otherwise -> do - srcVersionFix args - lift $ log "updated version and sha256" - return $ Just "Version update" + srcVersionFix args + lift $ log "updated version and sha256" + return $ Just "Version update" -------------------------------------------------------------------------------- -- Redirect homepage when moved. @@ -130,28 +130,28 @@ redirectedUrls log Args {..} = do rustCrateVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text) rustCrateVersion log args@Args {..} = do if - | and [(not (T.isInfixOf "cargoSha256" derivationContents)),(not (T.isInfixOf "cargoHash" derivationContents))] -> do - lift $ log "No cargoSha256 or cargoHash found" - return Nothing + | and [(not (T.isInfixOf "cargoSha256" derivationContents)), (not (T.isInfixOf "cargoHash" derivationContents))] -> do + lift $ log "No cargoSha256 or cargoHash found" + return Nothing | hasUpdateScript -> do - lift $ log "skipping because derivation has updateScript" - return Nothing + lift $ log "skipping because derivation has updateScript" + return Nothing | otherwise -> do - _ <- lift $ File.replaceIO "cargoSha256 =" "cargoHash =" derivationFile - -- This starts the same way `version` does, minus the assert - srcVersionFix args - -- But then from there we need to do this a second time for the cargoHash! - oldCargoHash <- Nix.getAttrString "cargoHash" attrPath - let fakeHash = Nix.fakeHashMatching oldCargoHash - _ <- lift $ File.replaceIO oldCargoHash fakeHash derivationFile - newCargoHash <- Nix.getHashFromBuild attrPath - when (oldCargoHash == newCargoHash) $ throwE ("cargo hashes equal; no update necessary: " <> oldCargoHash) - lift . log $ "Replacing cargoHash with " <> newCargoHash - _ <- lift $ File.replaceIO fakeHash newCargoHash derivationFile - -- Ensure the package actually builds and passes its tests - Nix.build attrPath - lift $ log "Finished updating Crate version and replacing hashes" - return $ Just "Rust version update" + _ <- lift $ File.replaceIO "cargoSha256 =" "cargoHash =" derivationFile + -- This starts the same way `version` does, minus the assert + srcVersionFix args + -- But then from there we need to do this a second time for the cargoHash! + oldCargoHash <- Nix.getAttrString "cargoHash" attrPath + let fakeHash = Nix.fakeHashMatching oldCargoHash + _ <- lift $ File.replaceIO oldCargoHash fakeHash derivationFile + newCargoHash <- Nix.getHashFromBuild attrPath + when (oldCargoHash == newCargoHash) $ throwE ("cargo hashes equal; no update necessary: " <> oldCargoHash) + lift . log $ "Replacing cargoHash with " <> newCargoHash + _ <- lift $ File.replaceIO fakeHash newCargoHash derivationFile + -- Ensure the package actually builds and passes its tests + Nix.build attrPath + lift $ log "Finished updating Crate version and replacing hashes" + return $ Just "Rust version update" -------------------------------------------------------------------------------- -- Rewrite Golang packages with buildGoModule @@ -161,38 +161,38 @@ golangModuleVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Ma golangModuleVersion log args@Args {..} = do if | and [not (T.isInfixOf "buildGoModule" derivationContents && T.isInfixOf "vendorSha256" derivationContents), not (T.isInfixOf "buildGoModule" derivationContents && T.isInfixOf "vendorHash" derivationContents)] -> do - lift $ log "Not a buildGoModule package with vendorSha256 or vendorHash" - return Nothing + lift $ log "Not a buildGoModule package with vendorSha256 or vendorHash" + return Nothing | hasUpdateScript -> do - lift $ log "skipping because derivation has updateScript" - return Nothing + lift $ log "skipping because derivation has updateScript" + return Nothing | otherwise -> do - _ <- lift $ File.replaceIO "vendorSha256 =" "vendorHash =" derivationFile - -- This starts the same way `version` does, minus the assert - srcVersionFix args - -- But then from there we need to do this a second time for the vendorHash! - -- Note that explicit `null` cannot be coerced to a string by nix eval --raw - oldVendorHash <- Nix.getAttr "vendorHash" attrPath - lift . log $ "Found old vendorHash = " <> oldVendorHash - original <- liftIO $ T.readFile derivationFile - _ <- lift $ File.replaceIO oldVendorHash "null" derivationFile - ok <- runExceptT $ Nix.build attrPath - _ <- - if isLeft ok - then do - _ <- liftIO $ T.writeFile derivationFile original - let fakeHash = Nix.fakeHashMatching oldVendorHash - _ <- lift $ File.replaceIO oldVendorHash ("\"" <> fakeHash <> "\"") derivationFile - newVendorHash <- Nix.getHashFromBuild attrPath - _ <- lift $ File.replaceIO fakeHash newVendorHash derivationFile - -- Note that on some small bumps, this may not actually change if go.sum did not - lift . log $ "Replaced vendorHash with " <> newVendorHash - else do - lift . log $ "Set vendorHash to null" - -- Ensure the package actually builds and passes its tests - Nix.build attrPath - lift $ log "Finished updating vendorHash" - return $ Just "Golang update" + _ <- lift $ File.replaceIO "vendorSha256 =" "vendorHash =" derivationFile + -- This starts the same way `version` does, minus the assert + srcVersionFix args + -- But then from there we need to do this a second time for the vendorHash! + -- Note that explicit `null` cannot be coerced to a string by nix eval --raw + oldVendorHash <- Nix.getAttr "vendorHash" attrPath + lift . log $ "Found old vendorHash = " <> oldVendorHash + original <- liftIO $ T.readFile derivationFile + _ <- lift $ File.replaceIO oldVendorHash "null" derivationFile + ok <- runExceptT $ Nix.build attrPath + _ <- + if isLeft ok + then do + _ <- liftIO $ T.writeFile derivationFile original + let fakeHash = Nix.fakeHashMatching oldVendorHash + _ <- lift $ File.replaceIO oldVendorHash ("\"" <> fakeHash <> "\"") derivationFile + newVendorHash <- Nix.getHashFromBuild attrPath + _ <- lift $ File.replaceIO fakeHash newVendorHash derivationFile + -- Note that on some small bumps, this may not actually change if go.sum did not + lift . log $ "Replaced vendorHash with " <> newVendorHash + else do + lift . log $ "Set vendorHash to null" + -- Ensure the package actually builds and passes its tests + Nix.build attrPath + lift $ log "Finished updating vendorHash" + return $ Just "Golang update" -------------------------------------------------------------------------------- -- Rewrite NPM packages with buildNpmPackage @@ -202,26 +202,26 @@ npmDepsVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe T npmDepsVersion log args@Args {..} = do if | not (T.isInfixOf "npmDepsHash" derivationContents) -> do - lift $ log "No npmDepsHash" - return Nothing + lift $ log "No npmDepsHash" + return Nothing | hasUpdateScript -> do - lift $ log "skipping because derivation has updateScript" - return Nothing + lift $ log "skipping because derivation has updateScript" + return Nothing | otherwise -> do - -- This starts the same way `version` does, minus the assert - srcVersionFix args - -- But then from there we need to do this a second time for the cargoHash! - oldDepsHash <- Nix.getAttrString "npmDepsHash" attrPath - let fakeHash = Nix.fakeHashMatching oldDepsHash - _ <- lift $ File.replaceIO oldDepsHash fakeHash derivationFile - newDepsHash <- Nix.getHashFromBuild attrPath - when (oldDepsHash == newDepsHash) $ throwE ("deps hashes equal; no update necessary: " <> oldDepsHash) - lift . log $ "Replacing npmDepsHash with " <> newDepsHash - _ <- lift $ File.replaceIO fakeHash newDepsHash derivationFile - -- Ensure the package actually builds and passes its tests - Nix.build attrPath - lift $ log "Finished updating NPM deps version and replacing hashes" - return $ Just "NPM version update" + -- This starts the same way `version` does, minus the assert + srcVersionFix args + -- But then from there we need to do this a second time for the cargoHash! + oldDepsHash <- Nix.getAttrString "npmDepsHash" attrPath + let fakeHash = Nix.fakeHashMatching oldDepsHash + _ <- lift $ File.replaceIO oldDepsHash fakeHash derivationFile + newDepsHash <- Nix.getHashFromBuild attrPath + when (oldDepsHash == newDepsHash) $ throwE ("deps hashes equal; no update necessary: " <> oldDepsHash) + lift . log $ "Replacing npmDepsHash with " <> newDepsHash + _ <- lift $ File.replaceIO fakeHash newDepsHash derivationFile + -- Ensure the package actually builds and passes its tests + Nix.build attrPath + lift $ log "Finished updating NPM deps version and replacing hashes" + return $ Just "NPM version update" -------------------------------------------------------------------------------- @@ -241,6 +241,7 @@ updateScript log Args {..} = do else do lift $ log "skipping because derivation has no updateScript" return Nothing + -------------------------------------------------------------------------------- -- Common helper functions and utilities -- Helper to update version and src attributes, re-computing the sha256. diff --git a/src/Skiplist.hs b/src/Skiplist.hs index 05d1b6d8..ef92425c 100644 --- a/src/Skiplist.hs +++ b/src/Skiplist.hs @@ -184,9 +184,9 @@ checkResultList = skipOutpathCalcList :: Skiplist skipOutpathCalcList = - [ eq "firefox-beta-bin-unwrapped" "master" - , eq "firefox-devedition-bin-unwrapped" "master" - -- "firefox-release-bin-unwrapped" is unneeded here because firefox-bin is a dependency of other packages that Hydra doesn't ignore. + [ eq "firefox-beta-bin-unwrapped" "master", + eq "firefox-devedition-bin-unwrapped" "master" + -- "firefox-release-bin-unwrapped" is unneeded here because firefox-bin is a dependency of other packages that Hydra doesn't ignore. ] binariesStickAround :: Text -> (Text -> Bool, Text) diff --git a/src/Update.hs b/src/Update.hs index 5fe94474..dc161693 100644 --- a/src/Update.hs +++ b/src/Update.hs @@ -25,12 +25,12 @@ import Control.Exception (bracket) import Control.Monad.Writer (execWriterT, tell) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe (fromJust) -import Data.Monoid (Alt(..)) +import Data.Monoid (Alt (..)) import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Time.Calendar (showGregorian) -import Data.Time.Clock (getCurrentTime, utctDay, addUTCTime, UTCTime) +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, utctDay) import qualified GH import qualified Git import Language.Haskell.TH.Env (envQ) @@ -41,6 +41,8 @@ import OurPrelude import qualified Outpaths import qualified Rewrite import qualified Skiplist +import System.Directory (doesDirectoryExist, withCurrentDirectory) +import System.Posix.Directory (createDirectory) import Utils ( Boundary (..), Options (..), @@ -55,12 +57,10 @@ import Utils import qualified Utils as U import qualified Version import Prelude hiding (log) -import System.Directory (doesDirectoryExist, withCurrentDirectory) -import System.Posix.Directory (createDirectory) default (T.Text) -alsoLogToAttrPath :: Text -> (Text -> IO()) -> IO (Text -> IO()) +alsoLogToAttrPath :: Text -> (Text -> IO ()) -> IO (Text -> IO ()) alsoLogToAttrPath attrPath topLevelLog = do logFile <- attrPathLogFilePath attrPath let attrPathLog = log' logFile @@ -181,9 +181,10 @@ updatePackageBatch simpleLog updateInfoLine updateEnv@UpdateEnv {..} = do Right foundAttrPath -> do log <- alsoLogToAttrPath foundAttrPath simpleLog log updateInfoLine - mergeBase <- if batchUpdate options - then Git.mergeBase - else pure "HEAD" + mergeBase <- + if batchUpdate options + then Git.mergeBase + else pure "HEAD" withWorktree mergeBase foundAttrPath updateEnv $ updateAttrPath log mergeBase updateEnv foundAttrPath @@ -198,12 +199,14 @@ checkExistingUpdate log updateEnv existingCommitMsg attrPath = do Nothing -> lift $ log "No auto update branch exists" Just msg -> do let nV = newVersion updateEnv - lift $ log - [interpolate|An auto update branch exists with message `$msg`. New version is $nV.|] + lift $ + log + [interpolate|An auto update branch exists with message `$msg`. New version is $nV.|] case U.titleVersion msg of - Just branchV | Version.matchVersion (RangeMatcher (Including nV) Unbounded) branchV -> - throwError "An auto update branch exists with an equal or greater version" + Just branchV + | Version.matchVersion (RangeMatcher (Including nV) Unbounded) branchV -> + throwError "An auto update branch exists with an equal or greater version" _ -> lift $ log "The auto update branch does not match or exceed the new version." @@ -329,7 +332,7 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do when hasUpdateScript do changedFiles <- Git.diffFileNames mergeBase - let rewrittenFile = case changedFiles of { [f] -> f; _ -> derivationFile } + let rewrittenFile = case changedFiles of [f] -> f; _ -> derivationFile assertNotUpdatedOn updateEnv' rewrittenFile "master" assertNotUpdatedOn updateEnv' rewrittenFile "staging" assertNotUpdatedOn updateEnv' rewrittenFile "staging-next" @@ -350,16 +353,18 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do -- -- Publish the result lift . log $ "Successfully finished processing" - result <- Nix.resultLink + result <- Nix.resultLink let opReport = if isJust skipOutpathBase - then "Outpath calculations were skipped for this package; total number of rebuilds unknown." - else Outpaths.outpathReport opDiff + then "Outpath calculations were skipped for this package; total number of rebuilds unknown." + else Outpaths.outpathReport opDiff let prBase = - flip fromMaybe skipOutpathBase + flip + fromMaybe + skipOutpathBase if Outpaths.numPackageRebuilds opDiff <= 500 - then "master" - else "staging" + then "master" + else "staging" publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs (isJust existingCommitMsg) case successOrFailure of @@ -437,10 +442,12 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase let ghUser = GH.untagName . githubUser . options $ updateEnv let mkPR = if branchExists then GH.prUpdate else GH.pr (reusedPR, pullRequestUrl) <- mkPR updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase - when branchExists $ liftIO $ log - if reusedPR - then "Updated existing PR" - else "Reused existing auto update branch, but no corresponding open PR was found, so created a new PR" + when branchExists $ + liftIO $ + log + if reusedPR + then "Updated existing PR" + else "Reused existing auto update branch, but no corresponding open PR was found, so created a new PR" liftIO $ log pullRequestUrl else liftIO $ T.putStrLn prMsg @@ -611,7 +618,8 @@ untilOfBorgFree log waitUntil = do stats <- shell "curl -s https://events.ofborg.org/stats.php" & readProcessInterleaved_ waiting <- - shell (jqBin <> " .evaluator.messages.waiting") & setStdin (byteStringInput stats) + shell (jqBin <> " .evaluator.messages.waiting") + & setStdin (byteStringInput stats) & readProcessInterleaved_ & fmap (BSL.readInt >>> fmap fst >>> fromMaybe 0) when (waiting > 2) $ do @@ -695,13 +703,12 @@ cveReport updateEnv = doCachix :: MonadIO m => (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text doCachix log updateEnv resultPath = let o = options updateEnv - in - if batchUpdate o && "r-ryantm" == (GH.untagName $ githubUser o) - then do - lift $ log ("cachix " <> (T.pack . show) resultPath) - Nix.cachix resultPath - return - [interpolate| + in if batchUpdate o && "r-ryantm" == (GH.untagName $ githubUser o) + then do + lift $ log ("cachix " <> (T.pack . show) resultPath) + Nix.cachix resultPath + return + [interpolate| Either **download from Cachix**: ``` nix-store -r $resultPath \ @@ -716,9 +723,9 @@ doCachix log updateEnv resultPath = Or, **build yourself**: |] - else do - lift $ log "skipping cachix" - return "Build yourself:" + else do + lift $ log "skipping cachix" + return "Build yourself:" updatePackage :: Options -> @@ -737,18 +744,19 @@ updatePackage o updateInfo = do UpdatePackageSuccess -> do log $ "[result] Success updating " <> updateInfoLine - withWorktree :: Text -> Text -> UpdateEnv -> IO a -> IO a withWorktree branch attrpath updateEnv action = do bracket - (do + ( do dir <- U.worktreeDir let path = dir <> "/" <> T.unpack (T.replace ".lock" "_lock" attrpath) Git.worktreeRemove path Git.delete1 (branchName updateEnv) Git.worktreeAdd path branch updateEnv - pure path) - (\ path -> do + pure path + ) + ( \path -> do Git.worktreeRemove path - Git.delete1 (branchName updateEnv)) - (\ path -> withCurrentDirectory path action) + Git.delete1 (branchName updateEnv) + ) + (\path -> withCurrentDirectory path action) diff --git a/src/Utils.hs b/src/Utils.hs index 24cd4344..efa43f7b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -27,7 +27,7 @@ module Utils regDirMode, outpathCacheDir, cacheDir, - worktreeDir + worktreeDir, ) where @@ -48,10 +48,10 @@ import Database.SQLite.Simple.ToField (ToField, toField) import qualified GitHub as GH import OurPrelude import Polysemy.Output -import System.Directory (doesDirectoryExist, createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import System.Environment (lookupEnv) import System.Posix.Directory (createDirectory) import System.Posix.Env (getEnv) -import System.Environment (lookupEnv) import System.Posix.Files ( directoryMode, fileExist, @@ -141,7 +141,10 @@ titleVersion title = if T.null prefix then Nothing else Just suffix regDirMode :: FileMode regDirMode = - directoryMode .|. ownerModes .|. groupModes .|. otherReadMode + directoryMode + .|. ownerModes + .|. groupModes + .|. otherReadMode .|. otherExecuteMode logsDirectory :: MonadIO m => ExceptT Text m FilePath @@ -149,7 +152,7 @@ logsDirectory = do dir <- noteT "Could not get environment variable LOGS_DIRECTORY" $ MaybeT $ - liftIO $ + liftIO $ getEnv "LOGS_DIRECTORY" dirExists <- liftIO $ doesDirectoryExist dir tryAssert ("LOGS_DIRECTORY " <> T.pack dir <> " does not exist.") dirExists @@ -163,8 +166,8 @@ logsDirectory = do cacheDir :: MonadIO m => m FilePath cacheDir = do cacheDirectory <- liftIO $ lookupEnv "CACHE_DIRECTORY" - xdgCacheHome <- liftIO $ fmap (fmap (\ dir -> dir "nixpkgs-update")) $ lookupEnv "XDG_CACHE_HOME" - cacheHome <- liftIO $ fmap (fmap (\ dir -> dir ".cache/nixpkgs-update")) $ lookupEnv "HOME" + xdgCacheHome <- liftIO $ fmap (fmap (\dir -> dir "nixpkgs-update")) $ lookupEnv "XDG_CACHE_HOME" + cacheHome <- liftIO $ fmap (fmap (\dir -> dir ".cache/nixpkgs-update")) $ lookupEnv "HOME" let dir = fromJust (cacheDirectory <|> xdgCacheHome <|> cacheHome) liftIO $ createDirectoryIfMissing True dir return dir @@ -214,7 +217,9 @@ logDir :: IO FilePath logDir = do r <- runExceptT - ( logsDirectory <|> xdgRuntimeDir <|> tmpRuntimeDir + ( logsDirectory + <|> xdgRuntimeDir + <|> tmpRuntimeDir <|> throwE "Failed to create log directory." ) diff --git a/src/Version.hs b/src/Version.hs index 9732538b..4c087b22 100644 --- a/src/Version.hs +++ b/src/Version.hs @@ -8,8 +8,8 @@ module Version ) where -import Data.Foldable (toList) import Data.Char (isAlpha, isDigit) +import Data.Foldable (toList) import Data.Function (on) import qualified Data.PartialOrd as PO import qualified Data.Text as T @@ -62,30 +62,30 @@ clearBreakOn boundary string = versionCompatibleWithPathPin :: Text -> Version -> Bool versionCompatibleWithPathPin attrPath newVer | "-unwrapped" `T.isSuffixOf` attrPath = - versionCompatibleWithPathPin (T.dropEnd 10 attrPath) newVer + versionCompatibleWithPathPin (T.dropEnd 10 attrPath) newVer | "_x" `T.isSuffixOf` T.toLower attrPath = - versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer + versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer | "_" `T.isInfixOf` attrPath = - let attrVersionPart = - let (_, version) = clearBreakOn "_" attrPath - in if T.any (notElemOf ('_' : ['0' .. '9'])) version - then Nothing - else Just version - -- Check assuming version part has underscore separators - attrVersionPeriods = T.replace "_" "." <$> attrVersionPart - in -- If we don't find version numbers in the attr path, exit success. - maybe True (`T.isPrefixOf` newVer) attrVersionPeriods + let attrVersionPart = + let (_, version) = clearBreakOn "_" attrPath + in if T.any (notElemOf ('_' : ['0' .. '9'])) version + then Nothing + else Just version + -- Check assuming version part has underscore separators + attrVersionPeriods = T.replace "_" "." <$> attrVersionPart + in -- If we don't find version numbers in the attr path, exit success. + maybe True (`T.isPrefixOf` newVer) attrVersionPeriods | otherwise = - let attrVersionPart = - let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath - in if T.any (notElemOf ['0' .. '9']) version - then Nothing - else Just version - -- Check assuming version part is the prefix of the version with dots - -- removed. For example, 91 => "9.1" - noPeriodNewVersion = T.replace "." "" newVer - in -- If we don't find version numbers in the attr path, exit success. - maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart + let attrVersionPart = + let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath + in if T.any (notElemOf ['0' .. '9']) version + then Nothing + else Just version + -- Check assuming version part is the prefix of the version with dots + -- removed. For example, 91 => "9.1" + noPeriodNewVersion = T.replace "." "" newVer + in -- If we don't find version numbers in the attr path, exit success. + maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart versionIncompatibleWithPathPin :: Text -> Version -> Bool versionIncompatibleWithPathPin path version = diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index c7b69ad9..05f4ed71 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -1,8 +1,8 @@ module CheckSpec where +import qualified Check import qualified Data.Text as T import Test.Hspec -import qualified Check main :: IO () main = hspec spec