ryantm/nixpkgs-update
1
1
Fork 0
mirror of https://github.com/ryantm/nixpkgs-update.git synced 2024-08-16 01:00:34 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #406 from qowoz/treefmt

Browse Source 
add treefmt
This commit is contained in:
zowoq 2024-04-28 12:01:12 +10:00 committed by GitHub
commit 0572aa48da
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
19 changed files with 390 additions and 309 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
app/Main.hs
View File

@ -71,9 +71,9 @@ deleteDoneParser =
commandParser :: O.Parser Command commandParser :: O.Parser Command
commandParser = commandParser =
O.hsubparser O.hsubparser
(O.command ( O.command
"update" "update"
(O.info (updateParser) (O.progDesc "Update one package")) (O.info (updateParser) (O.progDesc "Update one package"))
<> O.command <> O.command
"update-batch" "update-batch"
(O.info (updateBatchParser) (O.progDesc "Update one package in batch mode.")) (O.info (updateBatchParser) (O.progDesc "Update one package in batch mode."))
@ -116,7 +116,8 @@ commandParser =
checkVulnerable :: O.Parser Command checkVulnerable :: O.Parser Command
checkVulnerable = 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 "OLD_VERSION")
<*> O.strArgument (O.metavar "NEW_VERSION") <*> O.strArgument (O.metavar "NEW_VERSION")

23
flake.lock
View File

@ -54,7 +54,28 @@
"root": { "root": {
"inputs": { "inputs": {
"mmdoc": "mmdoc", "mmdoc": "mmdoc",
"nixpkgs": "nixpkgs" "nixpkgs": "nixpkgs",
"treefmt-nix": "treefmt-nix"
}
},
"treefmt-nix": {
"inputs": {
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1711963903,
"narHash": "sha256-N3QDhoaX+paWXHbEXZapqd1r95mdshxToGowtjtYkGI=",
"owner": "numtide",
"repo": "treefmt-nix",
"rev": "49dc4a92b02b8e68798abd99184f228243b6e3ac",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "treefmt-nix",
"type": "github"
} }
} }
}, },

19
flake.nix
View File

