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-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)
|
|
|
|
|
|
|
|
data Stats =
|
|
|
|
StartStats { repoName :: String
|
|
|
|
, via :: String
|
|
|
|
, gitDir :: String
|
|
|
|
, program :: String
|
|
|
|
, realIP :: Maybe String
|
|
|
|
, repoID :: Maybe String
|
|
|
|
, userID :: Maybe String }
|
|
|
|
| FinishStats { cpu :: Integer
|
|
|
|
, diskReadBytes :: Integer
|
|
|
|
, diskWriteBytes :: Integer
|
|
|
|
, resultCode :: Integer } deriving (Generic, Show)
|
|
|
|
|
|
|
|
instance ToJSON Stats where
|
|
|
|
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"
|
|
|
|
|
|
|
|
data GitmonMsg = GitmonMsg { command :: GitmonCommand, stats :: Stats } deriving (Show)
|
|
|
|
|
|
|
|
instance ToJSON GitmonMsg where
|
|
|
|
toJSON GitmonMsg{..} = object [
|
|
|
|
"command" .= command,
|
|
|
|
"data" .= stats
|
|
|
|
]
|
|
|
|
|
2017-02-22 22:14:12 +03:00
|
|
|
reportGitmon :: ReaderT LgRepo IO a -> ReaderT LgRepo IO a
|
|
|
|
reportGitmon command = 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-22 22:15:58 +03:00
|
|
|
let startStats = StartStats { repoName = "test-js", via = "gitrpc", gitDir = "/Users/vera/github/test-js", program = "semantic-diff", realIP = Nothing, repoID = Nothing, userID = Nothing }
|
2017-02-15 04:42:35 +03:00
|
|
|
let startStatsJSON = toStrict . encode $ GitmonMsg Update startStats
|
2017-02-22 23:54:43 +03:00
|
|
|
safeIO $ sendAll soc startStatsJSON
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-22 23:54:43 +03:00
|
|
|
result <- command
|
2017-02-15 04:42:35 +03:00
|
|
|
|
|
|
|
let finishStats = FinishStats { cpu = 100, diskReadBytes = 1000, diskWriteBytes = 1000, resultCode = 0 }
|
|
|
|
let finishStatsJSON = toStrict . encode $ GitmonMsg Finish finishStats
|
2017-02-23 00:34:04 +03:00
|
|
|
!result <- command
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-22 23:54:43 +03:00
|
|
|
safeIO $ sendAll soc finishStatsJSON `catch` noop
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-22 23:54:43 +03:00
|
|
|
safeIO $ close soc `catch` noop
|
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
|
|
|
|
|
|
|
|
noop :: IOException -> IO ()
|
|
|
|
noop _ = return ()
|