mirror of
https://github.com/github/semantic.git
synced 2024-12-27 17:05:33 +03:00
194 lines
8.9 KiB
Haskell
194 lines
8.9 KiB
Haskell
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))
|