Store keys as ByteStrings
[ganeti-github.git] / src / Ganeti / Monitoring / Server.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 {-| Implementation of the Ganeti confd server functionality.
4
5 -}
6
7 {-
8
9 Copyright (C) 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 module Ganeti.Monitoring.Server
38 ( main
39 , checkMain
40 , prepMain
41 , DataCollector(..)
42 ) where
43
44 import Control.Applicative
45 import Control.DeepSeq (force)
46 import Control.Exception.Base (evaluate)
47 import Control.Monad
48 import Control.Monad.IO.Class
49 import Data.ByteString.Char8 (pack, unpack)
50 import qualified Data.ByteString.UTF8 as UTF8
51 import Data.Maybe (fromMaybe)
52 import Data.List (find)
53 import Data.Monoid (mempty)
54 import qualified Data.Map as Map
55 import qualified Data.PSQueue as Queue
56 import Network.BSD (getServicePortNumber)
57 import Snap.Core
58 import Snap.Http.Server
59 import qualified Text.JSON as J
60 import Control.Concurrent
61
62 import qualified Ganeti.BasicTypes as BT
63 import Ganeti.Confd.Client
64 import Ganeti.Confd.Types
65 import qualified Ganeti.Confd.Types as CT
66 import Ganeti.Daemon
67 import qualified Ganeti.DataCollectors as DC
68 import Ganeti.DataCollectors.Types
69 import qualified Ganeti.JSON as GJ
70 import Ganeti.Objects (DataCollectorConfig(..))
71 import qualified Ganeti.Constants as C
72 import qualified Ganeti.ConstantUtils as CU
73 import Ganeti.Runtime
74 import Ganeti.Utils (getCurrentTimeUSec, withDefaultOnIOError)
75
76 -- * Types and constants definitions
77
78 type ConfigAccess = String -> DataCollectorConfig
79
80 -- | Type alias for checkMain results.
81 type CheckResult = ()
82
83 -- | Type alias for prepMain results.
84 type PrepResult = Config Snap ()
85
86 -- | Version of the latest supported http API.
87 latestAPIVersion :: Int
88 latestAPIVersion = C.mondLatestApiVersion
89
90 -- * Configuration handling
91
92 -- | The default configuration for the HTTP server.
93 defaultHttpConf :: FilePath -> FilePath -> Config Snap ()
94 defaultHttpConf accessLog errorLog =
95 setAccessLog (ConfigFileLog accessLog) .
96 setCompression False .
97 setErrorLog (ConfigFileLog errorLog) $
98 setVerbose False
99 emptyConfig
100
101 -- * Helper functions
102
103 -- | Check function for the monitoring agent.
104 checkMain :: CheckFn CheckResult
105 checkMain _ = return $ Right ()
106
107 -- | Prepare function for monitoring agent.
108 prepMain :: PrepFn CheckResult PrepResult
109 prepMain opts _ = do
110 accessLog <- daemonsExtraLogFile GanetiMond AccessLog
111 errorLog <- daemonsExtraLogFile GanetiMond ErrorLog
112 defaultPort <- withDefaultOnIOError C.defaultMondPort
113 . liftM fromIntegral
114 $ getServicePortNumber C.mond
115 return .
116 setPort
117 (maybe defaultPort fromIntegral (optPort opts)) .
118 maybe id (setBind . pack) (optBindAddress opts)
119 $ defaultHttpConf accessLog errorLog
120
121 -- * Query answers
122
123 -- | Reply to the supported API version numbers query.
124 versionQ :: Snap ()
125 versionQ = writeBS . pack $ J.encode [latestAPIVersion]
126
127 -- | Version 1 of the monitoring HTTP API.
128 version1Api :: MVar CollectorMap -> MVar ConfigAccess -> Snap ()
129 version1Api mvar mvarConfig =
130 let returnNull = writeBS . pack $ J.encode J.JSNull :: Snap ()
131 in ifTop returnNull <|>
132 route
133 [ ("list", listHandler mvarConfig)
134 , ("report", reportHandler mvar mvarConfig)
135 ]
136
137 -- | Gives a lookup function for DataCollectorConfig that corresponds to the
138 -- configuration known to RConfD.
139 collectorConfigs :: ConfdClient -> IO ConfigAccess
140 collectorConfigs confdClient = do
141 response <- query confdClient CT.ReqDataCollectors CT.EmptyQuery
142 return $ lookupConfig response
143 where
144 lookupConfig :: Maybe ConfdReply -> String -> DataCollectorConfig
145 lookupConfig response name = fromMaybe (mempty :: DataCollectorConfig) $ do
146 confdReply <- response
147 let answer = CT.confdReplyAnswer confdReply
148 case J.readJSON answer :: J.Result (GJ.Container DataCollectorConfig) of
149 J.Error _ -> Nothing
150 J.Ok container -> GJ.lookupContainer Nothing (UTF8.fromString name)
151 container
152
153 activeCollectors :: MVar ConfigAccess -> IO [DataCollector]
154 activeCollectors mvarConfig = do
155 configs <- readMVar mvarConfig
156 return $ filter (dataCollectorActive . configs . dName) DC.collectors
157
158 -- | Get the JSON representation of a data collector to be used in the collector
159 -- list.
160 dcListItem :: DataCollector -> J.JSValue
161 dcListItem dc =
162 J.JSArray
163 [ J.showJSON $ dName dc
164 , maybe defaultCategory J.showJSON $ dCategory dc
165 , J.showJSON $ dKind dc
166 ]
167 where
168 defaultCategory = J.showJSON C.mondDefaultCategory
169
170 -- | Handler for returning lists.
171 listHandler :: MVar ConfigAccess -> Snap ()
172 listHandler mvarConfig = dir "collectors" $ do
173 collectors' <- liftIO $ activeCollectors mvarConfig
174 writeBS . pack . J.encode $ map dcListItem collectors'
175
176 -- | Handler for returning data collector reports.
177 reportHandler :: MVar CollectorMap -> MVar ConfigAccess -> Snap ()
178 reportHandler mvar mvarConfig =
179 route
180 [ ("all", allReports mvar mvarConfig)
181 , (":category/:collector", oneReport mvar mvarConfig)
182 ] <|>
183 errorReport
184
185 -- | Return the report of all the available collectors.
186 allReports :: MVar CollectorMap -> MVar ConfigAccess -> Snap ()
187 allReports mvar mvarConfig = do
188 collectors' <- liftIO $ activeCollectors mvarConfig
189 reports <- mapM (liftIO . getReport mvar) collectors'
190 writeBS . pack . J.encode $ reports
191
192 -- | Takes the CollectorMap and a DataCollector and returns the report for this
193 -- collector.
194 getReport :: MVar CollectorMap -> DataCollector -> IO DCReport
195 getReport mvar collector =
196 case dReport collector of
197 StatelessR r -> r
198 StatefulR r -> do
199 colData <- getColData (dName collector) mvar
200 r colData
201
202 -- | Returns the data for the corresponding collector.
203 getColData :: String -> MVar CollectorMap -> IO (Maybe CollectorData)
204 getColData name mvar = do
205 m <- readMVar mvar
206 return $ Map.lookup name m
207
208 -- | Returns a category given its name.
209 -- If "collector" is given as the name, the collector has no category, and
210 -- Nothing will be returned.
211 catFromName :: String -> BT.Result (Maybe DCCategory)
212 catFromName "instance" = BT.Ok $ Just DCInstance
213 catFromName "storage" = BT.Ok $ Just DCStorage
214 catFromName "daemon" = BT.Ok $ Just DCDaemon
215 catFromName "hypervisor" = BT.Ok $ Just DCHypervisor
216 catFromName "default" = BT.Ok Nothing
217 catFromName _ = BT.Bad "No such category"
218
219 errorReport :: Snap ()
220 errorReport = do
221 modifyResponse $ setResponseStatus 404 "Not found"
222 writeBS "Unable to produce a report for the requested resource"
223
224 error404 :: Snap ()
225 error404 = do
226 modifyResponse $ setResponseStatus 404 "Not found"
227 writeBS "Resource not found"
228
229 -- | Return the report of one collector.
230 oneReport :: MVar CollectorMap -> MVar ConfigAccess -> Snap ()
231 oneReport mvar mvarConfig = do
232 collectors' <- liftIO $ activeCollectors mvarConfig
233 categoryName <- maybe mzero unpack <$> getParam "category"
234 collectorName <- maybe mzero unpack <$> getParam "collector"
235 category <-
236 case catFromName categoryName of
237 BT.Ok cat -> return cat
238 BT.Bad msg -> fail msg
239 collector <-
240 case
241 find (\col -> collectorName == dName col) $
242 filter (\c -> category == dCategory c) collectors' of
243 Just col -> return col
244 Nothing -> fail "Unable to find the requested collector"
245 dcr <- liftIO $ getReport mvar collector
246 writeBS . pack . J.encode $ dcr
247
248 -- | The function implementing the HTTP API of the monitoring agent.
249 monitoringApi :: MVar CollectorMap -> MVar ConfigAccess -> Snap ()
250 monitoringApi mvar mvarConfig =
251 ifTop versionQ <|>
252 dir "1" (version1Api mvar mvarConfig) <|>
253 error404
254
255 -- | The function collecting data for each data collector providing a dcUpdate
256 -- function.
257 collect :: CollectorMap -> DataCollector -> IO CollectorMap
258 collect m collector =
259 case dUpdate collector of
260 Nothing -> return m
261 Just update -> do
262 let name = dName collector
263 existing = Map.lookup name m
264 new_data <- update existing
265 _ <- evaluate $ force new_data
266 return $ Map.insert name new_data m
267
268 -- | Invokes collect for each data collector.
269 collection :: CollectorMap -> MVar ConfigAccess -> IO CollectorMap
270 collection m mvarConfig = do
271 collectors <- activeCollectors mvarConfig
272 foldM collect m collectors
273
274 -- | Convert seconds to microseconds
275 seconds :: Int -> Integer
276 seconds = (* 1000000) . fromIntegral
277
278 -- | The thread responsible for the periodical collection of data for each data
279 -- data collector. Note that even though the collectors might be deactivated,
280 -- they will still be collected to provide a complete history.
281 collectord :: MVar CollectorMap -> MVar ConfigAccess -> IO ()
282 collectord mvar mvarConfig = do
283 let queue = Queue.fromAscList . map (Queue.:-> 0)
284 $ CU.toList C.dataCollectorNames
285 foldM_ update queue [0::Integer ..]
286 where
287 resetTimer configs = Queue.adjustWithKey ((+) . dataCollectorInterval
288 . configs)
289 resetAll configs = foldr (resetTimer configs)
290 keyInList = flip . const . flip elem
291 update q _ = do
292 t <- getCurrentTimeUSec
293 configs <- readMVar mvarConfig
294 m <- takeMVar mvar
295 let dueNames = map Queue.key $ Queue.atMost t q
296 dueEntries = Map.filterWithKey (keyInList dueNames) m
297 m' <- collection dueEntries mvarConfig
298 let m'' = m' `Map.union` m
299 putMVar mvar m''
300 let q' = resetAll configs q dueNames
301 maxSleep = seconds C.mondTimeInterval
302 nextWakeup = fromMaybe maxSleep . liftM Queue.prio $ Queue.findMin q'
303 delay = min maxSleep nextWakeup
304 threadDelay $ fromInteger delay
305 return q'
306
307 -- | Main function.
308 main :: MainFn CheckResult PrepResult
309 main _ _ httpConf = do
310 mvarCollectorMap <- newMVar Map.empty
311 mvarConfig <- newEmptyMVar
312 confdClient <- getConfdClient Nothing Nothing
313 void . forkIO . forever $ do
314 configs <- collectorConfigs confdClient
315 putMVar mvarConfig configs
316 threadDelay . fromInteger $ seconds C.mondConfigTimeInterval
317 takeMVar mvarConfig
318 void . forkIO $ collectord mvarCollectorMap mvarConfig
319 httpServe httpConf . method GET $ monitoringApi mvarCollectorMap mvarConfig