@ -4,17 +4,32 @@
inputs.mmdoc.url = "github:ryantm/mmdoc"; inputs.mmdoc.url = "github:ryantm/mmdoc";
inputs.mmdoc.inputs.nixpkgs.follows = "nixpkgs"; inputs.mmdoc.inputs.nixpkgs.follows = "nixpkgs";
inputs.treefmt-nix.url = "github:numtide/treefmt-nix";
inputs.treefmt-nix.inputs.nixpkgs.follows = "nixpkgs";
nixConfig.extra-substituters = "https://nix-community.cachix.org"; nixConfig.extra-substituters = "https://nix-community.cachix.org";
nixConfig.extra-trusted-public-keys = "nix-community.cachix.org-1:mB9FSh9qf2dCimDSUo8Zy7bkq5CX+/rkCWyvRCYg3Fs="; nixConfig.extra-trusted-public-keys = "nix-community.cachix.org-1:mB9FSh9qf2dCimDSUo8Zy7bkq5CX+/rkCWyvRCYg3Fs=";
outputs = { self, nixpkgs, mmdoc } @ args: outputs = { self, nixpkgs, mmdoc, treefmt-nix } @ args:
let
systems = [ "x86_64-linux" "aarch64-linux" "x86_64-darwin" "aarch64-darwin" ];
eachSystem = f: nixpkgs.lib.genAttrs systems (system: f nixpkgs.legacyPackages.${system});
treefmtEval = eachSystem (pkgs: treefmt-nix.lib.evalModule pkgs {
projectRootFile = ".git/config";
programs.ormolu.enable = true;
});
in
{ {
checks.x86_64-linux = checks.x86_64-linux =
let let
packages = nixpkgs.lib.mapAttrs' (n: nixpkgs.lib.nameValuePair "package-${n}") self.packages.x86_64-linux; packages = nixpkgs.lib.mapAttrs' (n: nixpkgs.lib.nameValuePair "package-${n}") self.packages.x86_64-linux;
devShells = nixpkgs.lib.mapAttrs' (n: nixpkgs.lib.nameValuePair "devShell-${n}") self.devShells.x86_64-linux; devShells = nixpkgs.lib.mapAttrs' (n: nixpkgs.lib.nameValuePair "devShell-${n}") self.devShells.x86_64-linux;
in in
packages // devShells; packages // devShells // {
treefmt = treefmtEval.x86_64-linux.config.build.check self;
};
formatter = eachSystem (pkgs: treefmtEval.${pkgs.system}.config.build.wrapper);
packages.x86_64-linux = import ./pkgs/default.nix (args // { system = "x86_64-linux"; }); packages.x86_64-linux = import ./pkgs/default.nix (args // { system = "x86_64-linux"; });
devShells.x86_64-linux.default = self.packages."x86_64-linux".devShell; devShells.x86_64-linux.default = self.packages."x86_64-linux".devShell;

2
src/CVE.hs
View File

@ -16,6 +16,7 @@ where
import Data.Aeson import Data.Aeson
( FromJSON, ( FromJSON,
Key,
Object, Object,
eitherDecode, eitherDecode,
parseJSON, parseJSON,
@ -23,7 +24,6 @@ import Data.Aeson
(.!=), (.!=),
(.:), (.:),
(.:!), (.:!),
Key,
) )
import Data.Aeson.Types (Parser, prependFailure) import Data.Aeson.Types (Parser, prependFailure)
import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.ByteString.Lazy.Char8 as BSL

62
src/Check.hs
View File

@ -8,7 +8,7 @@ module Check
( result, ( result,
-- exposed for testing: -- exposed for testing:
hasVersion, hasVersion,
versionWithoutPath versionWithoutPath,
) )
where where
@ -19,7 +19,7 @@ import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Language.Haskell.TH.Env (envQ) import Language.Haskell.TH.Env (envQ)
import OurPrelude import OurPrelude
import System.Exit() import System.Exit ()
import Text.Regex.Applicative.Text (RE', (=~)) import Text.Regex.Applicative.Text (RE', (=~))
import qualified Text.Regex.Applicative.Text as RE import qualified Text.Regex.Applicative.Text as RE
import Utils (UpdateEnv (..), nixBuildOptions) import Utils (UpdateEnv (..), nixBuildOptions)
@ -50,11 +50,11 @@ isNonWordCharacter c = not (isWordCharacter c)
-- | Construct regex: /.*\b${version}\b.*/s -- | Construct regex: /.*\b${version}\b.*/s
versionRegex :: Text -> RE' () versionRegex :: Text -> RE' ()
versionRegex version = versionRegex version =
(\_ -> ()) <$> ( (\_ -> ())
(((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure "")) <$> ( (((many RE.anySym) <* (RE.psym isNonWordCharacter)) <|> (RE.pure ""))
*> (RE.string version) <* *> (RE.string version)
((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym))) <* ((RE.pure "") <|> ((RE.psym isNonWordCharacter) *> (many RE.anySym)))
) )
hasVersion :: Text -> Text -> Bool hasVersion :: Text -> Text -> Bool
hasVersion contents expectedVersion = hasVersion contents expectedVersion =
@ -63,10 +63,9 @@ hasVersion contents expectedVersion =
checkTestsBuild :: Text -> IO Bool checkTestsBuild :: Text -> IO Bool
checkTestsBuild attrPath = do checkTestsBuild attrPath = do
let timeout = "10m" let timeout = "10m"
let let args =
args = [T.unpack timeout, "nix-build"]
[ T.unpack timeout, "nix-build" ] ++ ++ nixBuildOptions
nixBuildOptions
++ [ "-E", ++ [ "-E",
"{ config }: (import ./. { inherit config; })." "{ config }: (import ./. { inherit config; })."
++ (T.unpack attrPath) ++ (T.unpack attrPath)
@ -99,19 +98,19 @@ versionWithoutPath resultPath expectedVersion =
-- This can be done with negative lookbehind e.g -- This can be done with negative lookbehind e.g
-- /^(?<!${storePathWithoutVersion})${version}/ -- /^(?<!${storePathWithoutVersion})${version}/
-- Note we also escape the version with \Q/\E for grep -P -- Note we also escape the version with \Q/\E for grep -P
let storePath = fromMaybe (T.pack resultPath) $ T.stripPrefix "/nix/store/" (T.pack resultPath) in let storePath = fromMaybe (T.pack resultPath) $ T.stripPrefix "/nix/store/" (T.pack resultPath)
case T.breakOn expectedVersion storePath of in case T.breakOn expectedVersion storePath of
(_, "") -> (_, "") ->
-- no version in prefix, just match version -- no version in prefix, just match version
"\\Q" "\\Q"
<> T.unpack expectedVersion <> T.unpack expectedVersion
<> "\\E" <> "\\E"
(storePrefix, _) -> (storePrefix, _) ->
"(?<!\\Q" "(?<!\\Q"
<> T.unpack storePrefix <> T.unpack storePrefix
<> "\\E)\\Q" <> "\\E)\\Q"
<> T.unpack expectedVersion <> T.unpack expectedVersion
<> "\\E" <> "\\E"
foundVersionInOutputs :: Text -> String -> IO (Maybe Text) foundVersionInOutputs :: Text -> String -> IO (Maybe Text)
foundVersionInOutputs expectedVersion resultPath = foundVersionInOutputs expectedVersion resultPath =
@ -140,7 +139,8 @@ foundVersionInFileNames expectedVersion resultPath =
( do ( do
(_, contents) <- (_, contents) <-
shell ("find " <> resultPath) & ourReadProcessInterleaved shell ("find " <> resultPath) & ourReadProcessInterleaved
(contents =~ versionRegex expectedVersion) & hoistMaybe (contents =~ versionRegex expectedVersion)
& hoistMaybe
& noteT (T.pack "Expected version not found") & noteT (T.pack "Expected version not found")
return $ return $
"- found " "- found "
@ -157,7 +157,8 @@ treeGist resultPath =
( do ( do
contents <- procTree [resultPath] & ourReadProcessInterleavedBS_ contents <- procTree [resultPath] & ourReadProcessInterleavedBS_
g <- g <-
shell gistBin & setStdin (byteStringInput contents) shell gistBin
& setStdin (byteStringInput contents)
& ourReadProcessInterleaved_ & ourReadProcessInterleaved_
return $ "- directory tree listing: " <> g <> "\n" return $ "- directory tree listing: " <> g <> "\n"
) )
@ -169,7 +170,8 @@ duGist resultPath =
( do ( do
contents <- proc "du" [resultPath] & ourReadProcessInterleavedBS_ contents <- proc "du" [resultPath] & ourReadProcessInterleavedBS_
g <- g <-
shell gistBin & setStdin (byteStringInput contents) shell gistBin
& setStdin (byteStringInput contents)
& ourReadProcessInterleaved_ & ourReadProcessInterleaved_
return $ "- du listing: " <> g <> "\n" return $ "- du listing: " <> g <> "\n"
) )
@ -182,9 +184,9 @@ result updateEnv resultPath =
someReports <- someReports <-
fromMaybe "" fromMaybe ""
<$> foundVersionInOutputs expectedVersion resultPath <$> foundVersionInOutputs expectedVersion resultPath
<> foundVersionInFileNames expectedVersion resultPath <> foundVersionInFileNames expectedVersion resultPath
<> treeGist resultPath <> treeGist resultPath
<> duGist resultPath <> duGist resultPath
return $ return $
let testsBuildSummary = checkTestsBuildReport testsBuild let testsBuildSummary = checkTestsBuildReport testsBuild
in [interpolate| in [interpolate|

62
src/GH.hs
View File

@ -23,7 +23,7 @@ import Data.Aeson (FromJSON)
import Data.Bitraversable (bitraverse) import Data.Bitraversable (bitraverse)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding 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 Data.Vector as V
import qualified Git import qualified Git
import qualified GitHub as GH import qualified GitHub as GH
@ -54,23 +54,25 @@ pr env title body prHead base = do
tryPR `catchE` \case tryPR `catchE` \case
-- If creating the PR returns a 422, most likely cause is that the -- If creating the PR returns a 422, most likely cause is that the
-- branch was deleted, so push it again and retry once. -- branch was deleted, so push it again and retry once.
GH.HTTPError (HttpExceptionRequest _ (StatusCodeException r _)) | statusCode (responseStatus r) == 422 -> GH.HTTPError (HttpExceptionRequest _ (StatusCodeException r _))
Git.push env >> withExceptT (T.pack . show) tryPR | statusCode (responseStatus r) == 422 ->
Git.push env >> withExceptT (T.pack . show) tryPR
e -> e ->
throwE . T.pack . show $ e throwE . T.pack . show $ e
where where
tryPR = ExceptT $ tryPR =
fmap ((False, ) . GH.getUrl . GH.pullRequestUrl) ExceptT $
<$> ( liftIO $ fmap ((False,) . GH.getUrl . GH.pullRequestUrl)
( GH.github <$> ( liftIO $
(authFrom env) ( GH.github
( GH.createPullRequestR (authFrom env)
(N "nixos") ( GH.createPullRequestR
(N "nixpkgs") (N "nixos")
(GH.CreatePullRequest title body prHead base) (N "nixpkgs")
(GH.CreatePullRequest title body prHead base)
)
) )
) )
)
prUpdate :: forall m. MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m (Bool, Text) prUpdate :: forall m. MonadIO m => UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m (Bool, Text)
prUpdate env title body prHead base = do 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) runRequest = ExceptT . fmap (first (T.pack . show)) . liftIO . GH.github (authFrom env)
let inNixpkgs f = f (N "nixos") (N "nixpkgs") let inNixpkgs f = f (N "nixos") (N "nixpkgs")
prs <- runRequest $ prs <-
inNixpkgs GH.pullRequestsForR (GH.optionsHead prHead) GH.FetchAll runRequest $
inNixpkgs GH.pullRequestsForR (GH.optionsHead prHead) GH.FetchAll
case V.toList prs of case V.toList prs of
[] -> pr env title body prHead base [] -> pr env title body prHead base
(_ : _ : _) -> throwE $ "Too many open PRs from " <> prHead
(_:_:_) -> throwE $ "Too many open PRs from " <> prHead
[thePR] -> do [thePR] -> do
let withExistingPR :: (GH.Name GH.Owner -> GH.Name GH.Repo -> GH.IssueNumber -> a) -> a let withExistingPR :: (GH.Name GH.Owner -> GH.Name GH.Repo -> GH.IssueNumber -> a) -> a
withExistingPR f = inNixpkgs f (GH.simplePullRequestNumber thePR) withExistingPR f = inNixpkgs f (GH.simplePullRequestNumber thePR)
_ <- runRequest $ _ <-
withExistingPR GH.updatePullRequestR $ runRequest $
GH.EditPullRequest (Just title) Nothing Nothing Nothing Nothing 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) return (True, GH.getUrl $ GH.simplePullRequestUrl thePR)
@ -129,12 +132,18 @@ parseURLMaybe url =
extension = RE.string ".zip" <|> RE.string ".tar.gz" extension = RE.string ".zip" <|> RE.string ".tar.gz"
toParts n o = URLParts (N n) (N o) toParts n o = URLParts (N n) (N o)
regex = regex =
( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment ( toParts
<$> (domain *> pathSegment)
<* slash
<*> pathSegment
<*> (RE.string "/releases/download/" *> pathSegment) <*> (RE.string "/releases/download/" *> pathSegment)
<* slash <* slash
<* pathSegment <* pathSegment
) )
<|> ( toParts <$> (domain *> pathSegment) <* slash <*> pathSegment <|> ( toParts
<$> (domain *> pathSegment)
<* slash
<*> pathSegment
<*> (RE.string "/archive/" *> pathSegment) <*> (RE.string "/archive/" *> pathSegment)
<* extension <* 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 :: GH.Auth -> GH.Name GH.Owner -> (Text, GH.Name GH.GitCommit) -> IO Bool
refShouldBeDeleted auth ghUser (ref, sha) = refShouldBeDeleted auth ghUser (ref, sha) =
liftA2 (&&) liftA2
(&&)
(either (const False) not <$> openPRWithAutoUpdateRefFrom auth ghUser ref) (either (const False) not <$> openPRWithAutoUpdateRefFrom auth ghUser ref)
(commitIsOldEnoughToDelete auth ghUser sha) (commitIsOldEnoughToDelete auth ghUser sha)

36
src/Git.hs
View File

@ -18,7 +18,7 @@ module Git
setupNixpkgs, setupNixpkgs,
Git.show, Git.show,
worktreeAdd, worktreeAdd,
worktreeRemove worktreeRemove,
) )
where where
@ -33,9 +33,9 @@ import Data.Time.Clock (addUTCTime, getCurrentTime)
import qualified Data.Vector as V import qualified Data.Vector as V
import Language.Haskell.TH.Env (envQ) import Language.Haskell.TH.Env (envQ)
import OurPrelude hiding (throw) 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.Environment.XDG.BaseDir (getUserCacheDir)
import System.Exit() import System.Exit ()
import System.IO.Error (tryIOError) import System.IO.Error (tryIOError)
import System.Posix.Env (setEnv) import System.Posix.Env (setEnv)
import Utils (Options (..), UpdateEnv (..), branchName, branchPrefix) import Utils (Options (..), UpdateEnv (..), branchName, branchPrefix)
@ -57,8 +57,8 @@ worktreeRemove :: FilePath -> IO ()
worktreeRemove path = do worktreeRemove path = do
exist <- doesDirectoryExist path exist <- doesDirectoryExist path
if exist if exist
then runProcessNoIndexIssue_IO $ silently $ procGit ["worktree", "remove", "--force", path] then runProcessNoIndexIssue_IO $ silently $ procGit ["worktree", "remove", "--force", path]
else return () else return ()
checkout :: Text -> Text -> ProcessConfig () () () checkout :: Text -> Text -> ProcessConfig () () ()
checkout branch target = checkout branch target =
@ -98,8 +98,9 @@ diff :: MonadIO m => Text -> ExceptT Text m Text
diff branch = readProcessInterleavedNoIndexIssue_ $ procGit ["diff", T.unpack branch] diff branch = readProcessInterleavedNoIndexIssue_ $ procGit ["diff", T.unpack branch]
diffFileNames :: MonadIO m => Text -> ExceptT Text m [Text] diffFileNames :: MonadIO m => Text -> ExceptT Text m [Text]
diffFileNames branch = readProcessInterleavedNoIndexIssue_ (procGit ["diff", T.unpack branch, "--name-only"]) diffFileNames branch =
& fmapRT T.lines readProcessInterleavedNoIndexIssue_ (procGit ["diff", T.unpack branch, "--name-only"])
& fmapRT T.lines
staleFetchHead :: MonadIO m => m Bool staleFetchHead :: MonadIO m => m Bool
staleFetchHead = staleFetchHead =
@ -121,7 +122,8 @@ fetchIfStale = whenM staleFetchHead fetch
fetch :: MonadIO m => ExceptT Text m () fetch :: MonadIO m => ExceptT Text m ()
fetch = fetch =
runProcessNoIndexIssue_ $ 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 :: MonadIO m => UpdateEnv -> ExceptT Text m ()
push updateEnv = push updateEnv =
@ -210,7 +212,6 @@ deleteBranchesEverywhere branches = do
Left error2 -> T.putStrLn $ tshow error2 Left error2 -> T.putStrLn $ tshow error2
Right success2 -> T.putStrLn $ tshow success2 Right success2 -> T.putStrLn $ tshow success2
runProcessNoIndexIssue_IO :: runProcessNoIndexIssue_IO ::
ProcessConfig () () () -> IO () ProcessConfig () () () -> IO ()
runProcessNoIndexIssue_IO config = go runProcessNoIndexIssue_IO config = go
@ -220,8 +221,8 @@ runProcessNoIndexIssue_IO config = go
case code of case code of
ExitFailure 128 ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict e -> do | "index.lock" `BS.isInfixOf` BSL.toStrict e -> do
threadDelay 100000 threadDelay 100000
go go
ExitSuccess -> return () ExitSuccess -> return ()
ExitFailure _ -> throw $ ExitCodeException code config out e ExitFailure _ -> throw $ ExitCodeException code config out e
@ -234,8 +235,8 @@ runProcessNoIndexIssue_ config = tryIOTextET go
case code of case code of
ExitFailure 128 ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict e -> do | "index.lock" `BS.isInfixOf` BSL.toStrict e -> do
threadDelay 100000 threadDelay 100000
go go
ExitSuccess -> return () ExitSuccess -> return ()
ExitFailure _ -> throw $ ExitCodeException code config out e ExitFailure _ -> throw $ ExitCodeException code config out e
@ -248,12 +249,11 @@ readProcessInterleavedNoIndexIssue_ config = tryIOTextET go
case code of case code of
ExitFailure 128 ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict out -> do | "index.lock" `BS.isInfixOf` BSL.toStrict out -> do
threadDelay 100000 threadDelay 100000
go go
ExitSuccess -> return $ bytestringToText out ExitSuccess -> return $ bytestringToText out
ExitFailure _ -> throw $ ExitCodeException code config out out ExitFailure _ -> throw $ ExitCodeException code config out out
readProcessInterleavedNoIndexIssue_IO :: readProcessInterleavedNoIndexIssue_IO ::
ProcessConfig () () () -> IO Text ProcessConfig () () () -> IO Text
readProcessInterleavedNoIndexIssue_IO config = go readProcessInterleavedNoIndexIssue_IO config = go
@ -263,7 +263,7 @@ readProcessInterleavedNoIndexIssue_IO config = go
case code of case code of
ExitFailure 128 ExitFailure 128
| "index.lock" `BS.isInfixOf` BSL.toStrict out -> do | "index.lock" `BS.isInfixOf` BSL.toStrict out -> do
threadDelay 100000 threadDelay 100000
go go
ExitSuccess -> return $ bytestringToText out ExitSuccess -> return $ bytestringToText out
ExitFailure _ -> throw $ ExitCodeException code config out out ExitFailure _ -> throw $ ExitCodeException code config out out

20
src/NVDRules.hs
View File

@ -15,15 +15,19 @@ filter _ cpeMatch "socat" v
| cpeUpdatePresentAndNotPartOfVersion cpeMatch v = False -- TODO consider if this rule should be applied to all packages | cpeUpdatePresentAndNotPartOfVersion cpeMatch v = False -- TODO consider if this rule should be applied to all packages
filter _ cpeMatch "uzbl" v filter _ cpeMatch "uzbl" v
| isNothing (v =~ yearRegex) | isNothing (v =~ yearRegex)
&& "2009.12.22" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = && "2009.12.22"
False `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =
False
| isNothing (v =~ yearRegex) | isNothing (v =~ yearRegex)
&& "2010.04.03" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = && "2010.04.03"
False `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =
False
filter _ cpeMatch "go" v filter _ cpeMatch "go" v
| "." `T.isInfixOf` v | "."
&& "-" `anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch = `T.isInfixOf` v
False && "-"
`anyVersionInfixOf` cpeMatchVersionMatcher cpeMatch =
False
filter _ cpeMatch "terraform" _ filter _ cpeMatch "terraform" _
| cpeTargetSoftware (cpeMatchCPE cpeMatch) == Just "aws" = False | cpeTargetSoftware (cpeMatchCPE cpeMatch) == Just "aws" = False
filter cve _ "tor" _ filter cve _ "tor" _
@ -31,7 +35,7 @@ filter cve _ "tor" _
filter _ cpeMatch "arena" _ filter _ cpeMatch "arena" _
| cpeVendor (cpeMatchCPE cpeMatch) == Just "rockwellautomation" | cpeVendor (cpeMatchCPE cpeMatch) == Just "rockwellautomation"
|| cpeVendor (cpeMatchCPE cpeMatch) == Just "openforis" = || cpeVendor (cpeMatchCPE cpeMatch) == Just "openforis" =
False False
filter _ cpeMatch "thrift" _ filter _ cpeMatch "thrift" _
| cpeVendor (cpeMatchCPE cpeMatch) == Just "facebook" = False | cpeVendor (cpeMatchCPE cpeMatch) == Just "facebook" = False
filter _ cpeMatch "kanboard" _ filter _ cpeMatch "kanboard" _

65
src/Nix.hs
View File

@ -40,8 +40,8 @@ import qualified Data.Text.Lazy.Encoding as TL
import qualified Git import qualified Git
import Language.Haskell.TH.Env (envQ) import Language.Haskell.TH.Env (envQ)
import OurPrelude import OurPrelude
import System.Exit ()
import qualified System.Process.Typed as TP import qualified System.Process.Typed as TP
import System.Exit()
import Utils (UpdateEnv (..), nixBuildOptions, nixCommonOptions, srcOrMain) import Utils (UpdateEnv (..), nixBuildOptions, nixCommonOptions, srcOrMain)
import Prelude hiding (log) import Prelude hiding (log)
@ -82,7 +82,7 @@ nixEvalApplyRaw applyFunc attrPath =
nixEvalExpr :: nixEvalExpr ::
MonadIO m => MonadIO m =>
Text -> Text ->
ExceptT Text m Text ExceptT Text m Text
nixEvalExpr expr = nixEvalExpr expr =
ourReadProcess_ ourReadProcess_
@ -116,22 +116,23 @@ assertNewerVersion updateEnv = do
lookupAttrPath :: MonadIO m => UpdateEnv -> ExceptT Text m Text lookupAttrPath :: MonadIO m => UpdateEnv -> ExceptT Text m Text
lookupAttrPath updateEnv = lookupAttrPath updateEnv =
-- lookup attrpath by nix-env -- lookup attrpath by nix-env
(proc ( proc
(binPath <> "/nix-env") (binPath <> "/nix-env")
( [ "-qa", ( [ "-qa",
(packageName updateEnv <> "-" <> oldVersion updateEnv) & T.unpack, (packageName updateEnv <> "-" <> oldVersion updateEnv) & T.unpack,
"-f", "-f",
".", ".",
"--attr-path" "--attr-path"
] ]
<> nixCommonOptions <> nixCommonOptions
) )
& ourReadProcess_ & ourReadProcess_
& fmapRT (fst >>> T.lines >>> head >>> T.words >>> head)) & fmapRT (fst >>> T.lines >>> head >>> T.words >>> head)
<|> )
-- if that fails, check by attrpath <|>
(getAttrString "name" (packageName updateEnv)) -- if that fails, check by attrpath
& fmapRT (const (packageName updateEnv)) (getAttrString "name" (packageName updateEnv))
& fmapRT (const (packageName updateEnv))
getDerivationFile :: MonadIO m => Text -> ExceptT Text m Text getDerivationFile :: MonadIO m => Text -> ExceptT Text m Text
getDerivationFile attrPath = do getDerivationFile attrPath = do
@ -143,10 +144,10 @@ getDerivationFile attrPath = do
-- Get an attribute that can be evaluated off a derivation, as in: -- Get an attribute that can be evaluated off a derivation, as in:
-- getAttr "cargoSha256" "ripgrep" -> 0lwz661rbm7kwkd6mallxym1pz8ynda5f03ynjfd16vrazy2dj21 -- getAttr "cargoSha256" "ripgrep" -> 0lwz661rbm7kwkd6mallxym1pz8ynda5f03ynjfd16vrazy2dj21
getAttr :: MonadIO m => Text -> Text -> ExceptT Text m Text 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 :: 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 :: MonadIO m => Text -> ExceptT Text m Text
getHash = getAttrString "drvAttrs.outputHash" getHash = getAttrString "drvAttrs.outputHash"
@ -178,8 +179,9 @@ getHomepage :: MonadIO m => Text -> ExceptT Text m Text
getHomepage = nixEvalApplyRaw "p: p.meta.homepage or \"\"" getHomepage = nixEvalApplyRaw "p: p.meta.homepage or \"\""
getSrcUrl :: MonadIO m => Text -> ExceptT Text m Text getSrcUrl :: MonadIO m => Text -> ExceptT Text m Text
getSrcUrl = srcOrMain getSrcUrl =
(nixEvalApplyRaw "p: builtins.elemAt p.drvAttrs.urls 0") srcOrMain
(nixEvalApplyRaw "p: builtins.elemAt p.drvAttrs.urls 0")
buildCmd :: Text -> ProcessConfig () () () buildCmd :: Text -> ProcessConfig () () ()
buildCmd attrPath = buildCmd attrPath =
@ -245,10 +247,9 @@ resultLink =
fakeHashMatching :: Text -> Text fakeHashMatching :: Text -> Text
fakeHashMatching oldHash = fakeHashMatching oldHash =
if "sha512-" `T.isPrefixOf` oldHash then if "sha512-" `T.isPrefixOf` oldHash
"sha512-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==" then "sha512-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA=="
else else "sha256-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="
"sha256-AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="
-- fixed-output derivation produced path '/nix/store/fg2hz90z5bc773gpsx4gfxn3l6fl66nw-source' with sha256 hash '0q1lsgc1621czrg49nmabq6am9sgxa9syxrwzlksqqr4dyzw4nmf' instead of the expected hash '0bp22mzkjy48gncj5vm9b7whzrggcbs5pd4cnb6k8jpl9j02dhdv' -- 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 getHashFromBuild :: MonadIO m => Text -> ExceptT Text m Text
@ -287,17 +288,19 @@ hasPatchNamed attrPath name = do
return $ name `T.isInfixOf` ps return $ name `T.isInfixOf` ps
hasUpdateScript :: MonadIO m => Text -> ExceptT Text m Bool hasUpdateScript :: MonadIO m => Text -> ExceptT Text m Bool
hasUpdateScript attrPath= do hasUpdateScript attrPath = do
nixEvalApply nixEvalApply
"p: builtins.hasAttr \"updateScript\" p" attrPath "p: builtins.hasAttr \"updateScript\" p"
attrPath
& readNixBool & readNixBool
runUpdateScript :: MonadIO m => Text -> ExceptT Text m (ExitCode, Text) runUpdateScript :: MonadIO m => Text -> ExceptT Text m (ExitCode, Text)
runUpdateScript attrPath = do runUpdateScript attrPath = do
let timeout = "10m" :: Text let timeout = "10m" :: Text
(exitCode, output) <- ourReadProcessInterleaved $ (exitCode, output) <-
TP.setStdin (TP.byteStringInput "\n") $ ourReadProcessInterleaved $
proc "timeout" [T.unpack timeout, "nix-shell", "maintainers/scripts/update.nix", "--argstr", "package", T.unpack attrPath ] TP.setStdin (TP.byteStringInput "\n") $
proc "timeout" [T.unpack timeout, "nix-shell", "maintainers/scripts/update.nix", "--argstr", "package", T.unpack attrPath]
case exitCode of case exitCode of
ExitFailure 124 -> do ExitFailure 124 -> do
return (exitCode, "updateScript for " <> attrPath <> " took longer than " <> timeout <> " and timed out. Other output: " <> output) return (exitCode, "updateScript for " <> attrPath <> " took longer than " <> timeout <> " and timed out. Other output: " <> output)

30
src/NixpkgsReview.hs
View File

@ -33,20 +33,22 @@ run ::
FilePath -> FilePath ->
Text -> Text ->
Sem r Text Sem r Text
run cache commit = let timeout = "45m" :: Text in do run cache commit =
-- TODO: probably just skip running nixpkgs-review if the directory let timeout = "45m" :: Text
-- already exists in do
void $ -- TODO: probably just skip running nixpkgs-review if the directory
ourReadProcessInterleavedSem $ -- already exists
proc "rm" ["-rf", revDir cache commit] void $
(exitCode, _nixpkgsReviewOutput) <- ourReadProcessInterleavedSem $
ourReadProcessInterleavedSem $ proc "rm" ["-rf", revDir cache commit]
proc "timeout" [T.unpack timeout, (binPath <> "/nixpkgs-review"), "rev", T.unpack commit, "--no-shell"] (exitCode, _nixpkgsReviewOutput) <-
case exitCode of ourReadProcessInterleavedSem $
ExitFailure 124 -> do proc "timeout" [T.unpack timeout, (binPath <> "/nixpkgs-review"), "rev", T.unpack commit, "--no-shell"]
output $ "[check][nixpkgs-review] took longer than " <> timeout <> " and timed out" case exitCode of
return $ "nixpkgs-review took longer than " <> timeout <> " and timed out" ExitFailure 124 -> do
_ -> F.read $ (revDir cache commit) <> "/report.md" 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 -- Assumes we are already in nixpkgs dir
runReport :: (Text -> IO ()) -> Text -> IO Text runReport :: (Text -> IO ()) -> Text -> IO Text

8
src/OurPrelude.hs
View File

@ -34,7 +34,6 @@ module OurPrelude
) )
where where
import System.FilePath ((</>))
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Category ((>>>)) import Control.Category ((>>>))
import Control.Error import Control.Error
@ -57,6 +56,7 @@ import Polysemy
import Polysemy.Error hiding (note, try, tryJust) import Polysemy.Error hiding (note, try, tryJust)
import qualified Process as P import qualified Process as P
import System.Exit import System.Exit
import System.FilePath ((</>))
import System.Process.Typed import System.Process.Typed
interpolate :: QuasiQuoter interpolate :: QuasiQuoter
@ -82,16 +82,16 @@ ourReadProcessInterleavedBS_ = readProcessInterleaved_ >>> tryIOTextET
ourReadProcess_ :: ourReadProcess_ ::
MonadIO m => MonadIO m =>
ProcessConfig stdin stdout stderr -> ProcessConfig stdin stdout stderr ->
ExceptT Text m (Text, Text) 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 :: ourReadProcess_Sem ::
Members '[P.Process] r => Members '[P.Process] r =>
ProcessConfig stdin stdoutIgnored stderrIgnored -> ProcessConfig stdin stdoutIgnored stderrIgnored ->
Sem r (Text, Text) Sem r (Text, Text)
ourReadProcess_Sem = ourReadProcess_Sem =
P.read_ >>> fmap (\(stdout,stderr) -> (bytestringToText stdout, bytestringToText stderr)) P.read_ >>> fmap (\(stdout, stderr) -> (bytestringToText stdout, bytestringToText stderr))
ourReadProcessInterleaved_ :: ourReadProcessInterleaved_ ::
MonadIO m => MonadIO m =>

37
src/Outpaths.hs
View File

@ -17,14 +17,14 @@ import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import qualified Data.Vector as V import qualified Data.Vector as V
import qualified System.Posix.Files as F
import qualified Git import qualified Git
import qualified Utils
import qualified System.Directory
import OurPrelude import OurPrelude
import qualified System.Directory
import qualified System.Posix.Files as F
import Text.Parsec (parse) import Text.Parsec (parse)
import Text.Parser.Char import Text.Parser.Char
import Text.Parser.Combinators import Text.Parser.Combinators
import qualified Utils
outPathsExpr :: Text outPathsExpr :: Text
outPathsExpr = outPathsExpr =
@ -94,14 +94,23 @@ outPath = do
liftIO $ T.writeFile outpathFile outPathsExpr liftIO $ T.writeFile outpathFile outPathsExpr
liftIO $ putStrLn "[outpaths] eval start" liftIO $ putStrLn "[outpaths] eval start"
currentDir <- liftIO $ System.Directory.getCurrentDirectory currentDir <- liftIO $ System.Directory.getCurrentDirectory
result <- ourReadProcessInterleaved_ $ proc "nix-env" [ result <-
"-f", outpathFile, ourReadProcessInterleaved_ $
"-qaP", proc
"--no-name", "nix-env"
"--out-path", [ "-f",
"--arg", "path", currentDir, outpathFile,
"--arg", "checkMeta", "true", "-qaP",
"--show-trace"] "--no-name",
"--out-path",
"--arg",
"path",
currentDir,
"--arg",
"checkMeta",
"true",
"--show-trace"
]
liftIO $ putStrLn "[outpaths] eval end" liftIO $ putStrLn "[outpaths] eval end"
pure result pure result
@ -163,7 +172,8 @@ parseResults = S.fromList <$> parseResultLine `sepEndBy` newline
parseResultLine :: CharParsing m => m ResultLine parseResultLine :: CharParsing m => m ResultLine
parseResultLine = parseResultLine =
ResultLine <$> (T.dropWhileEnd (== '.') <$> parseAttrpath) ResultLine
<$> (T.dropWhileEnd (== '.') <$> parseAttrpath)
<*> parseArchitecture <*> parseArchitecture
<* spaces <* spaces
<*> parseOutpaths <*> parseOutpaths
@ -182,7 +192,8 @@ parseOutpaths = V.fromList <$> (parseOutpath `sepBy1` char ';')
parseOutpath :: CharParsing m => m Outpath parseOutpath :: CharParsing m => m Outpath
parseOutpath = parseOutpath =
Outpath <$> optional (try (T.pack <$> (many (noneOf "=\n") <* char '='))) Outpath
<$> optional (try (T.pack <$> (many (noneOf "=\n") <* char '=')))
<*> (T.pack <$> many (noneOf ";\n")) <*> (T.pack <$> many (noneOf ";\n"))
packageRebuilds :: Set ResultLine -> Vector Text packageRebuilds :: Set ResultLine -> Vector Text

10
src/Repology.hs
View File

@ -16,7 +16,7 @@ import GHC.Generics
import Network.HTTP.Client.TLS (newTlsManager) import Network.HTTP.Client.TLS (newTlsManager)
import OurPrelude import OurPrelude
import Servant.API import Servant.API
import Servant.Client (BaseUrl (..), mkClientEnv, ClientM, Scheme (..), client, runClientM) import Servant.Client (BaseUrl (..), ClientM, Scheme (..), client, mkClientEnv, runClientM)
import System.IO import System.IO
baseUrl :: BaseUrl baseUrl :: BaseUrl
@ -35,9 +35,9 @@ type Project = Vector Package
type Projects = HashMap Text Project type Projects = HashMap Text Project
type API = type API =
"project" :> Capture "project_name" Text :> Get '[JSON] Project :<|> "project" :> Capture "project_name" Text :> Get '[JSON] Project
"projects" :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects :<|> :<|> "projects" :> QueryParam "inrepo" Text :> QueryParam "outdated" Bool :> Get '[JSON] Projects
"projects" :> Capture "name" Text :> 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 data Package = Package
{ repo :: Text, { repo :: Text,
@ -56,12 +56,10 @@ api :: Proxy API
api = Proxy api = Proxy
project :: Text -> ClientM (Vector Package) project :: Text -> ClientM (Vector Package)
projects :: projects ::
Maybe Text -> Maybe Text ->
Maybe Bool -> Maybe Bool ->
ClientM Projects ClientM Projects
projects' :: projects' ::
Text -> Text ->
Maybe Text -> Maybe Text ->

155
src/Rewrite.hs
View File

@ -22,7 +22,7 @@ import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Types.Status (statusCode) import Network.HTTP.Types.Status (statusCode)
import qualified Nix import qualified Nix
import OurPrelude import OurPrelude
import System.Exit() import System.Exit ()
import Utils (UpdateEnv (..)) import Utils (UpdateEnv (..))
import Prelude hiding (log) import Prelude hiding (log)
@ -61,7 +61,7 @@ plan =
("golangModuleVersion", golangModuleVersion), ("golangModuleVersion", golangModuleVersion),
("npmDepsVersion", npmDepsVersion), ("npmDepsVersion", npmDepsVersion),
("updateScript", updateScript) ("updateScript", updateScript)
--("redirectedUrl", Rewrite.redirectedUrls) -- ("redirectedUrl", Rewrite.redirectedUrls)
] ]
runAll :: (Text -> IO ()) -> Args -> ExceptT Text IO [Text] 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 version log args@Args {..} = do
if if
| Nix.numberOfFetchers derivationContents > 1 || Nix.numberOfHashes derivationContents > 1 -> do | Nix.numberOfFetchers derivationContents > 1 || Nix.numberOfHashes derivationContents > 1 -> do
lift $ log "generic version rewriter does not support multiple hashes" lift $ log "generic version rewriter does not support multiple hashes"
return Nothing return Nothing
| hasUpdateScript -> do | hasUpdateScript -> do
lift $ log "skipping because derivation has updateScript" lift $ log "skipping because derivation has updateScript"
return Nothing return Nothing
| otherwise -> do | otherwise -> do
srcVersionFix args srcVersionFix args
lift $ log "updated version and sha256" lift $ log "updated version and sha256"
return $ Just "Version update" return $ Just "Version update"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Redirect homepage when moved. -- Redirect homepage when moved.
@ -130,28 +130,28 @@ redirectedUrls log Args {..} = do
rustCrateVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text) rustCrateVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Maybe Text)
rustCrateVersion log args@Args {..} = do rustCrateVersion log args@Args {..} = do
if if
| and [(not (T.isInfixOf "cargoSha256" derivationContents)),(not (T.isInfixOf "cargoHash" derivationContents))] -> do | and [(not (T.isInfixOf "cargoSha256" derivationContents)), (not (T.isInfixOf "cargoHash" derivationContents))] -> do
lift $ log "No cargoSha256 or cargoHash found" lift $ log "No cargoSha256 or cargoHash found"
return Nothing return Nothing
| hasUpdateScript -> do | hasUpdateScript -> do
lift $ log "skipping because derivation has updateScript" lift $ log "skipping because derivation has updateScript"
return Nothing return Nothing
| otherwise -> do | otherwise -> do
_ <- lift $ File.replaceIO "cargoSha256 =" "cargoHash =" derivationFile _ <- lift $ File.replaceIO "cargoSha256 =" "cargoHash =" derivationFile
-- This starts the same way `version` does, minus the assert -- This starts the same way `version` does, minus the assert
srcVersionFix args srcVersionFix args
-- But then from there we need to do this a second time for the cargoHash! -- But then from there we need to do this a second time for the cargoHash!
oldCargoHash <- Nix.getAttrString "cargoHash" attrPath oldCargoHash <- Nix.getAttrString "cargoHash" attrPath
let fakeHash = Nix.fakeHashMatching oldCargoHash let fakeHash = Nix.fakeHashMatching oldCargoHash
_ <- lift $ File.replaceIO oldCargoHash fakeHash derivationFile _ <- lift $ File.replaceIO oldCargoHash fakeHash derivationFile
newCargoHash <- Nix.getHashFromBuild attrPath newCargoHash <- Nix.getHashFromBuild attrPath
when (oldCargoHash == newCargoHash) $ throwE ("cargo hashes equal; no update necessary: " <> oldCargoHash) when (oldCargoHash == newCargoHash) $ throwE ("cargo hashes equal; no update necessary: " <> oldCargoHash)
lift . log $ "Replacing cargoHash with " <> newCargoHash lift . log $ "Replacing cargoHash with " <> newCargoHash
_ <- lift $ File.replaceIO fakeHash newCargoHash derivationFile _ <- lift $ File.replaceIO fakeHash newCargoHash derivationFile
-- Ensure the package actually builds and passes its tests -- Ensure the package actually builds and passes its tests
Nix.build attrPath Nix.build attrPath
lift $ log "Finished updating Crate version and replacing hashes" lift $ log "Finished updating Crate version and replacing hashes"
return $ Just "Rust version update" return $ Just "Rust version update"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Rewrite Golang packages with buildGoModule -- Rewrite Golang packages with buildGoModule
@ -161,38 +161,38 @@ golangModuleVersion :: MonadIO m => (Text -> m ()) -> Args -> ExceptT Text m (Ma
golangModuleVersion log args@Args {..} = do golangModuleVersion log args@Args {..} = do
if if
| and [not (T.isInfixOf "buildGoModule" derivationContents && T.isInfixOf "vendorSha256" derivationContents), not (T.isInfixOf "buildGoModule" derivationContents && T.isInfixOf "vendorHash" derivationContents)] -> do | 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" lift $ log "Not a buildGoModule package with vendorSha256 or vendorHash"
return Nothing return Nothing
| hasUpdateScript -> do | hasUpdateScript -> do
lift $ log "skipping because derivation has updateScript" lift $ log "skipping because derivation has updateScript"
return Nothing return Nothing
| otherwise -> do | otherwise -> do
_ <- lift $ File.replaceIO "vendorSha256 =" "vendorHash =" derivationFile _ <- lift $ File.replaceIO "vendorSha256 =" "vendorHash =" derivationFile
-- This starts the same way `version` does, minus the assert -- This starts the same way `version` does, minus the assert
srcVersionFix args srcVersionFix args
-- But then from there we need to do this a second time for the vendorHash! -- 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 -- Note that explicit `null` cannot be coerced to a string by nix eval --raw
oldVendorHash <- Nix.getAttr "vendorHash" attrPath oldVendorHash <- Nix.getAttr "vendorHash" attrPath
lift . log $ "Found old vendorHash = " <> oldVendorHash lift . log $ "Found old vendorHash = " <> oldVendorHash
original <- liftIO $ T.readFile derivationFile original <- liftIO $ T.readFile derivationFile
_ <- lift $ File.replaceIO oldVendorHash "null" derivationFile _ <- lift $ File.replaceIO oldVendorHash "null" derivationFile
ok <- runExceptT $ Nix.build attrPath ok <- runExceptT $ Nix.build attrPath
_ <- _ <-
if isLeft ok if isLeft ok
then do then do
_ <- liftIO $ T.writeFile derivationFile original _ <- liftIO $ T.writeFile derivationFile original
let fakeHash = Nix.fakeHashMatching oldVendorHash let fakeHash = Nix.fakeHashMatching oldVendorHash
_ <- lift $ File.replaceIO oldVendorHash ("\"" <> fakeHash <> "\"") derivationFile _ <- lift $ File.replaceIO oldVendorHash ("\"" <> fakeHash <> "\"") derivationFile
newVendorHash <- Nix.getHashFromBuild attrPath newVendorHash <- Nix.getHashFromBuild attrPath
_ <- lift $ File.replaceIO fakeHash newVendorHash derivationFile _ <- lift $ File.replaceIO fakeHash newVendorHash derivationFile
-- Note that on some small bumps, this may not actually change if go.sum did not -- Note that on some small bumps, this may not actually change if go.sum did not
lift . log $ "Replaced vendorHash with " <> newVendorHash lift . log $ "Replaced vendorHash with " <> newVendorHash
else do else do
lift . log $ "Set vendorHash to null" lift . log $ "Set vendorHash to null"
-- Ensure the package actually builds and passes its tests -- Ensure the package actually builds and passes its tests
Nix.build attrPath Nix.build attrPath
lift $ log "Finished updating vendorHash" lift $ log "Finished updating vendorHash"
return $ Just "Golang update" return $ Just "Golang update"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Rewrite NPM packages with buildNpmPackage -- 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 npmDepsVersion log args@Args {..} = do
if if
| not (T.isInfixOf "npmDepsHash" derivationContents) -> do | not (T.isInfixOf "npmDepsHash" derivationContents) -> do
lift $ log "No npmDepsHash" lift $ log "No npmDepsHash"
return Nothing return Nothing
| hasUpdateScript -> do | hasUpdateScript -> do
lift $ log "skipping because derivation has updateScript" lift $ log "skipping because derivation has updateScript"
return Nothing return Nothing
| otherwise -> do | otherwise -> do
-- This starts the same way `version` does, minus the assert -- This starts the same way `version` does, minus the assert
srcVersionFix args srcVersionFix args
-- But then from there we need to do this a second time for the cargoHash! -- But then from there we need to do this a second time for the cargoHash!
oldDepsHash <- Nix.getAttrString "npmDepsHash" attrPath oldDepsHash <- Nix.getAttrString "npmDepsHash" attrPath
let fakeHash = Nix.fakeHashMatching oldDepsHash let fakeHash = Nix.fakeHashMatching oldDepsHash
_ <- lift $ File.replaceIO oldDepsHash fakeHash derivationFile _ <- lift $ File.replaceIO oldDepsHash fakeHash derivationFile
newDepsHash <- Nix.getHashFromBuild attrPath newDepsHash <- Nix.getHashFromBuild attrPath
when (oldDepsHash == newDepsHash) $ throwE ("deps hashes equal; no update necessary: " <> oldDepsHash) when (oldDepsHash == newDepsHash) $ throwE ("deps hashes equal; no update necessary: " <> oldDepsHash)
lift . log $ "Replacing npmDepsHash with " <> newDepsHash lift . log $ "Replacing npmDepsHash with " <> newDepsHash
_ <- lift $ File.replaceIO fakeHash newDepsHash derivationFile _ <- lift $ File.replaceIO fakeHash newDepsHash derivationFile
-- Ensure the package actually builds and passes its tests -- Ensure the package actually builds and passes its tests
Nix.build attrPath Nix.build attrPath
lift $ log "Finished updating NPM deps version and replacing hashes" lift $ log "Finished updating NPM deps version and replacing hashes"
return $ Just "NPM version update" return $ Just "NPM version update"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -241,6 +241,7 @@ updateScript log Args {..} = do
else do else do
lift $ log "skipping because derivation has no updateScript" lift $ log "skipping because derivation has no updateScript"
return Nothing return Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Common helper functions and utilities -- Common helper functions and utilities
-- Helper to update version and src attributes, re-computing the sha256. -- Helper to update version and src attributes, re-computing the sha256.

6
src/Skiplist.hs
View File

@ -197,9 +197,9 @@ checkResultList =
skipOutpathCalcList :: Skiplist skipOutpathCalcList :: Skiplist
skipOutpathCalcList = skipOutpathCalcList =
[ eq "firefox-beta-bin-unwrapped" "master" [ eq "firefox-beta-bin-unwrapped" "master",
, eq "firefox-devedition-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. -- "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) binariesStickAround :: Text -> (Text -> Bool, Text)

88
src/Update.hs
View File

@ -25,12 +25,12 @@ import Control.Exception (bracket)
import Control.Monad.Writer (execWriterT, tell) import Control.Monad.Writer (execWriterT, tell)
import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Monoid (Alt(..)) import Data.Monoid (Alt (..))
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Data.Time.Calendar (showGregorian) 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 GH
import qualified Git import qualified Git
import Language.Haskell.TH.Env (envQ) import Language.Haskell.TH.Env (envQ)
@ -41,6 +41,8 @@ import OurPrelude
import qualified Outpaths import qualified Outpaths
import qualified Rewrite import qualified Rewrite
import qualified Skiplist import qualified Skiplist
import System.Directory (doesDirectoryExist, withCurrentDirectory)
import System.Posix.Directory (createDirectory)
import Utils import Utils
( Boundary (..), ( Boundary (..),
Options (..), Options (..),
@ -55,12 +57,10 @@ import Utils
import qualified Utils as U import qualified Utils as U
import qualified Version import qualified Version
import Prelude hiding (log) import Prelude hiding (log)
import System.Directory (doesDirectoryExist, withCurrentDirectory)
import System.Posix.Directory (createDirectory)
default (T.Text) default (T.Text)
alsoLogToAttrPath :: Text -> (Text -> IO()) -> IO (Text -> IO()) alsoLogToAttrPath :: Text -> (Text -> IO ()) -> IO (Text -> IO ())
alsoLogToAttrPath attrPath topLevelLog = do alsoLogToAttrPath attrPath topLevelLog = do
logFile <- attrPathLogFilePath attrPath logFile <- attrPathLogFilePath attrPath
let attrPathLog = log' logFile let attrPathLog = log' logFile
@ -181,9 +181,10 @@ updatePackageBatch simpleLog updateInfoLine updateEnv@UpdateEnv {..} = do
Right foundAttrPath -> do Right foundAttrPath -> do
log <- alsoLogToAttrPath foundAttrPath simpleLog log <- alsoLogToAttrPath foundAttrPath simpleLog
log updateInfoLine log updateInfoLine
mergeBase <- if batchUpdate options mergeBase <-
then Git.mergeBase if batchUpdate options
else pure "HEAD" then Git.mergeBase
else pure "HEAD"
withWorktree mergeBase foundAttrPath updateEnv $ withWorktree mergeBase foundAttrPath updateEnv $
updateAttrPath log mergeBase updateEnv foundAttrPath updateAttrPath log mergeBase updateEnv foundAttrPath
@ -198,12 +199,14 @@ checkExistingUpdate log updateEnv existingCommitMsg attrPath = do
Nothing -> lift $ log "No auto update branch exists" Nothing -> lift $ log "No auto update branch exists"
Just msg -> do Just msg -> do
let nV = newVersion updateEnv let nV = newVersion updateEnv
lift $ log lift $
[interpolate|An auto update branch exists with message `$msg`. New version is $nV.|] log
[interpolate|An auto update branch exists with message `$msg`. New version is $nV.|]
case U.titleVersion msg of case U.titleVersion msg of
Just branchV | Version.matchVersion (RangeMatcher (Including nV) Unbounded) branchV -> Just branchV
throwError "An auto update branch exists with an equal or greater version" | 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." 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 when hasUpdateScript do
changedFiles <- Git.diffFileNames mergeBase 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 "master"
assertNotUpdatedOn updateEnv' rewrittenFile "staging" assertNotUpdatedOn updateEnv' rewrittenFile "staging"
assertNotUpdatedOn updateEnv' rewrittenFile "staging-next" assertNotUpdatedOn updateEnv' rewrittenFile "staging-next"
@ -350,16 +353,18 @@ updateAttrPath log mergeBase updateEnv@UpdateEnv {..} attrPath = do
-- --
-- Publish the result -- Publish the result
lift . log $ "Successfully finished processing" lift . log $ "Successfully finished processing"
result <- Nix.resultLink result <- Nix.resultLink
let opReport = let opReport =
if isJust skipOutpathBase if isJust skipOutpathBase
then "Outpath calculations were skipped for this package; total number of rebuilds unknown." then "Outpath calculations were skipped for this package; total number of rebuilds unknown."
else Outpaths.outpathReport opDiff else Outpaths.outpathReport opDiff
let prBase = let prBase =
flip fromMaybe skipOutpathBase flip
fromMaybe
skipOutpathBase
if Outpaths.numPackageRebuilds opDiff <= 500 if Outpaths.numPackageRebuilds opDiff <= 500
then "master" then "master"
else "staging" else "staging"
publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs (isJust existingCommitMsg) publishPackage log updateEnv' oldSrcUrl newSrcUrl attrPath result opReport prBase rewriteMsgs (isJust existingCommitMsg)
case successOrFailure of case successOrFailure of
@ -437,10 +442,12 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opReport prBase
let ghUser = GH.untagName . githubUser . options $ updateEnv let ghUser = GH.untagName . githubUser . options $ updateEnv
let mkPR = if branchExists then GH.prUpdate else GH.pr let mkPR = if branchExists then GH.prUpdate else GH.pr
(reusedPR, pullRequestUrl) <- mkPR updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase (reusedPR, pullRequestUrl) <- mkPR updateEnv (prTitle updateEnv attrPath) prMsg (ghUser <> ":" <> (branchName updateEnv)) prBase
when branchExists $ liftIO $ log when branchExists $
if reusedPR liftIO $
then "Updated existing PR" log
else "Reused existing auto update branch, but no corresponding open PR was found, so created a new PR" 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 liftIO $ log pullRequestUrl
else liftIO $ T.putStrLn prMsg else liftIO $ T.putStrLn prMsg
@ -611,7 +618,8 @@ untilOfBorgFree log waitUntil = do
stats <- stats <-
shell "curl -s https://events.ofborg.org/stats.php" & readProcessInterleaved_ shell "curl -s https://events.ofborg.org/stats.php" & readProcessInterleaved_
waiting <- waiting <-
shell (jqBin <> " .evaluator.messages.waiting") & setStdin (byteStringInput stats) shell (jqBin <> " .evaluator.messages.waiting")
& setStdin (byteStringInput stats)
& readProcessInterleaved_ & readProcessInterleaved_
& fmap (BSL.readInt >>> fmap fst >>> fromMaybe 0) & fmap (BSL.readInt >>> fmap fst >>> fromMaybe 0)
when (waiting > 2) $ do when (waiting > 2) $ do
@ -695,13 +703,12 @@ cveReport updateEnv =
doCachix :: MonadIO m => (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text doCachix :: MonadIO m => (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text
doCachix log updateEnv resultPath = doCachix log updateEnv resultPath =
let o = options updateEnv let o = options updateEnv
in in if batchUpdate o && "r-ryantm" == (GH.untagName $ githubUser o)
if batchUpdate o && "r-ryantm" == (GH.untagName $ githubUser o) then do
then do lift $ log ("cachix " <> (T.pack . show) resultPath)
lift $ log ("cachix " <> (T.pack . show) resultPath) Nix.cachix resultPath
Nix.cachix resultPath return
return [interpolate|
[interpolate|
Either **download from Cachix**: Either **download from Cachix**:
``` ```
nix-store -r $resultPath \ nix-store -r $resultPath \
@ -716,9 +723,9 @@ doCachix log updateEnv resultPath =
Or, **build yourself**: Or, **build yourself**:
|] |]
else do else do
lift $ log "skipping cachix" lift $ log "skipping cachix"
return "Build yourself:" return "Build yourself:"
updatePackage :: updatePackage ::
Options -> Options ->
@ -737,18 +744,19 @@ updatePackage o updateInfo = do
UpdatePackageSuccess -> do UpdatePackageSuccess -> do
log $ "[result] Success updating " <> updateInfoLine log $ "[result] Success updating " <> updateInfoLine
withWorktree :: Text -> Text -> UpdateEnv -> IO a -> IO a withWorktree :: Text -> Text -> UpdateEnv -> IO a -> IO a
withWorktree branch attrpath updateEnv action = do withWorktree branch attrpath updateEnv action = do
bracket bracket
(do ( do
dir <- U.worktreeDir dir <- U.worktreeDir
let path = dir <> "/" <> T.unpack (T.replace ".lock" "_lock" attrpath) let path = dir <> "/" <> T.unpack (T.replace ".lock" "_lock" attrpath)
Git.worktreeRemove path Git.worktreeRemove path
Git.delete1 (branchName updateEnv) Git.delete1 (branchName updateEnv)
Git.worktreeAdd path branch updateEnv Git.worktreeAdd path branch updateEnv
pure path) pure path
(\ path -> do )
( \path -> do
Git.worktreeRemove path Git.worktreeRemove path
Git.delete1 (branchName updateEnv)) Git.delete1 (branchName updateEnv)
(\ path -> withCurrentDirectory path action) )
(\path -> withCurrentDirectory path action)

21
src/Utils.hs
View File

@ -27,7 +27,7 @@ module Utils
regDirMode, regDirMode,
outpathCacheDir, outpathCacheDir,
cacheDir, cacheDir,
worktreeDir worktreeDir,
) )
where where
@ -48,10 +48,10 @@ import Database.SQLite.Simple.ToField (ToField, toField)
import qualified GitHub as GH import qualified GitHub as GH
import OurPrelude import OurPrelude
import Polysemy.Output 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.Directory (createDirectory)
import System.Posix.Env (getEnv) import System.Posix.Env (getEnv)
import System.Environment (lookupEnv)
import System.Posix.Files import System.Posix.Files
( directoryMode, ( directoryMode,
fileExist, fileExist,
@ -141,7 +141,10 @@ titleVersion title = if T.null prefix then Nothing else Just suffix
regDirMode :: FileMode regDirMode :: FileMode
regDirMode = regDirMode =
directoryMode .|. ownerModes .|. groupModes .|. otherReadMode directoryMode
.|. ownerModes
.|. groupModes
.|. otherReadMode
.|. otherExecuteMode .|. otherExecuteMode
logsDirectory :: MonadIO m => ExceptT Text m FilePath logsDirectory :: MonadIO m => ExceptT Text m FilePath
@ -149,7 +152,7 @@ logsDirectory = do
dir <- dir <-
noteT "Could not get environment variable LOGS_DIRECTORY" $ noteT "Could not get environment variable LOGS_DIRECTORY" $
MaybeT $ MaybeT $
liftIO $ liftIO $
getEnv "LOGS_DIRECTORY" getEnv "LOGS_DIRECTORY"
dirExists <- liftIO $ doesDirectoryExist dir dirExists <- liftIO $ doesDirectoryExist dir
tryAssert ("LOGS_DIRECTORY " <> T.pack dir <> " does not exist.") dirExists tryAssert ("LOGS_DIRECTORY " <> T.pack dir <> " does not exist.") dirExists
@ -163,8 +166,8 @@ logsDirectory = do
cacheDir :: MonadIO m => m FilePath cacheDir :: MonadIO m => m FilePath
cacheDir = do cacheDir = do
cacheDirectory <- liftIO $ lookupEnv "CACHE_DIRECTORY" cacheDirectory <- liftIO $ lookupEnv "CACHE_DIRECTORY"
xdgCacheHome <- liftIO $ fmap (fmap (\ dir -> dir </> "nixpkgs-update")) $ lookupEnv "XDG_CACHE_HOME" xdgCacheHome <- liftIO $ fmap (fmap (\dir -> dir </> "nixpkgs-update")) $ lookupEnv "XDG_CACHE_HOME"
cacheHome <- liftIO $ fmap (fmap (\ dir -> dir </> ".cache/nixpkgs-update")) $ lookupEnv "HOME" cacheHome <- liftIO $ fmap (fmap (\dir -> dir </> ".cache/nixpkgs-update")) $ lookupEnv "HOME"
let dir = fromJust (cacheDirectory <|> xdgCacheHome <|> cacheHome) let dir = fromJust (cacheDirectory <|> xdgCacheHome <|> cacheHome)
liftIO $ createDirectoryIfMissing True dir liftIO $ createDirectoryIfMissing True dir
return dir return dir
@ -214,7 +217,9 @@ logDir :: IO FilePath
logDir = do logDir = do
r <- r <-
runExceptT runExceptT
( logsDirectory <|> xdgRuntimeDir <|> tmpRuntimeDir ( logsDirectory
<|> xdgRuntimeDir
<|> tmpRuntimeDir
<|> throwE <|> throwE
"Failed to create log directory." "Failed to create log directory."
) )

44
src/Version.hs
View File

@ -8,8 +8,8 @@ module Version
) )
where where
import Data.Foldable (toList)
import Data.Char (isAlpha, isDigit) import Data.Char (isAlpha, isDigit)
import Data.Foldable (toList)
import Data.Function (on) import Data.Function (on)
import qualified Data.PartialOrd as PO import qualified Data.PartialOrd as PO
import qualified Data.Text as T import qualified Data.Text as T
@ -62,30 +62,30 @@ clearBreakOn boundary string =
versionCompatibleWithPathPin :: Text -> Version -> Bool versionCompatibleWithPathPin :: Text -> Version -> Bool
versionCompatibleWithPathPin attrPath newVer versionCompatibleWithPathPin attrPath newVer
| "-unwrapped" `T.isSuffixOf` attrPath = | "-unwrapped" `T.isSuffixOf` attrPath =
versionCompatibleWithPathPin (T.dropEnd 10 attrPath) newVer versionCompatibleWithPathPin (T.dropEnd 10 attrPath) newVer
| "_x" `T.isSuffixOf` T.toLower attrPath = | "_x" `T.isSuffixOf` T.toLower attrPath =
versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer versionCompatibleWithPathPin (T.dropEnd 2 attrPath) newVer
| "_" `T.isInfixOf` attrPath = | "_" `T.isInfixOf` attrPath =
let attrVersionPart = let attrVersionPart =
let (_, version) = clearBreakOn "_" attrPath let (_, version) = clearBreakOn "_" attrPath
in if T.any (notElemOf ('_' : ['0' .. '9'])) version in if T.any (notElemOf ('_' : ['0' .. '9'])) version
then Nothing then Nothing
else Just version else Just version
-- Check assuming version part has underscore separators -- Check assuming version part has underscore separators
attrVersionPeriods = T.replace "_" "." <$> attrVersionPart attrVersionPeriods = T.replace "_" "." <$> attrVersionPart
in -- If we don't find version numbers in the attr path, exit success. in -- If we don't find version numbers in the attr path, exit success.
maybe True (`T.isPrefixOf` newVer) attrVersionPeriods maybe True (`T.isPrefixOf` newVer) attrVersionPeriods
| otherwise = | otherwise =
let attrVersionPart = let attrVersionPart =
let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath let version = T.dropWhile (notElemOf ['0' .. '9']) attrPath
in if T.any (notElemOf ['0' .. '9']) version in if T.any (notElemOf ['0' .. '9']) version
then Nothing then Nothing
else Just version else Just version
-- Check assuming version part is the prefix of the version with dots -- Check assuming version part is the prefix of the version with dots
-- removed. For example, 91 => "9.1" -- removed. For example, 91 => "9.1"
noPeriodNewVersion = T.replace "." "" newVer noPeriodNewVersion = T.replace "." "" newVer
in -- If we don't find version numbers in the attr path, exit success. in -- If we don't find version numbers in the attr path, exit success.
maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart maybe True (`T.isPrefixOf` noPeriodNewVersion) attrVersionPart
versionIncompatibleWithPathPin :: Text -> Version -> Bool versionIncompatibleWithPathPin :: Text -> Version -> Bool
versionIncompatibleWithPathPin path version = versionIncompatibleWithPathPin path version =

2
test/CheckSpec.hs
View File

@ -1,8 +1,8 @@
module CheckSpec where module CheckSpec where
import qualified Check
import qualified Data.Text as T import qualified Data.Text as T
import Test.Hspec import Test.Hspec
import qualified Check
main :: IO () main :: IO ()
main = hspec spec main = hspec spec