src/Ganeti/Metad/Config.hs

{-# LANGUAGE FlexibleContexts #-}

{-

Copyright (C) 2014 Google Inc.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}
module Ganeti.Metad.Config where

import Control.Arrow (second)
import Control.Monad ((>=>), mzero)
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import qualified Data.List as List (isPrefixOf)
import qualified Data.Map as Map
import Text.JSON
import qualified Text.JSON as JSON

import Ganeti.Constants as Constants
import Ganeti.Metad.Types

-- | Merges two instance configurations into one.
--
-- In the case where instance IPs (i.e., map keys) are repeated, the
-- old instance configuration is thrown away by 'Map.union' and
-- replaced by the new configuration.  As a result, the old private
-- and secret OS parameters are completely lost.
mergeConfig :: InstanceParams -> InstanceParams -> InstanceParams
mergeConfig cfg1 cfg2 = cfg2 `Map.union` cfg1

-- | Extracts the OS parameters (public, private, secret) from a JSON
-- object.
--
-- This function checks whether the OS parameters are in fact a JSON
-- object.
getOsParams :: String -> String -> JSObject JSValue -> Result (JSObject JSValue)
getOsParams key msg jsonObj =
  case lookup key (fromJSObject jsonObj) of
    Nothing -> Error $ "Could not find " ++ msg ++ " OS parameters"
    Just x -> readJSON x

getPublicOsParams :: JSObject JSValue -> Result (JSObject JSValue)
getPublicOsParams = getOsParams "osparams" "public"

getPrivateOsParams :: JSObject JSValue -> Result (JSObject JSValue)
getPrivateOsParams = getOsParams "osparams_private" "private"

getSecretOsParams :: JSObject JSValue -> Result (JSObject JSValue)
getSecretOsParams = getOsParams "osparams_secret" "secret"

-- | Merges the OS parameters (public, private, secret) in a single
-- data structure containing all parameters and their visibility.
--
-- Example:
--
-- > { "os-image": ["http://example.com/disk.img", "public"],
-- >   "os-password": ["mypassword", "secret"] }
makeInstanceParams
  :: JSObject JSValue -> JSObject JSValue -> JSObject JSValue -> JSValue
makeInstanceParams pub priv sec =
  JSObject . JSON.toJSObject $
    addVisibility "public" pub ++
    addVisibility "private" priv ++
    addVisibility "secret" sec
  where
    key = JSString . JSON.toJSString

    addVisibility param params =
      map (second (JSArray . (:[key param]))) (JSON.fromJSObject params)

getOsParamsWithVisibility :: JSValue -> Result JSValue
getOsParamsWithVisibility json =
  do obj <- readJSON json
     publicOsParams <- getPublicOsParams obj
     privateOsParams <- getPrivateOsParams obj
     secretOsParams <- getSecretOsParams obj
     Ok $ makeInstanceParams publicOsParams privateOsParams secretOsParams

-- | Finds the IP address of the instance communication NIC in the
-- instance's NICs. If the corresponding NIC isn't found, 'Nothing' is returned.
getInstanceCommunicationIp :: JSObject JSValue -> Result (Maybe String)
getInstanceCommunicationIp =
    runMaybeT . (getNics >=> getInstanceCommunicationNic >=> getIp)
  where
    getIp :: JSObject JSValue -> MaybeT Result String
    getIp nic =
      case lookup "ip" (fromJSObject nic) of
        Nothing -> failErrorT "Could not find instance communication IP"
        Just (JSString ip) -> return (JSON.fromJSString ip)
        _ -> failErrorT "Instance communication IP is not a string"

    getInstanceCommunicationNic :: [JSValue] -> MaybeT Result (JSObject JSValue)
    getInstanceCommunicationNic [] = mzero -- no communication NIC found
    getInstanceCommunicationNic (JSObject nic : nics) =
      case lookup "name" (fromJSObject nic) of
        Just (JSString name)
          | Constants.instanceCommunicationNicPrefix
            `List.isPrefixOf` JSON.fromJSString name ->
            return nic
        _ -> getInstanceCommunicationNic nics
    getInstanceCommunicationNic (n : _) =
      failErrorT $ "Found wrong data in instance NICs: " ++ show n

    getNics :: JSObject JSValue -> MaybeT Result [JSValue]
    getNics jsonObj =
      case lookup "nics" (fromJSObject jsonObj) of
        Nothing -> failErrorT "Could not find OS parameters key 'nics'"
        Just (JSArray nics) -> return nics
        _ -> failErrorT "Instance nics is not an array"

    -- | A helper function for failing a 'Result' wrapped in a monad
    -- transformer.
    failErrorT :: (MonadTrans t) => String -> t Result a
    failErrorT = lift . JSON.Error

-- | Extracts the OS parameters from the instance's parameters and
-- returns a data structure containing all the OS parameters and their
-- visibility indexed by the instance's IP address which is used in
-- the instance communication NIC.
getInstanceParams :: JSValue -> Result (String, Maybe InstanceParams)
getInstanceParams json =
    case json of
      JSObject jsonObj -> do
        name <- case lookup "name" (fromJSObject jsonObj) of
                  Nothing -> failError "Could not find instance name"
                  Just (JSString x) -> return (JSON.fromJSString x)
                  _ -> failError "Name is not a string"
        m'ip <- getInstanceCommunicationIp jsonObj
        return (name, fmap (\ip -> Map.fromList [(ip, json)]) m'ip)
      _ ->
        failError "Expecting a dictionary"
  where
    failError = JSON.Error