Revision 5b11f8db

b/htest/Test/Ganeti/BasicTypes.hs
73 73

  
74 74
-- | Tests the applicative composition law (pure (.) <*> u <*> v <*> w
75 75
-- = u <*> (v <*> w)).
76
prop_applicative_composition :: (Result (Fun Int Int))
77
                             -> (Result (Fun Int Int))
76
prop_applicative_composition :: Result (Fun Int Int)
77
                             -> Result (Fun Int Int)
78 78
                             -> Result Int
79 79
                             -> Property
80 80
prop_applicative_composition u v w =
......
85 85
-- | Tests the applicative homomorphism law (pure f <*> pure x = pure (f x)).
86 86
prop_applicative_homomorphism :: Fun Int Int -> Int -> Property
87 87
prop_applicative_homomorphism (Fun _ f) x =
88
  ((pure f <*> pure x)::Result Int) ==?
89
  (pure (f x))
88
  ((pure f <*> pure x)::Result Int) ==? pure (f x)
90 89

  
91 90
-- | Tests the applicative interchange law (u <*> pure y = pure ($ y) <*> u).
92 91
prop_applicative_interchange :: Result (Fun Int Int)
b/htest/Test/Ganeti/Daemon.hs
38 38
import Ganeti.Common
39 39
import Ganeti.Daemon as Daemon
40 40

  
41
{-# ANN module "HLint: ignore Use camelCase" #-}
42

  
41 43
-- | Test a few string arguments.
42 44
prop_string_arg :: String -> Property
43 45
prop_string_arg argument =
......
65 67

  
66 68
-- | Tests a few invalid arguments.
67 69
case_wrong_arg :: Assertion
68
case_wrong_arg = do
70
case_wrong_arg =
69 71
  mapM_ (passFailOpt defaultOptions assertFailure (return ()))
70 72
        [ (oSyslogUsage, "foo", "yes")
71 73
        , (oPort 0,      "x",   "10")
b/htest/Test/Ganeti/HTools/CLI.hs
43 43
import qualified Ganeti.HTools.Program as Program
44 44
import qualified Ganeti.HTools.Types as Types
45 45

  
46
{-# ANN module "HLint: ignore Use camelCase" #-}
47

  
46 48
-- | Test correct parsing.
47 49
prop_parseISpec :: String -> Int -> Int -> Int -> Property
48 50
prop_parseISpec descr dsk mem cpu =
......
52 54
-- | Test parsing failure due to wrong section count.
53 55
prop_parseISpecFail :: String -> Property
54 56
prop_parseISpecFail descr =
55
  forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
57
  forAll (choose (0,100) `suchThat` (/= 3)) $ \nelems ->
56 58
  forAll (replicateM nelems arbitrary) $ \values ->
57 59
  let str = intercalate "," $ map show (values::[Int])
58 60
  in case parseISpecString descr str of
......
101 103

  
102 104
-- | Tests a few invalid arguments.
103 105
case_wrong_arg :: Assertion
104
case_wrong_arg = do
106
case_wrong_arg =
105 107
  mapM_ (passFailOpt defaultOptions assertFailure (return ()))
106 108
        [ (oSpindleUse,   "-1", "1")
107 109
        , (oSpindleUse,   "a",  "1")
b/htest/Test/Ganeti/HTools/Cluster.hs
47 47
import qualified Ganeti.HTools.Node as Node
48 48
import qualified Ganeti.HTools.Types as Types
49 49

  
50
{-# ANN module "HLint: ignore Use camelCase" #-}
51

  
50 52
-- * Helpers
51 53

  
52 54
-- | Make a small cluster, both nodes and instances.
......
148 150
prop_CanTieredAlloc :: Instance.Instance -> Property
149 151
prop_CanTieredAlloc inst =
150 152
  forAll (choose (2, 5)) $ \count ->
151
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
153
  forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
152 154
  let nl = makeSmallCluster node count
153 155
      il = Container.empty
154 156
      rqnodes = Instance.requiredNodes $ Instance.diskTemplate inst
......
196 198
prop_AllocRelocate :: Property
197 199
prop_AllocRelocate =
198 200
  forAll (choose (4, 8)) $ \count ->
199
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
201
  forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
200 202
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
201 203
  case genClusterAlloc count node inst of
202 204
    Types.Bad msg -> failTest msg
......
230 232
                                         (gdx == Group.idx grp)
231 233
           v -> failmsg  ("invalid solution: " ++ show v) False
232 234
  where failmsg :: String -> Bool -> Property
233
        failmsg = \msg -> printTestCase ("Failed to evacuate: " ++ msg)
235
        failmsg msg = printTestCase ("Failed to evacuate: " ++ msg)
234 236
        idx = Instance.idx inst
235 237

  
236 238
-- | Checks that on a 4-8 node cluster, once we allocate an instance,
......
238 240
prop_AllocEvacuate :: Property
239 241
prop_AllocEvacuate =
240 242
  forAll (choose (4, 8)) $ \count ->
241
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
243
  forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
242 244
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
243 245
  case genClusterAlloc count node inst of
244 246
    Types.Bad msg -> failTest msg
......
255 257
prop_AllocChangeGroup :: Property
256 258
prop_AllocChangeGroup =
257 259
  forAll (choose (4, 8)) $ \count ->
258
  forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node ->
260
  forAll (genOnlineNode `suchThat` isNodeBig 4) $ \node ->
259 261
  forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst ->
260 262
  case genClusterAlloc count node inst of
261 263
    Types.Bad msg -> failTest msg
......
327 329
canAllocOn :: Node.List -> Int -> Instance.Instance -> Bool
328 330
canAllocOn nl reqnodes inst =
329 331
  case Cluster.genAllocNodes defGroupList nl reqnodes True >>=
330
       Cluster.tryAlloc nl (Container.empty) inst of
332
       Cluster.tryAlloc nl Container.empty inst of
331 333
       Types.Bad _ -> False
332 334
       Types.Ok as ->
333 335
         case Cluster.asSolution as of
......
344 346
  -- rqn is the required nodes (1 or 2)
345 347
  forAll (choose (1, 2)) $ \rqn ->
346 348
  forAll (choose (5, 20)) $ \count ->
347
  forAll (arbitrary `suchThat` (canAllocOn (makeSmallCluster node count) rqn))
349
  forAll (arbitrary `suchThat` canAllocOn (makeSmallCluster node count) rqn)
348 350
         $ \inst ->
349 351
  forAll (arbitrary `suchThat` (isFailure .
350 352
                                Instance.instMatchesPolicy inst)) $ \ipol ->
b/htest/Test/Ganeti/HTools/Node.hs
85 85

  
86 86
-- | Helper function to generate a sane node.
87 87
genOnlineNode :: Gen Node.Node
88
genOnlineNode = do
88
genOnlineNode =
89 89
  arbitrary `suchThat` (\n -> not (Node.offline n) &&
90 90
                              not (Node.failN1 n) &&
91 91
                              Node.availDisk n > 0 &&
b/htest/Test/Ganeti/HTools/Text.hs
53 53
-- * Instance text loader tests
54 54

  
55 55
prop_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus
56
                   -> NonEmptyList Char -> [Char]
56
                   -> NonEmptyList Char -> String
57 57
                   -> NonNegative Int -> NonNegative Int -> Bool
58 58
                   -> Types.DiskTemplate -> Int -> Property
59 59
prop_Load_Instance name mem dsk vcpus status
b/htest/Test/Ganeti/HTools/Utils.hs
40 40
import qualified Ganeti.HTools.Utils as Utils
41 41

  
42 42
-- | Helper to generate a small string that doesn't contain commas.
43
genNonCommaString :: Gen [Char]
43
genNonCommaString :: Gen String
44 44
genNonCommaString = do
45 45
  size <- choose (0, 20) -- arbitrary max size
46
  vectorOf size (arbitrary `suchThat` ((/=) ','))
46
  vectorOf size (arbitrary `suchThat` (/=) ',')
47 47

  
48 48
-- | If the list is not just an empty element, and if the elements do
49 49
-- not contain commas, then join+split should be idempotent.
50 50
prop_commaJoinSplit :: Property
51 51
prop_commaJoinSplit =
52 52
  forAll (choose (0, 20)) $ \llen ->
53
  forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst ->
53
  forAll (vectorOf llen genNonCommaString `suchThat` (/=) [""]) $ \lst ->
54 54
  Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst
55 55

  
56 56
-- | Split and join should always be idempotent.
57
prop_commaSplitJoin :: [Char] -> Property
57
prop_commaSplitJoin :: String -> Property
58 58
prop_commaSplitJoin s =
59 59
  Utils.commaJoin (Utils.sepSplit ',' s) ==? s
60 60

  
b/htest/Test/Ganeti/Luxi.hs
58 58
    case lreq of
59 59
      Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter
60 60
      Luxi.ReqQueryFields -> Luxi.QueryFields <$> arbitrary <*> getFields
61
      Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*>
61
      Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> listOf getFQDN <*>
62 62
                            getFields <*> arbitrary
63 63
      Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*>
64 64
                             arbitrary <*> arbitrary
65
      Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*>
65
      Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> listOf getFQDN <*>
66 66
                                getFields <*> arbitrary
67 67
      Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields
68 68
      Luxi.ReqQueryExports -> Luxi.QueryExports <$>
69
                              (listOf getFQDN) <*> arbitrary
69
                              listOf getFQDN <*> arbitrary
70 70
      Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields
71 71
      Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo
72 72
      Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN
73
      Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary)
73
      Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> resize maxOpCodes arbitrary
74 74
      Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$>
75
                                (resize maxOpCodes arbitrary)
75
                                resize maxOpCodes arbitrary
76 76
      Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*>
77 77
                                  getFields <*> pure J.JSNull <*>
78 78
                                  pure J.JSNull <*> arbitrary
......
116 116
prop_ClientServer :: [[DNSChar]] -> Property
117 117
prop_ClientServer dnschars = monadicIO $ do
118 118
  let msgs = map (map dnsGetChar) dnschars
119
  fpath <- run $ getTempFileName
119
  fpath <- run getTempFileName
120 120
  -- we need to create the server first, otherwise (if we do it in the
121 121
  -- forked thread) the client could try to connect to it before it's
122 122
  -- ready
......
131 131
    bracket
132 132
      (Luxi.getClient fpath)
133 133
      Luxi.closeClient
134
      (\c -> luxiClientPong c msgs)
134
      (`luxiClientPong` msgs)
135 135
  stop $ replies ==? msgs
136 136

  
137 137
testSuite "Luxi"
b/htest/Test/Ganeti/Objects.hs
47 47
import Ganeti.Objects as Objects
48 48
import Ganeti.JSON
49 49

  
50
{-# ANN module "HLint: ignore Use camelCase" #-}
51

  
50 52
-- * Arbitrary instances
51 53

  
52 54
$(genArbitrary ''Hypervisor)
......
79 81
-- properties, we only generate disks with no children (FIXME), as
80 82
-- generating recursive datastructures is a bit more work.
81 83
instance Arbitrary Disk where
82
  arbitrary = Disk <$> arbitrary <*> (pure []) <*> arbitrary
84
  arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
83 85
                   <*> arbitrary <*> arbitrary
84 86

  
85 87
-- FIXME: we should generate proper values, >=0, etc., but this is
......
102 104
      <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
103 105
      <*> arbitrary
104 106
      -- FIXME: add non-empty hvparams when they're a proper type
105
      <*> (pure $ Container Map.empty) <*> arbitrary
107
      <*> pure (Container Map.empty) <*> arbitrary
106 108
      -- ... and for OSParams
107
      <*> (pure $ Container Map.empty) <*> arbitrary <*> arbitrary
109
      <*> pure (Container Map.empty) <*> arbitrary <*> arbitrary
108 110
      <*> arbitrary <*> arbitrary <*> arbitrary
109 111
      -- ts
110 112
      <*> arbitrary <*> arbitrary
......
127 129
-- validation rules.
128 130
instance Arbitrary NodeGroup where
129 131
  arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
130
                        <*> arbitrary <*> (pure $ Container Map.empty)
132
                        <*> arbitrary <*> pure (Container Map.empty)
131 133
                        -- ts
132 134
                        <*> arbitrary <*> arbitrary
133 135
                        -- uuid
......
181 183
                                      nodeName = nodeName n ++ show idx })
182 184
               nodes [(1::Int)..]
183 185
      contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
184
      continsts = Container $ Map.empty
186
      continsts = Container Map.empty
185 187
  grp <- arbitrary
186 188
  let contgroups = Container $ Map.singleton guuid grp
187 189
  serial <- arbitrary
b/htest/Test/Ganeti/OpCodes.hs
44 44
import qualified Ganeti.Constants as C
45 45
import qualified Ganeti.OpCodes as OpCodes
46 46

  
47
{-# ANN module "HLint: ignore Use camelCase" #-}
48

  
47 49
-- * Arbitrary instances
48 50

  
49 51
$(genArbitrary ''OpCodes.ReplaceDisksMode)
......
125 127
               \encoded = [op.__getstate__() for op in decoded]\n\
126 128
               \print serializer.Dump(encoded)" serialized
127 129
     >>= checkPythonResult
128
  let deserialised = (J.decode py_stdout::J.Result [OpCodes.OpCode])
130
  let deserialised = J.decode py_stdout::J.Result [OpCodes.OpCode]
129 131
  decoded <- case deserialised of
130 132
               J.Ok ops -> return ops
131 133
               J.Error msg ->
b/htest/Test/Ganeti/Query/Language.hs
65 65
    where value = oneof [ QuotedString <$> getName
66 66
                        , NumericValue <$> arbitrary
67 67
                        ]
68
genFilter' n = do
68
genFilter' n =
69 69
  oneof [ AndFilter  <$> vectorOf n'' (genFilter' n')
70 70
        , OrFilter   <$> vectorOf n'' (genFilter' n')
71 71
        , NotFilter  <$> genFilter' n'
......
92 92
-- recursive ones, and not 'JSNull', which we can't use in a
93 93
-- 'RSNormal' 'ResultEntry'.
94 94
genJSValue :: Gen JSValue
95
genJSValue = do
95
genJSValue =
96 96
  oneof [ JSBool <$> arbitrary
97 97
        , JSRational <$> pure False <*> arbitrary
98 98
        , JSString <$> (toJSString <$> arbitrary)
b/htest/Test/Ganeti/Query/Query.hs
47 47
import Ganeti.Query.Node
48 48
import Ganeti.Query.Query
49 49

  
50
{-# ANN module "HLint: ignore Use camelCase" #-}
51

  
50 52
-- * Helpers
51 53

  
52 54
-- | Checks if a list of field definitions contains unknown fields.
......
77 79
prop_queryNode_Unknown :: Property
78 80
prop_queryNode_Unknown =
79 81
  forAll (choose (0, maxNodes) >>= genEmptyCluster) $ \cluster ->
80
  forAll (arbitrary `suchThat` (`notElem` (Map.keys nodeFieldsMap)))
82
  forAll (arbitrary `suchThat` (`notElem` Map.keys nodeFieldsMap))
81 83
    $ \field -> monadicIO $ do
82 84
  QueryResult fdefs fdata <-
83 85
    run (query cluster (Query QRNode [field] EmptyFilter)) >>= resultProp
b/htest/Test/Ganeti/TestCommon.hs
149 149

  
150 150
-- | All valid tag chars. This doesn't need to match _exactly_
151 151
-- Ganeti's own tag regex, just enough for it to be close.
152
tagChar :: [Char]
152
tagChar :: String
153 153
tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
154 154

  
155 155
instance Arbitrary TagChar where
b/htest/Test/Ganeti/TestHelper.hs
95 95
mkConsArbitrary (name, types) =
96 96
  let infix_arb a = InfixE (Just a) (VarE '(<*>)) (Just (VarE 'arbitrary))
97 97
      constr = AppE (VarE 'pure) (ConE name)
98
  in foldl (\a _ -> infix_arb a) (constr) types
98
  in foldl (\a _ -> infix_arb a) constr types
99 99

  
100 100
-- | Extracts the name and the types from a constructor.
101 101
conInfo :: Con -> (Name, [Type])
......
108 108
mkRegularArbitrary :: Name -> [Con] -> Q [Dec]
109 109
mkRegularArbitrary name cons = do
110 110
  expr <- case cons of
111
            [] -> fail $ "Can't make Arbitrary instance for an empty data type"
111
            [] -> fail "Can't make Arbitrary instance for an empty data type"
112 112
            [x] -> return $ mkConsArbitrary (conInfo x)
113 113
            xs -> appE (varE 'oneof) $
114 114
                  listE (map (return . mkConsArbitrary . conInfo) xs)
b/htools/Ganeti/Common.hs
99 99
                  -> (a -> b -> Result b)
100 100
                  -> String
101 101
                  -> ArgDescr (b -> Result b)
102
reqWithConversion conversion_fn updater_fn metavar =
102
reqWithConversion conversion_fn updater_fn =
103 103
  ReqArg (\string_opt opts -> do
104 104
            parsed_value <- conversion_fn string_opt
105
            updater_fn parsed_value opts) metavar
105
            updater_fn parsed_value opts)
106 106

  
107 107
-- | Command line parser, using a generic 'Options' structure.
108 108
parseOpts :: (StandardOptions a) =>
b/htools/Ganeti/Confd.hs
146 146
  ])
147 147
$(makeJSONInstance ''ConfdErrorType)
148 148

  
149
$(buildObject "ConfdRequest" "confdRq" $
149
$(buildObject "ConfdRequest" "confdRq"
150 150
  [ simpleField "protocol" [t| Int |]
151 151
  , simpleField "type"     [t| ConfdRequestType |]
152 152
  , defaultField [| EmptyQuery |] $ simpleField "query" [t| ConfdQuery |]
b/htools/Ganeti/Confd/Server.hs
286 286

  
287 287
-- | Wrapper over 'updateConfig' that handles IO errors.
288 288
safeUpdateConfig :: FilePath -> FStat -> CRef -> IO (FStat, ConfigReload)
289
safeUpdateConfig path oldfstat cref = do
289
safeUpdateConfig path oldfstat cref =
290 290
  catch (do
291 291
          nt <- needsReload oldfstat path
292 292
          case nt of
......
410 410
-- This tries to setup the watch descriptor; in case of any IO errors,
411 411
-- it will return False.
412 412
addNotifier :: INotify -> FilePath -> CRef -> MVar ServerState -> IO Bool
413
addNotifier inotify path cref mstate = do
413
addNotifier inotify path cref mstate =
414 414
  catch (addWatch inotify [CloseWrite] path
415 415
                    (onInotify inotify path cref mstate) >> return True)
416 416
        (\e -> const (return False) (e::IOError))
......
430 430
                  path cref mstate
431 431
        return state' { reloadModel = mode }
432 432

  
433
onInotify inotify path cref mstate _ = do
433
onInotify inotify path cref mstate _ =
434 434
  modifyMVar_ mstate $ \state ->
435
    if (reloadModel state == ReloadNotify)
435
    if reloadModel state == ReloadNotify
436 436
       then do
437 437
         ctime <- getCurrentTime
438 438
         (newfstat, _) <- safeUpdateConfig path (reloadFStat state) cref
......
481 481
listener s hmac resp = do
482 482
  (msg, _, peer) <- S.recvFrom s 4096
483 483
  if confdMagicFourcc `isPrefixOf` msg
484
    then (forkIO $ resp s hmac (drop 4 msg) peer) >> return ()
484
    then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
485 485
    else logDebug "Invalid magic code!" >> return ()
486 486
  return ()
487 487

  
b/htools/Ganeti/Confd/Utils.hs
63 63
parseMessage hmac msg curtime = do
64 64
  (salt, origmsg, request) <- parseRequest hmac msg
65 65
  ts <- tryRead "Parsing timestamp" salt::Result Integer
66
  if (abs (ts - curtime) > (fromIntegral C.confdMaxClockSkew))
66
  if abs (ts - curtime) > fromIntegral C.confdMaxClockSkew
67 67
    then fail "Too old/too new timestamp or clock skew"
68 68
    else return (origmsg, request)
69 69

  
b/htools/Ganeti/Config.hs
111 111
-- | Computes the role of a node.
112 112
getNodeRole :: ConfigData -> Node -> NodeRole
113 113
getNodeRole cfg node
114
  | nodeName node == (clusterMasterNode $ configCluster cfg) = NRMaster
114
  | nodeName node == clusterMasterNode (configCluster cfg) = NRMaster
115 115
  | nodeMasterCandidate node = NRCandidate
116 116
  | nodeDrained node = NRDrained
117 117
  | nodeOffline node = NROffline
......
133 133
getItem :: String -> String -> M.Map String a -> Result a
134 134
getItem kind name allitems = do
135 135
  let lresult = lookupName (M.keys allitems) name
136
      err = \details -> Bad $ kind ++ " name " ++ name ++ " " ++ details
136
      err msg = Bad $ kind ++ " name " ++ name ++ " " ++ msg
137 137
  fullname <- case lrMatchPriority lresult of
138 138
                PartialMatch -> Ok $ lrContent lresult
139 139
                ExactMatch -> Ok $ lrContent lresult
......
160 160
       -- if not found by uuid, we need to look it up by name, slow
161 161
       Ok grp -> Ok grp
162 162
       Bad _ -> let by_name = M.mapKeys
163
                              (\k -> groupName ((M.!) groups k )) groups
163
                              (groupName . (M.!) groups) groups
164 164
                in getItem "NodeGroup" name by_name
165 165

  
166 166
-- | Computes a node group's node params.
......
232 232
                   link = nicpLink fparams
233 233
               in case nicIp nic of
234 234
                    Nothing -> accum
235
                    Just ip -> let oldipmap = M.findWithDefault (M.empty)
235
                    Just ip -> let oldipmap = M.findWithDefault M.empty
236 236
                                              link accum
237 237
                                   newipmap = M.insert ip iname oldipmap
238 238
                               in M.insert link newipmap accum
b/htools/Ganeti/Daemon.hs
105 105
instance StandardOptions DaemonOptions where
106 106
  helpRequested = optShowHelp
107 107
  verRequested  = optShowVer
108
  requestHelp   = \opts -> opts { optShowHelp = True }
109
  requestVer    = \opts -> opts { optShowVer  = True }
108
  requestHelp o = o { optShowHelp = True }
109
  requestVer  o = o { optShowVer  = True }
110 110

  
111 111
-- | Abrreviation for the option type.
112 112
type OptType = GenericOptType DaemonOptions
......
176 176
-- | Wrapper over '_writePidFile' that transforms IO exceptions into a
177 177
-- 'Bad' value.
178 178
writePidFile :: FilePath -> IO (Result Fd)
179
writePidFile path = do
179
writePidFile path =
180 180
  catch (fmap Ok $ _writePidFile path)
181 181
    (return . Bad . formatIOError "Failure during writing of the pid file")
182 182

  
183 183
-- | Helper function to ensure a socket doesn't exist. Should only be
184 184
-- called once we have locked the pid file successfully.
185 185
cleanupSocket :: FilePath -> IO ()
186
cleanupSocket socketPath = do
186
cleanupSocket socketPath =
187 187
  catchJust (guard . isDoesNotExistError) (removeLink socketPath)
188 188
            (const $ return ())
189 189

  
......
217 217
                -> Socket.Family        -- ^ The cluster IP family
218 218
                -> Result (Socket.Family, Socket.SockAddr)
219 219
defaultBindAddr port Socket.AF_INET =
220
  Ok $ (Socket.AF_INET,
221
        Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
220
  Ok (Socket.AF_INET,
221
      Socket.SockAddrInet (fromIntegral port) Socket.iNADDR_ANY)
222 222
defaultBindAddr port Socket.AF_INET6 =
223
  Ok $ (Socket.AF_INET6,
224
        Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
223
  Ok (Socket.AF_INET6,
224
      Socket.SockAddrInet6 (fromIntegral port) 0 Socket.iN6ADDR_ANY 0)
225 225
defaultBindAddr _ fam = Bad $ "Unsupported address family: " ++ show fam
226 226

  
227 227
-- | Default hints for the resolver
......
236 236
  resolved <- Socket.getAddrInfo resolveAddrHints (Just str) (Just (show port))
237 237
  return $ case resolved of
238 238
             [] -> Bad "Invalid results from lookup?"
239
             best:_ -> Ok $ (Socket.addrFamily best, Socket.addrAddress best)
239
             best:_ -> Ok (Socket.addrFamily best, Socket.addrAddress best)
240 240

  
241 241
-- | Based on the options, compute the socket address to use for the
242 242
-- daemon.
......
246 246
parseAddress opts defport = do
247 247
  let port = maybe defport fromIntegral $ optPort opts
248 248
  def_family <- Ssconf.getPrimaryIPFamily Nothing
249
  ainfo <- case optBindAddress opts of
250
             Nothing -> return (def_family >>= defaultBindAddr port)
251
             Just saddr -> catch (resolveAddr port saddr)
252
                           (annotateIOError $ "Invalid address " ++ saddr)
253
  return ainfo
249
  case optBindAddress opts of
250
    Nothing -> return (def_family >>= defaultBindAddr port)
251
    Just saddr -> catch (resolveAddr port saddr)
252
                  (annotateIOError $ "Invalid address " ++ saddr)
254 253

  
255 254
-- | Run an I/O action as a daemon.
256 255
--
b/htools/Ganeti/HTools/CLI.hs
199 199
instance StandardOptions Options where
200 200
  helpRequested = optShowHelp
201 201
  verRequested  = optShowVer
202
  requestHelp   = \opts -> opts { optShowHelp = True }
203
  requestVer    = \opts -> opts { optShowVer  = True }
202
  requestHelp o = o { optShowHelp = True }
203
  requestVer  o = o { optShowVer  = True }
204 204

  
205 205
-- * Helper functions
206 206

  
......
539 539
      m_cpu = optMcpu opts
540 540
      m_dsk = optMdsk opts
541 541

  
542
  unless (null offline_wrong) $ do
542
  unless (null offline_wrong) .
543 543
         exitErr $ printf "wrong node name(s) set as offline: %s\n"
544 544
                   (commaJoin (map lrContent offline_wrong))
545 545
  let setMCpuFn = case m_cpu of
b/htools/Ganeti/HTools/Instance.hs
276 276
instMatchesPolicy inst ipol = do
277 277
  instAboveISpec inst (T.iPolicyMinSpec ipol)
278 278
  instBelowISpec inst (T.iPolicyMaxSpec ipol)
279
  if (diskTemplate inst `elem` T.iPolicyDiskTemplates ipol)
279
  if diskTemplate inst `elem` T.iPolicyDiskTemplates ipol
280 280
    then T.OpGood ()
281 281
    else T.OpFail T.FailDisk
282 282

  
b/htools/Ganeti/HTools/Luxi.hs
212 212
  cpol <- tryFromObj errmsg obj' "ipolicy"
213 213
  return (ctags, cpol)
214 214

  
215
getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
215
getClusterData _ = Bad "Cannot parse cluster info, not a JSON record"
216 216

  
217 217
-- | Parses the cluster groups.
218 218
getGroups :: JSValue -> Result [(String, Group.Group)]
b/htools/Ganeti/HTools/Program/Hcheck.hs
158 158
-- readable mode).
159 159
printGroupsMappings :: Group.List -> IO ()
160 160
printGroupsMappings gl = do
161
    let extract_vals = \g -> (printf "GROUP_UUID_%d" $ Group.idx g :: String,
162
                              Group.uuid g)
161
    let extract_vals g = (printf "GROUP_UUID_%d" $ Group.idx g :: String,
162
                          Group.uuid g)
163 163
        printpairs = map extract_vals (Container.elems gl)
164 164
    printKeysHTC printpairs
165 165

  
b/htools/Ganeti/HTools/Program/Hinfo.hs
104 104
splitInstancesInfo :: Int -> Node.List -> Instance.List -> IO ()
105 105
splitInstancesInfo verbose nl il = do
106 106
  let split_insts = Cluster.findSplitInstances nl il
107
  if (null split_insts)
107
  if null split_insts
108 108
    then
109
      when (verbose > 1) $ do
109
      when (verbose > 1) $
110 110
        putStrLn "No split instances found"::IO ()
111 111
    else do
112 112
      putStrLn "Found instances belonging to multiple node groups:"
......
115 115
-- | Print common (interesting) information.
116 116
commonInfo :: Int -> Group.List -> Node.List -> Instance.List -> IO ()
117 117
commonInfo verbose gl nl il = do
118
  when (Container.null il && verbose > 1) $ do
119
         printf "Cluster is empty.\n"::IO ()
118
  when (Container.null il && verbose > 1) $
119
    printf "Cluster is empty.\n"::IO ()
120 120

  
121
  let nl_size = (Container.size nl)
122
      il_size = (Container.size il)
123
      gl_size = (Container.size gl)
121
  let nl_size = Container.size nl
122
      il_size = Container.size il
123
      gl_size = Container.size gl
124 124
  printf "Loaded %d %s, %d %s, %d %s\n"
125 125
             nl_size (plural nl_size "node" "nodes")
126 126
             il_size (plural il_size "instance" "instances")
......
145 145

  
146 146
  putStrLn $ "Loaded cluster tags: " ++ intercalate "," ctags
147 147

  
148
  when (verbose > 2) $ do
148
  when (verbose > 2) .
149 149
       putStrLn $ "Loaded cluster ipolicy: " ++ show ipol
150 150

  
151 151
  nlf <- setNodeStatus opts fixed_nl
b/htools/Ganeti/HTools/Program/Hspace.hs
372 372

  
373 373
-- | Create an instance from a given spec.
374 374
instFromSpec :: RSpec -> DiskTemplate -> Int -> Instance.Instance
375
instFromSpec spx disk_template su =
375
instFromSpec spx =
376 376
  Instance.create "new" (rspecMem spx) (rspecDsk spx)
377
    (rspecCpu spx) Running [] True (-1) (-1) disk_template su
377
    (rspecCpu spx) Running [] True (-1) (-1)
378 378

  
379 379
-- | Main function.
380 380
main :: Options -> [String] -> IO ()
b/htools/Ganeti/HTools/Rapi.hs
212 212
-- | Loads data via either 'readDataFile' or 'readDataHttp'.
213 213
readData :: String -- ^ URL to use as source
214 214
         -> IO (Result String, Result String, Result String, Result String)
215
readData url = do
215
readData url =
216 216
  if filePrefix `isPrefixOf` url
217 217
    then readDataFile (drop (length filePrefix) url)
218 218
    else readDataHttp url
b/htools/Ganeti/HTools/Text.hs
146 146
serializeAllIPolicies :: IPolicy -> Group.List -> String
147 147
serializeAllIPolicies cpol gl =
148 148
  let groups = Container.elems gl
149
      allpolicies = [("", cpol)] ++
149
      allpolicies = ("", cpol) :
150 150
                    map (\g -> (Group.name g, Group.iPolicy g)) groups
151 151
      strings = map (uncurry serializeIPolicy) allpolicies
152 152
  in unlines strings
......
259 259
  xdts <- mapM diskTemplateFromRaw $ commaSplit dtemplates
260 260
  xvcpu_ratio <- tryRead (owner ++ "/vcpu_ratio") vcpu_ratio
261 261
  xspindle_ratio <- tryRead (owner ++ "/spindle_ratio") spindle_ratio
262
  return $ (owner, IPolicy xstdspec xminspec xmaxspec xdts
263
            xvcpu_ratio xspindle_ratio)
262
  return (owner,
263
          IPolicy xstdspec xminspec xmaxspec xdts xvcpu_ratio xspindle_ratio)
264 264
loadIPolicy s = fail $ "Invalid ipolicy data: '" ++ show s ++ "'"
265 265

  
266 266
loadOnePolicy :: (IPolicy, Group.List) -> String
b/htools/Ganeti/Luxi.hs
342 342
    ReqQueryGroups -> do
343 343
              (names, fields, locking) <- fromJVal args
344 344
              return $ QueryGroups names fields locking
345
    ReqQueryClusterInfo -> do
345
    ReqQueryClusterInfo ->
346 346
              return QueryClusterInfo
347 347
    ReqQuery -> do
348 348
              (what, fields, qfilter) <- fromJVal args
b/htools/Ganeti/Objects.hs
276 276
          mB' <- readJSON mB
277 277
          k'  <- readJSON k
278 278
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
279
        _ -> fail $ "Can't read logical_id for DRBD8 type"
279
        _ -> fail "Can't read logical_id for DRBD8 type"
280 280
    LD_LV ->
281 281
      case lid of
282 282
        JSArray [vg, lv] -> do
283 283
          vg' <- readJSON vg
284 284
          lv' <- readJSON lv
285 285
          return $ LIDPlain vg' lv'
286
        _ -> fail $ "Can't read logical_id for plain type"
286
        _ -> fail "Can't read logical_id for plain type"
287 287
    LD_FILE ->
288 288
      case lid of
289 289
        JSArray [driver, path] -> do
290 290
          driver' <- readJSON driver
291 291
          path'   <- readJSON path
292 292
          return $ LIDFile driver' path'
293
        _ -> fail $ "Can't read logical_id for file type"
293
        _ -> fail "Can't read logical_id for file type"
294 294
    LD_BLOCKDEV ->
295 295
      case lid of
296 296
        JSArray [driver, path] -> do
297 297
          driver' <- readJSON driver
298 298
          path'   <- readJSON path
299 299
          return $ LIDBlockDev driver' path'
300
        _ -> fail $ "Can't read logical_id for blockdev type"
300
        _ -> fail "Can't read logical_id for blockdev type"
301 301
    LD_RADOS ->
302 302
      case lid of
303 303
        JSArray [driver, path] -> do
304 304
          driver' <- readJSON driver
305 305
          path'   <- readJSON path
306 306
          return $ LIDRados driver' path'
307
        _ -> fail $ "Can't read logical_id for rdb type"
307
        _ -> fail "Can't read logical_id for rdb type"
308 308

  
309 309
-- | Disk data structure.
310 310
--
......
363 363
  ])
364 364
$(makeJSONInstance ''AdminState)
365 365

  
366
$(buildParam "Be" "bep" $
366
$(buildParam "Be" "bep"
367 367
  [ simpleField "minmem"       [t| Int  |]
368 368
  , simpleField "maxmem"       [t| Int  |]
369 369
  , simpleField "vcpus"        [t| Int  |]
......
404 404

  
405 405
-- * IPolicy definitions
406 406

  
407
$(buildParam "ISpec" "ispec" $
407
$(buildParam "ISpec" "ispec"
408 408
  [ simpleField C.ispecMemSize     [t| Int |]
409 409
  , simpleField C.ispecDiskSize    [t| Int |]
410 410
  , simpleField C.ispecDiskCount   [t| Int |]
......
414 414

  
415 415
-- | Custom partial ipolicy. This is not built via buildParam since it
416 416
-- has a special 2-level inheritance mode.
417
$(buildObject "PartialIPolicy" "ipolicy" $
417
$(buildObject "PartialIPolicy" "ipolicy"
418 418
  [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
419 419
  , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
420 420
  , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
......
428 428

  
429 429
-- | Custom filled ipolicy. This is not built via buildParam since it
430 430
-- has a special 2-level inheritance mode.
431
$(buildObject "FilledIPolicy" "ipolicy" $
431
$(buildObject "FilledIPolicy" "ipolicy"
432 432
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
433 433
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
434 434
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
......
461 461
                }
462 462
-- * Node definitions
463 463

  
464
$(buildParam "ND" "ndp" $
464
$(buildParam "ND" "ndp"
465 465
  [ simpleField "oob_program"   [t| String |]
466 466
  , simpleField "spindle_count" [t| Int    |]
467 467
  ])
b/htools/Ganeti/Query/Language.hs
136 136
showFilter :: (JSON a) => Filter a -> JSValue
137 137
showFilter (EmptyFilter)          = JSNull
138 138
showFilter (AndFilter exprs)      =
139
  JSArray $ (showJSON C.qlangOpAnd):(map showJSON exprs)
139
  JSArray $ showJSON C.qlangOpAnd : map showJSON exprs
140 140
showFilter (OrFilter  exprs)      =
141
  JSArray $ (showJSON C.qlangOpOr):(map showJSON exprs)
141
  JSArray $ showJSON C.qlangOpOr : map showJSON exprs
142 142
showFilter (NotFilter flt)        =
143 143
  JSArray [showJSON C.qlangOpNot, showJSON flt]
144 144
showFilter (TrueFilter field)     =
......
223 223
-- Traversable implementation for 'Filter'.
224 224
traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
225 225
traverseFlt _ EmptyFilter       = pure EmptyFilter
226
traverseFlt f (AndFilter flts)  = AndFilter <$> (traverse (traverseFlt f) flts)
227
traverseFlt f (OrFilter  flts)  = OrFilter  <$> (traverse (traverseFlt f) flts)
228
traverseFlt f (NotFilter flt)   = NotFilter <$> (traverseFlt f flt)
226
traverseFlt f (AndFilter flts)  = AndFilter <$> traverse (traverseFlt f) flts
227
traverseFlt f (OrFilter  flts)  = OrFilter  <$> traverse (traverseFlt f) flts
228
traverseFlt f (NotFilter flt)   = NotFilter <$> traverseFlt f flt
229 229
traverseFlt f (TrueFilter a)    = TrueFilter <$> f a
230 230
traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval
231 231
traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval
b/htools/Ganeti/Query/Node.hs
76 76
nodeRoleDoc :: String
77 77
nodeRoleDoc =
78 78
  "Node role; " ++
79
  (intercalate ", " $
80
   map (\role ->
79
  intercalate ", "
80
   (map (\role ->
81 81
          "\"" ++ nodeRoleToRaw role ++ "\" for " ++ roleDescription role)
82 82
   (reverse [minBound..maxBound]))
83 83

  
b/htools/Ganeti/Query/Server.hs
69 69
      hypervisors = clusterEnabledHypervisors cluster
70 70
      bits = show (bitSize (0::Int)) ++ "bits"
71 71
      arch_tuple = [bits, arch]
72
      obj = [ ("software_version", showJSON $ C.releaseVersion)
73
            , ("protocol_version", showJSON $ C.protocolVersion)
74
            , ("config_version", showJSON $ C.configVersion)
72
      obj = [ ("software_version", showJSON C.releaseVersion)
73
            , ("protocol_version", showJSON C.protocolVersion)
74
            , ("config_version", showJSON C.configVersion)
75 75
            , ("os_api_version", showJSON $ maximum C.osApiVersions)
76
            , ("export_version", showJSON $ C.exportVersion)
77
            , ("architecture", showJSON $ arch_tuple)
76
            , ("export_version", showJSON C.exportVersion)
77
            , ("architecture", showJSON arch_tuple)
78 78
            , ("name", showJSON $ clusterClusterName cluster)
79 79
            , ("master", showJSON $ clusterMasterNode cluster)
80 80
            , ("default_hypervisor", showJSON $ head hypervisors)
81
            , ("enabled_hypervisors", showJSON $ hypervisors)
81
            , ("enabled_hypervisors", showJSON hypervisors)
82 82
            , ("hvparams", showJSON $ clusterHvparams cluster)
83 83
            , ("os_hvp", showJSON $ clusterOsHvp cluster)
84 84
            , ("beparams", showJSON $ clusterBeparams cluster)
......
93 93
            , ("master_netmask", showJSON $ clusterMasterNetmask cluster)
94 94
            , ("use_external_mip_script",
95 95
               showJSON $ clusterUseExternalMipScript cluster)
96
            , ("volume_group_name", showJSON $clusterVolumeGroupName cluster)
96
            , ("volume_group_name", showJSON $ clusterVolumeGroupName cluster)
97 97
            , ("drbd_usermode_helper",
98 98
               maybe JSNull showJSON (clusterDrbdUsermodeHelper cluster))
99 99
            , ("file_storage_dir", showJSON $ clusterFileStorageDir cluster)
b/htools/Ganeti/Rpc.hs
172 172
prepareUrl node call =
173 173
  let node_ip = nodePrimaryIp node
174 174
      port = snd C.daemonsPortsGanetiNoded
175
      path_prefix = "https://" ++ (node_ip) ++ ":" ++ (show port) in
176
  path_prefix ++ "/" ++ rpcCallName call
175
      path_prefix = "https://" ++ node_ip ++ ":" ++ show port
176
  in path_prefix ++ "/" ++ rpcCallName call
177 177

  
178 178
-- | Create HTTP request for a given node provided it is online,
179 179
-- otherwise create empty response.
180 180
prepareHttpRequest ::  (RpcCall a) => Node -> a
181 181
                   -> Either RpcError HttpClientRequest
182 182
prepareHttpRequest node call
183
  | rpcCallAcceptOffline call ||
184
    (not $ nodeOffline node) =
185
      Right $ HttpClientRequest { requestTimeout = rpcCallTimeout call
186
                                , requestUrl = prepareUrl node call
187
                                , requestPostData = rpcCallData node call
188
                                }
183
  | rpcCallAcceptOffline call || not (nodeOffline node) =
184
      Right HttpClientRequest { requestTimeout = rpcCallTimeout call
185
                              , requestUrl = prepareUrl node call
186
                              , requestPostData = rpcCallData node call
187
                              }
189 188
  | otherwise = Left $ OfflineNodeError node
190 189

  
191 190
-- | Parse the response or propagate the error.
......
212 211

  
213 212
-- | AllInstancesInfo
214 213
--   Returns information about all instances on the given nodes
215
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo" $
214
$(buildObject "RpcCallAllInstancesInfo" "rpcCallAllInstInfo"
216 215
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
217 216

  
218
$(buildObject "InstanceInfo" "instInfo" $
217
$(buildObject "InstanceInfo" "instInfo"
219 218
  [ simpleField "name"   [t| String |]
220 219
  , simpleField "memory" [t| Int|]
221 220
  , simpleField "state"  [t| AdminState |]
......
223 222
  , simpleField "time"   [t| Int |]
224 223
  ])
225 224

  
226
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo" $
225
$(buildObject "RpcResultAllInstancesInfo" "rpcResAllInstInfo"
227 226
  [ simpleField "instances" [t| [InstanceInfo] |] ])
228 227

  
229 228
instance RpcCall RpcCallAllInstancesInfo where
......
237 236

  
238 237
-- | InstanceList
239 238
-- Returns the list of running instances on the given nodes.
240
$(buildObject "RpcCallInstanceList" "rpcCallInstList" $
239
$(buildObject "RpcCallInstanceList" "rpcCallInstList"
241 240
  [ simpleField "hypervisors" [t| [Hypervisor] |] ])
242 241

  
243
$(buildObject "RpcResultInstanceList" "rpcResInstList" $
242
$(buildObject "RpcResultInstanceList" "rpcResInstList"
244 243
  [ simpleField "node"      [t| Node |]
245 244
  , simpleField "instances" [t| [String] |]
246 245
  ])
......
256 255

  
257 256
-- | NodeInfo
258 257
-- Return node information.
259
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo" $
258
$(buildObject "RpcCallNodeInfo" "rpcCallNodeInfo"
260 259
  [ simpleField "hypervisors" [t| [Hypervisor] |]
261 260
  , simpleField "volume_groups" [t| [String] |]
262 261
  ])
263 262

  
264
$(buildObject "VgInfo" "vgInfo" $
263
$(buildObject "VgInfo" "vgInfo"
265 264
  [ simpleField "name" [t| String |]
266 265
  , simpleField "free" [t| Int |]
267 266
  , simpleField "size" [t| Int |]
268 267
  ])
269 268

  
270 269
-- | We only provide common fields as described in hv_base.py.
271
$(buildObject "HvInfo" "hvInfo" $
270
$(buildObject "HvInfo" "hvInfo"
272 271
  [ simpleField "memory_total" [t| Int |]
273 272
  , simpleField "memory_free" [t| Int |]
274 273
  , simpleField "memory_dom0" [t| Int |]
......
277 276
  , simpleField "cpu_sockets" [t| Int |]
278 277
  ])
279 278

  
280
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo" $
279
$(buildObject "RpcResultNodeInfo" "rpcResNodeInfo"
281 280
  [ simpleField "boot_id" [t| String |]
282 281
  , simpleField "vg_info" [t| [VgInfo] |]
283 282
  , simpleField "hv_info" [t| [HvInfo] |]
b/htools/lint-hints.hs
1
{- Custom hint lints for Ganeti.
1
{-| Custom hint lints for Ganeti.
2 2

  
3
Since passing --hint to hlint will override, not extend the built-in hints, we need to import the existing hints so that we get full coverage.
3
Since passing --hint to hlint will override, not extend the built-in
4
hints, we need to import the existing hints so that we get full
5
coverage.
4 6

  
5 7
-}
6 8

  
7
import "hint" HLint.Default
9
import "hint" HLint.HLint
8 10
import "hint" HLint.Dollar
9 11

  
10 12
-- The following two hints warn to simplify e.g. "map (\v -> (v,

Also available in: Unified diff