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