diff --git a/githud.cabal b/githud.cabal --- a/githud.cabal +++ b/githud.cabal @@ -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 diff --git a/src/GitHUD.hs b/src/GitHUD.hs --- a/src/GitHUD.hs +++ b/src/GitHUD.hs @@ -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 diff --git a/src/GitHUD/Config/Types.hs b/src/GitHUD/Config/Types.hs --- a/src/GitHUD/Config/Types.hs +++ b/src/GitHUD/Config/Types.hs @@ -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" diff --git a/src/GitHUD/Daemon/Network.hs b/src/GitHUD/Daemon/Network.hs --- a/src/GitHUD/Daemon/Network.hs +++ b/src/GitHUD/Daemon/Network.hs @@ -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 diff --git a/src/GitHUD/Daemon/Runner.hs b/src/GitHUD/Daemon/Runner.hs --- a/src/GitHUD/Daemon/Runner.hs +++ b/src/GitHUD/Daemon/Runner.hs @@ -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 diff --git a/src/GitHUD/Debug.hs b/src/GitHUD/Debug.hs new file mode 100644 --- /dev/null +++ b/src/GitHUD/Debug.hs @@ -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 diff --git a/src/GitHUD/Git/Command.hs b/src/GitHUD/Git/Command.hs --- a/src/GitHUD/Git/Command.hs +++ b/src/GitHUD/Git/Command.hs @@ -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 () diff --git a/src/GitHUD/Terminal/Prompt.hs b/src/GitHUD/Terminal/Prompt.hs --- a/src/GitHUD/Terminal/Prompt.hs +++ b/src/GitHUD/Terminal/Prompt.hs @@ -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