Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
itminedu
snf-ganeti
Commits
ebf38064
Commit
ebf38064
authored
Nov 16, 2011
by
Iustin Pop
Browse files
htools: reindent the rest of the files
Signed-off-by:
Iustin Pop
<
iustin@google.com
>
Reviewed-by:
Michael Hanselmann
<
hansmi@google.com
>
parent
00dd69a2
Changes
22
Hide whitespace changes
Inline
Side-by-side
htools/Ganeti/HTools/Compat.hs
View file @
ebf38064
...
...
@@ -2,7 +2,8 @@
{- | Compatibility helper module.
This module holds definitions that help with supporting multiple library versions or transitions between versions.
This module holds definitions that help with supporting multiple
library versions or transitions between versions.
-}
...
...
@@ -28,9 +29,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.Compat
(
rwhnf
,
Control
.
Parallel
.
Strategies
.
parMap
)
where
(
rwhnf
,
Control
.
Parallel
.
Strategies
.
parMap
)
where
import
qualified
Control.Parallel.Strategies
...
...
htools/Ganeti/HTools/Container.hs
View file @
ebf38064
...
...
@@ -27,33 +27,32 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.Container
(
-- * Types
Container
,
Key
-- * Creation
,
IntMap
.
empty
,
IntMap
.
singleton
,
IntMap
.
fromList
-- * Query
,
IntMap
.
size
,
IntMap
.
null
,
find
,
IntMap
.
findMax
,
IntMap
.
member
-- * Update
,
add
,
addTwo
,
IntMap
.
map
,
IntMap
.
mapAccum
,
IntMap
.
filter
-- * Conversion
,
IntMap
.
elems
,
IntMap
.
keys
-- * Element functions
,
nameOf
,
findByName
)
where
(
-- * Types
Container
,
Key
-- * Creation
,
IntMap
.
empty
,
IntMap
.
singleton
,
IntMap
.
fromList
-- * Query
,
IntMap
.
size
,
IntMap
.
null
,
find
,
IntMap
.
findMax
,
IntMap
.
member
-- * Update
,
add
,
addTwo
,
IntMap
.
map
,
IntMap
.
mapAccum
,
IntMap
.
filter
-- * Conversion
,
IntMap
.
elems
,
IntMap
.
keys
-- * Element functions
,
nameOf
,
findByName
)
where
import
qualified
Data.IntMap
as
IntMap
...
...
@@ -86,8 +85,8 @@ nameOf c k = T.nameOf $ find k c
findByName
::
(
T
.
Element
a
,
Monad
m
)
=>
Container
a
->
String
->
m
a
findByName
c
n
=
let
all_elems
=
IntMap
.
elems
c
result
=
filter
((
n
`
elem
`)
.
T
.
allNames
)
all_elems
in
case
result
of
[
item
]
->
return
item
_
->
fail
$
"Wrong number of elems found with name "
++
n
let
all_elems
=
IntMap
.
elems
c
result
=
filter
((
n
`
elem
`)
.
T
.
allNames
)
all_elems
in
case
result
of
[
item
]
->
return
item
_
->
fail
$
"Wrong number of elems found with name "
++
n
htools/Ganeti/HTools/ExtLoader.hs
View file @
ebf38064
...
...
@@ -28,10 +28,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.ExtLoader
(
loadExternalData
,
commonSuffix
,
maybeSaveData
)
where
(
loadExternalData
,
commonSuffix
,
maybeSaveData
)
where
import
Control.Monad
import
Data.Maybe
(
isJust
,
fromJust
)
...
...
@@ -58,17 +58,17 @@ wrapIO = flip catch (return . Bad . show)
-- | Parses a user-supplied utilisation string.
parseUtilisation
::
String
->
Result
(
String
,
DynUtil
)
parseUtilisation
line
=
case
sepSplit
' '
line
of
[
name
,
cpu
,
mem
,
dsk
,
net
]
->
do
rcpu
<-
tryRead
name
cpu
rmem
<-
tryRead
name
mem
rdsk
<-
tryRead
name
dsk
rnet
<-
tryRead
name
net
let
du
=
DynUtil
{
cpuWeight
=
rcpu
,
memWeight
=
rmem
,
dskWeight
=
rdsk
,
netWeight
=
rnet
}
return
(
name
,
du
)
_
->
Bad
$
"Cannot parse line "
++
line
case
sepSplit
' '
line
of
[
name
,
cpu
,
mem
,
dsk
,
net
]
->
do
rcpu
<-
tryRead
name
cpu
rmem
<-
tryRead
name
mem
rdsk
<-
tryRead
name
dsk
rnet
<-
tryRead
name
net
let
du
=
DynUtil
{
cpuWeight
=
rcpu
,
memWeight
=
rmem
,
dskWeight
=
rdsk
,
netWeight
=
rnet
}
return
(
name
,
du
)
_
->
Bad
$
"Cannot parse line "
++
line
-- | External tool data loader from a variety of sources.
loadExternalData
::
Options
...
...
@@ -100,28 +100,28 @@ loadExternalData opts = do
Nothing
->
return
""
)
let
util_data
=
mapM
parseUtilisation
$
lines
util_contents
util_data'
<-
(
case
util_data
of
Ok
x
->
return
x
Ok
x
->
return
x
Bad
y
->
do
hPutStrLn
stderr
(
"Error: can't parse utilisation"
++
" data: "
++
show
y
)
exitWith
$
ExitFailure
1
)
input_data
<-
case
()
of
_
|
setRapi
->
wrapIO
$
Rapi
.
loadData
mhost
|
setLuxi
->
wrapIO
$
Luxi
.
loadData
$
fromJust
lsock
|
setSim
->
Simu
.
loadData
simdata
|
setFile
->
wrapIO
$
Text
.
loadData
$
fromJust
tfile
|
otherwise
->
return
$
Bad
"No backend selected! Exiting."
case
()
of
_
|
setRapi
->
wrapIO
$
Rapi
.
loadData
mhost
|
setLuxi
->
wrapIO
$
Luxi
.
loadData
$
fromJust
lsock
|
setSim
->
Simu
.
loadData
simdata
|
setFile
->
wrapIO
$
Text
.
loadData
$
fromJust
tfile
|
otherwise
->
return
$
Bad
"No backend selected! Exiting."
let
ldresult
=
input_data
>>=
mergeData
util_data'
exTags
selInsts
exInsts
cdata
<-
(
case
ldresult
of
Ok
x
->
return
x
Bad
s
->
do
hPrintf
stderr
"Error: failed to load data, aborting. Details:
\n
%s
\n
"
s
::
IO
()
exitWith
$
ExitFailure
1
)
(
case
ldresult
of
Ok
x
->
return
x
Bad
s
->
do
hPrintf
stderr
"Error: failed to load data, aborting. Details:
\n
%s
\n
"
s
::
IO
()
exitWith
$
ExitFailure
1
)
let
(
fix_msgs
,
nl
)
=
checkData
(
cdNodes
cdata
)
(
cdInstances
cdata
)
unless
(
optVerbose
opts
==
0
)
$
maybeShowWarnings
fix_msgs
...
...
htools/Ganeti/HTools/Group.hs
View file @
ebf38064
...
...
@@ -24,14 +24,14 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.Group
(
Group
(
..
)
,
List
,
AssocList
-- * Constructor
,
create
,
setIdx
,
isAllocable
)
where
(
Group
(
..
)
,
List
,
AssocList
-- * Constructor
,
create
,
setIdx
,
isAllocable
)
where
import
qualified
Ganeti.HTools.Container
as
Container
...
...
@@ -41,20 +41,20 @@ import qualified Ganeti.HTools.Types as T
-- | The node group type.
data
Group
=
Group
{
name
::
String
-- ^ The node name
,
uuid
::
T
.
GroupID
-- ^ The UUID of the group
,
idx
::
T
.
Gdx
-- ^ Internal index for book-keeping
,
allocPolicy
::
T
.
AllocPolicy
-- ^ The allocation policy for this group
}
deriving
(
Show
,
Read
,
Eq
)
{
name
::
String
-- ^ The node name
,
uuid
::
T
.
GroupID
-- ^ The UUID of the group
,
idx
::
T
.
Gdx
-- ^ Internal index for book-keeping
,
allocPolicy
::
T
.
AllocPolicy
-- ^ The allocation policy for this group
}
deriving
(
Show
,
Read
,
Eq
)
-- Note: we use the name as the alias, and the UUID as the official
-- name
instance
T
.
Element
Group
where
nameOf
=
uuid
idxOf
=
idx
setAlias
=
setName
setIdx
=
setIdx
allNames
n
=
[
name
n
,
uuid
n
]
nameOf
=
uuid
idxOf
=
idx
setAlias
=
setName
setIdx
=
setIdx
allNames
n
=
[
name
n
,
uuid
n
]
-- | A simple name for the int, node association list.
type
AssocList
=
[(
T
.
Gdx
,
Group
)]
...
...
@@ -67,11 +67,11 @@ type List = Container.Container Group
-- | Create a new group.
create
::
String
->
T
.
GroupID
->
T
.
AllocPolicy
->
Group
create
name_init
id_init
apol_init
=
Group
{
name
=
name_init
,
uuid
=
id_init
,
allocPolicy
=
apol_init
,
idx
=
-
1
}
Group
{
name
=
name_init
,
uuid
=
id_init
,
allocPolicy
=
apol_init
,
idx
=
-
1
}
-- | Sets the group index.
--
...
...
htools/Ganeti/HTools/Instance.hs
View file @
ebf38064
...
...
@@ -27,29 +27,29 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.Instance
(
Instance
(
..
)
,
AssocList
,
List
,
create
,
instanceRunning
,
instanceOffline
,
instanceDown
,
applyIfOnline
,
setIdx
,
setName
,
setAlias
,
setPri
,
setSec
,
setBoth
,
setMovable
,
specOf
,
shrinkByType
,
localStorageTemplates
,
hasSecondary
,
requiredNodes
,
allNodes
,
usesLocalStorage
)
where
(
Instance
(
..
)
,
AssocList
,
List
,
create
,
instanceRunning
,
instanceOffline
,
instanceDown
,
applyIfOnline
,
setIdx
,
setName
,
setAlias
,
setPri
,
setSec
,
setBoth
,
setMovable
,
specOf
,
shrinkByType
,
localStorageTemplates
,
hasSecondary
,
requiredNodes
,
allNodes
,
usesLocalStorage
)
where
import
qualified
Ganeti.HTools.Types
as
T
import
qualified
Ganeti.HTools.Container
as
Container
...
...
@@ -61,39 +61,39 @@ import Ganeti.HTools.Utils
-- | The instance type.
data
Instance
=
Instance
{
name
::
String
-- ^ The instance name
,
alias
::
String
-- ^ The shortened name
,
mem
::
Int
-- ^ Memory of the instance
,
dsk
::
Int
-- ^ Disk size of instance
,
vcpus
::
Int
-- ^ Number of VCPUs
,
runSt
::
T
.
InstanceStatus
-- ^ Original run status
,
pNode
::
T
.
Ndx
-- ^ Original primary node
,
sNode
::
T
.
Ndx
-- ^ Original secondary node
,
idx
::
T
.
Idx
-- ^ Internal index
,
util
::
T
.
DynUtil
-- ^ Dynamic resource usage
,
movable
::
Bool
-- ^ Can and should the instance be moved?
,
autoBalance
::
Bool
-- ^ Is the instance auto-balanced?
,
tags
::
[
String
]
-- ^ List of instance tags
,
diskTemplate
::
T
.
DiskTemplate
-- ^ The disk template of the instance
}
deriving
(
Show
,
Read
)
{
name
::
String
-- ^ The instance name
,
alias
::
String
-- ^ The shortened name
,
mem
::
Int
-- ^ Memory of the instance
,
dsk
::
Int
-- ^ Disk size of instance
,
vcpus
::
Int
-- ^ Number of VCPUs
,
runSt
::
T
.
InstanceStatus
-- ^ Original run status
,
pNode
::
T
.
Ndx
-- ^ Original primary node
,
sNode
::
T
.
Ndx
-- ^ Original secondary node
,
idx
::
T
.
Idx
-- ^ Internal index
,
util
::
T
.
DynUtil
-- ^ Dynamic resource usage
,
movable
::
Bool
-- ^ Can and should the instance be moved?
,
autoBalance
::
Bool
-- ^ Is the instance auto-balanced?
,
tags
::
[
String
]
-- ^ List of instance tags
,
diskTemplate
::
T
.
DiskTemplate
-- ^ The disk template of the instance
}
deriving
(
Show
,
Read
)
instance
T
.
Element
Instance
where
nameOf
=
name
idxOf
=
idx
setAlias
=
setAlias
setIdx
=
setIdx
allNames
n
=
[
name
n
,
alias
n
]
nameOf
=
name
idxOf
=
idx
setAlias
=
setAlias
setIdx
=
setIdx
allNames
n
=
[
name
n
,
alias
n
]
-- | Check if instance is running.
instanceRunning
::
Instance
->
Bool
instanceRunning
(
Instance
{
runSt
=
T
.
Running
})
=
True
instanceRunning
(
Instance
{
runSt
=
T
.
ErrorUp
})
=
True
instanceRunning
_
=
False
instanceRunning
_
=
False
-- | Check if instance is offline.
instanceOffline
::
Instance
->
Bool
instanceOffline
(
Instance
{
runSt
=
T
.
AdminOffline
})
=
True
instanceOffline
_
=
False
instanceOffline
_
=
False
-- | Check if instance is down.
instanceDown
::
Instance
->
Bool
...
...
@@ -141,21 +141,21 @@ create :: String -> Int -> Int -> Int -> T.InstanceStatus
->
[
String
]
->
Bool
->
T
.
Ndx
->
T
.
Ndx
->
T
.
DiskTemplate
->
Instance
create
name_init
mem_init
dsk_init
vcpus_init
run_init
tags_init
auto_balance_init
pn
sn
dt
=
Instance
{
name
=
name_init
,
alias
=
name_init
,
mem
=
mem_init
,
dsk
=
dsk_init
,
vcpus
=
vcpus_init
,
runSt
=
run_init
,
pNode
=
pn
,
sNode
=
sn
,
idx
=
-
1
,
util
=
T
.
baseUtil
,
tags
=
tags_init
,
movable
=
supportsMoves
dt
,
autoBalance
=
auto_balance_init
,
diskTemplate
=
dt
}
Instance
{
name
=
name_init
,
alias
=
name_init
,
mem
=
mem_init
,
dsk
=
dsk_init
,
vcpus
=
vcpus_init
,
runSt
=
run_init
,
pNode
=
pn
,
sNode
=
sn
,
idx
=
-
1
,
util
=
T
.
baseUtil
,
tags
=
tags_init
,
movable
=
supportsMoves
dt
,
autoBalance
=
auto_balance_init
,
diskTemplate
=
dt
}
-- | Changes the index.
--
...
...
@@ -228,7 +228,7 @@ shrinkByType _ f = T.Bad $ "Unhandled failure mode " ++ show f
-- | Return the spec of an instance.
specOf
::
Instance
->
T
.
RSpec
specOf
Instance
{
mem
=
m
,
dsk
=
d
,
vcpus
=
c
}
=
T
.
RSpec
{
T
.
rspecCpu
=
c
,
T
.
rspecMem
=
m
,
T
.
rspecDsk
=
d
}
T
.
RSpec
{
T
.
rspecCpu
=
c
,
T
.
rspecMem
=
m
,
T
.
rspecDsk
=
d
}
-- | Checks whether the instance uses a secondary node.
--
...
...
htools/Ganeti/HTools/JSON.hs
View file @
ebf38064
...
...
@@ -22,18 +22,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.JSON
(
fromJResult
,
readEitherString
,
JSRecord
,
loadJSArray
,
fromObj
,
maybeFromObj
,
fromObjWithDefault
,
fromJVal
,
asJSObject
,
asObjectList
)
where
(
fromJResult
,
readEitherString
,
JSRecord
,
loadJSArray
,
fromObj
,
maybeFromObj
,
fromObjWithDefault
,
fromJVal
,
asJSObject
,
asObjectList
)
where
import
Control.Monad
(
liftM
)
import
Data.Maybe
(
fromMaybe
)
...
...
@@ -57,9 +57,9 @@ fromJResult _ (J.Ok x) = return x
-- context of the current monad.
readEitherString
::
(
Monad
m
)
=>
J
.
JSValue
->
m
String
readEitherString
v
=
case
v
of
J
.
JSString
s
->
return
$
J
.
fromJSString
s
_
->
fail
"Wrong JSON type"
case
v
of
J
.
JSString
s
->
return
$
J
.
fromJSString
s
_
->
fail
"Wrong JSON type"
-- | Converts a JSON message into an array of JSON objects.
loadJSArray
::
(
Monad
m
)
...
...
@@ -71,18 +71,18 @@ loadJSArray s = fromJResult s . J.decodeStrict
-- | Reads the value of a key in a JSON object.
fromObj
::
(
J
.
JSON
a
,
Monad
m
)
=>
JSRecord
->
String
->
m
a
fromObj
o
k
=
case
lookup
k
o
of
Nothing
->
fail
$
printf
"key '%s' not found, object contains only %s"
k
(
show
(
map
fst
o
))
Just
val
->
fromKeyValue
k
val
case
lookup
k
o
of
Nothing
->
fail
$
printf
"key '%s' not found, object contains only %s"
k
(
show
(
map
fst
o
))
Just
val
->
fromKeyValue
k
val
-- | Reads the value of an optional key in a JSON object.
maybeFromObj
::
(
J
.
JSON
a
,
Monad
m
)
=>
JSRecord
->
String
->
m
(
Maybe
a
)
maybeFromObj
o
k
=
case
lookup
k
o
of
Nothing
->
return
Nothing
Just
val
->
liftM
Just
(
fromKeyValue
k
val
)
case
lookup
k
o
of
Nothing
->
return
Nothing
Just
val
->
liftM
Just
(
fromKeyValue
k
val
)
-- | Reads the value of a key in a JSON object with a default if missing.
fromObjWithDefault
::
(
J
.
JSON
a
,
Monad
m
)
=>
...
...
@@ -100,10 +100,10 @@ fromKeyValue k val =
-- | Small wrapper over readJSON.
fromJVal
::
(
Monad
m
,
J
.
JSON
a
)
=>
J
.
JSValue
->
m
a
fromJVal
v
=
case
J
.
readJSON
v
of
J
.
Error
s
->
fail
(
"Cannot convert value '"
++
show
v
++
"', error: "
++
s
)
J
.
Ok
x
->
return
x
case
J
.
readJSON
v
of
J
.
Error
s
->
fail
(
"Cannot convert value '"
++
show
v
++
"', error: "
++
s
)
J
.
Ok
x
->
return
x
-- | Converts a JSON value into a JSON object.
asJSObject
::
(
Monad
m
)
=>
J
.
JSValue
->
m
(
J
.
JSObject
J
.
JSValue
)
...
...
htools/Ganeti/HTools/Loader.hs
View file @
ebf38064
...
...
@@ -27,24 +27,24 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-}
module
Ganeti.HTools.Loader
(
mergeData
,
checkData
,
assignIndices
,
lookupName
,
goodLookupResult
,
lookupNode
,
lookupInstance
,
lookupGroup
,
commonSuffix
,
RqType
(
..
)
,
Request
(
..
)
,
ClusterData
(
..
)
,
emptyCluster
,
compareNameComponent
,
prefixMatch
,
LookupResult
(
..
)
,
MatchPriority
(
..
)
)
where
(
mergeData
,
checkData
,
assignIndices
,
lookupName
,
goodLookupResult
,
lookupNode
,
lookupInstance
,
lookupGroup
,
commonSuffix
,
RqType
(
..
)
,
Request
(
..
)
,
ClusterData
(
..
)
,
emptyCluster
,
compareNameComponent
,
prefixMatch
,
LookupResult
(
..
)
,
MatchPriority
(
..
)
)
where
import
Data.List
import
Data.Function
...
...
@@ -74,23 +74,23 @@ request-specific fields.
-}
data
RqType
=
Allocate
Instance
.
Instance
Int
-- ^ A new instance allocation
|
Relocate
Idx
Int
[
Ndx
]
-- ^ Choose a new secondary node
|
NodeEvacuate
[
Idx
]
EvacMode
-- ^ node-evacuate mode
|
ChangeGroup
[
Gdx
]
[
Idx
]
-- ^ Multi-relocate mode
=
Allocate
Instance
.
Instance
Int
-- ^ A new instance allocation
|
Relocate
Idx
Int
[
Ndx
]
-- ^ Choose a new secondary node
|
NodeEvacuate
[
Idx
]
EvacMode
-- ^ node-evacuate mode
|
ChangeGroup
[
Gdx
]
[
Idx
]
-- ^ Multi-relocate mode
deriving
(
Show
,
Read
)
-- | A complete request, as received from Ganeti.
data
Request
=
Request
RqType
ClusterData
deriving
(
Show
,
Read
)
deriving
(
Show
,
Read
)
-- | The cluster state.
data
ClusterData
=
ClusterData
{
cdGroups
::
Group
.
List
-- ^ The node group list
,
cdNodes
::
Node
.
List
-- ^ The node list
,
cdInstances
::
Instance
.
List
-- ^ The instance list
,
cdTags
::
[
String
]
-- ^ The cluster tags
}
deriving
(
Show
,
Read
)
{
cdGroups
::
Group
.
List
-- ^ The node group list
,
cdNodes
::
Node
.
List
-- ^ The node list
,
cdInstances
::
Instance
.
List
-- ^ The instance list
,
cdTags
::
[
String
]
-- ^ The cluster tags
}
deriving
(
Show
,
Read
)
-- | The priority of a match in a lookup result.
data
MatchPriority
=
ExactMatch
...
...
@@ -101,10 +101,10 @@ data MatchPriority = ExactMatch
-- | The result of a name lookup in a list.
data
LookupResult
=
LookupResult
{
lrMatchPriority
::
MatchPriority
-- ^ The result type
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
,
lrContent
::
String
}
deriving
(
Show
,
Read
)
{
lrMatchPriority
::
MatchPriority
-- ^ The result type
-- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise
,
lrContent
::
String
}
deriving
(
Show
,
Read
)
-- | Lookup results have an absolute preference ordering.
instance
Eq
LookupResult
where
...
...
@@ -122,23 +122,23 @@ emptyCluster = ClusterData Container.empty Container.empty Container.empty []
-- | Lookups a node into an assoc list.
lookupNode
::
(
Monad
m
)
=>
NameAssoc
->
String
->
String
->
m
Ndx
lookupNode
ktn
inst
node
=
case
M
.
lookup
node
ktn
of
Nothing
->
fail
$
"Unknown node '"
++
node
++
"' for instance "
++
inst
Just
idx
->
return
idx
case
M
.
lookup
node
ktn
of
Nothing
->
fail
$
"Unknown node '"
++
node
++
"' for instance "
++
inst
Just
idx
->
return
idx
-- | Lookups an instance into an assoc list.
lookupInstance
::
(
Monad
m
)
=>
NameAssoc
->
String
->
m
Idx
lookupInstance
kti
inst
=
case
M
.
lookup
inst
kti
of
Nothing
->
fail
$
"Unknown instance '"
++
inst
++
"'"
Just
idx
->
return
idx
case
M
.
lookup
inst
kti
of
Nothing
->
fail
$
"Unknown instance '"
++
inst
++
"'"
Just
idx
->
return
idx