Merge branch 'stable-2.13' into stable-2.14
[ganeti-github.git] / src / Ganeti / WConfd / Core.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 {-| The Ganeti WConfd core functions.
4
5 This module defines all the functions that WConfD exports for
6 RPC calls. They are in a separate module so that in a later
7 stage, TemplateHaskell can generate, e.g., the python interface
8 for those.
9
10 -}
11
12 {-
13
14 Copyright (C) 2013, 2014 Google Inc.
15 All rights reserved.
16
17 Redistribution and use in source and binary forms, with or without
18 modification, are permitted provided that the following conditions are
19 met:
20
21 1. Redistributions of source code must retain the above copyright notice,
22 this list of conditions and the following disclaimer.
23
24 2. Redistributions in binary form must reproduce the above copyright
25 notice, this list of conditions and the following disclaimer in the
26 documentation and/or other materials provided with the distribution.
27
28 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
29 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
30 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
32 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
33 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
34 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
35 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
36 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
37 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
38 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
39
40 -}
41
42 module Ganeti.WConfd.Core where
43
44 import Control.Arrow ((&&&))
45 import Control.Concurrent (myThreadId)
46 import Control.Lens.Setter (set)
47 import Control.Monad (liftM, unless)
48 import qualified Data.Map as M
49 import qualified Data.Set as S
50 import Language.Haskell.TH (Name)
51 import System.Posix.Process (getProcessID)
52 import qualified System.Random as Rand
53
54 import Ganeti.BasicTypes
55 import qualified Ganeti.Constants as C
56 import qualified Ganeti.JSON as J
57 import qualified Ganeti.Locking.Allocation as L
58 import Ganeti.Logging (logDebug, logWarning)
59 import Ganeti.Locking.Locks ( GanetiLocks(ConfigLock, BGL)
60 , LockLevel(LevelConfig)
61 , lockLevel, LockLevel
62 , ClientType(ClientOther), ClientId(..) )
63 import qualified Ganeti.Locking.Waiting as LW
64 import Ganeti.Objects (ConfigData, DRBDSecret, LogicalVolume, Ip4Address)
65 import Ganeti.Objects.Lens (configClusterL, clusterMasterNodeL)
66 import Ganeti.WConfd.ConfigState (csConfigDataL)
67 import qualified Ganeti.WConfd.ConfigVerify as V
68 import Ganeti.WConfd.DeathDetection (cleanupLocks)
69 import Ganeti.WConfd.Language
70 import Ganeti.WConfd.Monad
71 import qualified Ganeti.WConfd.TempRes as T
72 import qualified Ganeti.WConfd.ConfigModifications as CM
73 import qualified Ganeti.WConfd.ConfigWriter as CW
74
75 -- * Functions available to the RPC module
76
77 -- Just a test function
78 echo :: String -> WConfdMonad String
79 echo = return
80
81 -- ** Configuration related functions
82
83 checkConfigLock :: ClientId -> L.OwnerState -> WConfdMonad ()
84 checkConfigLock cid state = do
85 la <- readLockAllocation
86 unless (L.holdsLock cid ConfigLock state la)
87 . failError $ "Requested lock " ++ show state
88 ++ " on the configuration missing"
89
90 -- | Read the configuration.
91 readConfig :: WConfdMonad ConfigData
92 readConfig = CW.readConfig
93
94 -- | Write the configuration, checking that an exclusive lock is held.
95 -- If not, the call fails.
96 writeConfig :: ClientId -> ConfigData -> WConfdMonad ()
97 writeConfig ident cdata = do
98 checkConfigLock ident L.OwnExclusive
99 -- V.verifyConfigErr cdata
100 CW.writeConfig cdata
101
102 -- | Explicitly run verification of the configuration.
103 -- The caller doesn't need to hold the configuration lock.
104 verifyConfig :: WConfdMonad ()
105 verifyConfig = CW.readConfig >>= V.verifyConfigErr
106
107 -- *** Locks on the configuration (only transitional, will be removed later)
108
109 -- | Tries to acquire 'ConfigLock' for the client.
110 -- If the second parameter is set to 'True', the lock is acquired in
111 -- shared mode.
112 --
113 -- If the lock was successfully acquired, returns the current configuration
114 -- state.
115 lockConfig
116 :: ClientId
117 -> Bool -- ^ set to 'True' if the lock should be shared
118 -> WConfdMonad (J.MaybeForJSON ConfigData)
119 lockConfig cid shared = do
120 let (reqtype, owntype) = if shared
121 then (ReqShared, L.OwnShared)
122 else (ReqExclusive, L.OwnExclusive)
123 la <- readLockAllocation
124 if L.holdsLock cid ConfigLock owntype la
125 then do
126 -- warn if we already have the lock, but continue (with no-op)
127 -- on the locks
128 logWarning $ "Client " ++ show cid ++ " asked to lock the config"
129 ++ " while owning the lock"
130 liftM (J.MaybeForJSON . Just) CW.readConfig
131 else do
132 waiting <- tryUpdateLocks cid [(ConfigLock, reqtype)]
133 liftM J.MaybeForJSON $ case waiting of
134 [] -> liftM Just CW.readConfig
135 _ -> return Nothing
136
137 -- | Release the config lock, if the client currently holds it.
138 unlockConfig
139 :: ClientId -> WConfdMonad ()
140 unlockConfig cid = freeLocksLevel cid LevelConfig
141
142 -- | Write the configuration, if the config lock is held exclusively,
143 -- and release the config lock. It the caller does not have the config
144 -- lock, return False.
145 writeConfigAndUnlock :: ClientId -> ConfigData -> WConfdMonad Bool
146 writeConfigAndUnlock cid cdata = do
147 la <- readLockAllocation
148 if L.holdsLock cid ConfigLock L.OwnExclusive la
149 then do
150 CW.writeConfig cdata
151 unlockConfig cid
152 return True
153 else do
154 logWarning $ show cid ++ " tried writeConfigAndUnlock without owning"
155 ++ " the config lock"
156 return False
157
158 -- | Force the distribution of configuration without actually modifying it.
159 -- It is not necessary to hold a lock for this operation.
160 flushConfig :: WConfdMonad ()
161 flushConfig = forceConfigStateDistribution
162
163 -- ** Temporary reservations related functions
164
165 dropAllReservations :: ClientId -> WConfdMonad ()
166 dropAllReservations cid =
167 modifyTempResState (const $ T.dropAllReservations cid)
168
169 -- *** DRBD
170
171 computeDRBDMap :: WConfdMonad T.DRBDMap
172 computeDRBDMap = uncurry T.computeDRBDMap =<< readTempResState
173
174 -- Allocate a drbd minor.
175 --
176 -- The free minor will be automatically computed from the existing devices.
177 -- A node can not be given multiple times.
178 -- The result is the list of minors, in the same order as the passed nodes.
179 allocateDRBDMinor
180 :: T.DiskUUID -> [T.NodeUUID] -> WConfdMonad [T.DRBDMinor]
181 allocateDRBDMinor disk nodes =
182 modifyTempResStateErr (\cfg -> T.allocateDRBDMinor cfg disk nodes)
183
184 -- Release temporary drbd minors allocated for a given disk using
185 -- 'allocateDRBDMinor'.
186 --
187 -- This should be called on the error paths, on the success paths
188 -- it's automatically called by the ConfigWriter add and update
189 -- functions.
190 releaseDRBDMinors
191 :: T.DiskUUID -> WConfdMonad ()
192 releaseDRBDMinors disk = modifyTempResState (const $ T.releaseDRBDMinors disk)
193
194 -- *** MACs
195
196 -- Randomly generate a MAC for an instance and reserve it for
197 -- a given client.
198 generateMAC
199 :: ClientId -> J.MaybeForJSON T.NetworkUUID -> WConfdMonad T.MAC
200 generateMAC cid (J.MaybeForJSON netId) = do
201 g <- liftIO Rand.newStdGen
202 modifyTempResStateErr $ T.generateMAC g cid netId
203
204 -- Reserves a MAC for an instance in the list of temporary reservations.
205 reserveMAC :: ClientId -> T.MAC -> WConfdMonad ()
206 reserveMAC = (modifyTempResStateErr .) . T.reserveMAC
207
208 -- *** DRBDSecrets
209
210 -- Randomly generate a DRBDSecret for an instance and reserves it for
211 -- a given client.
212 generateDRBDSecret :: ClientId -> WConfdMonad DRBDSecret
213 generateDRBDSecret cid = do
214 g <- liftIO Rand.newStdGen
215 modifyTempResStateErr $ T.generateDRBDSecret g cid
216
217 -- *** LVs
218
219 reserveLV :: ClientId -> LogicalVolume -> WConfdMonad ()
220 reserveLV jobId lv = modifyTempResStateErr $ T.reserveLV jobId lv
221
222 -- *** IPv4s
223
224 -- | Reserve a given IPv4 address for use by an instance.
225 reserveIp :: ClientId -> T.NetworkUUID -> Ip4Address -> Bool -> WConfdMonad ()
226 reserveIp = (((modifyTempResStateErr .) .) .) . T.reserveIp
227
228 -- | Give a specific IP address back to an IP pool.
229 -- The IP address is returned to the IP pool designated by network id
230 -- and marked as reserved.
231 releaseIp :: ClientId -> T.NetworkUUID -> Ip4Address -> WConfdMonad ()
232 releaseIp = (((modifyTempResStateErr .) const .) .) . T.releaseIp
233
234 -- Find a free IPv4 address for an instance and reserve it.
235 generateIp :: ClientId -> T.NetworkUUID -> WConfdMonad Ip4Address
236 generateIp = (modifyTempResStateErr .) . T.generateIp
237
238 -- | Commit all reserved/released IP address to an IP pool.
239 -- The IP addresses are taken from the network's IP pool and marked as
240 -- reserved/free for instances.
241 --
242 -- Note that the reservations are kept, they are supposed to be cleaned
243 -- when a job finishes.
244 commitTemporaryIps :: ClientId -> WConfdMonad ()
245 commitTemporaryIps = modifyConfigDataErr_ . T.commitReservedIps
246
247 -- | Immediately release an IP address, without using the reservations pool.
248 commitReleaseTemporaryIp
249 :: T.NetworkUUID -> Ip4Address -> WConfdMonad ()
250 commitReleaseTemporaryIp net_uuid addr =
251 modifyConfigDataErr_ (const $ T.commitReleaseIp net_uuid addr)
252
253 -- | List all IP reservations for the current client.
254 --
255 -- This function won't be needed once the corresponding calls are moved to
256 -- WConfd.
257 listReservedIps :: ClientId -> WConfdMonad [T.IPv4Reservation]
258 listReservedIps jobId =
259 liftM (S.toList . T.listReservedIps jobId . snd) readTempResState
260
261 -- ** Locking related functions
262
263 -- | List the locks of a given owner (i.e., a job-id lockfile pair).
264 listLocks :: ClientId -> WConfdMonad [(GanetiLocks, L.OwnerState)]
265 listLocks cid = liftM (M.toList . L.listLocks cid) readLockAllocation
266
267 -- | List all active locks.
268 listAllLocks :: WConfdMonad [GanetiLocks]
269 listAllLocks = liftM L.listAllLocks readLockAllocation
270
271 -- | List all active locks with their owners.
272 listAllLocksOwners :: WConfdMonad [(GanetiLocks, [(ClientId, L.OwnerState)])]
273 listAllLocksOwners = liftM L.listAllLocksOwners readLockAllocation
274
275 -- | Get full information of the lock waiting status, i.e., provide
276 -- the information about all locks owners and all pending requests.
277 listLocksWaitingStatus :: WConfdMonad
278 ( [(GanetiLocks, [(ClientId, L.OwnerState)])]
279 , [(Integer, ClientId, [L.LockRequest GanetiLocks])]
280 )
281 listLocksWaitingStatus = liftM ( (L.listAllLocksOwners . LW.getAllocation)
282 &&& (S.toList . LW.getPendingRequests) )
283 readLockWaiting
284
285 -- | Try to update the locks of a given owner (i.e., a job-id lockfile pair).
286 -- This function always returns immediately. If the lock update was possible,
287 -- the empty list is returned; otherwise, the lock status is left completly
288 -- unchanged, and the return value is the list of jobs which need to release
289 -- some locks before this request can succeed.
290 tryUpdateLocks :: ClientId -> GanetiLockRequest -> WConfdMonad [ClientId]
291 tryUpdateLocks cid req =
292 liftM S.toList
293 . (>>= toErrorStr)
294 $ modifyLockWaiting (LW.updateLocks cid (fromGanetiLockRequest req))
295
296 -- | Try to update the locks of a given owner and make that a pending
297 -- request if not immediately possible.
298 updateLocksWaiting :: ClientId -> Integer
299 -> GanetiLockRequest -> WConfdMonad [ClientId]
300 updateLocksWaiting cid prio req =
301 liftM S.toList
302 . (>>= toErrorStr)
303 . modifyLockWaiting
304 $ LW.safeUpdateLocksWaiting prio cid (fromGanetiLockRequest req)
305
306 -- | Tell whether a given owner has pending requests.
307 hasPendingRequest :: ClientId -> WConfdMonad Bool
308 hasPendingRequest cid = liftM (LW.hasPendingRequest cid) readLockWaiting
309
310 -- | Free all locks of a given owner (i.e., a job-id lockfile pair).
311 freeLocks :: ClientId -> WConfdMonad ()
312 freeLocks cid =
313 modifyLockWaiting_ $ LW.releaseResources cid
314
315 -- | Free all locks of a given owner (i.e., a job-id lockfile pair)
316 -- of a given level in the Ganeti sense (e.g., "cluster", "node").
317 freeLocksLevel :: ClientId -> LockLevel -> WConfdMonad ()
318 freeLocksLevel cid level =
319 modifyLockWaiting_ $ LW.freeLocksPredicate ((==) level . lockLevel) cid
320
321 -- | Downgrade all locks of the given level to shared.
322 downGradeLocksLevel :: ClientId -> LockLevel -> WConfdMonad ()
323 downGradeLocksLevel cid level =
324 modifyLockWaiting_ $ LW.downGradeLocksPredicate ((==) level . lockLevel) cid
325
326 -- | Intersect the possesed locks of an owner with a given set.
327 intersectLocks :: ClientId -> [GanetiLocks] -> WConfdMonad ()
328 intersectLocks cid locks = modifyLockWaiting_ $ LW.intersectLocks locks cid
329
330 -- | Opportunistically allocate locks for a given owner.
331 opportunisticLockUnion :: ClientId
332 -> [(GanetiLocks, L.OwnerState)]
333 -> WConfdMonad [GanetiLocks]
334 opportunisticLockUnion cid req =
335 modifyLockWaiting $ LW.opportunisticLockUnion cid req
336
337 -- | Opprtunistially allocate locks for a given owner, requesting a
338 -- certain minimum of success.
339 guardedOpportunisticLockUnion :: Int
340 -> ClientId
341 -> [(GanetiLocks, L.OwnerState)]
342 -> WConfdMonad [GanetiLocks]
343 guardedOpportunisticLockUnion count cid req =
344 modifyLockWaiting $ LW.guardedOpportunisticLockUnion count cid req
345
346 -- * Prepareation for cluster destruction
347
348 -- | Prepare daemon for cluster destruction. This consists of
349 -- verifying that the requester owns the BGL exclusively, transfering the BGL
350 -- to WConfD itself, and modifying the configuration so that no
351 -- node is the master any more. Note that, since we own the BGL exclusively,
352 -- we can safely modify the configuration, as no other process can request
353 -- changes.
354 prepareClusterDestruction :: ClientId -> WConfdMonad ()
355 prepareClusterDestruction cid = do
356 la <- readLockAllocation
357 unless (L.holdsLock cid BGL L.OwnExclusive la)
358 . failError $ "Cluster destruction requested without owning BGL exclusively"
359 logDebug $ "preparing cluster destruction as requested by " ++ show cid
360 -- transfer BGL to ourselfs. The do this, by adding a super-priority waiting
361 -- request and then releasing the BGL of the requestor.
362 dh <- daemonHandle
363 pid <- liftIO getProcessID
364 tid <- liftIO myThreadId
365 let mycid = ClientId { ciIdentifier = ClientOther $ "wconfd-" ++ show tid
366 , ciLockFile = dhLivelock dh
367 , ciPid = pid
368 }
369 _ <- modifyLockWaiting $ LW.updateLocksWaiting
370 (fromIntegral C.opPrioHighest - 1) mycid
371 [L.requestExclusive BGL]
372 _ <- modifyLockWaiting $ LW.updateLocks cid [L.requestRelease BGL]
373 -- To avoid beeing restarted we change the configuration to a no-master
374 -- state.
375 modifyConfigState $ (,) ()
376 . set (csConfigDataL . configClusterL . clusterMasterNodeL) ""
377
378
379 -- * The list of all functions exported to RPC.
380
381 exportedFunctions :: [Name]
382 exportedFunctions = [ 'echo
383 , 'cleanupLocks
384 , 'prepareClusterDestruction
385 -- config
386 , 'readConfig
387 , 'writeConfig
388 , 'verifyConfig
389 , 'lockConfig
390 , 'unlockConfig
391 , 'writeConfigAndUnlock
392 , 'flushConfig
393 -- temporary reservations (common)
394 , 'dropAllReservations
395 -- DRBD
396 , 'computeDRBDMap
397 , 'allocateDRBDMinor
398 , 'releaseDRBDMinors
399 -- MACs
400 , 'reserveMAC
401 , 'generateMAC
402 -- DRBD secrets
403 , 'generateDRBDSecret
404 -- LVs
405 , 'reserveLV
406 -- IPv4s
407 , 'reserveIp
408 , 'releaseIp
409 , 'generateIp
410 , 'commitTemporaryIps
411 , 'commitReleaseTemporaryIp
412 , 'listReservedIps
413 -- locking
414 , 'listLocks
415 , 'listAllLocks
416 , 'listAllLocksOwners
417 , 'listLocksWaitingStatus
418 , 'tryUpdateLocks
419 , 'updateLocksWaiting
420 , 'freeLocks
421 , 'freeLocksLevel
422 , 'downGradeLocksLevel
423 , 'intersectLocks
424 , 'opportunisticLockUnion
425 , 'guardedOpportunisticLockUnion
426 , 'hasPendingRequest
427 ]
428 ++ CM.exportedFunctions