Merge remote-tracking branch 'origin/batch-copy-terms' into typescript

semantic-diff.cabal

@@ -63,6 +63,7 @@ library
                      , FDoc.Term
                      , FDoc.RecursionSchemes
                      , FDoc.NatExample
+                     , GitmonClient
   build-depends:       base >= 4.8 && < 5
                      , aeson
                      , aeson-pretty
@@ -106,6 +107,9 @@ library
                      , ruby
                      , javascript
                      , typescript
+                     , network
+                     , clock
+                     , yaml
   default-language:    Haskell2010
   default-extensions:  DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveGeneric, FlexibleContexts, FlexibleInstances, OverloadedStrings, NoImplicitPrelude, RecordWildCards, LambdaCase, StrictData
   ghc-options:        -Wall -fno-warn-name-shadowing -O2 -j
@@ -148,6 +152,7 @@ test-suite test
                      , Data.RandomWalkSimilarity.Spec
                      , DiffSpec
                      , SummarySpec
+                     , GitmonClientSpec
                      , InterpreterSpec
                      , PatchOutputSpec
                      , RangeSpec
@@ -167,6 +172,7 @@ test-suite test
                      , deepseq
                      , filepath
                      , gitlib
+                     , gitlib-libgit2
                      , Glob
                      , hspec >= 2.4.1
                      , hspec-core
@@ -174,11 +180,14 @@ test-suite test
                      , HUnit
                      , leancheck
                      , mtl
+                     , network
                      , protolude
                      , containers
                      , recursion-schemes >= 4.1
+                     , regex-compat
                      , semantic-diff
                      , text >= 1.2.1.3
+                     , unordered-containers
                      , these
                      , vector
   ghc-options:       -threaded -rtsopts -with-rtsopts=-N -j -pgml=script/g++

src/DiffCommand.hs

@@ -20,6 +20,7 @@ import Arguments
 import Category
 import Data.RandomWalkSimilarity
 import Data.Record
+import GitmonClient
 import Info
 import Diff
 import Interpreter
@@ -102,29 +103,30 @@ blobEntriesToDiff shas = do
   a <- blobEntries (fst shas)
   b <- blobEntries (snd shas)
   pure $ (a \\ b) <> (b \\ a)
-  where blobEntries sha = treeForCommitSha sha >>= treeBlobEntries
+  where blobEntries sha = treeForCommitSha sha >>= treeBlobEntries'
+        treeBlobEntries' tree = reportGitmon "ls-tree" $ treeBlobEntries tree
 
 -- | Returns a Git.Tree for a commit sha
 treeForCommitSha :: String -> ReaderT LgRepo IO (Git.Tree LgRepo)
 treeForCommitSha sha = do
   object <- parseObjOid (toS sha)
-  commit <- lookupCommit object
+  commit <- reportGitmon "cat-file" $ lookupCommit object
-  lookupTree (commitTree commit)
+  reportGitmon "cat-file" $ lookupTree (commitTree commit)
 
 -- | Returns a SourceBlob given a relative file path, and the sha to look up.
-getSourceBlob :: FilePath -> String -> ReaderT LgRepo IO SourceBlob
+getSourceBlob :: FilePath -> String -> ReaderT LgRepo IO Source.SourceBlob
 getSourceBlob path sha = do
   tree <- treeForCommitSha sha
-  entry <- treeEntry tree (toS path)
+  entry <- reportGitmon "ls-tree" $ treeEntry tree (toS path)
   (bytestring, oid, mode) <- case entry of
     Nothing -> pure (mempty, mempty, Nothing)
     Just (BlobEntry entryOid entryKind) -> do
-      blob <- lookupBlob entryOid
+      blob <- reportGitmon "cat-file" $ lookupBlob entryOid
       s <- blobToByteString blob
       let oid = renderObjOid $ blobOid blob
       pure (s, oid, Just entryKind)
   s <- liftIO $ transcode bytestring
