Fix typo 'option' instead of 'options'
[ganeti-github.git] / src / Ganeti / HTools / Program / Harep.hs
1 {-# LANGUAGE TupleSections #-}
2
3 {-| Auto-repair tool for Ganeti.
4
5 -}
6
7 {-
8
9 Copyright (C) 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 module Ganeti.HTools.Program.Harep
38 ( main
39 , arguments
40 , options) where
41
42 import Control.Exception (bracket)
43 import Control.Lens (over)
44 import Control.Monad
45 import Data.Function
46 import Data.List
47 import Data.Maybe
48 import Data.Ord
49 import System.Time
50 import qualified Data.Map as Map
51 import qualified Text.JSON as J
52
53 import Ganeti.BasicTypes
54 import Ganeti.Common
55 import Ganeti.Errors
56 import Ganeti.JQueue (currentTimestamp, reasonTrailTimestamp)
57 import Ganeti.JQueue.Objects (Timestamp)
58 import Ganeti.Jobs
59 import Ganeti.OpCodes
60 import Ganeti.OpCodes.Lens (metaParamsL, opReasonL)
61 import Ganeti.OpParams
62 import Ganeti.Types
63 import Ganeti.Utils
64 import qualified Ganeti.Constants as C
65 import qualified Ganeti.Luxi as L
66 import qualified Ganeti.Path as Path
67
68 import Ganeti.HTools.CLI
69 import Ganeti.HTools.Loader
70 import Ganeti.HTools.ExtLoader
71 import qualified Ganeti.HTools.Tags.Constants as Tags
72 import Ganeti.HTools.Types
73 import qualified Ganeti.HTools.Container as Container
74 import qualified Ganeti.HTools.Instance as Instance
75 import qualified Ganeti.HTools.Node as Node
76
77 import Ganeti.Version (version)
78
79
80 -- | Options list and functions.
81 options :: IO [OptType]
82 options = do
83 luxi <- oLuxiSocket
84 return
85 [ luxi
86 , oJobDelay
87 , oReason
88 , oDryRun
89 ]
90
91 arguments :: [ArgCompletion]
92 arguments = []
93
94 -- | Wraps an 'OpCode' in a 'MetaOpCode' while also adding a comment
95 -- about what generated the opcode.
96 annotateOpCode :: Maybe String -> Timestamp -> OpCode -> MetaOpCode
97 annotateOpCode reason ts =
98 over (metaParamsL . opReasonL)
99 (++ [( "harep", fromMaybe ("harep " ++ version ++ " called") reason
100 , reasonTrailTimestamp ts)])
101 . setOpComment ("automated repairs by harep " ++ version)
102 . wrapOpCode
103
104 data InstanceData = InstanceData { arInstance :: Instance.Instance
105 , arState :: AutoRepairStatus
106 , tagsToRemove :: [String]
107 }
108 deriving (Eq, Show)
109
110 -- | Parse a tag into an 'AutoRepairData' record.
111 --
112 -- @Nothing@ is returned if the tag is not an auto-repair tag, or if it's
113 -- malformed.
114 parseInitTag :: String -> Maybe AutoRepairData
115 parseInitTag tag =
116 let parsePending = do
117 subtag <- chompPrefix Tags.autoRepairTagPending tag
118 case sepSplit ':' subtag of
119 [rtype, uuid, ts, jobs] -> makeArData rtype uuid ts jobs
120 _ -> fail ("Invalid tag: " ++ show tag)
121
122 parseResult = do
123 subtag <- chompPrefix Tags.autoRepairTagResult tag
124 case sepSplit ':' subtag of
125 [rtype, uuid, ts, result, jobs] -> do
126 arData <- makeArData rtype uuid ts jobs
127 result' <- autoRepairResultFromRaw result
128 return arData { arResult = Just result' }
129 _ -> fail ("Invalid tag: " ++ show tag)
130
131 makeArData rtype uuid ts jobs = do
132 rtype' <- autoRepairTypeFromRaw rtype
133 ts' <- tryRead "auto-repair time" ts
134 jobs' <- mapM makeJobIdS $ sepSplit '+' jobs
135 return AutoRepairData { arType = rtype'
136 , arUuid = uuid
137 , arTime = TOD ts' 0
138 , arJobs = jobs'
139 , arResult = Nothing
140 , arTag = tag
141 }
142 in
143 parsePending `mplus` parseResult
144
145 -- | Return the 'AutoRepairData' element of an 'AutoRepairStatus' type.
146 getArData :: AutoRepairStatus -> Maybe AutoRepairData
147 getArData status =
148 case status of
149 ArHealthy (Just d) -> Just d
150 ArFailedRepair d -> Just d
151 ArPendingRepair d -> Just d
152 ArNeedsRepair d -> Just d
153 _ -> Nothing
154
155 -- | Return a short name for each auto-repair status.
156 --
157 -- This is a more concise representation of the status, because the default
158 -- "Show" formatting includes all the accompanying auto-repair data.
159 arStateName :: AutoRepairStatus -> String
160 arStateName status =
161 case status of
162 ArHealthy _ -> "Healthy"
163 ArFailedRepair _ -> "Failure"
164 ArPendingRepair _ -> "Pending repair"
165 ArNeedsRepair _ -> "Needs repair"
166
167 -- | Return a new list of tags to remove that includes @arTag@ if present.
168 delCurTag :: InstanceData -> [String]
169 delCurTag instData =
170 let arData = getArData $ arState instData
171 rmTags = tagsToRemove instData
172 in
173 case arData of
174 Just d -> arTag d : rmTags
175 Nothing -> rmTags
176
177 -- | Set the initial auto-repair state of an instance from its auto-repair tags.
178 --
179 -- The rules when there are multiple tags is:
180 --
181 -- * the earliest failure result always wins
182 --
183 -- * two or more pending repairs results in a fatal error
184 --
185 -- * a pending result from id X and a success result from id Y result in error
186 -- if Y is newer than X
187 --
188 -- * if there are no pending repairs, the newest success result wins,
189 -- otherwise the pending result is used.
190 setInitialState :: Instance.Instance -> Result InstanceData
191 setInitialState inst =
192 let arData = mapMaybe parseInitTag $ Instance.allTags inst
193 -- Group all the AutoRepairData records by id (i.e. by repair task), and
194 -- present them from oldest to newest.
195 arData' = sortBy (comparing arUuid) arData
196 arGroups = groupBy ((==) `on` arUuid) arData'
197 arGroups' = sortBy (comparing $ minimum . map arTime) arGroups
198 in
199 foldM arStatusCmp (InstanceData inst (ArHealthy Nothing) []) arGroups'
200
201 -- | Update the initial status of an instance with new repair task tags.
202 --
203 -- This function gets called once per repair group in an instance's tag, and it
204 -- determines whether to set the status of the instance according to this new
205 -- group, or to keep the existing state. See the documentation for
206 -- 'setInitialState' for the rules to be followed when determining this.
207 arStatusCmp :: InstanceData -> [AutoRepairData] -> Result InstanceData
208 arStatusCmp instData arData =
209 let curSt = arState instData
210 arData' = sortBy (comparing keyfn) arData
211 keyfn d = (arResult d, arTime d)
212 newData = last arData'
213 newSt = case arResult newData of
214 Just ArSuccess -> ArHealthy $ Just newData
215 Just ArEnoperm -> ArHealthy $ Just newData
216 Just ArFailure -> ArFailedRepair newData
217 Nothing -> ArPendingRepair newData
218 in
219 case curSt of
220 ArFailedRepair _ -> Ok instData -- Always keep the earliest failure.
221 ArHealthy _ -> Ok instData { arState = newSt
222 , tagsToRemove = delCurTag instData
223 }
224 ArPendingRepair d -> Bad (
225 "An unfinished repair was found in instance " ++
226 Instance.name (arInstance instData) ++ ": found tag " ++
227 show (arTag newData) ++ ", but older pending tag " ++
228 show (arTag d) ++ "exists.")
229
230 ArNeedsRepair _ -> Bad
231 "programming error: ArNeedsRepair found as an initial state"
232
233 -- | Query jobs of a pending repair, returning the new instance data.
234 processPending :: Options -> L.Client -> InstanceData -> IO InstanceData
235 processPending opts client instData =
236 case arState instData of
237 (ArPendingRepair arData) -> do
238 sts <- L.queryJobsStatus client $ arJobs arData
239 time <- getClockTime
240 case sts of
241 Bad e -> exitErr $ "could not check job status: " ++ formatError e
242 Ok sts' ->
243 if any (<= JOB_STATUS_RUNNING) sts' then
244 return instData -- (no change)
245 else do
246 let iname = Instance.name $ arInstance instData
247 srcSt = arStateName $ arState instData
248 destSt = arStateName arState'
249 putStrLn ("Moving " ++ iname ++ " from " ++ show srcSt ++ " to " ++
250 show destSt)
251 commitChange opts client instData'
252 where
253 instData' =
254 instData { arState = arState'
255 , tagsToRemove = delCurTag instData
256 }
257 arState' =
258 if all (== JOB_STATUS_SUCCESS) sts' then
259 ArHealthy $ Just (updateTag $ arData { arResult = Just ArSuccess
260 , arTime = time })
261 else
262 ArFailedRepair (updateTag $ arData { arResult = Just ArFailure
263 , arTime = time })
264
265 _ -> return instData
266
267 -- | Update the tag of an 'AutoRepairData' record to match all the other fields.
268 updateTag :: AutoRepairData -> AutoRepairData
269 updateTag arData =
270 let ini = [autoRepairTypeToRaw $ arType arData,
271 arUuid arData,
272 clockTimeToString $ arTime arData]
273 end = [intercalate "+" . map (show . fromJobId) $ arJobs arData]
274 (pfx, middle) =
275 case arResult arData of
276 Nothing -> (Tags.autoRepairTagPending, [])
277 Just rs -> (Tags.autoRepairTagResult, [autoRepairResultToRaw rs])
278 in
279 arData { arTag = pfx ++ intercalate ":" (ini ++ middle ++ end) }
280
281 -- | Apply and remove tags from an instance as indicated by 'InstanceData'.
282 --
283 -- If the /arState/ of the /InstanceData/ record has an associated
284 -- 'AutoRepairData', add its tag to the instance object. Additionally, if
285 -- /tagsToRemove/ is not empty, remove those tags from the instance object. The
286 -- returned /InstanceData/ object always has an empty /tagsToRemove/.
287 commitChange :: Options -> L.Client -> InstanceData -> IO InstanceData
288 commitChange opts client instData = do
289 now <- currentTimestamp
290 let iname = Instance.name $ arInstance instData
291 arData = getArData $ arState instData
292 rmTags = tagsToRemove instData
293 execJobsWaitOk' opcodes = unless (optDryRun opts) $ do
294 res <- execJobsWaitOk
295 [map (annotateOpCode (optReason opts) now) opcodes] client
296 case res of
297 Ok _ -> return ()
298 Bad e -> exitErr e
299
300 when (isJust arData) $ do
301 let tag = arTag $ fromJust arData
302 putStrLn (">>> Adding the following tag to " ++ iname ++ ":\n" ++ show tag)
303 execJobsWaitOk' [OpTagsSet TagKindInstance [tag] (Just iname)]
304
305 unless (null rmTags) $ do
306 putStr (">>> Removing the following tags from " ++ iname ++ ":\n" ++
307 unlines (map show rmTags))
308 execJobsWaitOk' [OpTagsDel TagKindInstance rmTags (Just iname)]
309
310 return instData { tagsToRemove = [] }
311
312 -- | Detect brokenness with an instance and suggest repair type and jobs to run.
313 detectBroken :: Node.List -> Instance.Instance
314 -> Maybe (AutoRepairType, [OpCode])
315 detectBroken nl inst =
316 let disk = Instance.diskTemplate inst
317 iname = Instance.name inst
318 offPri = Node.offline $ Container.find (Instance.pNode inst) nl
319 offSec = Node.offline $ Container.find (Instance.sNode inst) nl
320 in
321 case disk of
322 DTDrbd8
323 | offPri && offSec ->
324 Just (
325 ArReinstall,
326 [ OpInstanceRecreateDisks { opInstanceName = iname
327 , opInstanceUuid = Nothing
328 , opRecreateDisksInfo = RecreateDisksAll
329 , opNodes = []
330 -- FIXME: there should be a better way to
331 -- specify opcode parameters than abusing
332 -- mkNonEmpty in this way (using the fact
333 -- that Maybe is used both for optional
334 -- fields, and to express failure).
335 , opNodeUuids = Nothing
336 , opIallocator = mkNonEmpty "hail"
337 }
338 , OpInstanceReinstall { opInstanceName = iname
339 , opInstanceUuid = Nothing
340 , opOsType = Nothing
341 , opTempOsParams = Nothing
342 , opOsparamsPrivate = Nothing
343 , opOsparamsSecret = Nothing
344 , opForceVariant = False
345 }
346 ])
347 | offPri ->
348 Just (
349 ArFailover,
350 [ OpInstanceFailover { opInstanceName = iname
351 , opInstanceUuid = Nothing
352 -- FIXME: ditto, see above.
353 , opShutdownTimeout = fromJust $ mkNonNegative
354 C.defaultShutdownTimeout
355 , opIgnoreConsistency = False
356 , opTargetNode = Nothing
357 , opTargetNodeUuid = Nothing
358 , opIgnoreIpolicy = False
359 , opIallocator = Nothing
360 , opMigrationCleanup = False
361 }
362 ])
363 | offSec ->
364 Just (
365 ArFixStorage,
366 [ OpInstanceReplaceDisks { opInstanceName = iname
367 , opInstanceUuid = Nothing
368 , opReplaceDisksMode = ReplaceNewSecondary
369 , opReplaceDisksList = []
370 , opRemoteNode = Nothing
371 -- FIXME: ditto, see above.
372 , opRemoteNodeUuid = Nothing
373 , opIallocator = mkNonEmpty "hail"
374 , opEarlyRelease = False
375 , opIgnoreIpolicy = False
376 }
377 ])
378 | otherwise -> Nothing
379
380 DTPlain
381 | offPri ->
382 Just (
383 ArReinstall,
384 [ OpInstanceRecreateDisks { opInstanceName = iname
385 , opInstanceUuid = Nothing
386 , opRecreateDisksInfo = RecreateDisksAll
387 , opNodes = []
388 -- FIXME: ditto, see above.
389 , opNodeUuids = Nothing
390 , opIallocator = mkNonEmpty "hail"
391 }
392 , OpInstanceReinstall { opInstanceName = iname
393 , opInstanceUuid = Nothing
394 , opOsType = Nothing
395 , opTempOsParams = Nothing
396 , opOsparamsPrivate = Nothing
397 , opOsparamsSecret = Nothing
398 , opForceVariant = False
399 }
400 ])
401 | otherwise -> Nothing
402
403 _ -> Nothing -- Other cases are unimplemented for now: DTDiskless,
404 -- DTFile, DTSharedFile, DTBlock, DTRbd, DTExt.
405
406 -- | Submit jobs, unless a dry-run is requested; in this case, just report
407 -- the job that would be submitted.
408 submitJobs' :: Options -> [[MetaOpCode]] -> L.Client -> IO (Result [JobId])
409 submitJobs' opts jobs client =
410 if optDryRun opts
411 then do
412 putStrLn . (++) "jobs: " . J.encode $ map (map metaOpCode) jobs
413 return $ Ok []
414 else
415 submitJobs jobs client
416
417 -- | Perform the suggested repair on an instance if its policy allows it.
418 doRepair :: Options
419 -> L.Client -- ^ The Luxi client
420 -> Double -- ^ Delay to insert before the first repair opcode
421 -> InstanceData -- ^ The instance data
422 -> (AutoRepairType, [OpCode]) -- ^ The repair job to perform
423 -> IO InstanceData -- ^ The updated instance data
424 doRepair opts client delay instData (rtype, opcodes) =
425 let inst = arInstance instData
426 ipol = Instance.arPolicy inst
427 iname = Instance.name inst
428 in
429 case ipol of
430 ArEnabled maxtype ->
431 if rtype > maxtype then do
432 uuid <- newUUID
433 time <- getClockTime
434
435 let arState' = ArNeedsRepair (
436 updateTag $ AutoRepairData rtype uuid time [] (Just ArEnoperm) "")
437 instData' = instData { arState = arState'
438 , tagsToRemove = delCurTag instData
439 }
440
441 putStrLn ("Not performing a repair of type " ++ show rtype ++ " on " ++
442 iname ++ " because only repairs up to " ++ show maxtype ++
443 " are allowed")
444 commitChange opts client instData' -- Adds "enoperm" result label.
445 else do
446 now <- currentTimestamp
447 putStrLn ("Executing " ++ show rtype ++ " repair on " ++ iname)
448
449 -- After submitting the job, we must write an autorepair:pending tag,
450 -- that includes the repair job IDs so that they can be checked later.
451 -- One problem we run into is that the repair job immediately grabs
452 -- locks for the affected instance, and the subsequent TAGS_SET job is
453 -- blocked, introducing an unnecessary delay for the end-user. One
454 -- alternative would be not to wait for the completion of the TAGS_SET
455 -- job, contrary to what commitChange normally does; but we insist on
456 -- waiting for the tag to be set so as to abort in case of failure,
457 -- because the cluster is left in an invalid state in that case.
458 --
459 -- The proper solution (in 2.9+) would be not to use tags for storing
460 -- autorepair data, or make the TAGS_SET opcode not grab an instance's
461 -- locks (if that's deemed safe). In the meantime, we introduce an
462 -- artificial delay in the repair job (via a TestDelay opcode) so that
463 -- once we have the job ID, the TAGS_SET job can complete before the
464 -- repair job actually grabs the locks. (Please note that this is not
465 -- about synchronization, but merely about speeding up the execution of
466 -- the harep tool. If this TestDelay opcode is removed, the program is
467 -- still correct.)
468 let opcodes' =
469 if delay > 0 then
470 OpTestDelay { opDelayDuration = delay
471 , opDelayOnMaster = True
472 , opDelayOnNodes = []
473 , opDelayOnNodeUuids = Nothing
474 , opDelayRepeat = fromJust $ mkNonNegative 0
475 , opDelayInterruptible = False
476 , opDelayNoLocks = False
477 } : opcodes
478 else
479 opcodes
480
481 uuid <- newUUID
482 time <- getClockTime
483 jids <- submitJobs'
484 opts
485 [map (annotateOpCode (optReason opts) now) opcodes']
486 client
487
488 case jids of
489 Bad e -> exitErr e
490 Ok jids' ->
491 let arState' = ArPendingRepair (
492 updateTag $ AutoRepairData rtype uuid time jids' Nothing "")
493 instData' = instData { arState = arState'
494 , tagsToRemove = delCurTag instData
495 }
496 in
497 commitChange opts client instData' -- Adds "pending" label.
498
499 otherSt -> do
500 putStrLn ("Not repairing " ++ iname ++ " because it's in state " ++
501 show otherSt)
502 return instData
503
504 -- | Main function.
505 main :: Options -> [String] -> IO ()
506 main opts args = do
507 unless (null args) $
508 exitErr "this program doesn't take any arguments."
509
510 luxiDef <- Path.defaultQuerySocket
511 let master = fromMaybe luxiDef $ optLuxi opts
512 opts' = opts { optLuxi = Just master }
513
514 (ClusterData _ nl il _ _) <- loadExternalData opts'
515
516 let iniDataRes = mapM setInitialState $ Container.elems il
517 iniData <- exitIfBad "when parsing auto-repair tags" iniDataRes
518
519 -- First step: check all pending repairs, see if they are completed.
520 iniData' <- bracket (L.getLuxiClient master) L.closeClient $
521 forM iniData . processPending opts
522
523 -- Second step: detect any problems.
524 let repairs = map (detectBroken nl . arInstance) iniData'
525
526 -- Third step: create repair jobs for broken instances that are in ArHealthy.
527 let maybeRepair c (i, r) = maybe (return i) (repairHealthy c i) r
528 jobDelay = optJobDelay opts
529 repairHealthy c i = case arState i of
530 ArHealthy _ -> doRepair opts c jobDelay i
531 _ -> const (return i)
532
533 repairDone <- bracket (L.getLuxiClient master) L.closeClient $
534 forM (zip iniData' repairs) . maybeRepair
535
536 -- Print some stats and exit.
537 let states = map ((, 1 :: Int) . arStateName . arState) repairDone
538 counts = Map.fromListWith (+) states
539
540 putStrLn "---------------------"
541 putStrLn "Instance status count"
542 putStrLn "---------------------"
543 putStr . unlines . Map.elems $
544 Map.mapWithKey (\k v -> k ++ ": " ++ show v) counts