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