githud 3.0.1 → 3.1.0

raw patch · 8 files changed

+101/−48 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• githud.cabal +4/−3
• src/GitHUD.hs +9/−3
• src/GitHUD/Config/Types.hs +1/−1
• src/GitHUD/Daemon/Network.hs +14/−12
• src/GitHUD/Daemon/Runner.hs +44/−17
• src/GitHUD/Debug.hs +18/−0
• src/GitHUD/Git/Command.hs +4/−5
• src/GitHUD/Terminal/Prompt.hs +7/−7

@@ -1,8 +1,8 @@ cabal-version:       2.2 name:                githud-version:             3.0.1-synopsis:            More efficient replacement to the great git-radar-description:         Please see README.md (used to be gitHUD)+version:             3.1.0+synopsis:            Heads up, and you see your GIT context+description:         GIT Heads Up Display for your terminal prompt. More efficient replacement to the great git-radar. Please see README.md for more info homepage:            http://github.com/gbataille/gitHUD#readme license:             BSD-3-Clause license-file:        LICENSE@@ -20,6 +20,7 @@                     , GitHUD.Config.Types                     , GitHUD.Daemon.Network                     , GitHUD.Daemon.Runner+                    , GitHUD.Debug                     , GitHUD.Git.Types                     , GitHUD.Git.Common                     , GitHUD.Git.Command

@@ -5,14 +5,15 @@     githudd     ) where -import Control.Monad (when)+import Control.Monad (unless, void, when) import Control.Monad.Reader (runReader) import Data.Text import System.Directory (getCurrentDirectory) import System.Environment (getArgs)+import System.Exit (ExitCode(ExitSuccess)) import System.Posix.Files (fileExist) import System.Posix.User (getRealUserID, getUserEntryForID, UserEntry(..))-import System.Process (callProcess)+import System.Process (readProcessWithExitCode)  import GitHUD.Config.Parse import GitHUD.Config.Types@@ -31,12 +32,17 @@     shell <- processArguments getArgs     config <- getAppConfig     curDir <- getCurrentDirectory-    when (confRunFetcherDaemon config) (callProcess "githudd" [curDir])+    runFetcherDaemon curDir     repoState <- getGitRepoState     let prompt = runReader buildPromptWithConfig $ buildOutputConfig shell repoState config      -- Necessary to use putStrLn to properly terminate the output (needs the CR)     putStrLn $ unpack (strip (pack prompt))++    where+      runFetcherDaemon dir = do+        (code, out, err) <- readProcessWithExitCode "githudd" [dir] ""+        unless (Prelude.null err) (putStrLn $ "Issue with githudd: " ++ err)  processArguments :: IO [String]                  -> IO Shell

@@ -162,7 +162,7 @@   , confStashSuffixColor = Green   , confStashSuffixIntensity = Vivid -  , confRunFetcherDaemon = False+  , confRunFetcherDaemon = True   , confGithuddSleepSeconds = 30   , confGithuddPidFilePath = "/usr/local/var/run/githudd.pid"   , confGithuddSocketFilePath = "/usr/local/var/run/githudd.socket"

@@ -1,20 +1,21 @@ module GitHUD.Daemon.Network (   sendOnSocket,-  fromSocket+  receiveOnSocket,   ) where  import Control.Concurrent (forkFinally) import qualified Control.Exception as E-import Control.Monad (forever, void)+import Control.Monad (forever, void, when) import qualified Data.ByteString as S import qualified Data.ByteString.UTF8 as BSU import Network.Socket (Family(AF_UNIX), socket, defaultProtocol, Socket, SocketType(Stream), close, listen, accept, bind, SockAddr(SockAddrUnix), connect) import Network.Socket.ByteString (recv, sendAll)+import System.Directory (removeFile) import System.Posix.Files (fileExist)  sendOnSocket :: FilePath              -> String-             -> IO Bool+             -> IO () sendOnSocket socketPath msg =   E.bracket open mClose (mTalkOnClientSocket msg)   where@@ -30,16 +31,17 @@  mTalkOnClientSocket :: String                     -> Maybe Socket-                    -> IO Bool-mTalkOnClientSocket _ Nothing = return False-mTalkOnClientSocket msg (Just sock) = do-    sendAll sock $ BSU.fromString msg-    return True+                    -> IO ()+mTalkOnClientSocket _ Nothing = return ()+mTalkOnClientSocket msg (Just sock) = sendAll sock $ BSU.fromString msg -fromSocket :: FilePath-           -> (String -> IO m)-           -> IO ()-fromSocket socketPath withMessageCb = E.bracket open close loop+receiveOnSocket :: FilePath+                -> (String -> IO m)+                -> IO ()+receiveOnSocket socketPath withMessageCb = do+  socketExists <- fileExist socketPath+  when socketExists (removeFile socketPath)+  E.bracket open close loop   where     open = do       sock <- socket AF_UNIX Stream defaultProtocol

