## root / Ganeti / HTools / Utils.hs @ 00b15752

History | View | Annotate | Download (5.5 kB)

1 |
{-| Utility functions -} |
---|---|

2 | |

3 |
module Ganeti.HTools.Utils |

4 |
( |

5 |
debug |

6 |
, isLeft |

7 |
, fromLeft |

8 |
, fromRight |

9 |
, sepSplit |

10 |
, swapPairs |

11 |
, varianceCoeff |

12 |
, readData |

13 |
, commaJoin |

14 |
, combineEithers |

15 |
, ensureEitherList |

16 |
, eitherListHead |

17 |
, readEitherString |

18 |
, parseEitherList |

19 |
, loadJSArray |

20 |
, fromObj |

21 |
, getStringElement |

22 |
, getIntElement |

23 |
, getBoolElement |

24 |
, getListElement |

25 |
, getObjectElement |

26 |
, asJSObject |

27 |
, asObjectList |

28 |
, concatEitherElems |

29 |
, applyEither1 |

30 |
, applyEither2 |

31 |
) where |

32 | |

33 |
import Data.Either |

34 |
import Data.List |

35 |
import Monad |

36 |
import System |

37 |
import System.IO |

38 |
import Text.JSON |

39 |
import Text.Printf (printf) |

40 | |

41 |
import Debug.Trace |

42 | |

43 |
-- | To be used only for debugging, breaks referential integrity. |

44 |
debug :: Show a => a -> a |

45 |
debug x = trace (show x) x |

46 | |

47 |
-- | Check if the given argument is Left something |

48 |
isLeft :: Either a b -> Bool |

49 |
isLeft val = |

50 |
case val of |

51 |
Left _ -> True |

52 |
_ -> False |

53 | |

54 |
fromLeft :: Either a b -> a |

55 |
fromLeft = either (\x -> x) (\_ -> undefined) |

56 | |

57 |
fromRight :: Either a b -> b |

58 |
fromRight = either (\_ -> undefined) id |

59 | |

60 |
-- | Comma-join a string list. |

61 |
commaJoin :: [String] -> String |

62 |
commaJoin = intercalate "," |

63 | |

64 |
-- | Split a string on a separator and return an array. |

65 |
sepSplit :: Char -> String -> [String] |

66 |
sepSplit sep s |

67 |
| x == "" && xs == [] = [] |

68 |
| xs == [] = [x] |

69 |
| ys == [] = x:"":[] |

70 |
| otherwise = x:(sepSplit sep ys) |

71 |
where (x, xs) = break (== sep) s |

72 |
ys = drop 1 xs |

73 | |

74 |
-- | Partial application of sepSplit to @'.'@ |

75 |
commaSplit :: String -> [String] |

76 |
commaSplit = sepSplit ',' |

77 | |

78 |
-- | Swap a list of @(a, b)@ into @(b, a)@ |

79 |
swapPairs :: [(a, b)] -> [(b, a)] |

80 |
swapPairs = map (\ (a, b) -> (b, a)) |

81 | |

82 |
-- Simple and slow statistical functions, please replace with better versions |

83 | |

84 |
-- | Mean value of a list. |

85 |
meanValue :: Floating a => [a] -> a |

86 |
meanValue lst = (sum lst) / (fromIntegral $ length lst) |

87 | |

88 |
-- | Standard deviation. |

89 |
stdDev :: Floating a => [a] -> a |

90 |
stdDev lst = |

91 |
let mv = meanValue lst |

92 |
square = (^ (2::Int)) -- silences "defaulting the constraint..." |

93 |
av = sum $ map square $ map (\e -> e - mv) lst |

94 |
bv = sqrt (av / (fromIntegral $ length lst)) |

95 |
in bv |

96 | |

97 |
-- | Coefficient of variation. |

98 |
varianceCoeff :: Floating a => [a] -> a |

99 |
varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst) |

100 | |

101 |
-- | Get a Right result or print the error and exit |

102 |
readData :: (String -> IO (Either String String)) -> String -> IO String |

103 |
readData fn host = do |

104 |
nd <- fn host |

105 |
when (isLeft nd) $ |

106 |
do |

107 |
putStrLn $ fromLeft nd |

108 |
exitWith $ ExitFailure 1 |

