format

nix-community · Apr 2, 2024 · 784ba9f · 784ba9f
1 parent 60986a1
commit 784ba9f
Show file tree

Hide file tree

Showing 17 changed files with 351 additions and 306 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/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)
 

diff --git 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