module Ganeti.Objects
( HvParams
, OsParams
, OsParamsPrivate
, PartialNicParams(..)
, FilledNicParams(..)
, allNicParamFields
, PartialNic(..)
, FileDriver(..)
, DataCollectorConfig(..)
, DiskTemplate(..)
, PartialBeParams(..)
, FilledBeParams(..)
, PartialNDParams(..)
, FilledNDParams(..)
, allNDParamFields
, Node(..)
, AllocPolicy(..)
, FilledISpecParams(..)
, PartialISpecParams(..)
, allISpecParamFields
, MinMaxISpecs(..)
, FilledIPolicy(..)
, PartialIPolicy(..)
, GroupDiskParams
, NodeGroup(..)
, FilterAction(..)
, FilterPredicate(..)
, FilterRule(..)
, filterRuleOrder
, IpFamily(..)
, ipFamilyToRaw
, ipFamilyToVersion
, fillDict
, ClusterHvParams
, OsHvParams
, ClusterBeParams
, ClusterOsParams
, ClusterOsParamsPrivate
, ClusterNicParams
, UidPool
, formatUidRange
, UidRange
, Cluster(..)
, ConfigData(..)
, TimeStampObject(..)
, UuidObject(..)
, SerialNoObject(..)
, TagsObject(..)
, DictObject(..)
, TagSet
, Network(..)
, AddressPool(..)
, Ip4Address()
, mkIp4Address
, Ip4Network()
, mkIp4Network
, ip4netAddr
, ip4netMask
, readIp4Address
, ip4AddressToList
, ip4AddressToNumber
, ip4AddressFromNumber
, nextIp4Address
, IAllocatorParams
, MasterNetworkParameters(..)
, module Ganeti.PartialParams
, module Ganeti.Objects.Disk
, module Ganeti.Objects.Instance
) where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad.State
import Data.List (foldl', intercalate)
import Data.Maybe
import qualified Data.Map as Map
import Data.Monoid
import Data.Ord (comparing)
import Data.Ratio (numerator, denominator)
import Data.Tuple (swap)
import Data.Word
import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString,
toJSString)
import qualified Text.JSON as J
import qualified AutoConf
import qualified Ganeti.Constants as C
import qualified Ganeti.ConstantUtils as ConstantUtils
import Ganeti.JSON
import Ganeti.Objects.BitArray (BitArray)
import Ganeti.Objects.Disk
import Ganeti.Objects.Nic
import Ganeti.Objects.Instance
import Ganeti.Query.Language
import Ganeti.PartialParams
import Ganeti.Types
import Ganeti.THH
import Ganeti.THH.Field
import Ganeti.Utils (sepSplit, tryRead)
fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
fillDict defaults custom skip_keys =
let updated = Map.union custom defaults
in foldl' (flip Map.delete) updated skip_keys
data Ip4Address = Ip4Address Word8 Word8 Word8 Word8
deriving (Eq, Ord)
mkIp4Address :: (Word8, Word8, Word8, Word8) -> Ip4Address
mkIp4Address (a, b, c, d) = Ip4Address a b c d
instance Show Ip4Address where
show (Ip4Address a b c d) = intercalate "." $ map show [a, b, c, d]
readIp4Address :: (Applicative m, Monad m) => String -> m Ip4Address
readIp4Address s =
case sepSplit '.' s of
[a, b, c, d] -> Ip4Address <$>
tryRead "first octect" a <*>
tryRead "second octet" b <*>
tryRead "third octet" c <*>
tryRead "fourth octet" d
_ -> fail $ "Can't parse IPv4 address from string " ++ s
instance JSON Ip4Address where
showJSON = showJSON . show
readJSON (JSString s) = readIp4Address (fromJSString s)
readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 address"
ip4AddressToList :: Ip4Address -> [Word8]
ip4AddressToList (Ip4Address a b c d) = [a, b, c, d]
ip4AddressToNumber :: Ip4Address -> Integer
ip4AddressToNumber = foldl (\n i -> 256 * n + toInteger i) 0 . ip4AddressToList
ip4AddressFromNumber :: Integer -> Ip4Address
ip4AddressFromNumber n =
let s = state $ first fromInteger . swap . (`divMod` 256)
(d, c, b, a) = evalState ((,,,) <$> s <*> s <*> s <*> s) n
in Ip4Address a b c d
nextIp4Address :: Ip4Address -> Ip4Address
nextIp4Address = ip4AddressFromNumber . (+ 1) . ip4AddressToNumber
data Ip4Network = Ip4Network { ip4netAddr :: Ip4Address
, ip4netMask :: Word8
}
deriving (Eq)
mkIp4Network :: Ip4Address -> Word8 -> Ip4Network
mkIp4Network = Ip4Network
instance Show Ip4Network where
show (Ip4Network ip netmask) = show ip ++ "/" ++ show netmask
instance JSON Ip4Network where
showJSON = showJSON . show
readJSON (JSString s) =
case sepSplit '/' (fromJSString s) of
[ip, nm] -> do
ip' <- readIp4Address ip
nm' <- tryRead "parsing netmask" nm
if nm' >= 0 && nm' <= 32
then return $ Ip4Network ip' nm'
else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
fromJSString s
_ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"
newtype AddressPool = AddressPool { apReservations :: BitArray }
deriving (Eq, Ord, Show)
instance JSON AddressPool where
showJSON = showJSON . apReservations
readJSON = liftM AddressPool . readJSON
$(buildObject "Network" "network" $
[ simpleField "name" [t| NonEmptyString |]
, optionalField $
simpleField "mac_prefix" [t| String |]
, simpleField "network" [t| Ip4Network |]
, optionalField $
simpleField "network6" [t| String |]
, optionalField $
simpleField "gateway" [t| Ip4Address |]
, optionalField $
simpleField "gateway6" [t| String |]
, optionalField $
simpleField "reservations" [t| AddressPool |]
, optionalField $
simpleField "ext_reservations" [t| AddressPool |]
]
++ uuidFields
++ timeStampFields
++ serialFields
++ tagsFields)
instance SerialNoObject Network where
serialOf = networkSerial
instance TagsObject Network where
tagsOf = networkTags
instance UuidObject Network where
uuidOf = networkUuid
instance TimeStampObject Network where
cTimeOf = networkCtime
mTimeOf = networkMtime
type MicroSeconds = Integer
$(buildObject "DataCollectorConfig" "dataCollector" [
simpleField "active" [t| Bool|],
simpleField "interval" [t| MicroSeconds |]
])
instance Monoid DataCollectorConfig where
mempty = DataCollectorConfig
{ dataCollectorActive = True
, dataCollectorInterval = 10^(6::Integer) * fromIntegral C.mondTimeInterval
}
mappend _ a = a
$(buildParam "ISpec" "ispec"
[ simpleField ConstantUtils.ispecMemSize [t| Int |]
, simpleField ConstantUtils.ispecDiskSize [t| Int |]
, simpleField ConstantUtils.ispecDiskCount [t| Int |]
, simpleField ConstantUtils.ispecCpuCount [t| Int |]
, simpleField ConstantUtils.ispecNicCount [t| Int |]
, simpleField ConstantUtils.ispecSpindleUse [t| Int |]
])
$(buildObject "MinMaxISpecs" "mmis"
[ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
, renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
])
$(buildObject "PartialIPolicy" "ipolicy"
[ optionalField . renameField "MinMaxISpecsP" $
simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
, optionalField . renameField "StdSpecP" $
simpleField "std" [t| PartialISpecParams |]
, optionalField . renameField "SpindleRatioP" $
simpleField "spindle-ratio" [t| Double |]
, optionalField . renameField "VcpuRatioP" $
simpleField "vcpu-ratio" [t| Double |]
, optionalField . renameField "DiskTemplatesP" $
simpleField "disk-templates" [t| [DiskTemplate] |]
])
$(buildObject "FilledIPolicy" "ipolicy"
[ renameField "MinMaxISpecs" $
simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
, renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
, simpleField "spindle-ratio" [t| Double |]
, simpleField "vcpu-ratio" [t| Double |]
, simpleField "disk-templates" [t| [DiskTemplate] |]
])
instance PartialParams FilledIPolicy PartialIPolicy where
fillParams
(FilledIPolicy { ipolicyMinMaxISpecs = fminmax
, ipolicyStdSpec = fstd
, ipolicySpindleRatio = fspindleRatio
, ipolicyVcpuRatio = fvcpuRatio
, ipolicyDiskTemplates = fdiskTemplates})
(PartialIPolicy { ipolicyMinMaxISpecsP = pminmax
, ipolicyStdSpecP = pstd
, ipolicySpindleRatioP = pspindleRatio
, ipolicyVcpuRatioP = pvcpuRatio
, ipolicyDiskTemplatesP = pdiskTemplates}) =
FilledIPolicy
{ ipolicyMinMaxISpecs = fromMaybe fminmax pminmax
, ipolicyStdSpec = maybe fstd (fillParams fstd) pstd
, ipolicySpindleRatio = fromMaybe fspindleRatio pspindleRatio
, ipolicyVcpuRatio = fromMaybe fvcpuRatio pvcpuRatio
, ipolicyDiskTemplates = fromMaybe fdiskTemplates
pdiskTemplates
}
toPartial (FilledIPolicy { ipolicyMinMaxISpecs = fminmax
, ipolicyStdSpec = fstd
, ipolicySpindleRatio = fspindleRatio
, ipolicyVcpuRatio = fvcpuRatio
, ipolicyDiskTemplates = fdiskTemplates}) =
PartialIPolicy
{ ipolicyMinMaxISpecsP = Just fminmax
, ipolicyStdSpecP = Just $ toPartial fstd
, ipolicySpindleRatioP = Just fspindleRatio
, ipolicyVcpuRatioP = Just fvcpuRatio
, ipolicyDiskTemplatesP = Just fdiskTemplates
}
toFilled (PartialIPolicy { ipolicyMinMaxISpecsP = pminmax
, ipolicyStdSpecP = pstd
, ipolicySpindleRatioP = pspindleRatio
, ipolicyVcpuRatioP = pvcpuRatio
, ipolicyDiskTemplatesP = pdiskTemplates}) =
FilledIPolicy <$> pminmax <*> (toFilled =<< pstd) <*> pspindleRatio
<*> pvcpuRatio <*> pdiskTemplates
$(buildParam "ND" "ndp"
[ simpleField "oob_program" [t| String |]
, simpleField "spindle_count" [t| Int |]
, simpleField "exclusive_storage" [t| Bool |]
, simpleField "ovs" [t| Bool |]
, simpleField "ovs_name" [t| String |]
, simpleField "ovs_link" [t| String |]
, simpleField "ssh_port" [t| Int |]
, simpleField "cpu_speed" [t| Double |]
])
type DiskState = Container JSValue
type HypervisorState = Container JSValue
$(buildObject "Node" "node" $
[ simpleField "name" [t| String |]
, simpleField "primary_ip" [t| String |]
, simpleField "secondary_ip" [t| String |]
, simpleField "master_candidate" [t| Bool |]
, simpleField "offline" [t| Bool |]
, simpleField "drained" [t| Bool |]
, simpleField "group" [t| String |]
, simpleField "master_capable" [t| Bool |]
, simpleField "vm_capable" [t| Bool |]
, simpleField "ndparams" [t| PartialNDParams |]
, simpleField "powered" [t| Bool |]
, notSerializeDefaultField [| emptyContainer |] $
simpleField "hv_state_static" [t| HypervisorState |]
, notSerializeDefaultField [| emptyContainer |] $
simpleField "disk_state_static" [t| DiskState |]
]
++ timeStampFields
++ uuidFields
++ serialFields
++ tagsFields)
instance TimeStampObject Node where
cTimeOf = nodeCtime
mTimeOf = nodeMtime
instance UuidObject Node where
uuidOf = nodeUuid
instance SerialNoObject Node where
serialOf = nodeSerial
instance TagsObject Node where
tagsOf = nodeTags
type GroupDiskParams = Container DiskParams
type Networks = Container PartialNicParams
$(buildObject "NodeGroup" "group" $
[ simpleField "name" [t| String |]
, defaultField [| [] |] $ simpleField "members" [t| [String] |]
, simpleField "ndparams" [t| PartialNDParams |]
, simpleField "alloc_policy" [t| AllocPolicy |]
, simpleField "ipolicy" [t| PartialIPolicy |]
, simpleField "diskparams" [t| GroupDiskParams |]
, simpleField "networks" [t| Networks |]
, notSerializeDefaultField [| emptyContainer |] $
simpleField "hv_state_static" [t| HypervisorState |]
, notSerializeDefaultField [| emptyContainer |] $
simpleField "disk_state_static" [t| DiskState |]
]
++ timeStampFields
++ uuidFields
++ serialFields
++ tagsFields)
instance TimeStampObject NodeGroup where
cTimeOf = groupCtime
mTimeOf = groupMtime
instance UuidObject NodeGroup where
uuidOf = groupUuid
instance SerialNoObject NodeGroup where
serialOf = groupSerial
instance TagsObject NodeGroup where
tagsOf = groupTags
data FilterAction
= Accept
| Pause
| Reject
| Continue
| RateLimit Int
deriving (Eq, Ord, Show)
instance JSON FilterAction where
showJSON fa = case fa of
Accept -> JSString (toJSString "ACCEPT")
Pause -> JSString (toJSString "PAUSE")
Reject -> JSString (toJSString "REJECT")
Continue -> JSString (toJSString "CONTINUE")
RateLimit n -> JSArray [ JSString (toJSString "RATE_LIMIT")
, JSRational False (fromIntegral n)
]
readJSON v = case v of
JSString s | fromJSString s == "ACCEPT" -> return Accept
JSString s | fromJSString s == "PAUSE" -> return Pause
JSString s | fromJSString s == "REJECT" -> return Reject
JSString s | fromJSString s == "CONTINUE" -> return Continue
JSArray (JSString s : rest) | fromJSString s == "RATE_LIMIT" ->
case rest of
[JSRational False n] | denominator n == 1 && numerator n > 0 ->
return . RateLimit . fromIntegral $ numerator n
_ -> fail "RATE_LIMIT argument must be a positive integer"
x -> fail $ "malformed FilterAction JSON: " ++ J.showJSValue x ""
data FilterPredicate
= FPJobId (Filter FilterField)
| FPOpCode (Filter FilterField)
| FPReason (Filter FilterField)
deriving (Eq, Ord, Show)
instance JSON FilterPredicate where
showJSON fp = case fp of
FPJobId expr -> JSArray [string "jobid", showJSON expr]
FPOpCode expr -> JSArray [string "opcode", showJSON expr]
FPReason expr -> JSArray [string "reason", showJSON expr]
where
string = JSString . toJSString
readJSON v = case v of
JSArray [JSString name, expr]
| name == toJSString "jobid" -> FPJobId <$> readJSON expr
| name == toJSString "opcode" -> FPOpCode <$> readJSON expr
| name == toJSString "reason" -> FPReason <$> readJSON expr
JSArray (JSString name:params) ->
fail $ "malformed FilterPredicate: bad parameter list for\
\ '" ++ fromJSString name ++ "' predicate: "
++ J.showJSArray params ""
_ -> fail "malformed FilterPredicate: must be a list with the first\
\ entry being a string describing the predicate type"
$(buildObject "FilterRule" "fr" $
[ simpleField "watermark" [t| JobId |]
, simpleField "priority" [t| NonNegative Int |]
, simpleField "predicates" [t| [FilterPredicate] |]
, simpleField "action" [t| FilterAction |]
, simpleField "reason_trail" [t| ReasonTrail |]
]
++ uuidFields)
instance UuidObject FilterRule where
uuidOf = frUuid
filterRuleOrder :: FilterRule -> FilterRule -> Ordering
filterRuleOrder = compare
instance Ord FilterRule where
compare =
comparing $ \(FilterRule watermark prio predicates action reason uuid) ->
( prio, watermark, uuid
, predicates, action, reason
)
$(declareIADT "IpFamily"
[ ("IpFamilyV4", 'AutoConf.pyAfInet4)
, ("IpFamilyV6", 'AutoConf.pyAfInet6)
])
$(makeJSONInstance ''IpFamily)
ipFamilyToVersion :: IpFamily -> Int
ipFamilyToVersion IpFamilyV4 = C.ip4Version
ipFamilyToVersion IpFamilyV6 = C.ip6Version
type ClusterHvParams = GenericContainer Hypervisor HvParams
type OsHvParams = Container ClusterHvParams
type ClusterBeParams = Container FilledBeParams
type ClusterOsParams = Container OsParams
type ClusterOsParamsPrivate = Container (Private OsParams)
type ClusterNicParams = Container FilledNicParams
type UidRange = (Int, Int)
formatUidRange :: UidRange -> String
formatUidRange (lower, higher)
| lower == higher = show lower
| otherwise = show lower ++ "-" ++ show higher
type UidPool = [UidRange]
type IAllocatorParams = Container JSValue
type CandidateCertificates = Container String
$(buildObject "Cluster" "cluster" $
[ simpleField "rsahostkeypub" [t| String |]
, optionalField $
simpleField "dsahostkeypub" [t| String |]
, simpleField "highest_used_port" [t| Int |]
, simpleField "tcpudp_port_pool" [t| [Int] |]
, simpleField "mac_prefix" [t| String |]
, optionalField $
simpleField "volume_group_name" [t| String |]
, simpleField "reserved_lvs" [t| [String] |]
, optionalField $
simpleField "drbd_usermode_helper" [t| String |]
, simpleField "master_node" [t| String |]
, simpleField "master_ip" [t| String |]
, simpleField "master_netdev" [t| String |]
, simpleField "master_netmask" [t| Int |]
, simpleField "use_external_mip_script" [t| Bool |]
, simpleField "cluster_name" [t| String |]
, simpleField "file_storage_dir" [t| String |]
, simpleField "shared_file_storage_dir" [t| String |]
, simpleField "gluster_storage_dir" [t| String |]
, simpleField "enabled_hypervisors" [t| [Hypervisor] |]
, simpleField "hvparams" [t| ClusterHvParams |]
, simpleField "os_hvp" [t| OsHvParams |]
, simpleField "beparams" [t| ClusterBeParams |]
, simpleField "osparams" [t| ClusterOsParams |]
, simpleField "osparams_private_cluster" [t| ClusterOsParamsPrivate |]
, simpleField "nicparams" [t| ClusterNicParams |]
, simpleField "ndparams" [t| FilledNDParams |]
, simpleField "diskparams" [t| GroupDiskParams |]
, simpleField "candidate_pool_size" [t| Int |]
, simpleField "modify_etc_hosts" [t| Bool |]
, simpleField "modify_ssh_setup" [t| Bool |]
, simpleField "maintain_node_health" [t| Bool |]
, simpleField "uid_pool" [t| UidPool |]
, simpleField "default_iallocator" [t| String |]
, simpleField "default_iallocator_params" [t| IAllocatorParams |]
, simpleField "hidden_os" [t| [String] |]
, simpleField "blacklisted_os" [t| [String] |]
, simpleField "primary_ip_family" [t| IpFamily |]
, simpleField "prealloc_wipe_disks" [t| Bool |]
, simpleField "ipolicy" [t| FilledIPolicy |]
, defaultField [| emptyContainer |] $
simpleField "hv_state_static" [t| HypervisorState |]
, defaultField [| emptyContainer |] $
simpleField "disk_state_static" [t| DiskState |]
, simpleField "enabled_disk_templates" [t| [DiskTemplate] |]
, simpleField "candidate_certs" [t| CandidateCertificates |]
, simpleField "max_running_jobs" [t| Int |]
, simpleField "max_tracked_jobs" [t| Int |]
, simpleField "install_image" [t| String |]
, simpleField "instance_communication_network" [t| String |]
, simpleField "zeroing_image" [t| String |]
, simpleField "compression_tools" [t| [String] |]
, simpleField "enabled_user_shutdown" [t| Bool |]
, simpleField "data_collectors" [t| Container DataCollectorConfig |]
]
++ timeStampFields
++ uuidFields
++ serialFields
++ tagsFields)
instance TimeStampObject Cluster where
cTimeOf = clusterCtime
mTimeOf = clusterMtime
instance UuidObject Cluster where
uuidOf = clusterUuid
instance SerialNoObject Cluster where
serialOf = clusterSerial
instance TagsObject Cluster where
tagsOf = clusterTags
$(buildObject "ConfigData" "config" $
[ simpleField "version" [t| Int |]
, simpleField "cluster" [t| Cluster |]
, simpleField "nodes" [t| Container Node |]
, simpleField "nodegroups" [t| Container NodeGroup |]
, simpleField "instances" [t| Container Instance |]
, simpleField "networks" [t| Container Network |]
, simpleField "disks" [t| Container Disk |]
, simpleField "filters" [t| Container FilterRule |]
]
++ timeStampFields
++ serialFields)
instance SerialNoObject ConfigData where
serialOf = configSerial
instance TimeStampObject ConfigData where
cTimeOf = configCtime
mTimeOf = configMtime
$(buildObject "MasterNetworkParameters" "masterNetworkParameters"
[ simpleField "uuid" [t| String |]
, simpleField "ip" [t| String |]
, simpleField "netmask" [t| Int |]
, simpleField "netdev" [t| String |]
, simpleField "ip_family" [t| IpFamily |]
])