1
1
mirror of https://github.com/github/semantic.git synced 2024-12-23 23:11:50 +03:00
semantic/test/GitmonClientSpec.hs
2017-03-28 09:41:16 -07:00

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