From 734590d1c9d52766462df1d8e3a991f1f4ef206b Mon Sep 17 00:00:00 2001 From: Ryan Mulligan Date: Sun, 24 Mar 2019 22:20:44 -0700 Subject: [PATCH] more work stabalizing and cleaning up error messages and log output * Add waitForNoLock to try to fix recurrent git index.lock issue * Don't output most git commands to stdout * Add some spaces so ExceptT errors aren't smashed together --- package.yaml | 1 + src/Check.hs | 2 +- src/Clean.hs | 2 +- src/DeleteMerged.hs | 3 +- src/Git.hs | 120 ++++++++++++++++++++++++++++---------------- src/Nix.hs | 19 +++---- src/OurPrelude.hs | 21 ++++++++ src/Update.hs | 4 +- 8 files changed, 115 insertions(+), 57 deletions(-) diff --git a/package.yaml b/package.yaml index 569e988..310a064 100644 --- a/package.yaml +++ b/package.yaml @@ -28,6 +28,7 @@ dependencies: - shelly - typed-process - text + - bytestring - time >= 1.8 && < 1.10 - errors - mtl diff --git a/src/Check.hs b/src/Check.hs index afd95b1..a6f8831 100644 --- a/src/Check.hs +++ b/src/Check.hs @@ -12,7 +12,7 @@ import Control.Applicative (many) import Data.Char (isSpace) import qualified Data.Text as T import qualified Shell -import Shelly hiding (FilePath) +import Shelly hiding (FilePath, whenM) import qualified Text.Regex.Applicative.Text as RE import Text.Regex.Applicative.Text (RE', (=~)) import Utils (UpdateEnv(..), Version, runtimeDir) diff --git a/src/Clean.hs b/src/Clean.hs index 7821dc0..1c0ee7f 100644 --- a/src/Clean.hs +++ b/src/Clean.hs @@ -12,7 +12,7 @@ import Control.Applicative (some) import qualified Data.Text as T import qualified File import qualified Shell -import Shelly hiding (FilePath) +import Shelly hiding (FilePath, whenM) import qualified Text.Regex.Applicative.Text as RE import Text.Regex.Applicative.Text (RE', (=~)) import Utils (UpdateEnv(..), Version) diff --git a/src/DeleteMerged.hs b/src/DeleteMerged.hs index 596e0ea..cd2380c 100644 --- a/src/DeleteMerged.hs +++ b/src/DeleteMerged.hs @@ -23,4 +23,5 @@ deleteDone o = do case result of Left e -> T.putStrLn e Right refs -> - V.sequence_ (fmap (\r -> Git.deleteBranch ("auto-update/" <> r)) refs) + V.sequence_ + (fmap (\r -> Git.deleteBranchEverywhere ("auto-update/" <> r)) refs) diff --git a/src/Git.hs b/src/Git.hs index 9fb65c7..cbfc1a1 100644 --- a/src/Git.hs +++ b/src/Git.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Git ( cleanAndResetTo @@ -12,52 +10,69 @@ module Git , checkAutoUpdateBranchDoesntExist , commit , headHash - , deleteBranch - , showRef + , deleteBranchEverywhere ) where import OurPrelude +import Control.Concurrent import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Time.Clock (addUTCTime, getCurrentTime) -import qualified Shell -import Shelly import System.Directory (getHomeDirectory, getModificationTime) +import System.Posix.Files (fileExist) import System.Process.Typed import Utils (Options(..), UpdateEnv(..), branchName) -default (T.Text) +clean :: ProcessConfig () () () +clean = setStdin closed $ setStdout closed $ setStderr closed $ "git clean -fdx" -clean :: MonadIO m => m () -clean = runProcess_ "git clean -fdx" - -checkout :: MonadIO m => Text -> Text -> m () +checkout :: Text -> Text -> ProcessConfig () () () checkout branch target = - runProcess_ (proc "git" ["checkout", "-B", T.unpack branch, T.unpack target]) + setStdin closed $ + setStdout closed $ + setStderr closed $ + proc "git" ["checkout", "-B", T.unpack branch, T.unpack target] -reset :: MonadIO m => Text -> m () -reset target = runProcess_ (proc "git" ["reset", "--hard", T.unpack target]) +reset :: Text -> ProcessConfig () () () +reset target = + setStdin closed $ + setStdout closed $ + setStderr closed $ proc "git" ["reset", "--hard", T.unpack target] delete :: Text -> ProcessConfig () () () -delete branch = proc "git" ["branch", "-D", T.unpack branch] +delete branch = + setStdin closed $ + setStdout closed $ + setStderr closed $ proc "git" ["branch", "-D", T.unpack branch] + +deleteOrigin :: Text -> ProcessConfig () () () +deleteOrigin branch = + setStdin closed $ + setStdout closed $ + setStderr closed $ proc "git" ["push", "origin", T.unpack (":" <> branch)] cleanAndResetTo :: MonadIO m => Text -> m () cleanAndResetTo branch = let target = "upstream/" <> branch - in do runProcess_ "git reset --hard" - clean - checkout branch target - reset target - clean + in do runProcess_ $ + setStdin closed $ + setStdout closed $ setStderr closed $ "git reset --hard" + waitForNoLock + runProcess_ clean + waitForNoLock + runProcess_ $ checkout branch target + waitForNoLock + runProcess_ $ reset target + waitForNoLock + runProcess_ clean cleanup :: MonadIO m => Text -> m () cleanup bName = do + liftIO $ T.putStrLn ("Cleaning up " <> bName) cleanAndResetTo "master" void $ runProcess (delete bName) -showRef :: MonadIO m => Text -> m Text -showRef ref = shelly $ cmd "git" "show-ref" ref - staleFetchHead :: MonadIO m => m Bool staleFetchHead = liftIO $ do @@ -73,41 +88,60 @@ fetchIfStale = whenM staleFetchHead fetch -- Using void and runProcess because if this fails we want to keep -- going fetch :: MonadIO m => m () -fetch = void $ runProcess "git fetch -q --prune --multiple upstream origin" +fetch = + void $ + runProcess $ + setStdin closed $ + setStdout closed $ + setStderr closed $ "git fetch -q --prune --multiple upstream origin" push :: MonadIO m => UpdateEnv -> ExceptT Text m () push updateEnv = - Shell.shellyET $ - run_ - "git" - (["push", "--force", "--set-upstream", "origin", branchName updateEnv] ++ - ["--dry-run" | dryRun (options updateEnv)]) + runProcess_ + (proc + "git" + ([ "push" + , "--force" + , "--set-upstream" + , "origin" + , T.unpack (branchName updateEnv) + ] ++ + ["--dry-run" | dryRun (options updateEnv)])) & + tryIOTextET checkoutAtMergeBase :: MonadIO m => Text -> ExceptT Text m () checkoutAtMergeBase bName = do + waitForNoLock base <- - T.strip <$> - Shell.shellyET (cmd "git" "merge-base" "upstream/master" "upstream/staging") - Shell.shellyET $ cmd "git" "checkout" "-B" bName base + ourReadProcessInterleaved_ "git merge-base upstream/master upstream/staging" & + fmapRT T.strip + waitForNoLock + runProcess_ (checkout bName base) & tryIOTextET checkAutoUpdateBranchDoesntExist :: MonadIO m => Text -> ExceptT Text m () checkAutoUpdateBranchDoesntExist pName = do remoteBranches <- - lift $ - map T.strip . T.lines <$> shelly (silently $ cmd "git" "branch" "--remote") + ourReadProcessInterleaved_ "git branch --remote" & + fmapRT (T.lines >>> fmap T.strip) when (("origin/auto-update/" <> pName) `elem` remoteBranches) - (throwE "Update branch already on origin.") + (throwE "Update branch already on origin. ") commit :: MonadIO m => Text -> ExceptT Text m () -commit ref = Shell.shellyET $ cmd "git" "commit" "-am" ref +commit ref = + (runProcess_ (proc "git" ["commit", "-am", T.unpack ref])) & tryIOTextET headHash :: MonadIO m => ExceptT Text m Text -headHash = Shell.shellyET $ cmd "git" "rev-parse" "HEAD" +headHash = ourReadProcessInterleaved_ "git rev-parse HEAD" -deleteBranch :: MonadIO m => Text -> m () -deleteBranch bName = - shelly $ - Shell.canFail $ do - _ <- cmd "git" "branch" "-D" bName - cmd "git" "push" "origin" (":" <> bName) +deleteBranchEverywhere :: MonadIO m => Text -> m () +deleteBranchEverywhere bName = do + void $ runProcess (delete bName) + void $ runProcess (deleteOrigin bName) + +waitForNoLock :: MonadIO m => m () +waitForNoLock = do + liftIO $ + whenM (fileExist ".git/index.lock") $ do + threadDelay 10000 + waitForNoLock diff --git a/src/Nix.hs b/src/Nix.hs index 0e50103..ee3cea1 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -43,7 +43,7 @@ nixEvalET :: MonadIO m => Raw -> Text -> ExceptT Text m Text nixEvalET raw expr = run "nix" (["eval", "-f", "."] <> rawOpt raw <> [expr]) & fmap T.strip & Shell.shellyET & - overwriteErrorT ("nix eval failed for " <> expr) + overwriteErrorT ("nix eval failed for " <> expr <> " ") -- Error if the "new version" is actually newer according to nix assertNewerVersion :: MonadIO m => UpdateEnv -> ExceptT Text m () @@ -60,7 +60,8 @@ assertNewerVersion updateEnv = do throwE (newVersion updateEnv <> " is not newer than " <> oldVersion updateEnv <> " according to Nix; versionComparison: " <> - a) + a <> + " ") -- This is extremely slow but gives us the best results we know of lookupAttrPath :: MonadIO m => UpdateEnv -> ExceptT Text m Text @@ -77,14 +78,14 @@ lookupAttrPath updateEnv = "{ allowBroken = true; allowUnfree = true; allowAliases = false; }" & fmap (T.lines >>> head >>> T.words >>> head) & Shell.shellyET & - overwriteErrorT "nix-env -q failed to find package name with old version" + overwriteErrorT "nix-env -q failed to find package name with old version " getDerivationFile :: MonadIO m => Text -> ExceptT Text m FilePath getDerivationFile attrPath = cmd "env" "EDITOR=echo" "nix" "edit" attrPath "-f" "." & fmap T.strip & fmap T.unpack & Shell.shellyET & - overwriteErrorT "Couldn't find derivation file." + overwriteErrorT "Couldn't find derivation file. " getHash :: MonadIO m => Text -> ExceptT Text m Text getHash = @@ -113,7 +114,7 @@ readNixBool t = do case text of "true" -> return True "false" -> return False - a -> throwE ("Failed to read expected nix boolean " <> a) + a -> throwE ("Failed to read expected nix boolean " <> a <> " ") getIsBroken :: MonadIO m => Text -> ExceptT Text m Bool getIsBroken attrPath = @@ -168,13 +169,13 @@ build :: MonadIO m => Text -> ExceptT Text m () build attrPath = (buildCmd attrPath & Shell.shellyET) <|> (do _ <- buildFailedLog - throwE "nix log failed trying to get build logs") + throwE "nix log failed trying to get build logs ") where buildFailedLog = do buildLog <- cmd "nix" "log" "-f" "." attrPath & Shell.shellyET & fmap (T.lines >>> reverse >>> take 30 >>> reverse >>> T.unlines) - throwE ("nix build failed.\n" <> buildLog) + throwE ("nix build failed.\n" <> buildLog <> " ") cachix :: MonadIO m => FilePath -> m () cachix resultPath = @@ -208,7 +209,7 @@ resultLink = (T.strip >>> T.unpack) <$> do Shell.shellyET (cmd "readlink" "./result") <|> Shell.shellyET (cmd "readlink" "./result-bin") <|> - throwE "Could not find result link." + throwE "Could not find result link. " sha256Zero :: Text sha256Zero = "0000000000000000000000000000000000000000000000000000" @@ -220,7 +221,7 @@ getHashFromBuild = (\attrPath -> do stderr <- (ExceptT $ Shell.shRE (buildCmd attrPath)) <|> - throwE "Build succeeded unexpectedly" + throwE "Build succeeded unexpectedly. " let firstSplit = T.splitOn "with sha256 hash '" stderr firstSplitSecondPart <- tryAt "stdout did not split as expected" firstSplit 1 diff --git a/src/OurPrelude.hs b/src/OurPrelude.hs index 9195735..a6cb94e 100644 --- a/src/OurPrelude.hs +++ b/src/OurPrelude.hs @@ -15,6 +15,10 @@ module OurPrelude , Vector , interpolate , tshow + , tryIOTextET + , whenM + , ourReadProcessInterleaved_ + , runProcess ) where import Control.Applicative ((<|>)) @@ -24,16 +28,33 @@ import Control.Monad.Except import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Bifunctor +import qualified Data.ByteString.Lazy as BSL import Data.Function ((&)) import Data.Semigroup ((<>)) import Data.Set (Set) import Data.Text (Text, pack) +import qualified Data.Text.Encoding as T import Data.Vector (Vector) import Language.Haskell.TH.Quote import qualified NeatInterpolation +import System.Process.Typed interpolate :: QuasiQuoter interpolate = NeatInterpolation.text tshow :: Show a => a -> Text tshow = show >>> pack + +tryIOTextET :: MonadIO m => IO a -> ExceptT Text m a +tryIOTextET = tryIO >>> fmapLT tshow + +whenM :: Monad m => m Bool -> m () -> m () +whenM c a = c >>= \res -> when res a + +ourReadProcessInterleaved_ :: + MonadIO m + => ProcessConfig stdin stdoutIgnored stderrIgnored + -> ExceptT Text m Text +ourReadProcessInterleaved_ processConfig = + readProcessInterleaved_ processConfig & tryIOTextET & + fmapRT (BSL.toStrict >>> T.decodeUtf8) diff --git a/src/Update.hs b/src/Update.hs index be1c6a9..a27ed90 100644 --- a/src/Update.hs +++ b/src/Update.hs @@ -140,11 +140,11 @@ updatePackage log updateEnv mergeBaseOutpathsContext = lift $ File.replace (oldVersion updateEnv) (newVersion updateEnv) derivationFile newSrcUrl <- Nix.getSrcUrl attrPath - when (oldSrcUrl == newSrcUrl) $ throwE "Source url did not change." + when (oldSrcUrl == newSrcUrl) $ throwE "Source url did not change. " lift $ File.replace oldHash Nix.sha256Zero derivationFile newHash <- Nix.getHashFromBuild attrPath -- <|> -- lift (fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl) <|> - -- throwE "Could not get new hash." + -- throwE "Could not get new hash. " tryAssert "Hashes equal; no update necessary" (oldHash /= newHash) lift $ File.replace Nix.sha256Zero newHash derivationFile editedOutpathSet <- ExceptT currentOutpathSet