Fix error message in attachInstanceDiskChecks
[ganeti-github.git] / src / Ganeti / WConfd / ConfigModifications.hs
1 {-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction, FlexibleContexts #-}
2
3 {-| The WConfd functions for direct configuration manipulation
4
5 This module contains the client functions exported by WConfD for
6 specific configuration manipulation.
7
8 -}
9
10 {-
11
12 Copyright (C) 2014 Google Inc.
13 All rights reserved.
14
15 Redistribution and use in source and binary forms, with or without
16 modification, are permitted provided that the following conditions are
17 met:
18
19 1. Redistributions of source code must retain the above copyright notice,
20 this list of conditions and the following disclaimer.
21
22 2. Redistributions in binary form must reproduce the above copyright
23 notice, this list of conditions and the following disclaimer in the
24 documentation and/or other materials provided with the distribution.
25
26 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
27 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
28 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
30 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
31 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
32 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
33 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
34 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
35 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
36 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37
38 -}
39
40 module Ganeti.WConfd.ConfigModifications where
41
42 import Control.Applicative ((<$>))
43 import Control.Lens (_2)
44 import Control.Lens.Getter ((^.))
45 import Control.Lens.Setter ((.~), (%~))
46 import qualified Data.ByteString.UTF8 as UTF8
47 import Control.Lens.Traversal (mapMOf)
48 import Control.Monad (unless, when, forM_, foldM, liftM2)
49 import Control.Monad.Error (throwError, MonadError)
50 import Control.Monad.IO.Class (liftIO)
51 import Control.Monad.Trans.State (StateT, get, put, modify,
52 runStateT, execStateT)
53 import Data.Foldable (fold, foldMap)
54 import Data.List (elemIndex)
55 import Data.Maybe (isJust, maybeToList, fromMaybe, fromJust)
56 import Language.Haskell.TH (Name)
57 import System.Time (getClockTime, ClockTime)
58 import Text.Printf (printf)
59 import qualified Data.Map as M
60 import qualified Data.Set as S
61
62 import Ganeti.BasicTypes (GenericResult(..), genericResult, toError)
63 import Ganeti.Constants (lastDrbdPort)
64 import Ganeti.Errors (GanetiException(..))
65 import Ganeti.JSON (Container, GenericContainer(..), alterContainerL
66 , lookupContainer, MaybeForJSON(..), TimeAsDoubleJSON(..))
67 import Ganeti.Locking.Locks (ClientId, ciIdentifier)
68 import Ganeti.Logging.Lifted (logDebug, logInfo)
69 import Ganeti.Objects
70 import Ganeti.Objects.Lens
71 import Ganeti.Types (AdminState, AdminStateSource)
72 import Ganeti.WConfd.ConfigState (ConfigState, csConfigData, csConfigDataL)
73 import Ganeti.WConfd.Monad (WConfdMonad, modifyConfigWithLock
74 , modifyConfigAndReturnWithLock)
75 import qualified Ganeti.WConfd.TempRes as T
76
77 type DiskUUID = String
78 type InstanceUUID = String
79 type NodeUUID = String
80
81 -- * accessor functions
82
83 getInstanceByUUID :: ConfigState
84 -> InstanceUUID
85 -> GenericResult GanetiException Instance
86 getInstanceByUUID cs uuid = lookupContainer
87 (Bad . ConfigurationError $
88 printf "Could not find instance with UUID %s" uuid)
89 (UTF8.fromString uuid)
90 (configInstances . csConfigData $ cs)
91
92 -- * getters
93
94 -- | Gets all logical volumes in the cluster
95 getAllLVs :: ConfigState -> S.Set String
96 getAllLVs = S.fromList . concatMap getLVsOfDisk . M.elems
97 . fromContainer . configDisks . csConfigData
98 where convert (LogicalVolume lvG lvV) = lvG ++ "/" ++ lvV
99 getDiskLV :: Disk -> Maybe String
100 getDiskLV disk = case diskLogicalId disk of
101 Just (LIDPlain lv) -> Just (convert lv)
102 _ -> Nothing
103 getLVsOfDisk :: Disk -> [String]
104 getLVsOfDisk disk = maybeToList (getDiskLV disk)
105 ++ concatMap getLVsOfDisk (diskChildren disk)
106
107 -- | Gets the ids of nodes, instances, node groups,
108 -- networks, disks, nics, and the cluster itself.
109 getAllIDs :: ConfigState -> S.Set String
110 getAllIDs cs =
111 let lvs = getAllLVs cs
112 keysFromC :: GenericContainer a b -> [a]
113 keysFromC = M.keys . fromContainer
114
115 valuesFromC :: GenericContainer a b -> [b]
116 valuesFromC = M.elems . fromContainer
117
118 instKeys = keysFromC . configInstances . csConfigData $ cs
119 nodeKeys = keysFromC . configNodes . csConfigData $ cs
120
121 instValues = map uuidOf . valuesFromC
122 . configInstances . csConfigData $ cs
123 nodeValues = map uuidOf . valuesFromC . configNodes . csConfigData $ cs
124 nodeGroupValues = map uuidOf . valuesFromC
125 . configNodegroups . csConfigData $ cs
126 networkValues = map uuidOf . valuesFromC
127 . configNetworks . csConfigData $ cs
128 disksValues = map uuidOf . valuesFromC . configDisks . csConfigData $ cs
129
130 nics = map nicUuid . concatMap instNics
131 . valuesFromC . configInstances . csConfigData $ cs
132
133 cluster = uuidOf . configCluster . csConfigData $ cs
134 in S.union lvs . S.fromList $ map UTF8.toString instKeys
135 ++ map UTF8.toString nodeKeys
136 ++ instValues
137 ++ nodeValues
138 ++ nodeGroupValues
139 ++ networkValues
140 ++ disksValues
141 ++ map UTF8.toString nics ++ [cluster]
142
143 getAllMACs :: ConfigState -> S.Set String
144 getAllMACs = S.fromList . map nicMac . concatMap instNics . M.elems
145 . fromContainer . configInstances . csConfigData
146
147 -- | Checks if the two objects are equal,
148 -- excluding timestamps. The serial number of
149 -- current must be one greater than that of target.
150 --
151 -- If this is true, it implies that the update RPC
152 -- updated the config, but did not successfully return.
153 isIdentical :: (Eq a, SerialNoObjectL a, TimeStampObjectL a)
154 => ClockTime
155 -> a
156 -> a
157 -> Bool
158 isIdentical now target current = (mTimeL .~ now $ current) ==
159 ((serialL %~ (+1)) . (mTimeL .~ now) $ target)
160
161 -- | Checks if the two objects given have the same serial number
162 checkSerial :: SerialNoObject a => a -> a -> GenericResult GanetiException ()
163 checkSerial target current = if serialOf target == serialOf current
164 then Ok ()
165 else Bad . ConfigurationError $ printf
166 "Configuration object updated since it has been read: %d != %d"
167 (serialOf current) (serialOf target)
168
169 -- | Updates an object present in a container.
170 -- The presence of the object in the container
171 -- is determined by the uuid of the object.
172 --
173 -- A check that serial number of the
174 -- object is consistent with the serial number
175 -- of the object in the container is performed.
176 --
177 -- If the check passes, the object's serial number
178 -- is incremented, and modification time is updated,
179 -- and then is inserted into the container.
180 replaceIn :: (UuidObject a, TimeStampObjectL a, SerialNoObjectL a)
181 => ClockTime
182 -> a
183 -> Container a
184 -> GenericResult GanetiException (Container a)
185 replaceIn now target = alterContainerL (UTF8.fromString (uuidOf target)) extract
186 where extract Nothing = Bad $ ConfigurationError
187 "Configuration object unknown"
188 extract (Just current) = do
189 checkSerial target current
190 return . Just . (serialL %~ (+1)) . (mTimeL .~ now) $ target
191
192 -- | Utility fuction that combines the two
193 -- possible actions that could be taken when
194 -- given a target.
195 --
196 -- If the target is identical to the current
197 -- value, we return the modification time of
198 -- the current value, and not change the config.
199 --
200 -- If not, we update the config.
201 updateConfigIfNecessary :: (Monad m, MonadError GanetiException m, Eq a,
202 UuidObject a, SerialNoObjectL a, TimeStampObjectL a)
203 => ClockTime
204 -> a
205 -> (ConfigState -> Container a)
206 -> (ConfigState
207 -> m ((Int, ClockTime), ConfigState))
208 -> ConfigState
209 -> m ((Int, ClockTime), ConfigState)
210 updateConfigIfNecessary now target getContainer f cs = do
211 let container = getContainer cs
212 current <- lookupContainer (toError . Bad . ConfigurationError $
213 "Configuraton object unknown")
214 (UTF8.fromString (uuidOf target))
215 container
216 if isIdentical now target current
217 then return ((serialOf current, mTimeOf current), cs)
218 else f cs
219
220 -- * UUID config checks
221
222 -- | Checks if the config has the given UUID
223 checkUUIDpresent :: UuidObject a
224 => ConfigState
225 -> a
226 -> Bool
227 checkUUIDpresent cs a = uuidOf a `S.member` getAllIDs cs
228
229 -- | Checks if the given UUID is new (i.e., no in the config)
230 checkUniqueUUID :: UuidObject a
231 => ConfigState
232 -> a
233 -> Bool
234 checkUniqueUUID cs a = not $ checkUUIDpresent cs a
235
236 -- * RPC checks
237
238 -- | Verifications done before adding an instance.
239 -- Currently confirms that the instance's macs are not
240 -- in use, and that the instance's UUID being
241 -- present (or not present) in the config based on
242 -- weather the instance is being replaced (or not).
243 --
244 -- TODO: add more verifications to this call;
245 -- the client should have a lock on the name of the instance.
246 addInstanceChecks :: Instance
247 -> Bool
248 -> ConfigState
249 -> GenericResult GanetiException ()
250 addInstanceChecks inst replace cs = do
251 let macsInUse = S.fromList (map nicMac (instNics inst))
252 `S.intersection` getAllMACs cs
253 unless (S.null macsInUse) . Bad . ConfigurationError $ printf
254 "Cannot add instance %s; MAC addresses %s already in use"
255 (show $ instName inst) (show macsInUse)
256 if replace
257 then do
258 let check = checkUUIDpresent cs inst
259 unless check . Bad . ConfigurationError $ printf
260 "Cannot add %s: UUID %s already in use"
261 (show $ instName inst) (UTF8.toString (instUuid inst))
262 else do
263 let check = checkUniqueUUID cs inst
264 unless check . Bad . ConfigurationError $ printf
265 "Cannot replace %s: UUID %s not present"
266 (show $ instName inst) (UTF8.toString (instUuid inst))
267
268 addDiskChecks :: Disk
269 -> Bool
270 -> ConfigState
271 -> GenericResult GanetiException ()
272 addDiskChecks disk replace cs =
273 if replace
274 then
275 unless (checkUUIDpresent cs disk) . Bad . ConfigurationError $ printf
276 "Cannot add %s: UUID %s already in use"
277 (show $ diskName disk) (UTF8.toString (diskUuid disk))
278 else
279 unless (checkUniqueUUID cs disk) . Bad . ConfigurationError $ printf
280 "Cannot replace %s: UUID %s not present"
281 (show $ diskName disk) (UTF8.toString (diskUuid disk))
282
283 attachInstanceDiskChecks :: InstanceUUID
284 -> DiskUUID
285 -> MaybeForJSON Int
286 -> ConfigState
287 -> GenericResult GanetiException ()
288 attachInstanceDiskChecks uuidInst uuidDisk idx' cs = do
289 let diskPresent = elem uuidDisk . map (UTF8.toString . diskUuid) . M.elems
290 . fromContainer . configDisks . csConfigData $ cs
291 unless diskPresent . Bad . ConfigurationError $ printf
292 "Disk %s doesn't exist" uuidDisk
293
294 inst <- getInstanceByUUID cs uuidInst
295 let numDisks = length $ instDisks inst
296 idx = fromMaybe numDisks (unMaybeForJSON idx')
297
298 when (idx < 0) . Bad . GenericError $
299 "Not accepting negative indices"
300 when (idx > numDisks) . Bad . GenericError $ printf
301 "Got disk index %d, but there are only %d" idx numDisks
302
303 let insts = M.elems . fromContainer . configInstances . csConfigData $ cs
304 forM_ insts (\inst' -> when (uuidDisk `elem` instDisks inst') . Bad
305 . ReservationError $ printf "Disk %s already attached to instance %s"
306 uuidDisk (show . fromMaybe "" $ instName inst'))
307
308 -- * Pure config modifications functions
309
310 attachInstanceDisk' :: InstanceUUID
311 -> DiskUUID
312 -> MaybeForJSON Int
313 -> ClockTime
314 -> ConfigState
315 -> ConfigState
316 attachInstanceDisk' iUuid dUuid idx' ct cs =
317 let inst = genericResult (error "impossible") id (getInstanceByUUID cs iUuid)
318 numDisks = length $ instDisks inst
319 idx = fromMaybe numDisks (unMaybeForJSON idx')
320
321 insert = instDisksL %~ (\ds -> take idx ds ++ [dUuid] ++ drop idx ds)
322 incr = instSerialL %~ (+ 1)
323 time = instMtimeL .~ ct
324
325 inst' = time . incr . insert $ inst
326 disks = updateIvNames idx inst' (configDisks . csConfigData $ cs)
327
328 ri = csConfigDataL . configInstancesL
329 . alterContainerL (UTF8.fromString iUuid) .~ Just inst'
330 rds = csConfigDataL . configDisksL .~ disks
331 in rds . ri $ cs
332 where updateIvNames :: Int -> Instance -> Container Disk -> Container Disk
333 updateIvNames idx inst (GenericContainer m) =
334 let dUuids = drop idx (instDisks inst)
335 upgradeIv m' (idx'', dUuid') =
336 M.adjust (diskIvNameL .~ "disk/" ++ show idx'') dUuid' m'
337 in GenericContainer $ foldl upgradeIv m
338 (zip [idx..] (fmap UTF8.fromString dUuids))
339
340 -- * Monadic config modification functions which can return errors
341
342 detachInstanceDisk' :: MonadError GanetiException m
343 => InstanceUUID
344 -> DiskUUID
345 -> ClockTime
346 -> ConfigState
347 -> m ConfigState
348 detachInstanceDisk' iUuid dUuid ct cs =
349 let resetIv :: MonadError GanetiException m
350 => Int
351 -> [DiskUUID]
352 -> ConfigState
353 -> m ConfigState
354 resetIv startIdx disks = mapMOf (csConfigDataL . configDisksL)
355 (\cd -> foldM (\c (idx, dUuid') -> mapMOf (alterContainerL dUuid')
356 (\md -> case md of
357 Nothing -> throwError . ConfigurationError $
358 printf "Could not find disk with UUID %s" (UTF8.toString dUuid')
359 Just disk -> return
360 . Just
361 . (diskIvNameL .~ ("disk/" ++ show idx))
362 $ disk) c)
363 cd (zip [startIdx..] (fmap UTF8.fromString disks)))
364 iL = csConfigDataL . configInstancesL . alterContainerL
365 (UTF8.fromString iUuid)
366 in case cs ^. iL of
367 Nothing -> throwError . ConfigurationError $
368 printf "Could not find instance with UUID %s" iUuid
369 Just ist -> case elemIndex dUuid (instDisks ist) of
370 Nothing -> return cs
371 Just idx ->
372 let ist' = (instDisksL %~ filter (/= dUuid))
373 . (instSerialL %~ (+1))
374 . (instMtimeL .~ ct)
375 $ ist
376 cs' = iL .~ Just ist' $ cs
377 dks = drop (idx + 1) (instDisks ist)
378 in resetIv idx dks cs'
379
380 removeInstanceDisk' :: MonadError GanetiException m
381 => InstanceUUID
382 -> DiskUUID
383 -> ClockTime
384 -> ConfigState
385 -> m ConfigState
386 removeInstanceDisk' iUuid dUuid ct =
387 let f cs
388 | elem dUuid
389 . fold
390 . fmap instDisks
391 . configInstances
392 . csConfigData
393 $ cs
394 = throwError . ProgrammerError $
395 printf "Cannot remove disk %s. Disk is attached to an instance" dUuid
396 | elem dUuid
397 . foldMap (:[])
398 . fmap (UTF8.toString . diskUuid)
399 . configDisks
400 . csConfigData
401 $ cs
402 = return
403 . ((csConfigDataL . configDisksL . alterContainerL
404 (UTF8.fromString dUuid)) .~ Nothing)
405 . ((csConfigDataL . configClusterL . clusterSerialL) %~ (+1))
406 . ((csConfigDataL . configClusterL . clusterMtimeL) .~ ct)
407 $ cs
408 | otherwise = return cs
409 in (f =<<) . detachInstanceDisk' iUuid dUuid ct
410
411 -- * RPCs
412
413 -- | Add a new instance to the configuration, release DRBD minors,
414 -- and commit temporary IPs, all while temporarily holding the config
415 -- lock. Return True upon success and False if the config lock was not
416 -- available and the client should retry.
417 addInstance :: Instance -> ClientId -> Bool -> WConfdMonad Bool
418 addInstance inst cid replace = do
419 ct <- liftIO getClockTime
420 logDebug $ "AddInstance: client " ++ show (ciIdentifier cid)
421 ++ " adding instance " ++ uuidOf inst
422 ++ " with name " ++ show (instName inst)
423 let setCtime = instCtimeL .~ ct
424 setMtime = instMtimeL .~ ct
425 addInst i = csConfigDataL . configInstancesL
426 . alterContainerL (UTF8.fromString $ uuidOf i)
427 .~ Just i
428 commitRes tr = mapMOf csConfigDataL $ T.commitReservedIps cid tr
429 r <- modifyConfigWithLock
430 (\tr cs -> do
431 toError $ addInstanceChecks inst replace cs
432 commitRes tr $ addInst (setMtime . setCtime $ inst) cs)
433 . T.releaseDRBDMinors . UTF8.fromString $ uuidOf inst
434 logDebug $ "AddInstance: result of config modification is " ++ show r
435 return $ isJust r
436
437 addInstanceDisk :: InstanceUUID
438 -> Disk
439 -> MaybeForJSON Int
440 -> Bool
441 -> WConfdMonad Bool
442 addInstanceDisk iUuid disk idx replace = do
443 logInfo $ printf "Adding disk %s to configuration"
444 (UTF8.toString (diskUuid disk))
445 ct <- liftIO getClockTime
446 let addD = csConfigDataL . configDisksL . alterContainerL
447 (UTF8.fromString (uuidOf disk))
448 .~ Just disk
449 incrSerialNo = csConfigDataL . configSerialL %~ (+1)
450 r <- modifyConfigWithLock (\_ cs -> do
451 toError $ addDiskChecks disk replace cs
452 let cs' = incrSerialNo . addD $ cs
453 toError $ attachInstanceDiskChecks iUuid
454 (UTF8.toString (diskUuid disk)) idx cs'
455 return $ attachInstanceDisk' iUuid
456 (UTF8.toString (diskUuid disk)) idx ct cs')
457 . T.releaseDRBDMinors $ UTF8.fromString (uuidOf disk)
458 return $ isJust r
459
460 attachInstanceDisk :: InstanceUUID
461 -> DiskUUID
462 -> MaybeForJSON Int
463 -> WConfdMonad Bool
464 attachInstanceDisk iUuid dUuid idx = do
465 ct <- liftIO getClockTime
466 r <- modifyConfigWithLock (\_ cs -> do
467 toError $ attachInstanceDiskChecks iUuid dUuid idx cs
468 return $ attachInstanceDisk' iUuid dUuid idx ct cs)
469 (return ())
470 return $ isJust r
471
472 -- | Detach a disk from an instance.
473 detachInstanceDisk :: InstanceUUID -> DiskUUID -> WConfdMonad Bool
474 detachInstanceDisk iUuid dUuid = do
475 ct <- liftIO getClockTime
476 isJust <$> modifyConfigWithLock
477 (const $ detachInstanceDisk' iUuid dUuid ct) (return ())
478
479 -- | Detach a disk from an instance and
480 -- remove it from the config.
481 removeInstanceDisk :: InstanceUUID -> DiskUUID -> WConfdMonad Bool
482 removeInstanceDisk iUuid dUuid = do
483 ct <- liftIO getClockTime
484 isJust <$> modifyConfigWithLock
485 (const $ removeInstanceDisk' iUuid dUuid ct) (return ())
486
487 -- | Remove the instance from the configuration.
488 removeInstance :: InstanceUUID -> WConfdMonad Bool
489 removeInstance iUuid = do
490 ct <- liftIO getClockTime
491 let iL = csConfigDataL . configInstancesL . alterContainerL
492 (UTF8.fromString iUuid)
493 pL = csConfigDataL . configClusterL . clusterTcpudpPortPoolL
494 sL = csConfigDataL . configClusterL . clusterSerialL
495 mL = csConfigDataL . configClusterL . clusterMtimeL
496
497 -- Add the instances' network port to the cluster pool
498 f :: Monad m => StateT ConfigState m ()
499 f = get >>= (maybe
500 (return ())
501 (maybe
502 (return ())
503 (modify . (pL %~) . (:))
504 . instNetworkPort)
505 . (^. iL))
506
507 -- Release all IP addresses to the pool
508 g :: (MonadError GanetiException m, Functor m) => StateT ConfigState m ()
509 g = get >>= (maybe
510 (return ())
511 (mapM_ (\nic ->
512 when ((isJust . nicNetwork $ nic) && (isJust . nicIp $ nic)) $ do
513 let network = fromJust . nicNetwork $ nic
514 ip <- readIp4Address (fromJust . nicIp $ nic)
515 get >>= mapMOf csConfigDataL (T.commitReleaseIp
516 (UTF8.fromString network) ip) >>= put)
517 . instNics)
518 . (^. iL))
519
520 -- Remove the instance and update cluster serial num, and mtime
521 h :: Monad m => StateT ConfigState m ()
522 h = modify $ (iL .~ Nothing) . (sL %~ (+1)) . (mL .~ ct)
523 isJust <$> modifyConfigWithLock (const $ execStateT (f >> g >> h)) (return ())
524
525 -- | Allocate a port.
526 -- The port will be taken from the available port pool or from the
527 -- default port range (and in this case we increase
528 -- highest_used_port).
529 allocatePort :: WConfdMonad (MaybeForJSON Int)
530 allocatePort = do
531 maybePort <- modifyConfigAndReturnWithLock (\_ cs ->
532 let portPoolL = csConfigDataL . configClusterL . clusterTcpudpPortPoolL
533 hupL = csConfigDataL . configClusterL . clusterHighestUsedPortL
534 in case cs ^. portPoolL of
535 [] -> if cs ^. hupL >= lastDrbdPort
536 then throwError . ConfigurationError $ printf
537 "The highest used port is greater than %s. Aborting." lastDrbdPort
538 else return (cs ^. hupL + 1, hupL %~ (+1) $ cs)
539 (p:ps) -> return (p, portPoolL .~ ps $ cs))
540 (return ())
541 return . MaybeForJSON $ maybePort
542
543 -- | Adds a new port to the available port pool.
544 addTcpUdpPort :: Int -> WConfdMonad Bool
545 addTcpUdpPort port =
546 let pL = csConfigDataL . configClusterL . clusterTcpudpPortPoolL
547 f :: Monad m => ConfigState -> m ConfigState
548 f = mapMOf pL (return . (port:) . filter (/= port))
549 in isJust <$> modifyConfigWithLock (const f) (return ())
550
551 -- | Set the instances' status to a given value.
552 setInstanceStatus :: InstanceUUID
553 -> MaybeForJSON AdminState
554 -> MaybeForJSON Bool
555 -> MaybeForJSON AdminStateSource
556 -> WConfdMonad (MaybeForJSON Instance)
557 setInstanceStatus iUuid m1 m2 m3 = do
558 ct <- liftIO getClockTime
559 let modifyInstance = maybe id (instAdminStateL .~) (unMaybeForJSON m1)
560 . maybe id (instDisksActiveL .~) (unMaybeForJSON m2)
561 . maybe id (instAdminStateSourceL .~) (unMaybeForJSON m3)
562 reviseInstance = (instSerialL %~ (+1))
563 . (instMtimeL .~ ct)
564
565 g :: Instance -> Instance
566 g i = if modifyInstance i == i
567 then i
568 else reviseInstance . modifyInstance $ i
569
570 iL = csConfigDataL . configInstancesL . alterContainerL
571 (UTF8.fromString iUuid)
572
573 f :: MonadError GanetiException m => StateT ConfigState m Instance
574 f = get >>= (maybe
575 (throwError . ConfigurationError $
576 printf "Could not find instance with UUID %s" iUuid)
577 (liftM2 (>>)
578 (modify . (iL .~) . Just)
579 return . g)
580 . (^. iL))
581 MaybeForJSON <$> modifyConfigAndReturnWithLock
582 (const $ runStateT f) (return ())
583
584 -- | Sets the primary node of an existing instance
585 setInstancePrimaryNode :: InstanceUUID -> NodeUUID -> WConfdMonad Bool
586 setInstancePrimaryNode iUuid nUuid = isJust <$> modifyConfigWithLock
587 (\_ -> mapMOf (csConfigDataL . configInstancesL . alterContainerL
588 (UTF8.fromString iUuid))
589 (\mi -> case mi of
590 Nothing -> throwError . ConfigurationError $
591 printf "Could not find instance with UUID %s" iUuid
592 Just ist -> return . Just $ (instPrimaryNodeL .~ nUuid) ist))
593 (return ())
594
595 -- | The configuration is updated by the provided cluster
596 updateCluster :: Cluster -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
597 updateCluster cluster = do
598 ct <- liftIO getClockTime
599 r <- modifyConfigAndReturnWithLock (\_ cs -> do
600 let currentCluster = configCluster . csConfigData $ cs
601 if isIdentical ct cluster currentCluster
602 then return ((serialOf currentCluster, mTimeOf currentCluster), cs)
603 else do
604 toError $ checkSerial cluster currentCluster
605 let updateC = (clusterSerialL %~ (+1)) . (clusterMtimeL .~ ct)
606 return ((serialOf cluster + 1, ct)
607 , csConfigDataL . configClusterL .~ updateC cluster $ cs))
608 (return ())
609 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
610
611 -- | The configuration is updated by the provided node
612 updateNode :: Node -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
613 updateNode node = do
614 ct <- liftIO getClockTime
615 let nL = csConfigDataL . configNodesL
616 updateC = (clusterSerialL %~ (+1)) . (clusterMtimeL .~ ct)
617 r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct node
618 (^. nL) (\cs -> do
619 nC <- toError $ replaceIn ct node (cs ^. nL)
620 return ((serialOf node + 1, ct), (nL .~ nC)
621 . (csConfigDataL . configClusterL %~ updateC)
622 $ cs)))
623 (return ())
624 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
625
626 -- | The configuration is updated by the provided instance
627 updateInstance :: Instance -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
628 updateInstance inst = do
629 ct <- liftIO getClockTime
630 let iL = csConfigDataL . configInstancesL
631 r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct inst
632 (^. iL) (\cs -> do
633 iC <- toError $ replaceIn ct inst (cs ^. iL)
634 return ((serialOf inst + 1, ct), (iL .~ iC) cs)))
635 (return ())
636 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
637
638 -- | The configuration is updated by the provided nodegroup
639 updateNodeGroup :: NodeGroup
640 -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
641 updateNodeGroup ng = do
642 ct <- liftIO getClockTime
643 let ngL = csConfigDataL . configNodegroupsL
644 r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct ng
645 (^. ngL) (\cs -> do
646 ngC <- toError $ replaceIn ct ng (cs ^. ngL)
647 return ((serialOf ng + 1, ct), (ngL .~ ngC) cs)))
648 (return ())
649 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
650
651 -- | The configuration is updated by the provided network
652 updateNetwork :: Network -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
653 updateNetwork net = do
654 ct <- liftIO getClockTime
655 let nL = csConfigDataL . configNetworksL
656 r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct net
657 (^. nL) (\cs -> do
658 nC <- toError $ replaceIn ct net (cs ^. nL)
659 return ((serialOf net + 1, ct), (nL .~ nC) cs)))
660 (return ())
661 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
662
663 -- | The configuration is updated by the provided disk
664 updateDisk :: Disk -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON))
665 updateDisk disk = do
666 ct <- liftIO getClockTime
667 let dL = csConfigDataL . configDisksL
668 r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct disk
669 (^. dL) (\cs -> do
670 dC <- toError $ replaceIn ct disk (cs ^. dL)
671 return ((serialOf disk + 1, ct), (dL .~ dC) cs)))
672 . T.releaseDRBDMinors . UTF8.fromString $ uuidOf disk
673 return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r
674
675 -- * The list of functions exported to RPC.
676
677 exportedFunctions :: [Name]
678 exportedFunctions = [ 'addInstance
679 , 'addInstanceDisk
680 , 'addTcpUdpPort
681 , 'allocatePort
682 , 'attachInstanceDisk
683 , 'detachInstanceDisk
684 , 'removeInstance
685 , 'removeInstanceDisk
686 , 'setInstancePrimaryNode
687 , 'setInstanceStatus
688 , 'updateCluster
689 , 'updateDisk
690 , 'updateInstance
691 , 'updateNetwork
692 , 'updateNode
693 , 'updateNodeGroup
694 ]