module Ganeti.MaintD.CollectIncidents
( collectIncidents
) where
import Control.Applicative (liftA2)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.UTF8 as UTF8
import Data.IORef (IORef)
import Network.Curl
import System.Time (getClockTime)
import qualified Text.JSON as J
import Ganeti.BasicTypes (ResultT)
import qualified Ganeti.Constants as C
import qualified Ganeti.DataCollectors.Diagnose as D
import Ganeti.DataCollectors.Types (getCategoryName)
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
import Ganeti.Logging.Lifted
import Ganeti.MaintD.MemoryState (MemoryState, getIncidents, updateIncident)
import Ganeti.Objects.Maintenance
import Ganeti.Utils (newUUID)
queryStatus :: Node.Node -> IO (Maybe J.JSValue)
queryStatus node = do
let name = Node.name node
let url = name ++ ":" ++ show C.defaultMondPort
++ "/1/report/" ++ maybe "default" getCategoryName D.dcCategory
++ "/" ++ D.dcName
if Node.offline node
then do
logDebug $ "Not asking " ++ name ++ "; it is offline"
return Nothing
else do
(code, body) <- liftIO $ curlGetString url []
case code of
CurlOK ->
case J.decode body of
J.Ok r -> return $ Just r
_ -> return Nothing
_ -> do
logWarning $ "Failed to contact " ++ name
return Nothing
updateNode :: IORef MemoryState -> Node.Node -> ResultT String IO ()
updateNode memstate node = do
let name = Node.name node
logDebug $ "Inspecting " ++ name
report <- liftIO $ queryStatus node
case report of
Just (J.JSObject obj)
| Just orig@(J.JSObject origobj) <- lookup "data" $ J.fromJSObject obj,
Just s <- lookup "status" $ J.fromJSObject origobj,
J.Ok state <- J.readJSON s,
state /= RANoop -> do
let origs = J.encode orig
logDebug $ "Relevant event on " ++ name ++ ": " ++ origs
incidents <- getIncidents memstate
unless (any (liftA2 (&&)
((==) name . incidentNode)
((==) orig . incidentOriginal)) incidents) $ do
logInfo $ "Registering new incident on " ++ name ++ ": " ++ origs
uuid <- liftIO newUUID
now <- liftIO getClockTime
let tag = C.maintdSuccessTagPrefix ++ uuid
incident = Incident { incidentOriginal = orig
, incidentAction = state
, incidentRepairStatus = RSNoted
, incidentJobs = []
, incidentNode = name
, incidentTag = tag
, incidentUuid = UTF8.fromString uuid
, incidentCtime = now
, incidentMtime = now
, incidentSerial = 1
}
liftIO $ updateIncident memstate incident
_ -> return ()
collectIncidents :: IORef MemoryState -> Node.List -> ResultT String IO ()
collectIncidents memstate nl = do
_ <- getIncidents memstate
logDebug "Querying all nodes for incidents"
mapM_ (updateNode memstate) $ Container.elems nl