Revision b9666288

b/src/Ganeti/Config.hs
60 60
import qualified Text.JSON as J
61 61

  
62 62
import Ganeti.BasicTypes
63
import qualified Ganeti.ConstantUtils as C
64 63
import qualified Ganeti.Constants as C
65 64
import Ganeti.Errors
66 65
import Ganeti.JSON
......
243 242

  
244 243
-- | Retrieves the instance hypervisor params, missing values filled with
245 244
-- cluster defaults.
246
getFilledInstHvParams :: ConfigData -> Instance -> HvParams
247
getFilledInstHvParams cfg inst =
245
getFilledInstHvParams :: [String] -> ConfigData -> Instance -> HvParams
246
getFilledInstHvParams globals cfg inst =
248 247
  -- First get the defaults of the parent
249 248
  let hvName = hypervisorToRaw . instHypervisor $ inst
250 249
      hvParamMap = fromContainer . clusterHvparams $ configCluster cfg
......
257 256
  -- Then the child
258 257
      childHvParams = fromContainer . instHvparams $ inst
259 258
  -- Helper function
260
      fillFn con val = fillDict con val $ C.toList C.hvcGlobals
259
      fillFn con val = fillDict con val globals
261 260
  in GenericContainer $ fillFn (fillFn parentHvParams osHvParams) childHvParams
262 261

  
263 262
-- | Retrieves the instance backend params, missing values filled with cluster
b/src/Ganeti/Query/Instance.hs
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

Also available in: Unified diff