109 |
return $ fromRight nd |

110 | |

111 |
{-- Our cheap monad-like stuff. |

112 | |

113 |
Thi is needed since Either e a is already a monad instance somewhere |

114 |
in the standard libraries (Control.Monad.Error) and we don't need that |

115 |
entire thing. |

116 | |

117 |
-} |

118 |
combineEithers :: (Either String a) |

119 |
-> (a -> Either String b) |

120 |
-> (Either String b) |

121 |
combineEithers (Left s) _ = Left s |

122 |
combineEithers (Right s) f = f s |

123 | |

124 |
ensureEitherList :: [Either String a] -> Either String [a] |

125 |
ensureEitherList lst = |

126 |
foldr (\elem accu -> |

127 |
case (elem, accu) of |

128 |
(Left x, _) -> Left x |

129 |
(_, Left x) -> Left x -- should never happen |

130 |
(Right e, Right a) -> Right (e:a) |

131 |
) |

132 |
(Right []) lst |

133 | |

134 |
eitherListHead :: Either String [a] -> Either String a |

135 |
eitherListHead lst = |

136 |
case lst of |

137 |
Left x -> Left x |

138 |
Right (x:_) -> Right x |

139 |
Right [] -> Left "List empty" |

140 | |

141 |
readEitherString :: JSValue -> Either String String |

142 |
readEitherString v = |

143 |
case v of |

144 |
JSString s -> Right $ fromJSString s |

145 |
_ -> Left "Wrong JSON type" |

146 | |

147 |
parseEitherList :: (JSObject JSValue -> Either String String) |

148 |
-> [JSObject JSValue] |

149 |
-> Either String String |

150 |
parseEitherList fn idata = |

151 |
let ml = ensureEitherList $ map fn idata |

152 |
in ml `combineEithers` (Right . unlines) |

153 | |

154 |
loadJSArray :: String -> Either String [JSObject JSValue] |

155 |
loadJSArray s = resultToEither $ decodeStrict s |

156 | |

157 |
fromObj :: JSON a => String -> JSObject JSValue -> Either String a |

158 |
fromObj k o = |

159 |
case lookup k (fromJSObject o) of |

160 |
Nothing -> Left $ printf "key '%s' not found" k |

161 |
Just val -> resultToEither $ readJSON val |

162 | |

163 |
getStringElement :: String -> JSObject JSValue -> Either String String |

164 |
getStringElement = fromObj |

165 | |

166 |
getIntElement :: String -> JSObject JSValue -> Either String Int |

167 |
getIntElement = fromObj |

168 | |

169 |
getBoolElement :: String -> JSObject JSValue -> Either String Bool |

170 |
getBoolElement = fromObj |

171 | |

172 |
getListElement :: String -> JSObject JSValue |

173 |
-> Either String [JSValue] |

174 |
getListElement = fromObj |

175 | |

176 |
getObjectElement :: String -> JSObject JSValue |

177 |
-> Either String (JSObject JSValue) |

178 |
getObjectElement = fromObj |

179 | |

180 |
asJSObject :: JSValue -> Either String (JSObject JSValue) |

181 |
asJSObject (JSObject a) = Right a |

182 |
asJSObject _ = Left "not an object" |

183 | |

184 |
asObjectList :: [JSValue] -> Either String [JSObject JSValue] |

185 |
asObjectList = |

186 |
ensureEitherList . map asJSObject |

187 | |

188 |
concatEitherElems :: Either String String |

189 |
-> Either String String |

190 |
-> Either String String |

191 |
concatEitherElems = applyEither2 (\x y -> x ++ "|" ++ y) |

192 | |

193 |
applyEither1 :: (a -> b) -> Either String a -> Either String b |

194 |
applyEither1 fn a = |

195 |
case a of |

196 |
Left x -> Left x |

197 |
Right y -> Right $ fn y |

198 | |

199 |
applyEither2 :: (a -> b -> c) |

200 |
-> Either String a |

201 |
-> Either String b |

202 |
-> Either String c |

203 |
applyEither2 fn a b = |

204 |
case (a, b) of |

205 |
(Right x, Right y) -> Right $ fn x y |

206 |
(Left x, _) -> Left x |

207 |
(_, Left y) -> Left y |