githud 2.1.0 → 3.0.0

raw patch · 11 files changed

+362/−32 lines, 11 filesdep +bytestringdep +daemonsdep +data-defaultdep ~basedep ~mtldep ~parsecnew-component:exe:githuddPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, daemons, data-default, directory, network, utf8-string

Dependency ranges changed: base, mtl, parsec, tasty, tasty-hunit, tasty-quickcheck

API changes (from Hackage documentation)

Files

• app/Main.hs +0/−6
• app/githud/Main.hs +6/−0
• app/githudd/Main.hs +6/−0
• githud.cabal +32/−16
• src/GitHUD.hs +19/−4
• src/GitHUD/Config/Parse.hs +49/−2
• src/GitHUD/Config/Types.hs +22/−0
• src/GitHUD/Daemon/Network.hs +57/−0
• src/GitHUD/Daemon/Runner.hs +80/−0
• src/GitHUD/Git/Command.hs +16/−1
• test/Test/GitHUD/Config/Parse.hs +75/−3

@@ -1,6 +0,0 @@-module Main where--import GitHUD--main :: IO ()-main = githud

@@ -0,0 +1,6 @@+module Main where++import GitHUD++main :: IO ()+main = githud

@@ -0,0 +1,6 @@+module Main where++import GitHUD++main :: IO ()+main = githudd

@@ -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

@@ -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

@@ -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"

@@ -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 }

@@ -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))

@@ -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 ()

@@ -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 ()

@@ -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+  ]