Merge pull request #406 from qowoz/treefmt

add treefmt
nix-community · Apr 28, 2024 · 0572aa4 · 0572aa4
2 parents 936918c + 9c6d0ff
commit 0572aa4
Show file tree

Hide file tree

Showing 19 changed files with 390 additions and 309 deletions.
diff --git 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/flake.lock b/flake.lock
diff --git a/flake.nix b/flake.nix
@@ -4,17 +4,32 @@
   inputs.mmdoc.url = "github:ryantm/mmdoc";
   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-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 =
         let
           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;
         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"; });
       devShells.x86_64-linux.default = self.packages."x86_64-linux".devShell;

diff --git a/src/CVE.hs b/src/CVE.hs
@@ -16,14 +16,14 @@ where
 
 import Data.Aeson
   ( FromJSON,
+    Key,
     Object,
     eitherDecode,
     parseJSON,
     withObject,
     (.!=),
     (.:),
     (.:!),
-    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
@@ -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
   -- /^(?<!${storePathWithoutVersion})${version}/
   -- 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
-  case T.breakOn expectedVersion storePath of
-    (_, "") ->
-      -- no version in prefix, just match version
-      "\\Q"
-        <> T.unpack expectedVersion
-        <> "\\E"
-    (storePrefix, _) ->
-      "(?<!\\Q"
-        <> 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, _) ->
+          "(?<!\\Q"
+            <> 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
@@ -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,48 +54,51 @@ 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
   let runRequest :: FromJSON a => GH.Request k a -> ExceptT Text m a
       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)