2017-02-23 00:34:04 +03:00
|
|
|
{-# LANGUAGE RecordWildCards, BangPatterns #-}
|
2017-02-15 04:42:35 +03:00
|
|
|
module GitmonClient where
|
|
|
|
|
2017-02-22 22:15:58 +03:00
|
|
|
import Prologue hiding (toStrict)
|
2017-02-15 04:42:35 +03:00
|
|
|
import Prelude
|
|
|
|
import Data.Aeson
|
|
|
|
import Data.Aeson.Types
|
2017-02-22 22:15:58 +03:00
|
|
|
import Git.Libgit2
|
2017-02-23 01:52:03 +03:00
|
|
|
import Arguments
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-22 22:15:32 +03:00
|
|
|
import Network.Socket
|
|
|
|
import Network.Socket.ByteString (sendAll)
|
2017-02-15 04:42:35 +03:00
|
|
|
|
|
|
|
import Data.ByteString.Lazy (toStrict)
|
|
|
|
|
2017-02-23 00:34:28 +03:00
|
|
|
data ProcessStats =
|
|
|
|
ProcessBeforeStats { gitDir :: String
|
|
|
|
, program :: String
|
|
|
|
, realIP :: Maybe String
|
|
|
|
, repoID :: Maybe String
|
|
|
|
, repoName :: Maybe String
|
|
|
|
, userID :: Maybe String
|
|
|
|
, via :: String }
|
|
|
|
| ProcessAfterStats { cpu :: Integer
|
|
|
|
, diskReadBytes :: Integer
|
|
|
|
, diskWriteBytes :: Integer
|
|
|
|
, resultCode :: Integer } deriving (Generic, Show)
|
|
|
|
|
|
|
|
instance ToJSON ProcessStats where
|
2017-02-15 04:42:35 +03:00
|
|
|
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelTo2 '_' }
|
|
|
|
|
|
|
|
data GitmonCommand = Update
|
|
|
|
| Finish
|
|
|
|
| Schedule deriving (Show)
|
|
|
|
|
|
|
|
instance ToJSON GitmonCommand where
|
|
|
|
toJSON command = String $ case command of
|
|
|
|
Update -> "update"
|
|
|
|
Finish -> "finish"
|
|
|
|
Schedule -> "schedule"
|
|
|
|
|
2017-02-23 00:34:28 +03:00
|
|
|
data GitmonMsg = GitmonMsg { command :: GitmonCommand, stats :: ProcessStats } deriving (Show)
|
2017-02-15 04:42:35 +03:00
|
|
|
|
|
|
|
instance ToJSON GitmonMsg where
|
|
|
|
toJSON GitmonMsg{..} = object [
|
|
|
|
"command" .= command,
|
|
|
|
"data" .= stats
|
|
|
|
]
|
|
|
|
|
2017-02-23 00:35:05 +03:00
|
|
|
processJSON :: GitmonCommand -> ProcessStats -> ByteString
|
|
|
|
processJSON command stats = toStrict . encode $ GitmonMsg command stats
|
|
|
|
|
2017-02-23 01:52:03 +03:00
|
|
|
reportGitmon :: String -> Arguments -> ReaderT LgRepo IO a -> ReaderT LgRepo IO a
|
|
|
|
reportGitmon program Arguments{..} gitCommand = do
|
2017-02-22 22:15:58 +03:00
|
|
|
soc <- liftIO $ socket AF_UNIX Stream defaultProtocol
|
2017-02-22 23:54:43 +03:00
|
|
|
safeIO $ connect soc (SockAddrUnix "/tmp/gitstats.sock")
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-23 01:52:03 +03:00
|
|
|
safeIO $ sendAll soc (processJSON Update ProcessBeforeStats { gitDir = gitDir, via = "semantic-diff", program = program, realIP = realIP, repoID = repoID, repoName = repoName, userID = userID })
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-23 01:29:50 +03:00
|
|
|
!result <- gitCommand
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-23 00:35:05 +03:00
|
|
|
safeIO $ sendAll soc (processJSON Finish ProcessAfterStats { cpu = 100, diskReadBytes = 1000, diskWriteBytes = 1000, resultCode = 0 })
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-23 00:35:05 +03:00
|
|
|
safeIO $ close soc
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-22 23:54:43 +03:00
|
|
|
return result
|
|
|
|
|
|
|
|
where safeIO :: MonadIO m => IO () -> m ()
|
|
|
|
safeIO command = liftIO $ command `catch` noop
|
2017-02-23 00:35:05 +03:00
|
|
|
|
2017-02-22 23:54:43 +03:00
|
|
|
noop :: IOException -> IO ()
|
|
|
|
noop _ = return ()
|