-  pure $ SourceBlob s (toS oid) path (toSourceKind <$> mode)
+  pure $ Source.SourceBlob s (toS oid) path (toSourceKind <$> mode)
   where
     toSourceKind :: Git.BlobKind -> SourceKind
     toSourceKind (Git.PlainBlob mode) = Source.PlainBlob mode

src/GitmonClient.hs

@@ -0,0 +1,168 @@
+-- | We use BangPatterns to force evaluation of git operations to preserve accuracy in measuring system stats (particularly disk read bytes)
+{-# LANGUAGE RecordWildCards, DeriveGeneric, RankNTypes, BangPatterns #-}
+module GitmonClient where
+
+import Control.Exception (throw)
+import Data.Aeson
+import Data.Aeson.Types
+import Data.ByteString.Lazy (toStrict)
+import Data.Char (toLower)
+import Data.Text (unpack, isInfixOf)
+import qualified Data.Yaml as Y
+import GHC.Generics
+import Git.Libgit2
+import Network.Socket hiding (recv)
+import Network.Socket.ByteString (sendAll, recv)
+import Prelude
+import Prologue hiding (toStrict, map, print, show)
+import System.Clock
+import System.Environment
+import System.Timeout
+import Text.Regex
+
+newtype GitmonException = GitmonException String deriving (Show, Typeable)
+
+instance Exception GitmonException
+
+
+data ProcIO = ProcIO { readBytes :: Integer
+                     , writeBytes :: Integer } deriving (Show, Generic)
+
+instance FromJSON ProcIO
+
+instance ToJSON ProcIO where
+  toJSON ProcIO{..} = object [ "read_bytes" .= readBytes, "write_bytes" .= writeBytes ]
+
+
+data ProcessData = ProcessUpdateData { gitDir :: Maybe String
+                                     , program :: String
+                                     , realIP :: Maybe String
+                                     , repoName :: Maybe String
+                                     , repoID :: Maybe Int
+                                     , userID :: Maybe Int
+                                     , via :: String }
+                 | ProcessScheduleData
+                 | ProcessFinishData { cpu :: Integer
+                                     , diskReadBytes :: Integer
+                                     , diskWriteBytes :: Integer
+                                     , resultCode :: Integer } deriving (Generic, Show)
+
+instance ToJSON ProcessData where
+  toJSON ProcessUpdateData{..} = object [ "git_dir" .= gitDir, "program" .= program, "repo_name" .= repoName, "real_ip" .= realIP, "repo_id" .= repoID, "user_id" .= userID, "via" .= via ]
+  toJSON ProcessScheduleData   = object []
+  toJSON ProcessFinishData{..} = object [ "cpu" .= cpu, "disk_read_bytes" .= diskReadBytes, "disk_write_bytes" .= diskWriteBytes, "result_code" .= resultCode ]
+
+
+data GitmonCommand = Update
+                   | Finish
+                   | Schedule deriving (Generic, Show)
+
+instance ToJSON GitmonCommand where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = map toLower }
+
+
+data GitmonMsg = GitmonMsg { command :: GitmonCommand
+                           , processData :: ProcessData } deriving (Show)
+
+instance ToJSON GitmonMsg where
+  toJSON GitmonMsg{..} = case command of
+    Update -> object ["command" .= ("update" :: String), "data" .= processData]
+    Finish -> object ["command" .= ("finish" :: String), "data" .= processData]
+    Schedule -> object ["command" .= ("schedule" :: String)]
+
+
+type ProcInfo = Either Y.ParseException (Maybe ProcIO)
+
+newtype SocketFactory = SocketFactory { withSocket :: forall a. (Socket -> IO a) -> IO a }
+
+reportGitmon :: String -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a
+reportGitmon = reportGitmon' SocketFactory { withSocket = withGitmonSocket }
+
+reportGitmon' :: SocketFactory -> String -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a
+reportGitmon' SocketFactory{..} program gitCommand =
+  join . liftIO . withSocket $ \sock -> do
+    [gitDir, realIP, repoName, repoID, userID] <- traverse lookupEnv ["GIT_DIR", "GIT_SOCKSTAT_VAR_real_ip", "GIT_SOCKSTAT_VAR_repo_name", "GIT_SOCKSTAT_VAR_repo_id", "GIT_SOCKSTAT_VAR_user_id"]
+    void . safeGitmonIO . sendAll sock $ processJSON Update (ProcessUpdateData gitDir program realIP repoName (readIntFromEnv repoID) (readIntFromEnv userID) "semantic-diff")
+    void . safeGitmonIO . sendAll sock $ processJSON Schedule ProcessScheduleData
+    gitmonStatus <- safeGitmonIO $ recv sock 1024
+
+    (startTime, beforeProcIOContents) <- collectStats
+    -- | The result of the gitCommand is strictly evaluated (to next normal form). This is not equivalent to a `deepseq`. The underlying `Git.Types` do not have instances of `NFData` preventing us from using `deepseq` at this time.
+    let !result = withGitmonStatus gitmonStatus gitCommand
+    (afterTime, afterProcIOContents) <- collectStats
+
+    let (cpuTime, diskReadBytes, diskWriteBytes, resultCode) = procStats startTime afterTime beforeProcIOContents afterProcIOContents
+    void . safeGitmonIO . sendAll sock $ processJSON Finish (ProcessFinishData cpuTime diskReadBytes diskWriteBytes resultCode)
+    pure result
+
+  where
+    withGitmonStatus :: Maybe ByteString -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a
+    withGitmonStatus maybeGitmonStatus gitCommand = case maybeGitmonStatus of
+      Just gitmonStatus | "fail" `isInfixOf` decodeUtf8 gitmonStatus -> throwGitmonException gitmonStatus
+      _ -> gitCommand
+
+    throwGitmonException :: ByteString -> e
+    throwGitmonException command = throw . GitmonException . unpack $ "Received: '" <> decodeUtf8 command <> "' from Gitmon"
+
+    collectStats :: IO (TimeSpec, ProcInfo)
+    collectStats = do
+      time <- getTime clock
+      procIOContents <- Y.decodeFileEither procFileAddr :: IO ProcInfo
+      pure (time, procIOContents)
+
+    procStats :: TimeSpec -> TimeSpec -> ProcInfo -> ProcInfo -> ( Integer, Integer, Integer, Integer )
+    procStats beforeTime afterTime beforeProcIOContents afterProcIOContents = ( cpuTime, diskReadBytes, diskWriteBytes, resultCode )
+      where
+        -- | toNanoSecs converts TimeSpec to Integer, and we further convert this value to milliseconds (expected by Gitmon).
+        cpuTime = div (1 * 1000 * 1000) . toNanoSecs $ afterTime - beforeTime
+        beforeDiskReadBytes = either (const 0) (maybe 0 readBytes) beforeProcIOContents
+        afterDiskReadBytes = either (const 0) (maybe 0 readBytes) afterProcIOContents
+        beforeDiskWriteBytes = either (const 0) (maybe 0 writeBytes) beforeProcIOContents
+        afterDiskWriteBytes = either (const 0) (maybe 0 writeBytes) afterProcIOContents
+        diskReadBytes = afterDiskReadBytes - beforeDiskReadBytes
+        diskWriteBytes = afterDiskWriteBytes - beforeDiskWriteBytes
+        resultCode = 0
+
+    readIntFromEnv :: Maybe String -> Maybe Int
+    readIntFromEnv Nothing = Nothing
+    readIntFromEnv (Just s) = readInt $ matchRegex regex s
+      where
+        -- | Expected format for userID and repoID is: "uint:123",
+        -- where "uint:" indicates an unsigned integer followed by an integer value.
+        regex :: Regex
+        regex = mkRegexWithOpts "^uint:([0-9]+)$" False True
+
+        readInt :: Maybe [String] -> Maybe Int
+        readInt (Just [s]) = Just (read s :: Int)
+        readInt _ = Nothing
+
+withGitmonSocket :: (Socket -> IO c) -> IO c
+withGitmonSocket = bracket connectSocket close
+  where
+    connectSocket = do
+      s <- socket AF_UNIX Stream defaultProtocol
+      void . safeGitmonIO $ connect s (SockAddrUnix gitmonSocketAddr)
+      pure s
+
+-- | Timeout in nanoseconds to wait before giving up on Gitmon response to schedule.
+gitmonTimeout :: Int
+gitmonTimeout = 1 * 1000 * 1000
+
+gitmonSocketAddr :: String
+gitmonSocketAddr = "/tmp/gitstats.sock"
+
+safeGitmonIO :: MonadIO m => IO a -> m (Maybe a)
+safeGitmonIO command = liftIO $ timeout gitmonTimeout command `catch` logError
+
+logError :: IOException -> IO (Maybe a)
+logError _ = pure Nothing
+
+procFileAddr :: String
+procFileAddr = "/proc/self/io"
+
+clock :: Clock
+clock = Realtime
+
+processJSON :: GitmonCommand -> ProcessData -> ByteString
+processJSON command processData = toStrict . encode $ GitmonMsg command processData
+

