import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.State
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as F
import Data.List (foldl', nub)
import Data.Maybe (fromMaybe)
-- | Returns the default cluster link.
getDefaultNicLink :: ConfigData -> String
getDefaultNicLink =
- nicpLink . (M.! C.ppDefault) . fromContainer .
- clusterNicparams . configCluster
+ let ppDefault = UTF8.fromString C.ppDefault
+ in nicpLink . (M.! ppDefault) . fromContainer
+ . clusterNicparams . configCluster
-- | Returns the default cluster hypervisor.
getDefaultHypervisor :: ConfigData -> Hypervisor
maybe (err "not found after successfull match?!") Ok $
M.lookup fullname allitems
+-- | Simple lookup function, insisting on exact matches and using
+-- byte strings.
+getItem' :: String -> String -> M.Map BS.ByteString a -> ErrorResult a
+getItem' kind name allitems =
+ let name' = UTF8.fromString name
+ err = Bad $ OpPrereqError (kind ++ " uuid " ++ name ++ " not found")
+ ECodeNoEnt
+ in maybe err Ok $ M.lookup name' allitems
+
-- | Looks up a node by name or uuid.
getNode :: ConfigData -> String -> ErrorResult Node
getNode cfg name =
let nodes = fromContainer (configNodes cfg)
- in case getItem "Node" name nodes of
+ in case getItem' "Node" name nodes of
-- if not found by uuid, we need to look it up by name
Ok node -> Ok node
Bad _ -> let by_name = M.mapKeys
getInstance :: ConfigData -> String -> ErrorResult Instance
getInstance cfg name =
let instances = fromContainer (configInstances cfg)
- in case getItem "Instance" name instances of
+ in case getItem' "Instance" name instances of
-- if not found by uuid, we need to look it up by name
Ok inst -> Ok inst
Bad _ -> let by_name =
getDisk :: ConfigData -> String -> ErrorResult Disk
getDisk cfg name =
let disks = fromContainer (configDisks cfg)
- in getItem "Disk" name disks
+ in getItem' "Disk" name disks
-- | Looks up a filter by uuid.
getFilterRule :: ConfigData -> String -> ErrorResult FilterRule
getFilterRule cfg name =
let filters = fromContainer (configFilters cfg)
- in getItem "Filter" name filters
+ in getItem' "Filter" name filters
-- | Looks up a node group by name or uuid.
getGroup :: ConfigData -> String -> ErrorResult NodeGroup
getGroup cfg name =
let groups = fromContainer (configNodegroups cfg)
- in case getItem "NodeGroup" name groups of
+ in case getItem' "NodeGroup" name groups of
-- if not found by uuid, we need to look it up by name, slow
Ok grp -> Ok grp
Bad _ -> let by_name = M.mapKeys
parentHvParams =
maybe M.empty fromContainer (maybeHvName >>= flip M.lookup hvParamMap)
-- Then the os defaults for the given hypervisor
- maybeOsName = instOs inst
+ maybeOsName = UTF8.fromString <$> instOs inst
osParamMap = fromContainer . clusterOsHvp $ configCluster cfg
osHvParamMap =
maybe M.empty (maybe M.empty fromContainer . flip M.lookup osParamMap)
-- Then the child
childHvParams = fromContainer . instHvparams $ inst
-- Helper function
- fillFn con val = fillDict con val globals
+ fillFn con val = fillDict con val $ fmap UTF8.fromString globals
in GenericContainer $ fillFn (fillFn parentHvParams osHvParams) childHvParams
-- | Retrieves the instance backend params, missing values filled with cluster
getFilledInstBeParams :: ConfigData -> Instance -> ErrorResult FilledBeParams
getFilledInstBeParams cfg inst = do
let beParamMap = fromContainer . clusterBeparams . configCluster $ cfg
- parentParams <- getItem "FilledBeParams" C.ppDefault beParamMap
+ parentParams <- getItem' "FilledBeParams" C.ppDefault beParamMap
return $ fillParams parentParams (instBeparams inst)
-- | Retrieves the instance os params, missing values filled with cluster
osParamMap = fromContainer . clusterOsparams $ configCluster cfg
childOsParams = instOsparams inst
in case withMissingParam "Instance without OS"
- (flip (getItem "OsParams") osParamMap)
+ (flip (getItem' "OsParams") osParamMap)
maybeOsLookupName of
Ok parentOsParams -> GenericContainer $
fillDict (fromContainer parentOsParams)
buildLinkIpInstnameMap cfg =
let cluster = configCluster cfg
instances = M.elems . fromContainer . configInstances $ cfg
- defparams = (M.!) (fromContainer $ clusterNicparams cluster) C.ppDefault
+ defparams = (M.!) (fromContainer $ clusterNicparams cluster)
+ $ UTF8.fromString C.ppDefault
nics = concatMap (\i -> [(fromMaybe (uuidOf i) $ instName i, nic)
| nic <- instNics i])
instances
-- (configuration corrupt).
getGroupOfNode :: ConfigData -> Node -> Maybe NodeGroup
getGroupOfNode cfg node =
- M.lookup (nodeGroup node) (fromContainer . configNodegroups $ cfg)
+ M.lookup (UTF8.fromString $ nodeGroup node)
+ (fromContainer . configNodegroups $ cfg)
-- | Returns a node's ndparams, filled.
getNodeNdParams :: ConfigData -> Node -> Maybe FilledNDParams
getNetwork :: ConfigData -> String -> ErrorResult Network
getNetwork cfg name =
let networks = fromContainer (configNetworks cfg)
- in case getItem "Network" name networks of
+ in case getItem' "Network" name networks of
Ok net -> Ok net
Bad _ -> let by_name = M.mapKeys
(fromNonEmpty . networkName . (M.!) networks)
module Ganeti.DataCollectors( collectors ) where
+import qualified Data.ByteString.UTF8 as UTF8
import Data.Map (findWithDefault)
import Data.Monoid (mempty)
any xenHypervisor . clusterEnabledHypervisors $ configCluster cfg
collectorConfig name cfg =
let config = fromContainer . clusterDataCollectors $ configCluster cfg
- in findWithDefault mempty name config
+ in findWithDefault mempty (UTF8.fromString name) config
updateInterval name cfg = dataCollectorInterval $ collectorConfig name cfg
activeConfig name cfg = dataCollectorActive $ collectorConfig name cfg
diskStatsCollector =
import Control.DeepSeq
import Control.Monad.Error.Class
import Control.Monad.Writer
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as F
import qualified Data.Text as T
import qualified Data.Traversable as F
emptyContainer = GenericContainer Map.empty
-- | Type alias for string keys.
-type Container = GenericContainer String
+type Container = GenericContainer BS.ByteString
+
+instance HasStringRepr BS.ByteString where
+ fromStringRepr = return . UTF8.fromString
+ toStringRepr = UTF8.toString
-- | Creates a GenericContainer from a list of key-value pairs.
containerFromList :: Ord a => [(a,b)] -> GenericContainer a b
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString.Char8 (pack, unpack)
+import qualified Data.ByteString.UTF8 as UTF8
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Monoid (mempty)
let answer = CT.confdReplyAnswer confdReply
case J.readJSON answer :: J.Result (GJ.Container DataCollectorConfig) of
J.Error _ -> Nothing
- J.Ok container -> GJ.lookupContainer Nothing name container
+ J.Ok container -> GJ.lookupContainer Nothing (UTF8.fromString name)
+ container
activeCollectors :: MVar ConfigAccess -> IO [DataCollector]
activeCollectors mvarConfig = do
import Control.Applicative
import Control.Monad (liftM, (>=>))
+import qualified Data.ByteString.UTF8 as UTF8
import Data.Either
import Data.List
import Data.Maybe
-- | Given a network name id, returns the network's name.
getNetworkName :: ConfigData -> String -> NonEmptyString
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg)
+ . UTF8.fromString
-- | Gets the bridge of a NIC.
getNicBridge :: FilledNicParams -> Maybe String
-- | Retrieves the default network interface parameters.
getDefaultNicParams :: ConfigData -> FilledNicParams
getDefaultNicParams cfg =
- (Map.!) (fromContainer . clusterNicparams . configCluster $ cfg) C.ppDefault
+ (Map.!) (fromContainer . clusterNicparams . configCluster $ cfg)
+ $ UTF8.fromString C.ppDefault
-- | Retrieves the real disk size requirements for all the disks of the
-- instance. This includes the metadata etc. and is different from the values
hvParamGetter :: String -- ^ The field we're building the getter for
-> ConfigData -> Instance -> ResultEntry
hvParamGetter field cfg inst =
- rsMaybeUnavail . Map.lookup field . fromContainer $
+ rsMaybeUnavail . Map.lookup (UTF8.fromString field) . fromContainer $
getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst
-- * Live fields functionality
allowDown =
userShutdownEnabled cfg &&
(instHypervisor inst /= Just Kvm ||
- (Map.member C.hvKvmUserShutdown hvparams &&
- hvparams Map.! C.hvKvmUserShutdown == J.JSBool True))
+ (Map.member (UTF8.fromString C.hvKvmUserShutdown) hvparams &&
+ hvparams Map.! UTF8.fromString C.hvKvmUserShutdown
+ == J.JSBool True))
-- | Determines the status of a dead instance.
deadInstanceStatus :: ConfigData -> Instance -> InstanceStatus
-- FIXME: everything except fieldsMap
-- is only exported for testing.
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (find, intercalate)
String -> NodeGroup -> Maybe (String, String, String, String)
getGroupConnection network_uuid group =
let networks = fromContainer . groupNetworks $ group
- in case Map.lookup network_uuid networks of
+ in case Map.lookup (UTF8.fromString network_uuid) networks of
Nothing -> Nothing
Just net ->
Just (groupName group, getNicMode net, getNicLink net, getNicVlan net)
import Control.Monad (filterM, foldM, liftM, unless)
import Control.Monad.IO.Class
import Control.Monad.Trans (lift)
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as Foldable
import Data.List (intercalate, nub, find)
import Data.Maybe (fromMaybe)
(CollectorSimple $ recollectLocksData livedata)
id
(const . GenericContainer . Map.fromList
- . map ((id &&& id) . lockName) $ allLocks)
+ . map ((UTF8.fromString &&& id) . lockName) $ allLocks)
(const Ok)
cfg live fields qfilter []
toError answer
, frUuid = UTF8.fromString uuid
}
writeConfig cid
- . (configFiltersL . alterContainerL uuid .~ Just rule)
+ . (configFiltersL . alterContainerL (UTF8.fromString uuid)
+ .~ Just rule)
$ lockedCfg
-- Return UUID of added/replaced filter.
-- Check if filter exists.
_ <- lookupContainer
(failError $ "Filter rule with UUID " ++ uuid ++ " does not exist")
- uuid
+ (UTF8.fromString uuid)
(configFilters cfg)
-- Ask WConfd to change the config for us.
cid <- liftIO $ makeLuxidClientId status
withLockedWconfdConfig cid $ \lockedCfg ->
writeConfig cid
- . (configFiltersL . alterContainerL uuid .~ Nothing)
+ . (configFiltersL . alterContainerL (UTF8.fromString uuid) .~ Nothing)
$ lockedCfg
return JSNull
module Ganeti.WConfd.ConfigModifications where
+import qualified Data.ByteString.UTF8 as UTF8
import Control.Lens.Setter ((.~))
import Control.Lens.Traversal (mapMOf)
import Data.Maybe (isJust)
logDebug $ "AddInstance: client " ++ show (ciIdentifier cid)
++ " adding instance " ++ uuidOf inst
++ " with name " ++ show (instName inst)
- let addInst = csConfigDataL . configInstancesL . alterContainerL (uuidOf inst)
+ let addInst = csConfigDataL . configInstancesL
+ . alterContainerL (UTF8.fromString $ uuidOf inst)
.~ Just inst
commitRes tr = mapMOf csConfigDataL $ T.commitReservedIps cid tr
r <- modifyConfigWithLock
(\tr cs -> commitRes tr $ addInst cs)
- . T.releaseDRBDMinors $ uuidOf inst
+ . T.releaseDRBDMinors . UTF8.fromString $ uuidOf inst
logDebug $ "AddInstance: result of config modification is " ++ show r
return $ isJust r
) where
import Control.Monad.Error
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Set as S
=> String -> Container a -> ValidationMonad ()
checkUUIDKeys what = mapM_ check . M.toList . fromContainer
where
- check (uuid, x) = reportIf (uuid /= uuidOf x)
+ check (uuid, x) = reportIf (uuid /= UTF8.fromString (uuidOf x))
$ what ++ " '" ++ show x
- ++ "' is indexed by wrong UUID '" ++ uuid ++ "'"
+ ++ "' is indexed by wrong UUID '"
+ ++ UTF8.toString uuid ++ "'"
-- | Checks that all linked UUID of given objects exist.
checkUUIDRefs :: (UuidObject a, Show a, F.Foldable f)
where
uuids = keysSet targets
check x = forM_ (linkf x) $ \uuid ->
- reportIf (not $ S.member uuid uuids)
+ reportIf (not $ S.member (UTF8.fromString uuid) uuids)
$ whatObj ++ " '" ++ show x ++ "' references a non-existing "
++ whatTarget ++ " UUID '" ++ uuid ++ "'"
-- we don't need to check for invalid templates as they wouldn't parse
let masterNodeName = clusterMasterNode cluster
- reportIf (not $ masterNodeName `S.member` keysSet (configNodes cd))
+ reportIf (not $ UTF8.fromString masterNodeName
+ `S.member` keysSet (configNodes cd))
$ "cluster has invalid primary node " ++ masterNodeName
-- UUIDs
, mkSSConf
) where
-import Control.Arrow ((&&&), first, second)
+import Control.Arrow ((&&&), (***), first)
+import qualified Data.ByteString.UTF8 as UTF8
import Data.Foldable (Foldable(..), toList)
import Data.List (partition)
import Data.Maybe (mapMaybe)
-- @key=value@.
hvparamsStrings :: HvParams -> [String]
hvparamsStrings =
- map (eqPair . second hvparamShow) . M.toList . fromContainer
+ map (eqPair . (UTF8.toString *** hvparamShow)) . M.toList . fromContainer
-- | Convert a hypervisor parameter in its JSON representation to a String.
-- Strings, numbers and booleans are just printed (without quotes), booleans
mapLines :: (Foldable f) => (a -> String) -> f a -> [String]
mapLines f = map f . toList
spcPair (x, y) = x ++ " " ++ y
- toPairs = M.assocs . fromContainer
+ toPairs = M.assocs . M.mapKeys UTF8.toString . fromContainer
cluster = configCluster cdata
mcs = getMasterOrCandidates cdata
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Trans.Maybe
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Foldable as F
import Data.Maybe
import Data.Map (Map)
-- ** Aliases to make types more meaningful:
-type NodeUUID = String
+type NodeUUID = BS.ByteString
-type InstanceUUID = String
+type InstanceUUID = BS.ByteString
-type DiskUUID = String
+type DiskUUID = BS.ByteString
-type NetworkUUID = String
+type NetworkUUID = BS.ByteString
type DRBDMinor = Int
-- | Adds minors of a disk within the state monad
addMinors disk = do
let minors = getDrbdMinorsForDisk disk
- forM_ minors $ \(minor, node) -> nodeMinor node minor %= (uuidOf disk :)
+ forM_ minors $ \(minor, node) ->
+ nodeMinor (UTF8.fromString node) minor %=
+ (UTF8.fromString (uuidOf disk) :)
-- | Compute the map of used DRBD minor/nodes.
-- Report any duplicate entries as an error.
instance Arbitrary (Container DataCollectorConfig) where
arbitrary = do
- let names = CU.toList C.dataCollectorNames
+ let names = map UTF8.fromString $ CU.toList C.dataCollectorNames
activations <- vector $ length names
timeouts <- vector $ length names
let configs = zipWith DataCollectorConfig activations timeouts
arbitrary = return $ GenericContainer Map.empty
instance Arbitrary ClusterNicParams where
- arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
+ arbitrary = (GenericContainer . Map.singleton (UTF8.fromString C.ppDefault))
+ <$> arbitrary
instance Arbitrary OsParams where
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
nodes' = zipWith (\n idx ->
let newname = takeWhile (/= '.') (nodeName n)
++ "-" ++ show idx
- in (newname, n { nodeGroup = guuid,
- nodeName = newname}))
+ in ( UTF8.fromString newname
+ , n { nodeGroup = guuid, nodeName = newname}))
nodes [(1::Int)..]
nodemap = Map.fromList nodes'
contnodes = if Map.size nodemap /= ncount
networks = GenericContainer Map.empty
disks = GenericContainer Map.empty
filters = GenericContainer Map.empty
- let contgroups = GenericContainer $ Map.singleton guuid grp
+ let contgroups = GenericContainer $ Map.singleton (UTF8.fromString guuid) grp
serial <- arbitrary
-- timestamp fields
ctime <- arbitrary
let nets_unique = map ( \(name, net) -> net { networkName = name } )
(zip net_names nets)
net_map = GenericContainer $ Map.fromList
- (map (\n -> (uuidOf n, n)) nets_unique)
+ (map (\n -> (UTF8.fromString $ uuidOf n, n)) nets_unique)
new_cfg = old_cfg { configNetworks = net_map }
return new_cfg
ipolicy <- arbitrary
diskparams <- pure (GenericContainer Map.empty)
num_networks <- choose (0, 3)
- net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
+ net_uuid_list <- vectorOf num_networks (arbitrary::Gen BS.ByteString)
nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
net_map <- pure (GenericContainer . Map.fromList $
zip net_uuid_list nic_param_list)
, ExportTargetRemote <$> pure []
]
-arbitraryDataCollector :: Gen (Container Bool)
+arbitraryDataCollector :: Gen (GenericContainer String Bool)
arbitraryDataCollector = do
els <- listOf . elements $ CU.toList C.dataCollectorNames
activation <- vector $ length els
return . GenericContainer . Map.fromList $ zip els activation
-arbitraryDataCollectorInterval :: Gen (Maybe (Container Int))
+arbitraryDataCollectorInterval :: Gen (Maybe (GenericContainer String Int))
arbitraryDataCollectorInterval = do
els <- listOf . elements $ CU.toList C.dataCollectorNames
intervals <- vector $ length els
import Test.QuickCheck hiding (Result)
import Test.QuickCheck.Monadic
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as Map
import Data.List
import Text.JSON (showJSON)
genClusterNames min_nodes max_nodes = do
numnodes <- choose (min_nodes, max_nodes)
cfg <- genEmptyCluster numnodes
- return (cfg, niceSort . Map.keys . fromContainer $ configNodes cfg)
+ return (cfg , niceSort . map UTF8.toString . Map.keys . fromContainer
+ $ configNodes cfg)
-- * Test cases
import Test.QuickCheck
+import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as Map
import Data.Maybe
-- a non-Nothing result.
prop_getGroupConnection :: NodeGroup -> Property
prop_getGroupConnection group =
- let net_keys = (Map.keys . fromContainer . groupNetworks) group
+ let net_keys = map UTF8.toString . Map.keys . fromContainer . groupNetworks
+ $ group
in True ==? all
(\nk -> isJust (getGroupConnection nk group)) net_keys
-- yields 'Nothing'.
prop_getGroupConnection_notFound :: NodeGroup -> String -> Property
prop_getGroupConnection_notFound group uuid =
- let net_keys = (Map.keys . fromContainer . groupNetworks) group
- in notElem uuid net_keys ==> isNothing (getGroupConnection uuid group)
+ let net_map = fromContainer . groupNetworks $ group
+ in not (UTF8.fromString uuid `Map.member` net_map)
+ ==> isNothing (getGroupConnection uuid group)
-- | Checks whether actually connected instances are identified as such.
prop_instIsConnected :: ConfigData -> Property
prop_instIsConnected cfg =
let nets = (fromContainer . configNetworks) cfg
- net_keys = Map.keys nets
+ net_keys = map UTF8.toString $ Map.keys nets
in forAll (genInstWithNets net_keys) $ \inst ->
True ==? all (`instIsConnected` inst) net_keys
prop_instIsConnected_notFound :: ConfigData -> String -> Property
prop_instIsConnected_notFound cfg network_uuid =
let nets = (fromContainer . configNetworks) cfg
- net_keys = Map.keys nets
+ net_keys = map UTF8.toString $ Map.keys nets
in notElem network_uuid net_keys ==>
forAll (genInstWithNets net_keys) $ \inst ->
not (instIsConnected network_uuid inst)
projects / ganeti-github.git / commitdiff