LGTM, thanks On Fri, Nov 20, 2015 at 2:08 PM, 'Helga Velroyen' via ganeti-devel < [email protected]> wrote:
> commit 8337653769f617abfe39876d7cb794d68064ab13 > Merge: 2ebf4e8 598897c > Author: Helga Velroyen <[email protected]> > Date: Fri Nov 20 11:34:44 2015 +0100 > > Merge branch 'stable-2.15' into stable-2.16 > > * stable-2.15 > Document the decission why optimisation is turned off > Don't keep input for error messages > Use dict.copy instead of deepcopy > Use bulk-adding of keys in renew-crypto > Make NodeSshKeyAdd use its *Bulk companion > Unit test bulk-adding normal nodes > Unit test for bulk-adding pot. master candidates > Introduce bulk-adding of SSH keys > Pause watcher during performance QA > Send answers strictly > Store keys as ByteStrings > Encode UUIDs as ByteStrings > Prefer the UuidObject type class over specific functions > Assign the variables before use (bugfix for dee6adb9) > Extend QA to detect autopromotion errors > Handle SSH key distribution on auto promotion > Do not remove authorized key of node itself > Fix indentation > Support force option for deactivate disks on RAPI > > * stable-2.14 > Fix faulty iallocator type check > Improve cfgupgrade output in case of errors > > * stable-2.13 > Extend timeout for gnt-cluster renew-crypto > Reduce flakyness of GetCmdline test on slow machines > Remove duplicated words > > * stable-2.12 > Revert "Also consider connection time out a network error" > Clone lists before modifying > Make lockConfig call retryable > Return the correct error code in the post-upgrade script > Make openssl refrain from DH altogether > Fix upgrades of instances with missing creation time > > * stable-2.11 > (none) > > * stable-2.10 > Remove -X from hspace man page > Make htools tolerate missing "dtotal" and "dfree" on luxi > > Conflicts: > lib/backend.py > lib/cmdlib/node.py > src/Ganeti/WConfd/ConfigModifications.hs > > Resolutions: > lib/backend.py > use bulk-adding keys with renamed public key file variable > lib/cmdlib/node.py > use self.cfg.RemoveNode rather than self.context.RemoveNode > src/Ganeti/WConfd/ConfigModifications.hs > fix imports > add UTF8.{to,from}String at appropriate places > > Signed-off-by: Helga Velroyen <[email protected]> > > diff --cc lib/backend.py > index 7ebbdb9,d470060..6c51df8 > --- a/lib/backend.py > +++ b/lib/backend.py > @@@ -2002,21 -2073,24 +2080,23 @@@ def RenewSshKeys(node_uuids, node_names > " (UUID %s)" % (node_name, node_uuid)) > > if potential_master_candidate: > - ssh.RemovePublicKey(node_uuid, key_file=pub_key_file) > - ssh.AddPublicKey(node_uuid, pub_key, key_file=pub_key_file) > + ssh.RemovePublicKey(node_uuid, key_file=ganeti_pub_keys_file) > + ssh.AddPublicKey(node_uuid, pub_key, key_file=ganeti_pub_keys_file) > > -- logging.debug("Add ssh key of node '%s'.", node_name) > - node_errors = AddNodeSshKey( > - node_uuid, node_name, potential_master_candidates, > - to_authorized_keys=master_candidate, > - to_public_keys=potential_master_candidate, > - get_public_keys=True, > - pub_key_file=ganeti_pub_keys_file, > - ssconf_store=ssconf_store, > - noded_cert_file=noded_cert_file, > - run_cmd_fn=run_cmd_fn) > - if node_errors: > - all_node_errors = all_node_errors + node_errors > + node_info = SshAddNodeInfo(name=node_name, > + uuid=node_uuid, > + to_authorized_keys=master_candidate, > + to_public_keys=potential_master_candidate, > + get_public_keys=True) > + node_keys_to_add.append(node_info) > + > + node_errors = AddNodeSshKeyBulk( > + node_keys_to_add, potential_master_candidates, > - pub_key_file=pub_key_file, ssconf_store=ssconf_store, > ++ pub_key_file=ganeti_pub_keys_file, ssconf_store=ssconf_store, > + noded_cert_file=noded_cert_file, > + run_cmd_fn=run_cmd_fn) > + if node_errors: > + all_node_errors = all_node_errors + node_errors > > # Renewing the master node's key > > diff --cc lib/cmdlib/common.py > index 696a331,1d79a3e..638abd7 > --- a/lib/cmdlib/common.py > +++ b/lib/cmdlib/common.py > @@@ -485,7 -511,12 +511,11 @@@ def AdjustCandidatePool > lu.LogInfo("Promoted nodes to master candidate role: %s", > utils.CommaJoin(node.name for node in mod_list)) > for node in mod_list: > - lu.context.ReaddNode(node) > AddNodeCertToCandidateCerts(lu, lu.cfg, node.uuid) > + if modify_ssh_setup: > + AddMasterCandidateSshKey( > + lu, master_node, node, potential_master_candidates, > feedback_fn) > + > mc_now, mc_max, _ = lu.cfg.GetMasterCandidateStats(exceptions) > if mc_now > mc_max: > lu.LogInfo("Note: more nodes are candidates (%d) than desired (%d)" % > diff --cc lib/cmdlib/node.py > index 111de97,c0eccce..210fd97 > --- a/lib/cmdlib/node.py > +++ b/lib/cmdlib/node.py > @@@ -857,10 -868,9 +862,8 @@@ class LUNodeSetParams(LogicalUnit) > # this will trigger job queue propagation or cleanup if the mc > # flag changed > if [self.old_role, self.new_role].count(self._ROLE_CANDIDATE) == 1: > - self.context.ReaddNode(node) > > - if self.cfg.GetClusterInfo().modify_ssh_setup: > - potential_master_candidates = > self.cfg.GetPotentialMasterCandidates() > - master_node = self.cfg.GetMasterNode() > + if modify_ssh_setup: > if self.old_role == self._ROLE_CANDIDATE: > master_candidate_uuids = self.cfg.GetMasterCandidateUuids() > ssh_result = self.rpc.call_node_ssh_key_remove( > @@@ -1586,8 -1588,10 +1581,10 @@@ class LUNodeRemove(LogicalUnit) > WarnAboutFailedSshUpdates(result, master_node, feedback_fn) > > # Promote nodes to master candidate as needed > - AdjustCandidatePool(self, [self.node.uuid]) > + AdjustCandidatePool( > + self, [self.node.uuid], master_node, potential_master_candidates, > + feedback_fn, modify_ssh_setup) > - self.context.RemoveNode(self.cfg, self.node) > + self.cfg.RemoveNode(self.node.uuid) > > # Run post hooks on the node before it's removed > RunPostHook(self, self.node.name) > diff --cc src/Ganeti/Objects/Disk.hs > index 18ae20a,0a2e6db..ca939d1 > --- a/src/Ganeti/Objects/Disk.hs > +++ b/src/Ganeti/Objects/Disk.hs > @@@ -256,16 -257,9 +257,16 @@@ $(buildObjectWithForthcoming "Disk" "di > ++ serialFields > ++ timeStampFields) > > +instance TimeStampObject Disk where > + cTimeOf = diskCtime > + mTimeOf = diskMtime > + > instance UuidObject Disk where > - uuidOf = diskUuid > + uuidOf = UTF8.toString . diskUuid > > +instance SerialNoObject Disk where > + serialOf = diskSerial > + > instance ForthcomingObject Disk where > isForthcoming = diskForthcoming > > diff --cc src/Ganeti/Objects/Lens.hs > index 05bb5f2,11413a2..e838bfd > --- a/src/Ganeti/Objects/Lens.hs > +++ b/src/Ganeti/Objects/Lens.hs > @@@ -78,15 -86,6 +86,15 @@@ $(makeCustomLenses ''PartialNic > > $(makeCustomLenses ''Disk) > > +instance TimeStampObjectL Disk where > + mTimeL = diskMtimeL > + > +instance UuidObjectL Disk where > - uuidL = diskUuidL > ++ uuidL = diskUuidL . stringL > + > +instance SerialNoObjectL Disk where > + serialL = diskSerialL > + > $(makeCustomLenses ''Instance) > > instance TimeStampObjectL Instance where > diff --cc src/Ganeti/WConfd/ConfigModifications.hs > index f724c2e,b0a425b..9e66609 > --- a/src/Ganeti/WConfd/ConfigModifications.hs > +++ b/src/Ganeti/WConfd/ConfigModifications.hs > @@@ -39,366 -39,21 +39,376 @@@ SOFTWARE, EVEN IF ADVISED OF THE POSSIB > > module Ganeti.WConfd.ConfigModifications where > > +import Control.Applicative ((<$>)) > +import Control.Lens (_2) > +import Control.Lens.Getter ((^.)) > +import Control.Lens.Setter ((.~), (%~)) > + import qualified Data.ByteString.UTF8 as UTF8 > -import Control.Lens.Setter ((.~)) > import Control.Lens.Traversal (mapMOf) > -import Data.Maybe (isJust) > +import Control.Monad (unless, when, forM_, foldM, liftM2) > +import Control.Monad.Error (throwError, MonadError) > +import Control.Monad.IO.Class (liftIO) > +import Control.Monad.Trans.State (StateT, get, put, modify, > + runStateT, execStateT) > +import Data.Foldable (fold, foldMap) > +import Data.List (elemIndex) > +import Data.Maybe (isJust, maybeToList, fromMaybe, fromJust) > import Language.Haskell.TH (Name) > +import System.Time (getClockTime, ClockTime) > +import Text.Printf (printf) > +import qualified Data.Map as M > +import qualified Data.Set as S > > -import Ganeti.JSON (alterContainerL) > +import Ganeti.BasicTypes (GenericResult(..), genericResult, toError) > +import Ganeti.Constants (lastDrbdPort) > +import Ganeti.Errors (GanetiException(..)) > +import Ganeti.JSON (Container, GenericContainer(..), alterContainerL > + , lookupContainer, MaybeForJSON(..), > TimeAsDoubleJSON(..)) > import Ganeti.Locking.Locks (ClientId, ciIdentifier) > -import Ganeti.Logging.Lifted (logDebug) > +import Ganeti.Logging.Lifted (logDebug, logInfo) > import Ganeti.Objects > import Ganeti.Objects.Lens > -import Ganeti.WConfd.ConfigState (csConfigDataL) > -import Ganeti.WConfd.Monad (WConfdMonad, modifyConfigWithLock) > +import Ganeti.Types (AdminState, AdminStateSource) > +import Ganeti.WConfd.ConfigState (ConfigState, csConfigData, > csConfigDataL) > +import Ganeti.WConfd.Monad (WConfdMonad, modifyConfigWithLock > + , modifyConfigAndReturnWithLock) > import qualified Ganeti.WConfd.TempRes as T > > +type DiskUUID = String > +type InstanceUUID = String > +type NodeUUID = String > + > +-- * accessor functions > + > +getInstanceByUUID :: ConfigState > + -> InstanceUUID > + -> GenericResult GanetiException Instance > +getInstanceByUUID cs uuid = lookupContainer > + (Bad . ConfigurationError $ > + printf "Could not find instance with UUID %s" uuid) > - uuid > ++ (UTF8.fromString uuid) > + (configInstances . csConfigData $ cs) > + > +-- * getters > + > +-- | Gets all logical volumes in the cluster > +getAllLVs :: ConfigState -> S.Set String > +getAllLVs = S.fromList . concatMap getLVsOfDisk . M.elems > + . fromContainer . configDisks . csConfigData > + where convert (LogicalVolume lvG lvV) = lvG ++ "/" ++ lvV > + getDiskLV :: Disk -> Maybe String > + getDiskLV disk = case diskLogicalId disk of > + Just (LIDPlain lv) -> Just (convert lv) > + _ -> Nothing > + getLVsOfDisk :: Disk -> [String] > + getLVsOfDisk disk = maybeToList (getDiskLV disk) > + ++ concatMap getLVsOfDisk (diskChildren disk) > + > +-- | Gets the ids of nodes, instances, node groups, > - -- networks, disks, nics, and the custer itself. > ++-- networks, disks, nics, and the cluster itself. > +getAllIDs :: ConfigState -> S.Set String > +getAllIDs cs = > + let lvs = getAllLVs cs > + keysFromC :: GenericContainer a b -> [a] > + keysFromC = M.keys . fromContainer > + > + valuesFromC :: GenericContainer a b -> [b] > + valuesFromC = M.elems . fromContainer > + > + instKeys = keysFromC . configInstances . csConfigData $ cs > + nodeKeys = keysFromC . configNodes . csConfigData $ cs > + > + instValues = map uuidOf . valuesFromC > + . configInstances . csConfigData $ cs > + nodeValues = map uuidOf . valuesFromC . configNodes . csConfigData > $ cs > + nodeGroupValues = map uuidOf . valuesFromC > + . configNodegroups . csConfigData $ cs > + networkValues = map uuidOf . valuesFromC > + . configNetworks . csConfigData $ cs > + disksValues = map uuidOf . valuesFromC . configDisks . > csConfigData $ cs > + > + nics = map nicUuid . concatMap instNics > + . valuesFromC . configInstances . csConfigData $ cs > + > + cluster = uuidOf . configCluster . csConfigData $ cs > - in S.union lvs . S.fromList $ instKeys ++ nodeKeys ++ instValues ++ > nodeValues > - ++ nodeGroupValues ++ networkValues ++ disksValues ++ nics ++ > [cluster] > ++ in S.union lvs . S.fromList $ map UTF8.toString instKeys > ++ ++ map UTF8.toString nodeKeys > ++ ++ instValues > ++ ++ nodeValues > ++ ++ nodeGroupValues > ++ ++ networkValues > ++ ++ disksValues > ++ ++ map UTF8.toString nics ++ [cluster] > + > +getAllMACs :: ConfigState -> S.Set String > +getAllMACs = S.fromList . map nicMac . concatMap instNics . M.elems > + . fromContainer . configInstances . csConfigData > + > +-- | Checks if the two objects are equal, > +-- excluding timestamps. The serial number of > +-- current must be one greater than that of target. > +-- > +-- If this is true, it implies that the update RPC > +-- updated the config, but did not successfully return. > +isIdentical :: (Eq a, SerialNoObjectL a, TimeStampObjectL a) > + => ClockTime > + -> a > + -> a > + -> Bool > +isIdentical now target current = (mTimeL .~ now $ current) == > + ((serialL %~ (+1)) . (mTimeL .~ now) $ target) > + > +-- | Checks if the two objects given have the same serial number > +checkSerial :: SerialNoObject a => a -> a -> GenericResult > GanetiException () > +checkSerial target current = if serialOf target == serialOf current > + then Ok () > + else Bad . ConfigurationError $ printf > + "Configuration object updated since it has been read: %d != %d" > + (serialOf current) (serialOf target) > + > +-- | Updates an object present in a container. > +-- The presence of the object in the container > +-- is determined by the uuid of the object. > +-- > +-- A check that serial number of the > +-- object is consistent with the serial number > +-- of the object in the container is performed. > +-- > +-- If the check passes, the object's serial number > +-- is incremented, and modification time is updated, > +-- and then is inserted into the container. > +replaceIn :: (UuidObject a, TimeStampObjectL a, SerialNoObjectL a) > + => ClockTime > + -> a > + -> Container a > + -> GenericResult GanetiException (Container a) > - replaceIn now target = alterContainerL (uuidOf target) extract > ++replaceIn now target = alterContainerL (UTF8.fromString (uuidOf target)) > extract > + where extract Nothing = Bad $ ConfigurationError > + "Configuration object unknown" > + extract (Just current) = do > + checkSerial target current > + return . Just . (serialL %~ (+1)) . (mTimeL .~ now) $ target > + > +-- | Utility fuction that combines the two > +-- possible actions that could be taken when > +-- given a target. > +-- > +-- If the target is identical to the current > +-- value, we return the modification time of > +-- the current value, and not change the config. > +-- > +-- If not, we update the config. > +updateConfigIfNecessary :: (Monad m, MonadError GanetiException m, Eq a, > + UuidObject a, SerialNoObjectL a, > TimeStampObjectL a) > + => ClockTime > + -> a > + -> (ConfigState -> Container a) > + -> (ConfigState > + -> m ((Int, ClockTime), ConfigState)) > + -> ConfigState > + -> m ((Int, ClockTime), ConfigState) > +updateConfigIfNecessary now target getContainer f cs = do > + let container = getContainer cs > + current <- lookupContainer (toError . Bad . ConfigurationError $ > + "Configuraton object unknown") > - (uuidOf target) > ++ (UTF8.fromString (uuidOf target)) > + container > + if isIdentical now target current > + then return ((serialOf current, mTimeOf current), cs) > + else f cs > + > +-- * UUID config checks > + > +-- | Checks if the config has the given UUID > +checkUUIDpresent :: UuidObject a > + => ConfigState > + -> a > + -> Bool > +checkUUIDpresent cs a = uuidOf a `S.member` getAllIDs cs > + > +-- | Checks if the given UUID is new (i.e., no in the config) > +checkUniqueUUID :: UuidObject a > + => ConfigState > + -> a > + -> Bool > +checkUniqueUUID cs a = not $ checkUUIDpresent cs a > + > +-- * RPC checks > + > +-- | Verifications done before adding an instance. > +-- Currently confirms that the instance's macs are not > +-- in use, and that the instance's UUID being > +-- present (or not present) in the config based on > +-- weather the instance is being replaced (or not). > +-- > +-- TODO: add more verifications to this call; > +-- the client should have a lock on the name of the instance. > +addInstanceChecks :: Instance > + -> Bool > + -> ConfigState > + -> GenericResult GanetiException () > +addInstanceChecks inst replace cs = do > + let macsInUse = S.fromList (map nicMac (instNics inst)) > + `S.intersection` getAllMACs cs > + unless (S.null macsInUse) . Bad . ConfigurationError $ printf > + "Cannot add instance %s; MAC addresses %s already in use" > + (show $ instName inst) (show macsInUse) > + if replace > + then do > + let check = checkUUIDpresent cs inst > + unless check . Bad . ConfigurationError $ printf > + "Cannot add %s: UUID %s already in use" > - (show $ instName inst) (instUuid inst) > ++ (show $ instName inst) (UTF8.toString (instUuid inst)) > + else do > + let check = checkUniqueUUID cs inst > + unless check . Bad . ConfigurationError $ printf > + "Cannot replace %s: UUID %s not present" > - (show $ instName inst) (instUuid inst) > ++ (show $ instName inst) (UTF8.toString (instUuid inst)) > + > +addDiskChecks :: Disk > + -> Bool > + -> ConfigState > + -> GenericResult GanetiException () > +addDiskChecks disk replace cs = > + if replace > + then > + unless (checkUUIDpresent cs disk) . Bad . ConfigurationError $ > printf > + "Cannot add %s: UUID %s already in use" > - (show $ diskName disk) (diskUuid disk) > ++ (show $ diskName disk) (UTF8.toString (diskUuid disk)) > + else > + unless (checkUniqueUUID cs disk) . Bad . ConfigurationError $ > printf > + "Cannot replace %s: UUID %s not present" > - (show $ diskName disk) (diskUuid disk) > ++ (show $ diskName disk) (UTF8.toString (diskUuid disk)) > + > +attachInstanceDiskChecks :: InstanceUUID > + -> DiskUUID > + -> MaybeForJSON Int > + -> ConfigState > + -> GenericResult GanetiException () > +attachInstanceDiskChecks uuidInst uuidDisk idx' cs = do > - let diskPresent = elem uuidDisk . map diskUuid . M.elems > ++ let diskPresent = elem uuidDisk . map (UTF8.toString . diskUuid) . > M.elems > + . fromContainer . configDisks . csConfigData $ cs > + unless diskPresent . Bad . ConfigurationError $ printf > + "Disk %s doesn't exist" uuidDisk > + > + inst <- getInstanceByUUID cs uuidInst > + let numDisks = length $ instDisks inst > + idx = fromMaybe numDisks (unMaybeForJSON idx') > + > + when (idx < 0) . Bad . GenericError $ > + "Not accepting negative indices" > + when (idx > numDisks) . Bad . GenericError $ printf > + "Got disk index %d, but there are only %d" idx numDisks > + > + let insts = M.elems . fromContainer . configInstances . csConfigData $ > cs > + forM_ insts (\inst' -> when (uuidDisk `elem` instDisks inst') . Bad > + . ReservationError $ printf "Disk %s already attached to instance %s" > + uuidDisk (show $ instName inst)) > + > +-- * Pure config modifications functions > + > +attachInstanceDisk' :: InstanceUUID > + -> DiskUUID > + -> MaybeForJSON Int > + -> ClockTime > + -> ConfigState > + -> ConfigState > +attachInstanceDisk' iUuid dUuid idx' ct cs = > + let inst = genericResult (error "impossible") id (getInstanceByUUID cs > iUuid) > + numDisks = length $ instDisks inst > + idx = fromMaybe numDisks (unMaybeForJSON idx') > + > + insert = instDisksL %~ (\ds -> take idx ds ++ [dUuid] ++ drop idx > ds) > + incr = instSerialL %~ (+ 1) > + time = instMtimeL .~ ct > + > + inst' = time . incr . insert $ inst > + disks = updateIvNames idx inst' (configDisks . csConfigData $ cs) > + > + ri = csConfigDataL . configInstancesL > - . alterContainerL iUuid .~ Just inst' > ++ . alterContainerL (UTF8.fromString iUuid) .~ Just inst' > + rds = csConfigDataL . configDisksL .~ disks > + in rds . ri $ cs > + where updateIvNames :: Int -> Instance -> Container Disk -> > Container Disk > + updateIvNames idx inst (GenericContainer m) = > + let dUuids = drop idx (instDisks inst) > + upgradeIv m' (idx'', dUuid') = > + M.adjust (diskIvNameL .~ "disk/" ++ show idx'') dUuid' > m' > - in GenericContainer $ foldl upgradeIv m (zip [idx..] dUuids) > ++ in GenericContainer $ foldl upgradeIv m > ++ (zip [idx..] (fmap UTF8.fromString dUuids)) > + > +-- * Monadic config modification functions which can return errors > + > +detachInstanceDisk' :: MonadError GanetiException m > + => InstanceUUID > + -> DiskUUID > + -> ClockTime > + -> ConfigState > + -> m ConfigState > +detachInstanceDisk' iUuid dUuid ct cs = > + let resetIv :: MonadError GanetiException m > + => Int > + -> [DiskUUID] > + -> ConfigState > + -> m ConfigState > + resetIv startIdx disks = mapMOf (csConfigDataL . configDisksL) > + (\cd -> foldM (\c (idx, dUuid') -> mapMOf (alterContainerL > dUuid') > + (\md -> case md of > + Nothing -> throwError . ConfigurationError $ > - printf "Could not find disk with UUID %s" dUuid' > ++ printf "Could not find disk with UUID %s" (UTF8.toString > dUuid') > + Just disk -> return > + . Just > + . (diskIvNameL .~ ("disk/" ++ show idx)) > + $ disk) c) > - cd (zip [startIdx..] disks)) > - iL = csConfigDataL . configInstancesL . alterContainerL iUuid > ++ cd (zip [startIdx..] (fmap UTF8.fromString disks))) > ++ iL = csConfigDataL . configInstancesL . alterContainerL > ++ (UTF8.fromString iUuid) > + in case cs ^. iL of > + Nothing -> throwError . ConfigurationError $ > + printf "Could not find instance with UUID %s" iUuid > + Just ist -> case elemIndex dUuid (instDisks ist) of > + Nothing -> return cs > + Just idx -> > + let ist' = (instDisksL %~ filter (/= dUuid)) > + . (instSerialL %~ (+1)) > + . (instMtimeL .~ ct) > + $ ist > + cs' = iL .~ Just ist' $ cs > + dks = drop (idx + 1) (instDisks ist) > + in resetIv idx dks cs' > + > +removeInstanceDisk' :: MonadError GanetiException m > + => InstanceUUID > + -> DiskUUID > + -> ClockTime > + -> ConfigState > + -> m ConfigState > +removeInstanceDisk' iUuid dUuid ct = > + let f cs > + | elem dUuid > + . fold > + . fmap instDisks > + . configInstances > + . csConfigData > + $ cs > + = throwError . ProgrammerError $ > + printf "Cannot remove disk %s. Disk is attached to an instance" > dUuid > + | elem dUuid > + . foldMap (:[]) > - . fmap diskUuid > ++ . fmap (UTF8.toString . diskUuid) > + . configDisks > + . csConfigData > + $ cs > + = return > - . ((csConfigDataL . configDisksL . alterContainerL dUuid) .~ > Nothing) > ++ . ((csConfigDataL . configDisksL . alterContainerL > ++ (UTF8.fromString dUuid)) .~ Nothing) > + . ((csConfigDataL . configClusterL . clusterSerialL) %~ (+1)) > + . ((csConfigDataL . configClusterL . clusterMtimeL) .~ ct) > + $ cs > + | otherwise = return cs > + in (f =<<) . detachInstanceDisk' iUuid dUuid ct > + > +-- * RPCs > > -- | Add a new instance to the configuration, release DRBD minors, > -- and commit temporary IPs, all while temporarily holding the config > @@@ -410,249 -68,16 +420,258 @@@ addInstance inst cid replace = d > logDebug $ "AddInstance: client " ++ show (ciIdentifier cid) > ++ " adding instance " ++ uuidOf inst > ++ " with name " ++ show (instName inst) > - let addInst = csConfigDataL . configInstancesL > - . alterContainerL (UTF8.fromString $ uuidOf inst) > - .~ Just inst > + let setCtime = instCtimeL .~ ct > + setMtime = instMtimeL .~ ct > - addInst i = csConfigDataL . configInstancesL . alterContainerL > (uuidOf i) > - .~ Just i > ++ addInst i = csConfigDataL . configInstancesL > ++ . alterContainerL (UTF8.fromString $ uuidOf i) > ++ .~ Just i > commitRes tr = mapMOf csConfigDataL $ T.commitReservedIps cid tr > r <- modifyConfigWithLock > - (\tr cs -> commitRes tr $ addInst cs) > + (\tr cs -> do > + toError $ addInstanceChecks inst replace cs > + commitRes tr $ addInst (setMtime . setCtime $ inst) cs) > - . T.releaseDRBDMinors $ uuidOf inst > + . T.releaseDRBDMinors . UTF8.fromString $ uuidOf inst > logDebug $ "AddInstance: result of config modification is " ++ show r > return $ isJust r > > +addInstanceDisk :: InstanceUUID > + -> Disk > + -> MaybeForJSON Int > + -> Bool > + -> WConfdMonad Bool > +addInstanceDisk iUuid disk idx replace = do > - logInfo $ printf "Adding disk %s to configuration" (diskUuid disk) > ++ logInfo $ printf "Adding disk %s to configuration" > ++ (UTF8.toString (diskUuid disk)) > + ct <- liftIO getClockTime > - let addD = csConfigDataL . configDisksL . alterContainerL (uuidOf disk) > ++ let addD = csConfigDataL . configDisksL . alterContainerL > ++ (UTF8.fromString (uuidOf disk)) > + .~ Just disk > + incrSerialNo = csConfigDataL . configSerialL %~ (+1) > + r <- modifyConfigWithLock (\_ cs -> do > + toError $ addDiskChecks disk replace cs > + let cs' = incrSerialNo . addD $ cs > - toError $ attachInstanceDiskChecks iUuid (diskUuid disk) idx > cs' > - return $ attachInstanceDisk' iUuid (diskUuid disk) idx ct cs') > - . T.releaseDRBDMinors $ uuidOf disk > ++ toError $ attachInstanceDiskChecks iUuid > ++ (UTF8.toString (diskUuid disk)) idx cs' > ++ return $ attachInstanceDisk' iUuid > ++ (UTF8.toString (diskUuid disk)) idx ct cs') > ++ . T.releaseDRBDMinors $ UTF8.fromString (uuidOf disk) > + return $ isJust r > + > +attachInstanceDisk :: InstanceUUID > + -> DiskUUID > + -> MaybeForJSON Int > + -> WConfdMonad Bool > +attachInstanceDisk iUuid dUuid idx = do > + ct <- liftIO getClockTime > + r <- modifyConfigWithLock (\_ cs -> do > + toError $ attachInstanceDiskChecks iUuid dUuid idx cs > + return $ attachInstanceDisk' iUuid dUuid idx ct cs) > + (return ()) > + return $ isJust r > + > +-- | Detach a disk from an instance. > +detachInstanceDisk :: InstanceUUID -> DiskUUID -> WConfdMonad Bool > +detachInstanceDisk iUuid dUuid = do > + ct <- liftIO getClockTime > + isJust <$> modifyConfigWithLock > + (const $ detachInstanceDisk' iUuid dUuid ct) (return ()) > + > +-- | Detach a disk from an instance and > +-- remove it from the config. > +removeInstanceDisk :: InstanceUUID -> DiskUUID -> WConfdMonad Bool > +removeInstanceDisk iUuid dUuid = do > + ct <- liftIO getClockTime > + isJust <$> modifyConfigWithLock > + (const $ removeInstanceDisk' iUuid dUuid ct) (return ()) > + > +-- | Remove the instance from the configuration. > +removeInstance :: InstanceUUID -> WConfdMonad Bool > +removeInstance iUuid = do > + ct <- liftIO getClockTime > - let iL = csConfigDataL . configInstancesL . alterContainerL iUuid > ++ let iL = csConfigDataL . configInstancesL . alterContainerL > ++ (UTF8.fromString iUuid) > + pL = csConfigDataL . configClusterL . clusterTcpudpPortPoolL > + sL = csConfigDataL . configClusterL . clusterSerialL > + mL = csConfigDataL . configClusterL . clusterMtimeL > + > + -- Add the instances' network port to the cluster pool > + f :: Monad m => StateT ConfigState m () > + f = get >>= (maybe > + (return ()) > + (maybe > + (return ()) > + (modify . (pL %~) . (:)) > + . instNetworkPort) > + . (^. iL)) > + > + -- Release all IP addresses to the pool > + g :: (MonadError GanetiException m, Functor m) => StateT > ConfigState m () > + g = get >>= (maybe > + (return ()) > + (mapM_ (\nic -> > + when ((isJust . nicNetwork $ nic) && (isJust . nicIp $ nic)) $ > do > + let network = fromJust . nicNetwork $ nic > + ip <- readIp4Address (fromJust . nicIp $ nic) > - get >>= mapMOf csConfigDataL (T.commitReleaseIp network ip) > >>= put) > ++ get >>= mapMOf csConfigDataL (T.commitReleaseIp > ++ (UTF8.fromString network) ip) > >>= put) > + . instNics) > + . (^. iL)) > + > + -- Remove the instance and update cluster serial num, and mtime > + h :: Monad m => StateT ConfigState m () > + h = modify $ (iL .~ Nothing) . (sL %~ (+1)) . (mL .~ ct) > + isJust <$> modifyConfigWithLock (const $ execStateT (f >> g >> h)) > (return ()) > + > +-- | Allocate a port. > +-- The port will be taken from the available port pool or from the > +-- default port range (and in this case we increase > +-- highest_used_port). > +allocatePort :: WConfdMonad (MaybeForJSON Int) > +allocatePort = do > + maybePort <- modifyConfigAndReturnWithLock (\_ cs -> > + let portPoolL = csConfigDataL . configClusterL . > clusterTcpudpPortPoolL > + hupL = csConfigDataL . configClusterL . clusterHighestUsedPortL > + in case cs ^. portPoolL of > + [] -> if cs ^. hupL >= lastDrbdPort > + then throwError . ConfigurationError $ printf > + "The highest used port is greater than %s. Aborting." > lastDrbdPort > + else return (cs ^. hupL + 1, hupL %~ (+1) $ cs) > + (p:ps) -> return (p, portPoolL .~ ps $ cs)) > + (return ()) > + return . MaybeForJSON $ maybePort > + > +-- | Adds a new port to the available port pool. > +addTcpUdpPort :: Int -> WConfdMonad Bool > +addTcpUdpPort port = > + let pL = csConfigDataL . configClusterL . clusterTcpudpPortPoolL > + f :: Monad m => ConfigState -> m ConfigState > + f = mapMOf pL (return . (port:) . filter (/= port)) > + in isJust <$> modifyConfigWithLock (const f) (return ()) > + > +-- | Set the instances' status to a given value. > +setInstanceStatus :: InstanceUUID > + -> MaybeForJSON AdminState > + -> MaybeForJSON Bool > + -> MaybeForJSON AdminStateSource > + -> WConfdMonad (MaybeForJSON Instance) > +setInstanceStatus iUuid m1 m2 m3 = do > + ct <- liftIO getClockTime > + let modifyInstance = maybe id (instAdminStateL .~) (unMaybeForJSON m1) > + . maybe id (instDisksActiveL .~) (unMaybeForJSON m2) > + . maybe id (instAdminStateSourceL .~) > (unMaybeForJSON m3) > + reviseInstance = (instSerialL %~ (+1)) > + . (instMtimeL .~ ct) > + > + g :: Instance -> Instance > + g i = if modifyInstance i == i > + then i > + else reviseInstance . modifyInstance $ i > + > - iL = csConfigDataL . configInstancesL . alterContainerL iUuid > ++ iL = csConfigDataL . configInstancesL . alterContainerL > ++ (UTF8.fromString iUuid) > + > + f :: MonadError GanetiException m => StateT ConfigState m Instance > + f = get >>= (maybe > + (throwError . ConfigurationError $ > + printf "Could not find instance with UUID %s" iUuid) > + (liftM2 (>>) > + (modify . (iL .~) . Just) > + return . g) > + . (^. iL)) > + MaybeForJSON <$> modifyConfigAndReturnWithLock > + (const $ runStateT f) (return ()) > + > +-- | Sets the primary node of an existing instance > +setInstancePrimaryNode :: InstanceUUID -> NodeUUID -> WConfdMonad Bool > +setInstancePrimaryNode iUuid nUuid = isJust <$> modifyConfigWithLock > - (\_ -> mapMOf (csConfigDataL . configInstancesL . alterContainerL > iUuid) > ++ (\_ -> mapMOf (csConfigDataL . configInstancesL . alterContainerL > ++ (UTF8.fromString iUuid)) > + (\mi -> case mi of > + Nothing -> throwError . ConfigurationError $ > + printf "Could not find instance with UUID %s" iUuid > + Just ist -> return . Just $ (instPrimaryNodeL .~ nUuid) ist)) > + (return ()) > + > +-- | The configuration is updated by the provided cluster > +updateCluster :: Cluster -> WConfdMonad (MaybeForJSON (Int, > TimeAsDoubleJSON)) > +updateCluster cluster = do > + ct <- liftIO getClockTime > + r <- modifyConfigAndReturnWithLock (\_ cs -> do > + let currentCluster = configCluster . csConfigData $ cs > + if isIdentical ct cluster currentCluster > + then return ((serialOf currentCluster, mTimeOf currentCluster), cs) > + else do > + toError $ checkSerial cluster currentCluster > + let updateC = (clusterSerialL %~ (+1)) . (clusterMtimeL .~ ct) > + return ((serialOf cluster + 1, ct) > + , csConfigDataL . configClusterL .~ updateC cluster $ cs)) > + (return ()) > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > +-- | The configuration is updated by the provided node > +updateNode :: Node -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON)) > +updateNode node = do > + ct <- liftIO getClockTime > + let nL = csConfigDataL . configNodesL > + updateC = (clusterSerialL %~ (+1)) . (clusterMtimeL .~ ct) > + r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct > node > + (^. nL) (\cs -> do > + nC <- toError $ replaceIn ct node (cs ^. nL) > + return ((serialOf node + 1, ct), (nL .~ nC) > + . (csConfigDataL . configClusterL %~ updateC) > + $ cs))) > + (return ()) > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > +-- | The configuration is updated by the provided instance > +updateInstance :: Instance -> WConfdMonad (MaybeForJSON (Int, > TimeAsDoubleJSON)) > +updateInstance inst = do > + ct <- liftIO getClockTime > + let iL = csConfigDataL . configInstancesL > + r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct > inst > + (^. iL) (\cs -> do > + iC <- toError $ replaceIn ct inst (cs ^. iL) > + return ((serialOf inst + 1, ct), (iL .~ iC) cs))) > + (return ()) > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > +-- | The configuration is updated by the provided nodegroup > +updateNodeGroup :: NodeGroup > + -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON)) > +updateNodeGroup ng = do > + ct <- liftIO getClockTime > + let ngL = csConfigDataL . configNodegroupsL > + r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct ng > + (^. ngL) (\cs -> do > + ngC <- toError $ replaceIn ct ng (cs ^. ngL) > + return ((serialOf ng + 1, ct), (ngL .~ ngC) cs))) > + (return ()) > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > +-- | The configuration is updated by the provided network > +updateNetwork :: Network -> WConfdMonad (MaybeForJSON (Int, > TimeAsDoubleJSON)) > +updateNetwork net = do > + ct <- liftIO getClockTime > + let nL = csConfigDataL . configNetworksL > + r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct > net > + (^. nL) (\cs -> do > + nC <- toError $ replaceIn ct net (cs ^. nL) > + return ((serialOf net + 1, ct), (nL .~ nC) cs))) > + (return ()) > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > +-- | The configuration is updated by the provided disk > +updateDisk :: Disk -> WConfdMonad (MaybeForJSON (Int, TimeAsDoubleJSON)) > +updateDisk disk = do > + ct <- liftIO getClockTime > + let dL = csConfigDataL . configDisksL > + r <- modifyConfigAndReturnWithLock (\_ -> updateConfigIfNecessary ct > disk > + (^. dL) (\cs -> do > + dC <- toError $ replaceIn ct disk (cs ^. dL) > + return ((serialOf disk + 1, ct), (dL .~ dC) cs))) > - . T.releaseDRBDMinors $ uuidOf disk > ++ . T.releaseDRBDMinors . UTF8.fromString $ uuidOf disk > + return . MaybeForJSON $ fmap (_2 %~ TimeAsDoubleJSON) r > + > -- * The list of functions exported to RPC. > > exportedFunctions :: [Name] > diff --cc test/hs/Test/Ganeti/Objects.hs > index 8f7563b,e2a17a1..90967ce > --- a/test/hs/Test/Ganeti/Objects.hs > +++ b/test/hs/Test/Ganeti/Objects.hs > @@@ -373,15 -377,8 +380,15 @@@ instance Arbitrary FilterRule wher > <*> arbitrary > <*> arbitrary > <*> arbitrary > - <*> genUUID > + <*> fmap UTF8.fromString genUUID > > +instance Arbitrary SshKeyType where > + arbitrary = oneof > + [ pure RSA > + , pure DSA > + , pure ECDSA > + ] > + > -- | Generates a network instance with minimum netmasks of /24. > Generating > -- bigger networks slows down the tests, because long bit strings are > generated > -- for the reservations. > -- > > Helga Velroyen > Software Engineer > [email protected] > > Google Germany GmbH > Dienerstraße 12 > 80331 München > > Geschäftsführer: Matthew Scott Sucherman, Paul Terence Manicle > Registergericht und -nummer: Hamburg, HRB 86891 > Sitz der Gesellschaft: Hamburg > > Diese E-Mail ist vertraulich. Wenn Sie nicht der richtige Adressat sind, > leiten Sie diese bitte nicht weiter, informieren Sie den Absender und > löschen Sie die E-Mail und alle Anhänge. Vielen Dank. > > This e-mail is confidential. If you are not the right addressee please do > not forward it, please inform the sender, and please erase this e-mail > including any attachments. Thanks. > > Hrvoje Ribicic Ganeti Engineering Google Germany GmbH Dienerstr. 12, 80331, München Geschäftsführer: Matthew Scott Sucherman, Paul Terence Manicle Registergericht und -nummer: Hamburg, HRB 86891 Sitz der Gesellschaft: Hamburg Diese E-Mail ist vertraulich. Wenn Sie nicht der richtige Adressat sind, leiten Sie diese bitte nicht weiter, informieren Sie den Absender und löschen Sie die E-Mail und alle Anhänge. Vielen Dank. This e-mail is confidential. If you are not the right addressee please do not forward it, please inform the sender, and please erase this e-mail including any attachments. Thanks.
