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                     ]