@@ -1,4 +1,5 @@ {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-} module GitHUD.Daemon.Runner (     runDaemon     ) where@@ -10,22 +11,45 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Maybe (fromMaybe) import System.Directory (removeFile)-import System.Posix.Daemon (isRunning, runDetached, Redirection(DevNull, ToFile))+import System.Exit (exitFailure)+import System.Posix.Daemon (brutalKill, isRunning, runDetached, Redirection(DevNull, ToFile)) import System.Posix.Files (fileExist)  import GitHUD.Config.Types-import GitHUD.Git.Command import GitHUD.Daemon.Network+import GitHUD.Debug+import GitHUD.Git.Command  runDaemon :: Config           -> Maybe String           -> IO ()-runDaemon config mArg = do+runDaemon = tryRunDaemon 5++tryRunDaemon :: Int+             -> Config+             -> Maybe String+             -> IO ()+tryRunDaemon attempt config mArg = do   let pathToPoll = (fromMaybe "/" mArg)-  ensureDaemonRunning config socketFile pathToPoll-  void $ sendOnSocket socketFile pathToPoll+  -- If there are exception trying to access the pid file or the socket,+  -- we just kill the process and start again+  success <- E.try @E.SomeException $ do+    ensureDaemonRunning config socketFile pathToPoll+    sendOnSocket socketFile pathToPoll+  restartIfNeeded attempt success   where     socketFile = confGithuddSocketFilePath config+    pidFilePath = confGithuddPidFilePath config+    restartIfNeeded 0 _ = void exitFailure+    restartIfNeeded _ (Right _) = return ()+    restartIfNeeded attempt (Left e) = do+      debugOnStderr $ show e+      debugOnStderr "Error on client. Restarting daemon"+      E.try @E.SomeException (brutalKill pidFilePath)   -- ignore possible errors+      threadDelay 100_000+      pidFileExists <- fileExist pidFilePath+      when pidFileExists (removeFile pidFilePath)+      tryRunDaemon (attempt - 1) config mArg  ensureDaemonRunning :: Config                     -> FilePath@@ -34,10 +58,9 @@ ensureDaemonRunning config socketPath pathToPoll = do   running <- isRunning pidFilePath   unless running $ do-    socketExists <- fileExist socketPath-    when socketExists (removeFile socketPath)     removeLogFile stdoutFile     runDetached (Just pidFilePath) stdoutFile (daemon delaySec pathToPoll socketPath)+    threadDelay 100_000     -- Give the daemon some time to start   where     stdoutFile = confGithuddLogFilePath config     pidFilePath = confGithuddPidFilePath config@@ -56,24 +79,28 @@        -> IO () daemon delaySec path socket = do   pathToPoll <- newMVar path-  forkIO $ socketClient socket pathToPoll-  forever $ fetcher delaySec socket pathToPoll+  forkIO $ socketServer socket pathToPoll+  forever $ fetcher delaySec pathToPoll -socketClient :: FilePath+socketServer :: FilePath              -> MVar String              -> IO ()-socketClient socketPath mvar =-  fromSocket socketPath withMessage+socketServer socketPath mvar = do+  success <- E.try @E.SomeException (receiveOnSocket socketPath withMessage)+  restartIfNeeded success     where-      withMessage msg = do-        putStrLn $ "Switching to poll " ++ msg-        swapMVar mvar msg+      withMessage = swapMVar mvar+      restartIfNeeded (Right _) = return ()+      restartIfNeeded (Left e) = do+        debug "Error on server. Restarting socket"+        debug $ show e+        threadDelay 100_000+        socketServer socketPath mvar  fetcher :: Int-        -> FilePath         -> MVar String         -> IO ()-fetcher delaySec socketPath mvar = do+fetcher delaySec mvar = do   path <- readMVar mvar   gitCmdFetch path   threadDelay $ delaySec * 1_000_000

@@ -0,0 +1,18 @@+module GitHUD.Debug (+  debug,+  debugOnStderr+  ) where++import System.IO (stdout, stderr, hFlush, hPutStrLn)++debug :: String+      -> IO ()+debug msg = do+  putStrLn msg+  hFlush stdout++debugOnStderr :: String+              -> IO ()+debugOnStderr msg = do+  hPutStrLn stderr msg+  hFlush stderr

@@ -14,10 +14,11 @@   ) where  import Control.Concurrent.MVar (MVar, putMVar)+import Control.Monad (void) import GHC.IO.Handle (hGetLine) import System.Directory (doesDirectoryExist) import System.Exit (ExitCode(ExitSuccess))-import System.Process (readCreateProcess, readProcessWithExitCode, proc, StdStream(CreatePipe, UseHandle), createProcess, CreateProcess(..))+import System.Process (readCreateProcessWithExitCode, readProcessWithExitCode, proc, StdStream(CreatePipe, UseHandle), createProcess, CreateProcess(..))  import GitHUD.Process (readProcessWithIgnoreExitCode) import GitHUD.Git.Common@@ -106,8 +107,6 @@   if isDir     then do       let fetch_proc = (proc "git" ["fetch"]) { cwd = Just path }-      readCreateProcess fetch_proc ""-      return ()-    else do+      void $ readCreateProcessWithExitCode fetch_proc ""+    else       putStrLn ("Folder" ++ path ++ " does not exist")-      return ()

@@ -34,13 +34,13 @@   repoState <- askRepoState   let branch = gitLocalBranch repoState   resetPromptAtBeginning-  when (confShowPartRepoIndicator config) $ addGitRepoIndicator-  when (showMergeBranchIndicator branch config) $ addNoTrackedUpstreamIndicator-  when (showMergeBranchIndicator branch config) $ addMergeBranchCommits-  when (confShowPartLocalBranch config) $ addLocalBranchName-  when (confShowPartCommitsToOrigin config) $ addLocalCommits-  when (confShowPartLocalChangesState config) $ addRepoState-  when (confShowPartStashes config) $ addStashes+  when (confShowPartRepoIndicator config) addGitRepoIndicator+  when (showMergeBranchIndicator branch config) addNoTrackedUpstreamIndicator+  when (showMergeBranchIndicator branch config) addMergeBranchCommits+  when (confShowPartLocalBranch config) addLocalBranchName+  when (confShowPartCommitsToOrigin config) addLocalCommits+  when (confShowPartLocalChangesState config) addRepoState+  when (confShowPartStashes config) addStashes   return ()  showMergeBranchIndicator :: String -> Config -> Bool