src/TreeSitter.hs

@@ -19,6 +19,7 @@ import Source
 import qualified Syntax
 import Foreign
 import Foreign.C.String (peekCString)
+import Foreign.Marshal.Array (allocaArray)
 import Data.Text.Foreign (withCStringLen)
 import qualified Syntax as S
 import Term
@@ -42,39 +43,40 @@ treeSitterParser language grammar blob = do
 
 -- | Return a parser for a tree sitter language & document.
 documentToTerm :: Language -> Ptr Document -> Parser (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan])
-documentToTerm language document SourceBlob{..} = alloca $ \ root -> do
+documentToTerm language document SourceBlob{..} = do
-  ts_document_root_node_p document root
+  root <- alloca (\ rootPtr -> do
-  toTerm root (totalRange source) source
+    ts_document_root_node_p document rootPtr
-  where toTerm node range source = do
+    peek rootPtr)
-          name <- ts_node_p_name node document
+  toTerm root source
-          name <- peekCString name
+  where toTerm :: Node -> Source -> IO (Term (Syntax.Syntax Text) (Record '[Range, Category, SourceSpan]))
-          count <- ts_node_p_named_child_count node
+        toTerm node source = do
+          name <- peekCString (nodeType node)
 
-          let getChild getter parentNode n childNode = do
+          children <- getChildren (fromIntegral (nodeNamedChildCount node)) copyNamed
-                _ <- getter parentNode n childNode
+          let allChildren = getChildren (fromIntegral (nodeChildCount node)) copyAll
-                let childRange = nodeRange childNode
-                toTerm childNode childRange (slice (offsetRange childRange (negate (start range))) source)
 
-          children <- filter isNonEmpty <$> traverse (alloca . getChild ts_node_p_named_child node) (take (fromIntegral count) [0..])
+          assignTerm language source (range :. categoryForLanguageProductionName language (toS name) :. nodeSpan node :. Nil) children allChildren
+          where getChildren count copy = do
+                  nodes <- allocaArray count $ \ childNodesPtr -> do
+                    _ <- with (nodeTSNode node) (\ nodePtr -> copy nodePtr childNodesPtr (fromIntegral count))
+                    peekArray count childNodesPtr
+                  children <- traverse childNodeToTerm nodes
+                  return $! filter isNonEmpty children
+                childNodeToTerm childNode = toTerm childNode (slice (offsetRange (nodeRange childNode) (negate (start range))) source)
+                range = nodeRange node
+        copyNamed = ts_node_copy_named_child_nodes document
+        copyAll = ts_node_copy_child_nodes document
 
-          let startPos = SourcePos (1 + (fromIntegral $! ts_node_p_start_point_row node)) (1 + (fromIntegral $! ts_node_p_start_point_column node))
-          let endPos = SourcePos (1 + (fromIntegral $! ts_node_p_end_point_row node)) (1 + (fromIntegral $! ts_node_p_end_point_column node))
-          let sourceSpan = SourceSpan { spanStart = startPos , spanEnd = endPos }
-
-          allChildrenCount <- ts_node_p_child_count node
-          let allChildren = filter isNonEmpty <$> traverse (alloca . getChild ts_node_p_child node) (take (fromIntegral allChildrenCount) [0..])
-
-          -- Note: The strict application here is semantically important.
-          -- Without it, we may not evaluate the value until after we’ve exited
-          -- the scope that `node` was allocated within, meaning `alloca` will
-          -- free it & other stack data may overwrite it.
-          range `seq` sourceSpan `seq` assignTerm language source (range :. categoryForLanguageProductionName language (toS name) :. sourceSpan :. Nil) children allChildren
 
 isNonEmpty :: HasField fields Category => SyntaxTerm Text fields -> Bool
 isNonEmpty = (/= Empty) . category . extract
 
-nodeRange :: Ptr Node -> Range
+nodeRange :: Node -> Range
-nodeRange node = Range { start = fromIntegral (ts_node_p_start_byte node), end = fromIntegral (ts_node_p_end_byte node) }
+nodeRange Node{..} = Range (fromIntegral nodeStartByte) (fromIntegral nodeEndByte)
+
+nodeSpan :: Node -> SourceSpan
+nodeSpan Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` SourceSpan (pointPos nodeStartPoint) (pointPos nodeEndPoint)
+  where pointPos TSPoint{..} = pointRow `seq` pointColumn `seq` SourcePos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
 
 assignTerm :: Language -> Source -> Record '[Range, Category, SourceSpan] -> [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO [ SyntaxTerm Text '[ Range, Category, SourceSpan ] ] -> IO (SyntaxTerm Text '[ Range, Category, SourceSpan ])
 assignTerm language source annotation children allChildren =

test/GitmonClientSpec.hs

@@ -0,0 +1,193 @@
+module GitmonClientSpec where
+
+import Control.Exception
+import Data.Aeson
+import Data.Aeson.Types
+import Data.ByteString.Char8 (ByteString, pack, unpack)
+import Data.Foldable
+import Data.HashMap.Lazy (empty)
+import Data.Maybe (fromMaybe)
+import Data.Text hiding (empty)
+import Git.Libgit2
+import Git.Repository
+import Git.Types hiding (Object)
+import GitmonClient
+import Network.Socket hiding (recv)
+import Network.Socket.ByteString
+import Prelude hiding (lookup)
+import Prologue (liftIO, runReaderT)
+import System.Environment (setEnv)
+import Test.Hspec hiding (shouldBe, shouldSatisfy, shouldThrow, anyErrorCall)
+import Test.Hspec.Expectations.Pretty
+import Text.Regex
+
+spec :: Spec
+spec =
+  describe "gitmon" $ do
+    let wd = "test/fixtures/git/examples/all-languages.git"
+        realIP' = "127.0.0.1"
+        repoName' = "examples/all-languages"
+
+    it "receives commands in order" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ sendAll server "continue"
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, scheduleData, finishData] = infoToCommands info
+
+        liftIO $ do
+          shouldBe (commitOid commit) object
+          shouldBe updateData (Just "update")
+          shouldBe scheduleData (Just "schedule")
+          shouldBe finishData (Just "finish")
+
+    it "receives update command with correct data" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ do
+          traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:10"), ("GIT_SOCKSTAT_VAR_user_id", "uint:20")]
+          sendAll server "continue"
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, _, finishData] = infoToData info
+
+        liftIO $ do
+          shouldBe (commitOid commit) object
+          shouldBe (either Just gitDir updateData) (Just wd)
+          shouldBe (either id program updateData) "cat-file"
+          shouldBe (either Just realIP updateData) (Just "127.0.0.1")
+          shouldBe (either Just repoName updateData) (Just "examples/all-languages")
+          shouldBe (either (const $ Just 1) repoID updateData) (Just 10)
+          shouldBe (either (const $ Just 1) userID updateData) (Just 20)
+          shouldBe (either id via updateData) "semantic-diff"
+
+          shouldSatisfy (either (const (-1)) cpu finishData) (>= 0)
+          shouldSatisfy (either (const (-1)) diskReadBytes finishData) (>= 0)
+          shouldSatisfy (either (const (-1)) diskWriteBytes finishData) (>= 0)
+          shouldSatisfy (either (const (-1)) resultCode finishData) (>= 0)
+
+    it "reads Nothing for user_id and repo_id when valid prefix but invalid value" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ do
+          traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:not_valid"), ("GIT_SOCKSTAT_VAR_user_id", "uint:not_valid")]
+          sendAll server "continue"
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, _, _] = infoToData info
+
+        liftIO $ do
+          shouldBe (either (const $ Just 1) repoID updateData) Nothing
+          shouldBe (either (const $ Just 1) userID updateData) Nothing
+
+    it "reads Nothing for user_id and repo_id when valid prefix but value is preceeded by invalid chars" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ do
+          traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:abc100"), ("GIT_SOCKSTAT_VAR_user_id", "uint:abc100")]
+          sendAll server "continue"
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, _, _] = infoToData info
+
+        liftIO $ do
+          shouldBe (either (const $ Just 1) repoID updateData) Nothing
+          shouldBe (either (const $ Just 1) userID updateData) Nothing
+
+    it "reads Nothing for user_id and repo_id when valid prefix but value is proceeded by invalid chars" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ do
+          traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "uint:100abc"), ("GIT_SOCKSTAT_VAR_user_id", "uint:100abc")]
+          sendAll server "continue"
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, _, _] = infoToData info
+
+        liftIO $ do
+          shouldBe (either (const $ Just 1) repoID updateData) Nothing
+          shouldBe (either (const $ Just 1) userID updateData) Nothing
+
+    it "reads Nothing for user_id and repo_id when missing prefix but value is valid" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ do
+          traverse_ (uncurry setEnv) [("GIT_DIR", wd), ("GIT_SOCKSTAT_VAR_real_ip", realIP'), ("GIT_SOCKSTAT_VAR_repo_name", repoName'), ("GIT_SOCKSTAT_VAR_repo_id", "100"), ("GIT_SOCKSTAT_VAR_user_id", "100")]
+          sendAll server "continue"
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        _ <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        let [updateData, _, _] = infoToData info
+
+        liftIO $ do
+          shouldBe (either (const $ Just 1) repoID updateData) Nothing
+          shouldBe (either (const $ Just 1) userID updateData) Nothing
+
+    it "returns the correct git result if the socket is unavailable" . withSocketPair $ \(client, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        liftIO $ close client
+
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+        commit <- reportGitmon' socketFactory "cat-file" $ lookupCommit object
+        info <- liftIO $ recv server 1024
+
+        liftIO $ shouldBe (commitOid commit) object
+        liftIO $ shouldBe "" info
+
+    it "throws if schedule response is fail" . withSocketPair $ \(_, server, socketFactory) ->
+      withRepository lgFactory wd $ do
+        repo <- getRepository
+        liftIO $ sendAll server "fail too busy"
+        object <- parseObjOid (Data.Text.pack "dfac8fd681b0749af137aebf3203e77a06fbafc2")
+
+        liftIO $ shouldThrow (runReaderT (reportGitmon' socketFactory "cat-file" (lookupCommit object)) repo) gitmonException
+
+gitmonException :: GitmonException -> Bool
+gitmonException = const True
+
+withSocketPair :: ((Socket, Socket, SocketFactory) -> IO c) -> IO c
+withSocketPair = bracket create release
+  where
+    create = do
+      (client, server) <- socketPair AF_UNIX Stream defaultProtocol
+      pure (client, server, SocketFactory (\f -> f client))
+    release (client, server, _) = do
+      close client
+      close server
+
+infoToCommands :: ByteString -> [Maybe Text]
+infoToCommands input = command' . toObject <$> extract regex input
+  where
+    command' :: Object -> Maybe Text
+    command' = parseMaybe (.: "command")
+
+infoToData :: ByteString -> [Either String ProcessData]
+infoToData input = data' . toObject <$> extract regex input
+  where
+    data' = parseEither parser
+    parser o = do
+      dataO <- o .: "data"
+      asum [ ProcessUpdateData <$> (dataO .: "git_dir") <*> (dataO .: "program") <*> (dataO .:? "real_ip") <*> (dataO .:? "repo_name") <*> (dataO .:? "repo_id") <*> (dataO .:? "user_id") <*> (dataO .: "via")
+           , ProcessFinishData <$> (dataO .: "cpu") <*> (dataO .: "disk_read_bytes") <*> (dataO .: "disk_write_bytes") <*> (dataO .: "result_code")
+           , pure ProcessScheduleData
+           ]
+
+toObject :: ByteString -> Object
+toObject input = fromMaybe empty (decodeStrict input)
+
+regex :: Regex
+regex = mkRegexWithOpts "(\\{.*\"update\".*\"\\}\\})(\\{.*\"schedule\"\\})(\\{.*\"finish\".*\\}\\})" False True
+
+extract :: Regex -> ByteString -> [ByteString]
+extract regex input = Data.ByteString.Char8.pack <$> fromMaybe [""] (matchRegex regex (Data.ByteString.Char8.unpack input))

test/Spec.hs

@@ -6,6 +6,7 @@ import qualified Data.Mergeable.Spec
 import qualified Data.RandomWalkSimilarity.Spec
 import qualified DiffSpec
 import qualified SummarySpec
+import qualified GitmonClientSpec
 import qualified InterpreterSpec
 import qualified PatchOutputSpec
 import qualified RangeSpec
@@ -19,19 +20,22 @@ import qualified IntegrationSpec
 import Test.Hspec
 
 main :: IO ()
-main = hspec . parallel $ do
+main = do
-  describe "Alignment" AlignmentSpec.spec
+  hspec . parallel $ do
-  describe "Data.Mergeable" Data.Mergeable.Spec.spec
+    describe "Alignment" AlignmentSpec.spec
-  describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
+    describe "Data.Mergeable" Data.Mergeable.Spec.spec
-  describe "Diff" DiffSpec.spec
+    describe "Data.RandomWalkSimilarity" Data.RandomWalkSimilarity.Spec.spec
-  describe "Summary" SummarySpec.spec
+    describe "Diff" DiffSpec.spec
-  describe "Interpreter" InterpreterSpec.spec
+    describe "Summary" SummarySpec.spec
-  describe "PatchOutput" PatchOutputSpec.spec
+    describe "Interpreter" InterpreterSpec.spec
-  describe "Range" RangeSpec.spec
+    describe "PatchOutput" PatchOutputSpec.spec
-  describe "SES.Myers" SES.Myers.Spec.spec
+    describe "Range" RangeSpec.spec
-  describe "Source" SourceSpec.spec
+    describe "SES.Myers" SES.Myers.Spec.spec
-  describe "Term" TermSpec.spec
+    describe "Source" SourceSpec.spec
-  describe "TOC" TOCSpec.spec
+    describe "Term" TermSpec.spec
-  describe "DiffCommand" DiffCommandSpec.spec
+    describe "TOC" TOCSpec.spec
-  describe "ParseCommand" ParseCommandSpec.spec
+    describe "DiffCommand" DiffCommandSpec.spec
-  describe "Integration" IntegrationSpec.spec
+    describe "ParseCommand" ParseCommandSpec.spec
+    describe "Integration" IntegrationSpec.spec
+
+  hspec $ describe "GitmonClient" GitmonClientSpec.spec