diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import GitHUD - -main :: IO () -main = githud diff --git a/app/githud/Main.hs b/app/githud/Main.hs new file mode 100644 --- /dev/null +++ b/app/githud/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import GitHUD + +main :: IO () +main = githud diff --git a/app/githudd/Main.hs b/app/githudd/Main.hs new file mode 100644 --- /dev/null +++ b/app/githudd/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import GitHUD + +main :: IO () +main = githudd diff --git a/githud.cabal b/githud.cabal --- a/githud.cabal +++ b/githud.cabal @@ -1,23 +1,25 @@ +cabal-version: 2.2 name: githud -version: 2.1.0 +version: 3.0.0 synopsis: More efficient replacement to the great git-radar description: Please see README.md (used to be gitHUD) homepage: http://github.com/gbataille/gitHUD#readme -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Grégory Bataille maintainer: gregory.bataille@gmail.com -copyright: Grégory Bataille 2015-2016 +copyright: Grégory Bataille 2015-2019 category: Development build-type: Simple -- extra-source-files: -cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: GitHUD , GitHUD.Config.Parse , GitHUD.Config.Types + , GitHUD.Daemon.Network + , GitHUD.Daemon.Runner , GitHUD.Git.Types , GitHUD.Git.Common , GitHUD.Git.Command @@ -30,35 +32,50 @@ , GitHUD.Terminal.Prompt , GitHUD.Terminal.Types , GitHUD.Types - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.11 && < 5 + , bytestring >= 0.10 && < 0.11 + , daemons >= 0.2.1 && < 0.3 + , data-default >= 0.7 && < 0.8 + , directory >= 1.3 && < 1.4 , process - , parsec >= 3.1.9 && < 4 - , mtl >= 2.2.1 && < 3 + , parsec >= 3.1.13 && < 4 + , mtl >= 2.2.2 && < 3 + , network >= 2.8 && < 3.0 , text >= 1.2 && < 1.3 , unix >= 2.7 && < 3 + , utf8-string >= 1.0 && < 1.1 default-language: Haskell2010 executable githud - hs-source-dirs: app + hs-source-dirs: app/githud main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: base , githud default-language: Haskell2010 +executable githudd + hs-source-dirs: app/githudd + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: base + , githud + default-language: Haskell2010 + test-suite githud-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs build-depends: base - , tasty >= 0.10 && < 0.12 - , tasty-hunit >= 0.9 && < 0.10 + , tasty >= 1.2 && < 1.3 + , tasty-hunit >= 0.10 && < 0.11 , tasty-smallcheck >= 0.8 && < 0.9 - , tasty-quickcheck >= 0.8 && < 0.9 - , parsec >= 3.1.9 && < 4 - , mtl >= 2.2.1 && < 3 + , tasty-quickcheck >= 0.10 && < 0.11 + , daemons >= 0.2.1 && < 0.3 + , parsec >= 3.1.13 && < 4 + , mtl >= 2.2.2 && < 3 , githud - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fsimpl-tick-factor=120 default-language: Haskell2010 Other-modules: Test.GitHUD.Git.Parse.Status , Test.GitHUD.Git.Parse.Branch @@ -67,7 +84,6 @@ , Test.GitHUD.Terminal.Base , Test.GitHUD.Terminal.Prompt , Test.GitHUD.Config.Parse - Ghc-Options: -rtsopts -Wall -fno-warn-unused-do-bind -threaded source-repository head type: git diff --git a/src/GitHUD.hs b/src/GitHUD.hs --- a/src/GitHUD.hs +++ b/src/GitHUD.hs @@ -1,18 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module GitHUD ( - githud + githud, + githudd ) where import Control.Monad (when) import Control.Monad.Reader (runReader) import Data.Text +import System.Directory (getCurrentDirectory) import System.Environment (getArgs) import System.Posix.Files (fileExist) import System.Posix.User (getRealUserID, getUserEntryForID, UserEntry(..)) +import System.Process (callProcess) import GitHUD.Config.Parse import GitHUD.Config.Types +import GitHUD.Daemon.Runner import GitHUD.Terminal.Prompt import GitHUD.Terminal.Types import GitHUD.Git.Parse.Base @@ -26,6 +30,8 @@ when isGit $ do shell <- processArguments getArgs config <- getAppConfig + curDir <- getCurrentDirectory + when (confRunFetcherDaemon config) (callProcess "githudd" [curDir]) repoState <- getGitRepoState let prompt = runReader buildPromptWithConfig $ buildOutputConfig shell repoState config @@ -34,9 +40,7 @@ processArguments :: IO [String] -> IO Shell -processArguments args = do - arguments <- args - return $ getShell arguments +processArguments args = getShell <$> args getShell :: [String] -> Shell @@ -54,3 +58,14 @@ if configFilePresent then parseConfigFile configFilePath else return defaultConfig + +githudd :: IO() +githudd = do + mArg <- processDaemonArguments <$> getArgs + config <- getAppConfig + runDaemon config mArg + +processDaemonArguments :: [String] + -> Maybe String +processDaemonArguments [] = Nothing +processDaemonArguments (fst:_) = Just fst diff --git a/src/GitHUD/Config/Parse.hs b/src/GitHUD/Config/Parse.hs --- a/src/GitHUD/Config/Parse.hs +++ b/src/GitHUD/Config/Parse.hs @@ -8,11 +8,16 @@ , colorConfigToColor , intensityConfigToIntensity , stringConfigToStringList + , redirectionParser + , strConfigToRedirection + , boolConfigToBool + , intConfigToInt ) where import Control.Monad (void, when) +import System.Posix.Daemon (Redirection(ToFile, DevNull)) import Text.Parsec (parse) -import Text.Parsec.Char (anyChar, char, newline, noneOf, letter, spaces, string) +import Text.Parsec.Char (anyChar, char, digit, newline, noneOf, letter, spaces, string) import Text.Parsec.Combinator (choice, eof, many1, manyTill, optional, sepBy) import Text.Parsec.Prim (many, try, unexpected, (<|>), ()) import Text.Parsec.String (parseFromFile, Parser) @@ -204,6 +209,17 @@ configItemsFolder conf (Item "stash_suffix_intensity" value) = conf { confStashSuffixIntensity = intensityConfigToIntensity value } +configItemsFolder conf (Item "run_fetcher_daemon" value) = + conf { confRunFetcherDaemon = boolConfigToBool value } +configItemsFolder conf (Item "githudd_sleep_seconds" value) = + conf { confGithuddSleepSeconds = intConfigToInt value } +configItemsFolder conf (Item "githudd_pid_file_path" value) = + conf { confGithuddPidFilePath = value } +configItemsFolder conf (Item "githudd_socket_file_path" value) = + conf { confGithuddSocketFilePath = value } +configItemsFolder conf (Item "githudd_log_file_path" value) = + conf { confGithuddLogFilePath = strConfigToRedirection value } + configItemsFolder conf _ = conf colorConfigToColor :: String -> Color @@ -259,7 +275,7 @@ return $ filter noEmptyStringFilter branchNameList noEmptyStringFilter :: String -> Bool -noEmptyStringFilter str = not (str == "") +noEmptyStringFilter = (/=) "" stripedBranchName :: Parser String stripedBranchName = do @@ -268,6 +284,16 @@ spaces return branchName +intParser :: Parser Int +intParser = read <$> many1 digit + +intConfigToInt :: String -> Int +intConfigToInt str = + either + (const 30) + id + (parse intParser "" str) + boolParser :: Parser Bool boolParser = choice [ string "False" >> return False @@ -287,3 +313,24 @@ , string "yes" >> return True , string "y" >> return True ] "bool" + +boolConfigToBool :: String -> Bool +boolConfigToBool str = + either + (const False) + id + (parse boolParser "" str) + +strConfigToRedirection :: String -> Redirection +strConfigToRedirection str = + either + (const DevNull) + id + (parse redirectionParser "" str) + +redirectionParser :: Parser Redirection +redirectionParser = + choice [ + try (string "/dev/null") >> return DevNull + , ToFile <$> many1 anyChar + ] "Redirection" 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 @@ -3,8 +3,16 @@ , defaultConfig ) where +import System.Posix.Daemon (Redirection(DevNull, ToFile)) + import GitHUD.Terminal.Types +instance Eq Redirection where + (==) DevNull DevNull = True + (==) _ DevNull = False + (==) DevNull _ = False + (==) (ToFile a) (ToFile b) = a == b + data Config = Config { confShowPartRepoIndicator :: Bool , confShowPartMergeBranchCommitsDiff :: Bool @@ -74,6 +82,13 @@ , confStashSuffix :: String , confStashSuffixColor :: Color , confStashSuffixIntensity :: ColorIntensity + + , confRunFetcherDaemon :: Bool + , confGithuddSleepSeconds :: Int + , confGithuddPidFilePath :: FilePath + , confGithuddSocketFilePath :: FilePath + + , confGithuddLogFilePath :: Redirection } deriving (Eq, Show) defaultConfig :: Config @@ -146,4 +161,11 @@ , confStashSuffix = "≡" , confStashSuffixColor = Green , confStashSuffixIntensity = Vivid + + , confRunFetcherDaemon = True + , confGithuddSleepSeconds = 30 + , confGithuddPidFilePath = "/usr/local/var/run/githudd.pid" + , confGithuddSocketFilePath = "/usr/local/var/run/githudd.socket" + + , confGithuddLogFilePath = DevNull } diff --git a/src/GitHUD/Daemon/Network.hs b/src/GitHUD/Daemon/Network.hs new file mode 100644 --- /dev/null +++ b/src/GitHUD/Daemon/Network.hs @@ -0,0 +1,57 @@ +module GitHUD.Daemon.Network ( + sendOnSocket, + fromSocket + ) where + +import Control.Concurrent (forkFinally) +import qualified Control.Exception as E +import Control.Monad (forever, void) +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.Posix.Files (fileExist) + +sendOnSocket :: FilePath + -> String + -> IO Bool +sendOnSocket socketPath msg = + E.bracket open mClose (mTalkOnClientSocket msg) + where + open = do + socketExists <- fileExist socketPath + if socketExists + then do + sock <- socket AF_UNIX Stream defaultProtocol + connect sock (SockAddrUnix socketPath) + return $ Just sock + else return Nothing + mClose = maybe (return ()) close + +mTalkOnClientSocket :: String + -> Maybe Socket + -> IO Bool +mTalkOnClientSocket _ Nothing = return False +mTalkOnClientSocket msg (Just sock) = do + sendAll sock $ BSU.fromString msg + return True + +fromSocket :: FilePath + -> (String -> IO m) + -> IO () +fromSocket socketPath withMessageCb = E.bracket open close loop + where + open = do + sock <- socket AF_UNIX Stream defaultProtocol + bind sock (SockAddrUnix socketPath) + listen sock 1 + return sock + loop sock = forever $ do + (conn, peer) <- accept sock + void $ forkFinally (talk conn) (\_ -> close conn) + talk conn = (readPacket conn "") >>= withMessageCb + readPacket conn acc = do + msg <- recv conn 1024 + if (S.null msg) + then return acc + else readPacket conn (acc ++ (BSU.toString msg)) diff --git a/src/GitHUD/Daemon/Runner.hs b/src/GitHUD/Daemon/Runner.hs new file mode 100644 --- /dev/null +++ b/src/GitHUD/Daemon/Runner.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE NumericUnderscores #-} +module GitHUD.Daemon.Runner ( + runDaemon + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar (MVar, readMVar, newMVar, swapMVar) +import qualified Control.Exception as E +import Control.Monad (when, forever, void, unless) +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.Posix.Files (fileExist) + +import GitHUD.Config.Types +import GitHUD.Git.Command +import GitHUD.Daemon.Network + +runDaemon :: Config + -> Maybe String + -> IO () +runDaemon config mArg = do + let pathToPoll = (fromMaybe "/" mArg) + ensureDaemonRunning config socketFile pathToPoll + void $ sendOnSocket socketFile pathToPoll + where + socketFile = confGithuddSocketFilePath config + +ensureDaemonRunning :: Config + -> FilePath + -> FilePath + -> IO () +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) + where + stdoutFile = confGithuddLogFilePath config + pidFilePath = confGithuddPidFilePath config + delaySec = confGithuddSleepSeconds config + +removeLogFile :: Redirection + -> IO () +removeLogFile DevNull = return () +removeLogFile (ToFile file) = do + debugFileExists <- fileExist file + when debugFileExists (removeFile file) + +daemon :: Int + -> FilePath + -> FilePath + -> IO () +daemon delaySec path socket = do + pathToPoll <- newMVar path + forkIO $ socketClient socket pathToPoll + forever $ fetcher delaySec socket pathToPoll + +socketClient :: FilePath + -> MVar String + -> IO () +socketClient socketPath mvar = + fromSocket socketPath withMessage + where + withMessage msg = do + putStrLn $ "Switching to poll " ++ msg + swapMVar mvar msg + +fetcher :: Int + -> FilePath + -> MVar String + -> IO () +fetcher delaySec socketPath mvar = do + path <- readMVar mvar + gitCmdFetch path + threadDelay $ delaySec * 1_000_000 + return () 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 @@ -9,13 +9,15 @@ , gitCmdStashCount , gitCmdCommitShortSHA , gitCmdCommitTag + , gitCmdFetch , checkInGitDirectory ) where import Control.Concurrent.MVar (MVar, putMVar) -import System.Process (readProcessWithExitCode, proc, StdStream(CreatePipe, UseHandle), createProcess, CreateProcess(..)) 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 GitHUD.Process (readProcessWithIgnoreExitCode) import GitHUD.Git.Common @@ -96,3 +98,16 @@ gitCmdCommitTag out = do tag <- readProcessWithIgnoreExitCode "git" ["describe", "--exact-match", "--tags"] "" putMVar out tag + +gitCmdFetch :: String + -> IO () +gitCmdFetch path = do + isDir <- doesDirectoryExist path + if isDir + then do + let fetch_proc = (proc "git" ["fetch"]) { cwd = Just path } + readCreateProcess fetch_proc "" + return () + else do + putStrLn ("Folder" ++ path ++ " does not exist") + return () diff --git a/test/Test/GitHUD/Config/Parse.hs b/test/Test/GitHUD/Config/Parse.hs --- a/test/Test/GitHUD/Config/Parse.hs +++ b/test/Test/GitHUD/Config/Parse.hs @@ -5,6 +5,7 @@ import Test.Tasty import Test.Tasty.HUnit +import System.Posix.Daemon (Redirection(DevNull, ToFile)) import Text.Parsec (parse) import Text.Parsec.String (Parser) @@ -20,6 +21,9 @@ , testColorConfigToColor , testIntensityConfigToIntensity , testStringConfigToStringList + , testStringConfigToRedirection + , testBoolConfigToBool + , testIntConfigToInt ] testItemParser :: TestTree @@ -443,19 +447,49 @@ toBeInField confStashSuffixIntensity $ forConfigItemKey "stash_suffix_intensity" $ withValue "Dull" + + , testCase "Key: run_fetcher_daemon" $ + expectValue True $ + toBeInField confRunFetcherDaemon $ + forConfigItemKey "run_fetcher_daemon" $ + withValue "True" + + , testCase "Key: githudd_sleep_seconds" $ + expectValue 5 $ + toBeInField confGithuddSleepSeconds $ + forConfigItemKey "githudd_sleep_seconds" $ + withValue "5" + + , testCase "Key: githudd_pid_file_path" $ + expectValue "/tmp" $ + toBeInField confGithuddPidFilePath $ + forConfigItemKey "githudd_pid_file_path" $ + withValue "/tmp" + + , testCase "Key: githudd_socket_file_path" $ + expectValue "/tmp" $ + toBeInField confGithuddSocketFilePath $ + forConfigItemKey "githudd_socket_file_path" $ + withValue "/tmp" + + , testCase "Key: githudd_log_file_path" $ + expectValue DevNull $ + toBeInField confGithuddLogFilePath $ + forConfigItemKey "githudd_log_file_path" $ + withValue "/dev/null" ] expectValue :: (Eq a, Show a) => a -> a -> Assertion expectValue expected actual = actual @?= expected toBeInField :: (Config -> a) -> Config -> a -toBeInField accessor config = accessor config +toBeInField = id forConfigItemKey :: String -> String -> Config forConfigItemKey key value = configItemsFolder defaultConfig (Item key value) -withValue :: a -> a +withValue :: String -> String withValue = id utilConfigItemParser :: Parser ConfigItem -> String -> ConfigItem @@ -489,9 +523,47 @@ stringConfigToStringList "foo,bar" @?= ["foo", "bar"] , testCase "valid string list, comma separated, spaces" $ - stringConfigToStringList "foo, bar , baz " @?= ["foo", "bar", "baz"] + stringConfigToStringList "foo, bar , baz " @?= ["foo", "bar", "baz"] , testCase "valid string list, comma separated, finish with comma" $ stringConfigToStringList "foo,bar, " @?= ["foo", "bar"] ] +testStringConfigToRedirection :: TestTree +testStringConfigToRedirection = testGroup "#strConfigToRedirection" + [ testCase "dev null" $ + strConfigToRedirection "/dev/null" @?= DevNull + + , testCase "other path" $ + strConfigToRedirection "/foo/bar" @?= ToFile "/foo/bar" + ] + +testBoolConfigToBool :: TestTree +testBoolConfigToBool = testGroup "#boolConfigToBool" + [ testCase "True" $ + boolConfigToBool "True" @?= True + + , testCase "true" $ + boolConfigToBool "true" @?= True + + , testCase "yes" $ + boolConfigToBool "yes" @?= True + + , testCase "False" $ + boolConfigToBool "False" @?= False + + , testCase "Defaults to False on failed parsing" $ + boolConfigToBool "foo" @?= False + ] + +testIntConfigToInt :: TestTree +testIntConfigToInt = testGroup "#intConfigToInt" + [ testCase "standard valid int" $ + intConfigToInt "12" @?= 12 + + , testCase "Cuts to the integer part found" $ + intConfigToInt "12.5" @?= 12 + + , testCase "any bad value defaults to 5" $ + intConfigToInt "foo" @?= 5 + ]