32 |
32 |
) where
|
33 |
33 |
|
34 |
34 |
import Control.Applicative
|
|
35 |
import Data.Either
|
35 |
36 |
import Data.List
|
36 |
37 |
import Data.Maybe
|
37 |
38 |
import Data.Monoid
|
38 |
39 |
import qualified Data.Map as Map
|
|
40 |
import Data.Ord (comparing)
|
39 |
41 |
import qualified Text.JSON as J
|
40 |
42 |
import Text.Printf
|
41 |
43 |
|
... | ... | |
55 |
57 |
import Ganeti.Types
|
56 |
58 |
import Ganeti.Utils (formatOrdinal)
|
57 |
59 |
|
58 |
|
-- | The LiveInfo structure packs additional information beside the
|
59 |
|
-- 'InstanceInfo'. We also need to know whether the instance information was
|
60 |
|
-- found on the primary node, and encode this as a Bool.
|
61 |
|
type LiveInfo = (InstanceInfo, Bool)
|
|
60 |
-- | The LiveInfo consists of two entries whose presence is independent.
|
|
61 |
-- The 'InstanceInfo' is the live instance information, accompanied by a bool
|
|
62 |
-- signifying if it was found on its designated primary node or not.
|
|
63 |
-- The 'InstanceConsoleInfo' describes how to connect to an instance.
|
|
64 |
-- Any combination of these may or may not be present, depending on node and
|
|
65 |
-- instance availability.
|
|
66 |
type LiveInfo = (Maybe (InstanceInfo, Bool), Maybe InstanceConsoleInfo)
|
62 |
67 |
|
63 |
|
-- | Runtime possibly containing the 'LiveInfo'. See the genericQuery function
|
64 |
|
-- in the Query.hs file for an explanation of the terms used.
|
65 |
|
type Runtime = Either RpcError (Maybe LiveInfo)
|
|
68 |
-- | Runtime containing the 'LiveInfo'. See the genericQuery function in
|
|
69 |
-- the Query.hs file for an explanation of the terms used.
|
|
70 |
type Runtime = Either RpcError LiveInfo
|
66 |
71 |
|
67 |
72 |
-- | The instance fields map.
|
68 |
73 |
fieldsMap :: FieldMap Instance Runtime
|
... | ... | |
138 |
143 |
-- Instance parameter fields, whole
|
139 |
144 |
[ (FieldDefinition "hvparams" "HypervisorParameters" QFTOther
|
140 |
145 |
"Hypervisor parameters (merged)",
|
141 |
|
FieldConfig ((rsNormal .) . getFilledInstHvParams), QffNormal)
|
142 |
|
, (FieldDefinition "beparams" "BackendParameters" QFTOther
|
|
146 |
FieldConfig
|
|
147 |
((rsNormal .) . getFilledInstHvParams (C.toList C.hvcGlobals)),
|
|
148 |
QffNormal),
|
|
149 |
|
|
150 |
(FieldDefinition "beparams" "BackendParameters" QFTOther
|
143 |
151 |
"Backend parameters (merged)",
|
144 |
152 |
FieldConfig ((rsErrorNoData .) . getFilledInstBeParams), QffNormal)
|
145 |
153 |
, (FieldDefinition "osparams" "OpSysParameters" QFTOther
|
... | ... | |
289 |
297 |
FieldConfigRuntime statusExtract, QffNormal)
|
290 |
298 |
, (FieldDefinition "oper_state" "Running" QFTBool
|
291 |
299 |
"Actual state of instance",
|
292 |
|
FieldRuntime operStatusExtract, QffNormal)
|
|
300 |
FieldRuntime operStatusExtract, QffNormal),
|
|
301 |
|
|
302 |
(FieldDefinition "console" "Console" QFTOther
|
|
303 |
"Instance console information",
|
|
304 |
FieldRuntime consoleExtract, QffNormal)
|
293 |
305 |
] ++
|
294 |
306 |
|
295 |
307 |
-- Simple live fields
|
... | ... | |
522 |
534 |
-> ConfigData -> Instance -> ResultEntry
|
523 |
535 |
hvParamGetter field cfg inst =
|
524 |
536 |
rsMaybeUnavail . Map.lookup field . fromContainer $
|
525 |
|
getFilledInstHvParams cfg inst
|
|
537 |
getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst
|
526 |
538 |
|
527 |
539 |
-- * Live fields functionality
|
528 |
540 |
|
... | ... | |
542 |
554 |
instanceLiveFieldExtract n _ _ = J.showJSON $
|
543 |
555 |
"The field " ++ n ++ " is not an expected or extractable live field!"
|
544 |
556 |
|
545 |
|
-- | Helper for extracting field from RPC result.
|
|
557 |
-- | Helper for extracting an instance live field from the RPC results.
|
546 |
558 |
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry
|
547 |
|
instanceLiveRpcCall fname (Right (Just (res, _))) inst =
|
|
559 |
instanceLiveRpcCall fname (Right (Just (res, _), _)) inst =
|
548 |
560 |
case instanceLiveFieldExtract fname res inst of
|
549 |
561 |
J.JSNull -> rsNoData
|
550 |
562 |
x -> rsNormal x
|
551 |
|
instanceLiveRpcCall _ (Right Nothing) _ = rsUnavail
|
|
563 |
instanceLiveRpcCall _ (Right (Nothing, _)) _ = rsUnavail
|
552 |
564 |
instanceLiveRpcCall _ (Left err) _ =
|
553 |
565 |
ResultEntry (rpcErrorToStatus err) Nothing
|
554 |
566 |
|
... | ... | |
593 |
605 |
Bad _ -> error "Programmer error - result assumed to be OK is Bad!"
|
594 |
606 |
|
595 |
607 |
-- | Determines the status of a live instance
|
596 |
|
liveInstanceStatus :: LiveInfo -> Instance -> InstanceStatus
|
|
608 |
liveInstanceStatus :: (InstanceInfo, Bool) -> Instance -> InstanceStatus
|
597 |
609 |
liveInstanceStatus (_, foundOnPrimary) inst
|
598 |
610 |
| not foundOnPrimary = WrongNode
|
599 |
611 |
| adminState == AdminUp = Running
|
... | ... | |
618 |
630 |
determineInstanceStatus cfg res inst
|
619 |
631 |
| isPrimaryOffline cfg inst = NodeOffline
|
620 |
632 |
| otherwise = case res of
|
621 |
|
Left _ -> NodeDown
|
622 |
|
Right (Just liveData) -> liveInstanceStatus liveData inst
|
623 |
|
Right Nothing -> deadInstanceStatus inst
|
|
633 |
Left _ -> NodeDown
|
|
634 |
Right (Just liveData, _) -> liveInstanceStatus liveData inst
|
|
635 |
Right (Nothing, _) -> deadInstanceStatus inst
|
624 |
636 |
|
625 |
637 |
-- | Extracts the instance status, retrieving it using the functions above and
|
626 |
638 |
-- transforming it into a 'ResultEntry'.
|
... | ... | |
634 |
646 |
operStatusExtract res _ =
|
635 |
647 |
rsMaybeNoData $ J.showJSON <$>
|
636 |
648 |
case res of
|
637 |
|
Left _ -> Nothing
|
638 |
|
Right x -> Just $ isJust x
|
|
649 |
Left _ -> Nothing
|
|
650 |
Right (x, _) -> Just $ isJust x
|
|
651 |
|
|
652 |
-- | Extracts the console connection information
|
|
653 |
consoleExtract :: Runtime -> Instance -> ResultEntry
|
|
654 |
consoleExtract (Left err) _ = ResultEntry (rpcErrorToStatus err) Nothing
|
|
655 |
consoleExtract (Right (_, val)) _ = rsMaybeNoData val
|
639 |
656 |
|
640 |
657 |
-- * Helper functions extracting information as necessary for the generic query
|
641 |
658 |
-- interfaces
|
642 |
659 |
|
|
660 |
-- | This function checks if a node with a given uuid has experienced an error
|
|
661 |
-- or not.
|
|
662 |
checkForNodeError :: [(String, ERpcError a)]
|
|
663 |
-> String
|
|
664 |
-> Maybe RpcError
|
|
665 |
checkForNodeError uuidList uuid =
|
|
666 |
case snd <$> pickPairUnique uuid uuidList of
|
|
667 |
Just (Left err) -> Just err
|
|
668 |
Just (Right _) -> Nothing
|
|
669 |
Nothing -> Just . RpcResultError $
|
|
670 |
"Node response not present"
|
|
671 |
|
643 |
672 |
-- | Finds information about the instance in the info delivered by a node
|
644 |
|
findInstanceInfo :: Instance
|
645 |
|
-> ERpcError RpcResultAllInstancesInfo
|
646 |
|
-> Maybe InstanceInfo
|
647 |
|
findInstanceInfo inst nodeResponse =
|
|
673 |
findInfoInNodeResult :: Instance
|
|
674 |
-> ERpcError RpcResultAllInstancesInfo
|
|
675 |
-> Maybe InstanceInfo
|
|
676 |
findInfoInNodeResult inst nodeResponse =
|
648 |
677 |
case nodeResponse of
|
649 |
678 |
Left _err -> Nothing
|
650 |
679 |
Right allInfo ->
|
... | ... | |
652 |
681 |
maybeMatch = pickPairUnique (instName inst) instances
|
653 |
682 |
in snd <$> maybeMatch
|
654 |
683 |
|
655 |
|
-- | Finds the node information ('RPCResultError') or the instance information
|
656 |
|
-- (Maybe 'LiveInfo').
|
657 |
|
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)]
|
658 |
|
-> Instance
|
659 |
|
-> Runtime
|
660 |
|
extractLiveInfo nodeResultList inst =
|
661 |
|
let uuidResultList = [(nodeUuid x, y) | (x, y) <- nodeResultList]
|
662 |
|
pNodeUuid = instPrimaryNode inst
|
663 |
|
maybeRPCError = getNodeStatus uuidResultList pNodeUuid
|
664 |
|
in case maybeRPCError of
|
665 |
|
Just err -> Left err
|
666 |
|
Nothing -> Right $ getInstanceStatus uuidResultList pNodeUuid inst
|
667 |
|
|
668 |
|
-- | Tries to find out if the node given by the uuid is bad - unreachable or
|
669 |
|
-- returning errors, does not mather for the purpose of this call.
|
670 |
|
getNodeStatus :: [(String, ERpcError RpcResultAllInstancesInfo)]
|
671 |
|
-> String
|
672 |
|
-> Maybe RpcError
|
673 |
|
getNodeStatus uuidList uuid =
|
674 |
|
case snd <$> pickPairUnique uuid uuidList of
|
675 |
|
Just (Left err) -> Just err
|
676 |
|
Just (Right _) -> Nothing
|
677 |
|
Nothing -> Just . RpcResultError $
|
678 |
|
"Primary node response not present"
|
679 |
|
|
680 |
684 |
-- | Retrieves the instance information if it is present anywhere in the all
|
681 |
685 |
-- instances RPC result. Notes if it originates from the primary node.
|
682 |
|
-- All nodes are represented as UUID's for ease of use.
|
683 |
|
getInstanceStatus :: [(String, ERpcError RpcResultAllInstancesInfo)]
|
684 |
|
-> String
|
685 |
|
-> Instance
|
686 |
|
-> Maybe LiveInfo
|
687 |
|
getInstanceStatus uuidList pNodeUuid inst =
|
688 |
|
let primarySearchResult =
|
689 |
|
snd <$> pickPairUnique pNodeUuid uuidList >>= findInstanceInfo inst
|
|
686 |
-- An error is delivered if there is no result, and the primary node is down.
|
|
687 |
getInstanceInfo :: [(String, ERpcError RpcResultAllInstancesInfo)]
|
|
688 |
-> Instance
|
|
689 |
-> ERpcError (Maybe (InstanceInfo, Bool))
|
|
690 |
getInstanceInfo uuidList inst =
|
|
691 |
let pNodeUuid = instPrimaryNode inst
|
|
692 |
primarySearchResult =
|
|
693 |
pickPairUnique pNodeUuid uuidList >>= findInfoInNodeResult inst . snd
|
690 |
694 |
in case primarySearchResult of
|
691 |
|
Just instInfo -> Just (instInfo, True)
|
|
695 |
Just instInfo -> Right . Just $ (instInfo, True)
|
692 |
696 |
Nothing ->
|
693 |
697 |
let allSearchResult =
|
694 |
698 |
getFirst . mconcat $ map
|
695 |
|
(First . findInstanceInfo inst . snd) uuidList
|
|
699 |
(First . findInfoInNodeResult inst . snd) uuidList
|
696 |
700 |
in case allSearchResult of
|
697 |
|
Just liveInfo -> Just (liveInfo, False)
|
698 |
|
Nothing -> Nothing
|
|
701 |
Just instInfo -> Right . Just $ (instInfo, False)
|
|
702 |
Nothing ->
|
|
703 |
case checkForNodeError uuidList pNodeUuid of
|
|
704 |
Just err -> Left err
|
|
705 |
Nothing -> Right Nothing
|
|
706 |
|
|
707 |
-- | Retrieves the console information if present anywhere in the given results
|
|
708 |
getConsoleInfo :: [(String, ERpcError RpcResultInstanceConsoleInfo)]
|
|
709 |
-> Instance
|
|
710 |
-> Maybe InstanceConsoleInfo
|
|
711 |
getConsoleInfo uuidList inst =
|
|
712 |
let allValidResults = concatMap rpcResInstConsInfoInstancesInfo .
|
|
713 |
rights . map snd $ uuidList
|
|
714 |
in snd <$> pickPairUnique (instName inst) allValidResults
|
|
715 |
|
|
716 |
-- | Extracts all the live information that can be extracted.
|
|
717 |
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)]
|
|
718 |
-> [(Node, ERpcError RpcResultInstanceConsoleInfo)]
|
|
719 |
-> Instance
|
|
720 |
-> Runtime
|
|
721 |
extractLiveInfo nodeResultList nodeConsoleList inst =
|
|
722 |
let uuidConvert = map (\(x, y) -> (nodeUuid x, y))
|
|
723 |
uuidResultList = uuidConvert nodeResultList
|
|
724 |
uuidConsoleList = uuidConvert nodeConsoleList
|
|
725 |
in case getInstanceInfo uuidResultList inst of
|
|
726 |
-- If we can't get the instance info, we can't get the console info either.
|
|
727 |
-- Best to propagate the error further.
|
|
728 |
Left err -> Left err
|
|
729 |
Right res -> Right (res, getConsoleInfo uuidConsoleList inst)
|
|
730 |
|
|
731 |
-- | Retrieves all the parameters for the console calls.
|
|
732 |
getAllConsoleParams :: ConfigData
|
|
733 |
-> [Instance]
|
|
734 |
-> ErrorResult [InstanceConsoleInfoParams]
|
|
735 |
getAllConsoleParams cfg instances = do
|
|
736 |
pNodes <- mapM (getPrimaryNode cfg) instances
|
|
737 |
let filledHvParams = map (getFilledInstHvParams [] cfg) instances
|
|
738 |
filledBeParams <- mapM (getFilledInstBeParams cfg) instances
|
|
739 |
return . map (\(i, n, h, b) -> InstanceConsoleInfoParams i n h b) $
|
|
740 |
zip4 instances pNodes filledHvParams filledBeParams
|
|
741 |
|
|
742 |
-- | Compares two params according to their node, needed for grouping.
|
|
743 |
compareParamsByNode :: InstanceConsoleInfoParams
|
|
744 |
-> InstanceConsoleInfoParams
|
|
745 |
-> Bool
|
|
746 |
compareParamsByNode x y = instConsInfoParamsNode x == instConsInfoParamsNode y
|
|
747 |
|
|
748 |
-- | Groups instance information calls heading out to the same nodes.
|
|
749 |
consoleParamsToCalls :: [InstanceConsoleInfoParams]
|
|
750 |
-> [(Node, RpcCallInstanceConsoleInfo)]
|
|
751 |
consoleParamsToCalls params =
|
|
752 |
let sortedParams = sortBy
|
|
753 |
(comparing (instPrimaryNode . instConsInfoParamsInstance)) params
|
|
754 |
groupedParams = groupBy compareParamsByNode sortedParams
|
|
755 |
in map (\x -> case x of
|
|
756 |
[] -> error "Programmer error: group must have one or more members"
|
|
757 |
paramGroup@(y:_) ->
|
|
758 |
let node = instConsInfoParamsNode y
|
|
759 |
packer z = (instName $ instConsInfoParamsInstance z, z)
|
|
760 |
in (node, RpcCallInstanceConsoleInfo . map packer $ paramGroup)
|
|
761 |
) groupedParams
|
|
762 |
|
|
763 |
-- | Retrieves a list of all the hypervisors and params used by the given
|
|
764 |
-- instances.
|
|
765 |
getHypervisorSpecs :: ConfigData -> [Instance] -> [(Hypervisor, HvParams)]
|
|
766 |
getHypervisorSpecs cfg instances =
|
|
767 |
let hvs = nub . map instHypervisor $ instances
|
|
768 |
hvParamMap = (fromContainer . clusterHvparams . configCluster $ cfg)
|
|
769 |
in zip hvs . map ((Map.!) hvParamMap . hypervisorToRaw) $ hvs
|
699 |
770 |
|
700 |
771 |
-- | Collect live data from RPC query if enabled.
|
701 |
772 |
collectLiveData :: Bool -> ConfigData -> [Instance] -> IO [(Instance, Runtime)]
|
... | ... | |
703 |
774 |
| not liveDataEnabled = return . zip instances . repeat . Left .
|
704 |
775 |
RpcResultError $ "Live data disabled"
|
705 |
776 |
| otherwise = do
|
706 |
|
let hvSpec = getDefaultHypervisorSpec cfg
|
707 |
|
instance_nodes = nub . justOk $
|
708 |
|
map (getNode cfg . instPrimaryNode) instances
|
709 |
|
good_nodes = nodesWithValidConfig cfg instance_nodes
|
710 |
|
rpcres <- executeRpcCall good_nodes $ RpcCallAllInstancesInfo [hvSpec]
|
711 |
|
return . zip instances . map (extractLiveInfo rpcres) $ instances
|
|
777 |
let hvSpecs = getHypervisorSpecs cfg instances
|
|
778 |
instanceNodes = nub . justOk $
|
|
779 |
map (getNode cfg . instPrimaryNode) instances
|
|
780 |
goodNodes = nodesWithValidConfig cfg instanceNodes
|
|
781 |
instInfoRes <- executeRpcCall goodNodes (RpcCallAllInstancesInfo hvSpecs)
|
|
782 |
consInfoRes <- case getAllConsoleParams cfg instances of
|
|
783 |
Bad _ -> return . zip goodNodes . repeat . Left $ RpcResultError
|
|
784 |
"Cannot construct parameters for console info call"
|
|
785 |
Ok p -> executeRpcCalls $ consoleParamsToCalls p
|
|
786 |
return . zip instances .
|
|
787 |
map (extractLiveInfo instInfoRes consInfoRes) $ instances
|