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

@@ -28,6 +28,7 @@ dependencies:
   - shelly
   - typed-process
   - text
+  - bytestring
   - time >= 1.8 && < 1.10
   - errors
   - mtl

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)

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)

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)

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_
+  runProcess_
+    (proc
        "git"
-    (["push", "--force", "--set-upstream", "origin", branchName updateEnv] ++
-     ["--dry-run" | dryRun (options updateEnv)])
+       ([ "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. ")
 
 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

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
@@ -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 =
@@ -174,7 +175,7 @@ build attrPath =
       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 =
@@ -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

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)