|
1 |
{-# LANGUAGE BangPatterns #-}
|
|
2 |
|
|
3 |
{-| Implementation of the Ganeti confd server functionality.
|
|
4 |
|
|
5 |
-}
|
|
6 |
|
|
7 |
{-
|
|
8 |
|
|
9 |
Copyright (C) 2011 Google Inc.
|
|
10 |
|
|
11 |
This program is free software; you can redistribute it and/or modify
|
|
12 |
it under the terms of the GNU General Public License as published by
|
|
13 |
the Free Software Foundation; either version 2 of the License, or
|
|
14 |
(at your option) any later version.
|
|
15 |
|
|
16 |
This program is distributed in the hope that it will be useful, but
|
|
17 |
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
18 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
19 |
General Public License for more details.
|
|
20 |
|
|
21 |
You should have received a copy of the GNU General Public License
|
|
22 |
along with this program; if not, write to the Free Software
|
|
23 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
|
|
24 |
02110-1301, USA.
|
|
25 |
|
|
26 |
-}
|
|
27 |
|
|
28 |
module Ganeti.Confd.Server
|
|
29 |
( main
|
|
30 |
) where
|
|
31 |
|
|
32 |
import Control.Concurrent
|
|
33 |
import Control.Monad (forever)
|
|
34 |
import qualified Data.ByteString as B
|
|
35 |
import Data.IORef
|
|
36 |
import Data.List
|
|
37 |
import qualified Data.Map as M
|
|
38 |
import qualified Network.Socket as S
|
|
39 |
import System.Posix.Files
|
|
40 |
import System.Posix.Types
|
|
41 |
import System.Time
|
|
42 |
import qualified Text.JSON as J
|
|
43 |
import System.INotify
|
|
44 |
|
|
45 |
import Ganeti.Daemon
|
|
46 |
import Ganeti.HTools.JSON
|
|
47 |
import Ganeti.HTools.Types
|
|
48 |
import Ganeti.HTools.Utils
|
|
49 |
import Ganeti.Objects
|
|
50 |
import Ganeti.Confd
|
|
51 |
import Ganeti.Config
|
|
52 |
import Ganeti.Hash
|
|
53 |
import Ganeti.Logging
|
|
54 |
import qualified Ganeti.Constants as C
|
|
55 |
|
|
56 |
-- * Types and constants definitions
|
|
57 |
|
|
58 |
-- | What we store as configuration.
|
|
59 |
type CRef = IORef (Result (ConfigData, LinkIpMap))
|
|
60 |
|
|
61 |
-- | File stat identifier.
|
|
62 |
type FStat = (EpochTime, FileID, FileOffset)
|
|
63 |
|
|
64 |
-- | Null 'FStat' value.
|
|
65 |
nullFStat :: FStat
|
|
66 |
nullFStat = (-1, -1, -1)
|
|
67 |
|
|
68 |
-- | A small type alias for readability.
|
|
69 |
type StatusAnswer = (ConfdReplyStatus, J.JSValue)
|
|
70 |
|
|
71 |
-- | Reload model data type.
|
|
72 |
data ReloadModel = ReloadNotify -- ^ We are using notifications
|
|
73 |
| ReloadPoll Int -- ^ We are using polling
|
|
74 |
deriving (Eq, Show)
|
|
75 |
|
|
76 |
-- | Server state data type.
|
|
77 |
data ServerState = ServerState
|
|
78 |
{ reloadModel :: ReloadModel
|
|
79 |
, reloadTime :: Integer
|
|
80 |
, reloadFStat :: FStat
|
|
81 |
}
|
|
82 |
|
|
83 |
-- | Maximum no-reload poll rounds before reverting to inotify.
|
|
84 |
maxIdlePollRounds :: Int
|
|
85 |
maxIdlePollRounds = 2
|
|
86 |
|
|
87 |
-- | Reload timeout in microseconds.
|
|
88 |
configReloadTimeout :: Int
|
|
89 |
configReloadTimeout = C.confdConfigReloadTimeout * 1000000
|
|
90 |
|
|
91 |
-- | Ratelimit timeout in microseconds.
|
|
92 |
configReloadRatelimit :: Int
|
|
93 |
configReloadRatelimit = C.confdConfigReloadRatelimit * 1000000
|
|
94 |
|
|
95 |
-- | Initial poll round.
|
|
96 |
initialPoll :: ReloadModel
|
|
97 |
initialPoll = ReloadPoll 0
|
|
98 |
|
|
99 |
-- | Initial server state.
|
|
100 |
initialState :: ServerState
|
|
101 |
initialState = ServerState initialPoll 0 nullFStat
|
|
102 |
|
|
103 |
-- | Reload status data type.
|
|
104 |
data ConfigReload = ConfigToDate -- ^ No need to reload
|
|
105 |
| ConfigReloaded -- ^ Configuration reloaded
|
|
106 |
| ConfigIOError -- ^ Error during configuration reload
|
|
107 |
|
|
108 |
-- | Unknown entry standard response.
|
|
109 |
queryUnknownEntry :: StatusAnswer
|
|
110 |
queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
|
|
111 |
|
|
112 |
{- not used yet
|
|
113 |
-- | Internal error standard response.
|
|
114 |
queryInternalError :: StatusAnswer
|
|
115 |
queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
|
|
116 |
-}
|
|
117 |
|
|
118 |
-- | Argument error standard response.
|
|
119 |
queryArgumentError :: StatusAnswer
|
|
120 |
queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
|
|
121 |
|
|
122 |
-- | Returns the current time.
|
|
123 |
getCurrentTime :: IO Integer
|
|
124 |
getCurrentTime = do
|
|
125 |
TOD ctime _ <- getClockTime
|
|
126 |
return ctime
|
|
127 |
|
|
128 |
-- * Confd base functionality
|
|
129 |
|
|
130 |
-- | Returns the HMAC key.
|
|
131 |
getClusterHmac :: IO HashKey
|
|
132 |
getClusterHmac = fmap B.unpack $ B.readFile C.confdHmacKey
|
|
133 |
|
|
134 |
-- | Computes the node role.
|
|
135 |
nodeRole :: ConfigData -> String -> Result ConfdNodeRole
|
|
136 |
nodeRole cfg name =
|
|
137 |
let cmaster = clusterMasterNode . configCluster $ cfg
|
|
138 |
mnode = M.lookup name . configNodes $ cfg
|
|
139 |
in case mnode of
|
|
140 |
Nothing -> Bad "Node not found"
|
|
141 |
Just node | cmaster == name -> Ok NodeRoleMaster
|
|
142 |
| nodeDrained node -> Ok NodeRoleDrained
|
|
143 |
| nodeOffline node -> Ok NodeRoleOffline
|
|
144 |
| nodeMasterCandidate node -> Ok NodeRoleCandidate
|
|
145 |
_ -> Ok NodeRoleRegular
|
|
146 |
|
|
147 |
-- | Does an instance ip -> instance -> primary node -> primary ip
|
|
148 |
-- transformation.
|
|
149 |
getNodePipByInstanceIp :: ConfigData
|
|
150 |
-> LinkIpMap
|
|
151 |
-> String
|
|
152 |
-> String
|
|
153 |
-> StatusAnswer
|
|
154 |
getNodePipByInstanceIp cfg linkipmap link instip =
|
|
155 |
case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
|
|
156 |
Nothing -> queryUnknownEntry
|
|
157 |
Just instname ->
|
|
158 |
case getInstPrimaryNode cfg instname of
|
|
159 |
Bad _ -> queryUnknownEntry -- either instance or node not found
|
|
160 |
Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
|
|
161 |
|
|
162 |
-- | Builds the response to a given query.
|
|
163 |
buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
|
|
164 |
buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
|
|
165 |
return (ReplyStatusOk, J.showJSON (configVersion cfg))
|
|
166 |
|
|
167 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
|
|
168 |
case confdRqQuery req of
|
|
169 |
EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
|
|
170 |
PlainQuery _ -> return queryArgumentError
|
|
171 |
DictQuery reqq -> do
|
|
172 |
mnode <- getNode cfg master_name
|
|
173 |
let fvals =map (\field -> case field of
|
|
174 |
ReqFieldName -> master_name
|
|
175 |
ReqFieldIp -> clusterMasterIp cluster
|
|
176 |
ReqFieldMNodePip -> nodePrimaryIp mnode
|
|
177 |
) (confdReqQFields reqq)
|
|
178 |
return (ReplyStatusOk, J.showJSON fvals)
|
|
179 |
where master_name = clusterMasterNode cluster
|
|
180 |
cluster = configCluster cfg
|
|
181 |
cfg = fst cdata
|
|
182 |
|
|
183 |
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
|
|
184 |
node_name <- case confdRqQuery req of
|
|
185 |
PlainQuery str -> return str
|
|
186 |
_ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
|
|
187 |
role <- nodeRole (fst cdata) node_name
|
|
188 |
return (ReplyStatusOk, J.showJSON role)
|
|
189 |
|
|
190 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
|
|
191 |
-- note: we use foldlWithKey because that's present accross more
|
|
192 |
-- versions of the library
|
|
193 |
return (ReplyStatusOk, J.showJSON $
|
|
194 |
M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
|
|
195 |
(configNodes (fst cdata)))
|
|
196 |
|
|
197 |
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
|
|
198 |
-- note: we use foldlWithKey because that's present accross more
|
|
199 |
-- versions of the library
|
|
200 |
return (ReplyStatusOk, J.showJSON $
|
|
201 |
M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
|
|
202 |
then nodePrimaryIp n:accu
|
|
203 |
else accu) []
|
|
204 |
(configNodes (fst cdata)))
|
|
205 |
|
|
206 |
buildResponse (cfg, linkipmap)
|
|
207 |
req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
|
|
208 |
link <- case confdRqQuery req of
|
|
209 |
PlainQuery str -> return str
|
|
210 |
EmptyQuery -> return (getDefaultNicLink cfg)
|
|
211 |
_ -> fail "Invalid query type"
|
|
212 |
return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
|
|
213 |
|
|
214 |
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
|
|
215 |
, confdRqQuery = DictQuery query}) =
|
|
216 |
let (cfg, linkipmap) = cdata
|
|
217 |
link = maybe (getDefaultNicLink cfg) id (confdReqQLink query)
|
|
218 |
in case confdReqQIp query of
|
|
219 |
Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
|
|
220 |
Nothing -> return (ReplyStatusOk,
|
|
221 |
J.showJSON $
|
|
222 |
map (getNodePipByInstanceIp cfg linkipmap link)
|
|
223 |
(confdReqQIpList query))
|
|
224 |
|
|
225 |
buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
|
|
226 |
return queryArgumentError
|
|
227 |
|
|
228 |
-- | Parses a signed request.
|
|
229 |
parseRequest :: HashKey -> String -> Result (String, String, ConfdRequest)
|
|
230 |
parseRequest key str = do
|
|
231 |
(SignedMessage hmac msg salt) <- fromJResult "parsing request" $ J.decode str
|
|
232 |
req <- if verifyMac key (Just salt) msg hmac
|
|
233 |
then fromJResult "parsing message" $ J.decode msg
|
|
234 |
else Bad "HMAC verification failed"
|
|
235 |
return (salt, msg, req)
|
|
236 |
|
|
237 |
-- | Creates a ConfdReply from a given answer.
|
|
238 |
serializeResponse :: Result StatusAnswer -> ConfdReply
|
|
239 |
serializeResponse r =
|
|
240 |
let (status, result) = case r of
|
|
241 |
Bad err -> (ReplyStatusError, J.showJSON err)
|
|
242 |
Ok (code, val) -> (code, val)
|
|
243 |
in ConfdReply { confdReplyProtocol = 1
|
|
244 |
, confdReplyStatus = status
|
|
245 |
, confdReplyAnswer = result
|
|
246 |
, confdReplySerial = 0 }
|
|
247 |
|
|
248 |
-- | Signs a message with a given key and salt.
|
|
249 |
signMessage :: HashKey -> String -> String -> SignedMessage
|
|
250 |
signMessage key salt msg =
|
|
251 |
SignedMessage { signedMsgMsg = msg
|
|
252 |
, signedMsgSalt = salt
|
|
253 |
, signedMsgHmac = hmac
|
|
254 |
}
|
|
255 |
where hmac = computeMac key (Just salt) msg
|
|
256 |
|
|
257 |
-- * Configuration handling
|
|
258 |
|
|
259 |
-- ** Helper functions
|
|
260 |
|
|
261 |
-- | Helper function for logging transition into polling mode.
|
|
262 |
moveToPolling :: String -> INotify -> FilePath -> CRef -> MVar ServerState
|
|
263 |
-> IO ReloadModel
|
|
264 |
moveToPolling msg inotify path cref mstate = do
|
|
265 |
logInfo $ "Moving to polling mode: " ++ msg
|
|
266 |
let inotiaction = addNotifier inotify path cref mstate
|
|
267 |
_ <- forkIO $ onReloadTimer inotiaction path cref mstate
|
|
268 |
return initialPoll
|
|
269 |
|
|
270 |
-- | Helper function for logging transition into inotify mode.
|
|
271 |
moveToNotify :: IO ReloadModel
|
|
272 |
moveToNotify = do
|
|
273 |
logInfo "Moving to inotify mode"
|
|
274 |
return ReloadNotify
|
|
275 |
|
|
276 |
-- ** Configuration loading
|
|
277 |
|
|
278 |
-- | (Re)loads the configuration.
|
|
279 |
updateConfig :: FilePath -> CRef -> IO ()
|
|
280 |
updateConfig path r = do
|
|
281 |
newcfg <- loadConfig path
|
|
282 |
let !newdata = case newcfg of
|
|
283 |
Ok !cfg -> Ok (cfg, buildLinkIpInstnameMap cfg)
|
|
284 |
Bad _ -> Bad "Cannot load configuration"
|
|
285 |
writeIORef r newdata
|
|
286 |
case newcfg of
|
|
287 |
Ok cfg -> logInfo ("Loaded new config, serial " ++
|
|
288 |
show (configSerial cfg))
|
|
289 |
Bad msg -> logError $ "Failed to load config: " ++ msg
|
|
290 |
return ()
|
|
291 |
|
|
292 |
-- | Wrapper over 'updateConfig' that handles IO errors.
|
|
293 |
safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
|
|
294 |
safeUpdateConfig path oldfstat cref = do
|
|
295 |
catch (do
|
|
296 |
nt <- needsReload oldfstat path
|
|
297 |
case nt of
|
|
298 |
Nothing -> return (oldfstat, ConfigToDate)
|
|
299 |
Just nt' -> do
|
|
300 |
updateConfig path cref
|
|
301 |
return (nt', ConfigReloaded)
|
|
302 |
) (\e -> do
|
|
303 |
let msg = "Failure during configuration update: " ++ show e
|
|
304 |
writeIORef cref (Bad msg)
|
|
305 |
return (nullFStat, ConfigIOError)
|
|
306 |
)
|
|
307 |
|
|
308 |
-- | Computes the file cache data from a FileStatus structure.
|
|
309 |
buildFileStatus :: FileStatus -> FStat
|
|
310 |
buildFileStatus ofs =
|
|
311 |
let modt = modificationTime ofs
|
|
312 |
inum = fileID ofs
|
|
313 |
fsize = fileSize ofs
|
|
314 |
in (modt, inum, fsize)
|
|
315 |
|
|
316 |
-- | Wrapper over 'buildFileStatus'. This reads the data from the
|
|
317 |
-- filesystem and then builds our cache structure.
|
|
318 |
getFStat :: FilePath -> IO FStat
|
|
319 |
getFStat p = getFileStatus p >>= (return . buildFileStatus)
|
|
320 |
|
|
321 |
-- | Check if the file needs reloading
|
|
322 |
needsReload :: FStat -> FilePath -> IO (Maybe FStat)
|
|
323 |
needsReload oldstat path = do
|
|
324 |
newstat <- getFStat path
|
|
325 |
return $ if newstat /= oldstat
|
|
326 |
then Just newstat
|
|
327 |
else Nothing
|
|
328 |
|
|
329 |
-- ** Watcher threads
|
|
330 |
|
|
331 |
-- $watcher
|
|
332 |
-- We have three threads/functions that can mutate the server state:
|
|
333 |
--
|
|
334 |
-- 1. the long-interval watcher ('onTimeoutTimer')
|
|
335 |
--
|
|
336 |
-- 2. the polling watcher ('onReloadTimer')
|
|
337 |
--
|
|
338 |
-- 3. the inotify event handler ('onInotify')
|
|
339 |
--
|
|
340 |
-- All of these will mutate the server state under 'modifyMVar' or
|
|
341 |
-- 'modifyMVar_', so that server transitions are more or less
|
|
342 |
-- atomic. The inotify handler remains active during polling mode, but
|
|
343 |
-- checks for polling mode and doesn't do anything in this case (this
|
|
344 |
-- check is needed even if we would unregister the event handler due
|
|
345 |
-- to how events are serialised).
|
|
346 |
|
|
347 |
-- | Long-interval reload watcher.
|
|
348 |
--
|
|
349 |
-- This is on top of the inotify-based triggered reload.
|
|
350 |
onTimeoutTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
|
|
351 |
onTimeoutTimer inotiaction path cref state = do
|
|
352 |
threadDelay configReloadTimeout
|
|
353 |
modifyMVar_ state (onTimeoutInner path cref)
|
|
354 |
_ <- inotiaction
|
|
355 |
onTimeoutTimer inotiaction path cref state
|
|
356 |
|
|
357 |
-- | Inner onTimeout handler.
|
|
358 |
--
|
|
359 |
-- This mutates the server state under a modifyMVar_ call. It never
|
|
360 |
-- changes the reload model, just does a safety reload and tried to
|
|
361 |
-- re-establish the inotify watcher.
|
|
362 |
onTimeoutInner :: FilePath -> CRef -> ServerState -> IO ServerState
|
|
363 |
onTimeoutInner path cref state = do
|
|
364 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
|
|
365 |
return state { reloadFStat = newfstat }
|
|
366 |
|
|
367 |
-- | Short-interval (polling) reload watcher.
|
|
368 |
--
|
|
369 |
-- This is only active when we're in polling mode; it will
|
|
370 |
-- automatically exit when it detects that the state has changed to
|
|
371 |
-- notification.
|
|
372 |
onReloadTimer :: IO Bool -> FilePath -> CRef -> MVar ServerState -> IO ()
|
|
373 |
onReloadTimer inotiaction path cref state = do
|
|
374 |
continue <- modifyMVar state (onReloadInner inotiaction path cref)
|
|
375 |
if continue
|
|
376 |
then do
|
|
377 |
threadDelay configReloadRatelimit
|
|
378 |
onReloadTimer inotiaction path cref state
|
|
379 |
else -- the inotify watch has been re-established, we can exit
|
|
380 |
return ()
|
|
381 |
|
|
382 |
-- | Inner onReload handler.
|
|
383 |
--
|
|
384 |
-- This again mutates the state under a modifyMVar call, and also
|
|
385 |
-- returns whether the thread should continue or not.
|
|
386 |
onReloadInner :: IO Bool -> FilePath -> CRef -> ServerState
|
|
387 |
-> IO (ServerState, Bool)
|
|
388 |
onReloadInner _ _ _ state@(ServerState { reloadModel = ReloadNotify } ) =
|
|
389 |
return (state, False)
|
|
390 |
onReloadInner inotiaction path cref
|
|
391 |
state@(ServerState { reloadModel = ReloadPoll pround } ) = do
|
|
392 |
(newfstat, reload) <- safeUpdateConfig path (reloadFStat state) cref
|
|
393 |
let state' = state { reloadFStat = newfstat }
|
|
394 |
-- compute new poll model based on reload data; however, failure to
|
|
395 |
-- re-establish the inotifier means we stay on polling
|
|
396 |
newmode <- case reload of
|
|
397 |
ConfigToDate ->
|
|
398 |
if pround >= maxIdlePollRounds
|
|
399 |
then do -- try to switch to notify
|
|
400 |
result <- inotiaction
|
|
401 |
if result
|
|
402 |
then moveToNotify
|
|
403 |
else return initialPoll
|
|
404 |
else return (ReloadPoll (pround + 1))
|
|
405 |
_ -> return initialPoll
|
|
406 |
let continue = case newmode of
|
|
407 |
ReloadNotify -> False
|
|
408 |
_ -> True
|
|
409 |
return (state' { reloadModel = newmode }, continue)
|
|
410 |
|
|
411 |
-- | Setup inotify watcher.
|
|
412 |
--
|
|
413 |
-- This tries to setup the watch descriptor; in case of any IO errors,
|
|
414 |
-- it will return False.
|
|
415 |
addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
|
|
416 |
addNotifier inotify path cref mstate = do
|
|
417 |
catch (addWatch inotify [CloseWrite] path
|
|
418 |
(onInotify inotify path cref mstate) >> return True)
|
|
419 |
(const $ return False)
|
|
420 |
|
|
421 |
-- | Inotify event handler.
|
|
422 |
onInotify :: INotify -> String -> CRef -> MVar ServerState -> Event -> IO ()
|
|
423 |
onInotify inotify path cref mstate Ignored = do
|
|
424 |
logInfo "File lost, trying to re-establish notifier"
|
|
425 |
modifyMVar_ mstate $ \state -> do
|
|
426 |
result <- addNotifier inotify path cref mstate
|
|
427 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
|
|
428 |
let state' = state { reloadFStat = newfstat }
|
|
429 |
if result
|
|
430 |
then return state' -- keep notify
|
|
431 |
else do
|
|
432 |
mode <- moveToPolling "cannot re-establish inotify watch" inotify
|
|
433 |
path cref mstate
|
|
434 |
return state' { reloadModel = mode }
|
|
435 |
|
|
436 |
onInotify inotify path cref mstate _ = do
|
|
437 |
modifyMVar_ mstate $ \state ->
|
|
438 |
if (reloadModel state == ReloadNotify)
|
|
439 |
then do
|
|
440 |
ctime <- getCurrentTime
|
|
441 |
(newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
|
|
442 |
let state' = state { reloadFStat = newfstat, reloadTime = ctime }
|
|
443 |
if abs (reloadTime state - ctime) <
|
|
444 |
fromIntegral C.confdConfigReloadRatelimit
|
|
445 |
then do
|
|
446 |
mode <- moveToPolling "too many reloads" inotify path cref mstate
|
|
447 |
return state' { reloadModel = mode }
|
|
448 |
else return state'
|
|
449 |
else return state
|
|
450 |
|
|
451 |
-- ** Client input/output handlers
|
|
452 |
|
|
453 |
-- | Main loop for a given client.
|
|
454 |
responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
|
|
455 |
responder cfgref socket hmac msg peer = do
|
|
456 |
ctime <- getCurrentTime
|
|
457 |
case parseMessage hmac msg ctime of
|
|
458 |
Ok (origmsg, rq) -> do
|
|
459 |
logDebug $ "Processing request: " ++ origmsg
|
|
460 |
mcfg <- readIORef cfgref
|
|
461 |
let response = respondInner mcfg hmac rq
|
|
462 |
_ <- S.sendTo socket response peer
|
|
463 |
return ()
|
|
464 |
Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
|
|
465 |
return ()
|
|
466 |
|
|
467 |
-- | Mesage parsing. This can either result in a good, valid message,
|
|
468 |
-- or fail in the Result monad.
|
|
469 |
parseMessage :: HashKey -> String -> Integer
|
|
470 |
-> Result (String, ConfdRequest)
|
|
471 |
parseMessage hmac msg curtime = do
|
|
472 |
(salt, origmsg, request) <- parseRequest hmac msg
|
|
473 |
ts <- tryRead "Parsing timestamp" salt::Result Integer
|
|
474 |
if (abs (ts - curtime) > (fromIntegral C.confdMaxClockSkew))
|
|
475 |
then fail "Too old/too new timestamp or clock skew"
|
|
476 |
else return (origmsg, request)
|
|
477 |
|
|
478 |
-- | Inner helper function for a given client. This generates the
|
|
479 |
-- final encoded message (as a string), ready to be sent out to the
|
|
480 |
-- client.
|
|
481 |
respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
|
|
482 |
-> ConfdRequest -> String
|
|
483 |
respondInner cfg hmac rq =
|
|
484 |
let rsalt = confdRqRsalt rq
|
|
485 |
innermsg = serializeResponse (cfg >>= flip buildResponse rq)
|
|
486 |
innerserialised = J.encodeStrict innermsg
|
|
487 |
outermsg = signMessage hmac rsalt innerserialised
|
|
488 |
outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
|
|
489 |
in outerserialised
|
|
490 |
|
|
491 |
-- | Main listener loop.
|
|
492 |
listener :: S.Socket -> HashKey
|
|
493 |
-> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
|
|
494 |
-> IO ()
|
|
495 |
listener s hmac resp = do
|
|
496 |
(msg, _, peer) <- S.recvFrom s 4096
|
|
497 |
if confdMagicFourcc `isPrefixOf` msg
|
|
498 |
then (forkIO $ resp s hmac (drop 4 msg) peer) >> return ()
|
|
499 |
else logDebug "Invalid magic code!" >> return ()
|
|
500 |
return ()
|
|
501 |
|
|
502 |
-- | Main function.
|
|
503 |
main :: DaemonOptions -> IO ()
|
|
504 |
main opts = do
|
|
505 |
s <- S.socket S.AF_INET S.Datagram S.defaultProtocol
|
|
506 |
let port = maybe C.defaultConfdPort fromIntegral $ optPort opts
|
|
507 |
S.bindSocket s (S.SockAddrInet (fromIntegral port) S.iNADDR_ANY)
|
|
508 |
cref <- newIORef (Bad "Configuration not yet loaded")
|
|
509 |
statemvar <- newMVar initialState
|
|
510 |
hmac <- getClusterHmac
|
|
511 |
-- Inotify setup
|
|
512 |
inotify <- initINotify
|
|
513 |
let inotiaction = addNotifier inotify C.clusterConfFile cref statemvar
|
|
514 |
-- fork the timeout timer
|
|
515 |
_ <- forkIO $ onTimeoutTimer inotiaction C.clusterConfFile cref statemvar
|
|
516 |
-- fork the polling timer
|
|
517 |
_ <- forkIO $ onReloadTimer inotiaction C.clusterConfFile cref statemvar
|
|
518 |
-- and finally enter the responder loop
|
|
519 |
forever $ listener s hmac (responder cref)
|