Revision 65a3ff88
b/src/Ganeti/JQueue.hs | ||
---|---|---|
40 | 40 |
, currentTimestamp |
41 | 41 |
, advanceTimestamp |
42 | 42 |
, setReceivedTimestamp |
43 |
, extendJobReasonTrail |
|
43 | 44 |
, opStatusFinalized |
44 | 45 |
, extractOpSummary |
45 | 46 |
, calcJobStatus |
... | ... | |
206 | 207 |
ops' <- mapM (`resolveDependencies` jobid) ops |
207 | 208 |
return QueuedJob { qjId = jobid |
208 | 209 |
, qjOps = map queuedOpCodeFromMetaOpCode ops' |
209 |
, qjReceivedTimestamp = Nothing
|
|
210 |
, qjReceivedTimestamp = Nothing |
|
210 | 211 |
, qjStartTimestamp = Nothing |
211 | 212 |
, qjEndTimestamp = Nothing |
212 | 213 |
} |
... | ... | |
215 | 216 |
setReceivedTimestamp :: Timestamp -> QueuedJob -> QueuedJob |
216 | 217 |
setReceivedTimestamp ts job = job { qjReceivedTimestamp = Just ts } |
217 | 218 |
|
219 |
-- | Build a timestamp in the format expected by the reason trail (nanoseconds) |
|
220 |
-- starting from a JQueue Timestamp. |
|
221 |
reasonTrailTimestamp :: Timestamp -> Integer |
|
222 |
reasonTrailTimestamp (sec, micro) = |
|
223 |
let sec' = toInteger sec |
|
224 |
micro' = toInteger micro |
|
225 |
in sec' * 1000000000 + micro' * 1000 |
|
226 |
|
|
227 |
-- | Append an element to the reason trail of an input opcode. |
|
228 |
extendInputOpCodeReasonTrail :: JobId -> Timestamp -> Int -> InputOpCode |
|
229 |
-> InputOpCode |
|
230 |
extendInputOpCodeReasonTrail _ _ _ op@(InvalidOpCode _) = op |
|
231 |
extendInputOpCodeReasonTrail jid ts i (ValidOpCode vOp) = |
|
232 |
let metaP = metaParams vOp |
|
233 |
op = metaOpCode vOp |
|
234 |
trail = opReason metaP |
|
235 |
reasonSrc = opReasonSrcID op |
|
236 |
reasonText = "job=" ++ show (fromJobId jid) ++ ";index=" ++ show i |
|
237 |
reason = (reasonSrc, reasonText, reasonTrailTimestamp ts) |
|
238 |
trail' = trail ++ [reason] |
|
239 |
in ValidOpCode $ vOp { metaParams = metaP { opReason = trail' } } |
|
240 |
|
|
241 |
-- | Append an element to the reason trail of a queued opcode. |
|
242 |
extendOpCodeReasonTrail :: JobId -> Timestamp -> Int -> QueuedOpCode |
|
243 |
-> QueuedOpCode |
|
244 |
extendOpCodeReasonTrail jid ts i op = |
|
245 |
let inOp = qoInput op |
|
246 |
in op { qoInput = extendInputOpCodeReasonTrail jid ts i inOp } |
|
247 |
|
|
248 |
-- | Append an element to the reason trail of all the OpCodes of a queued job. |
|
249 |
extendJobReasonTrail :: QueuedJob -> QueuedJob |
|
250 |
extendJobReasonTrail job = |
|
251 |
let jobId = qjId job |
|
252 |
mTimestamp = qjReceivedTimestamp job |
|
253 |
-- This function is going to be called on QueuedJobs that already contain |
|
254 |
-- a timestamp. But for safety reasons we cannot assume mTimestamp will |
|
255 |
-- be (Just timestamp), so we use the value 0 in the extremely unlikely |
|
256 |
-- case this is not true. |
|
257 |
timestamp = fromMaybe (0, 0) mTimestamp |
|
258 |
in job |
|
259 |
{ qjOps = |
|
260 |
zipWith (extendOpCodeReasonTrail jobId timestamp) [0..] $ |
|
261 |
qjOps job |
|
262 |
} |
|
263 |
|
|
218 | 264 |
-- | Change the priority of a QueuedOpCode, if it is not already |
219 | 265 |
-- finalized. |
220 | 266 |
changeOpCodePriority :: Int -> QueuedOpCode -> QueuedOpCode |
... | ... | |
307 | 353 |
-- | Determine if a job is finalized and its timestamp is before |
308 | 354 |
-- a given time. |
309 | 355 |
jobArchivable :: Timestamp -> QueuedJob -> Bool |
310 |
jobArchivable ts = liftA2 (&&) jobFinalized
|
|
356 |
jobArchivable ts = liftA2 (&&) jobFinalized |
|
311 | 357 |
$ maybe False (< ts) |
312 | 358 |
. liftA2 (<|>) qjEndTimestamp qjStartTimestamp |
313 | 359 |
|
... | ... | |
481 | 527 |
putMVar lock () |
482 | 528 |
let msg = "Failed to write serial file: " ++ show e |
483 | 529 |
logError msg |
484 |
return . Bad $ msg
|
|
530 |
return . Bad $ msg |
|
485 | 531 |
Right () -> do |
486 | 532 |
serial' <- makeVirtualPath serial |
487 | 533 |
_ <- executeRpcCall mastercandidates |
... | ... | |
556 | 602 |
loadResult <- loadJobFromDisk qDir False jid |
557 | 603 |
case loadResult of |
558 | 604 |
Bad _ -> continue |
559 |
Ok (job, _) ->
|
|
605 |
Ok (job, _) -> |
|
560 | 606 |
if jobArchivable cutt job |
561 | 607 |
then do |
562 | 608 |
let live = liveJobFile qDir jid |
563 | 609 |
archive = archivedJobFile qDir jid |
564 | 610 |
renameResult <- safeRenameFile queueDirPermissions |
565 | 611 |
live archive |
566 |
case renameResult of
|
|
612 |
case renameResult of |
|
567 | 613 |
Bad s -> do |
568 | 614 |
logWarning $ "Renaming " ++ live ++ " to " ++ archive |
569 | 615 |
++ " failed unexpectedly: " ++ s |
... | ... | |
576 | 622 |
archiveMore (arch + 1) [] jids |
577 | 623 |
else archiveMore (arch + 1) torepl' jids |
578 | 624 |
else continue |
579 |
|
|
625 |
|
|
580 | 626 |
-- | Archive jobs older than the given time, but do not exceed the timeout for |
581 | 627 |
-- carrying out this task. |
582 | 628 |
archiveJobs :: ConfigData -- ^ cluster configuration |
Also available in: Unified diff