2017-02-24 01:03:01 +03:00
|
|
|
{-# LANGUAGE RecordWildCards, BangPatterns, DeriveGeneric #-}
|
2017-02-15 04:42:35 +03:00
|
|
|
module GitmonClient where
|
|
|
|
|
2017-02-24 01:03:26 +03:00
|
|
|
import Arguments
|
2017-02-24 01:03:01 +03:00
|
|
|
import qualified Data.Yaml as Y
|
2017-02-15 04:42:35 +03:00
|
|
|
import Data.Aeson
|
|
|
|
import Data.Aeson.Types
|
2017-02-24 01:03:26 +03:00
|
|
|
import Data.ByteString.Lazy (toStrict)
|
|
|
|
import GHC.Generics
|
2017-02-22 22:15:58 +03:00
|
|
|
import Git.Libgit2
|
2017-02-22 22:15:32 +03:00
|
|
|
import Network.Socket
|
|
|
|
import Network.Socket.ByteString (sendAll)
|
2017-02-24 01:03:26 +03:00
|
|
|
import Prelude
|
|
|
|
import Prologue hiding (toStrict)
|
2017-02-24 01:01:53 +03:00
|
|
|
import System.Clock
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-24 01:03:01 +03:00
|
|
|
data ProcIO = ProcIO {
|
|
|
|
read_bytes :: Integer
|
|
|
|
, write_bytes :: Integer
|
|
|
|
} deriving (Show, Generic)
|
|
|
|
|
|
|
|
instance FromJSON ProcIO
|
|
|
|
|
|
|
|
|
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 '_' }
|
|
|
|
|
2017-02-24 01:04:24 +03:00
|
|
|
|
2017-02-15 04:42:35 +03:00
|
|
|
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-24 01:04:24 +03:00
|
|
|
|
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-24 01:01:53 +03:00
|
|
|
|
2017-02-24 03:42:07 +03:00
|
|
|
gitmonSocketAddr :: String
|
|
|
|
gitmonSocketAddr = "/tmp/gitstats.sock"
|
|
|
|
|
2017-02-24 01:01:53 +03:00
|
|
|
clock :: Clock
|
|
|
|
clock = Realtime
|
|
|
|
|
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-24 03:42:07 +03:00
|
|
|
safeIO $ connect soc (SockAddrUnix gitmonSocketAddr)
|
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-24 01:01:53 +03:00
|
|
|
startTime <- liftIO $ getTime clock
|
2017-02-24 01:03:01 +03:00
|
|
|
beforeProcIOContents <- liftIO (Y.decodeFileEither "/proc/self/io" :: IO (Either Y.ParseException (Maybe ProcIO)))
|
|
|
|
|
2017-02-23 01:29:50 +03:00
|
|
|
!result <- gitCommand
|
2017-02-15 04:42:35 +03:00
|
|
|
|
2017-02-24 01:01:53 +03:00
|
|
|
endTime <- liftIO $ getTime clock
|
2017-02-24 01:03:01 +03:00
|
|
|
afterProcIOContents <- liftIO (Y.decodeFileEither "/proc/self/io" :: IO (Either Y.ParseException (Maybe ProcIO)))
|
|
|
|
|
|
|
|
let beforeDiskReadBytes = either (const 0) (maybe 0 read_bytes) beforeProcIOContents
|
|
|
|
let afterDiskReadBytes = either (const 0) (maybe 0 read_bytes) afterProcIOContents
|
|
|
|
let beforeDiskWriteBytes = either (const 0) (maybe 0 write_bytes) beforeProcIOContents
|
|
|
|
let afterDiskWriteBytes = either (const 0) (maybe 0 write_bytes) afterProcIOContents
|
|
|
|
|
|
|
|
safeIO $ sendAll soc (processJSON Finish ProcessAfterStats { cpu = toNanoSecs endTime - toNanoSecs startTime, diskReadBytes = afterDiskReadBytes - beforeDiskReadBytes, diskWriteBytes = afterDiskWriteBytes - beforeDiskWriteBytes, 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 ()
|