Ssconf.hs 8.06 KB
Newer Older
Iustin Pop's avatar
Iustin Pop committed
1 2 3 4 5 6 7 8 9
{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti Ssconf interface.

-}

{-

Copyright (C) 2012 Google Inc.
Klaus Aehlig's avatar
Klaus Aehlig committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
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.
Iustin Pop's avatar
Iustin Pop committed
34 35 36 37 38 39 40

-}

module Ganeti.Ssconf
  ( SSKey(..)
  , sSKeyToRaw
  , sSKeyFromRaw
41
  , hvparamsSSKey
Iustin Pop's avatar
Iustin Pop committed
42
  , getPrimaryIPFamily
43 44
  , parseNodesVmCapable
  , getNodesVmCapable
45
  , getMasterCandidatesIps
46
  , getMasterNode
47 48 49 50
  , parseHypervisorList
  , getHypervisorList
  , parseEnabledUserShutdown
  , getEnabledUserShutdown
51 52
  , keyToFilename
  , sSFilePrefix
53 54
  , SSConf(..)
  , emptySSConf
Iustin Pop's avatar
Iustin Pop committed
55 56
  ) where

57
import Control.Arrow ((&&&))
58
import Control.Applicative ((<$>))
59
import Control.Exception
60
import Control.Monad (forM, liftM)
61
import qualified Data.Map as M
Iustin Pop's avatar
Iustin Pop committed
62 63 64
import Data.Maybe (fromMaybe)
import qualified Network.Socket as Socket
import System.FilePath ((</>))
65
import System.IO.Error (isDoesNotExistError)
66
import qualified Text.JSON as J
Iustin Pop's avatar
Iustin Pop committed
67

68 69
import qualified AutoConf
import Ganeti.BasicTypes
Iustin Pop's avatar
Iustin Pop committed
70
import qualified Ganeti.Constants as C
71
import qualified Ganeti.ConstantUtils as CU
72
import Ganeti.JSON (GenericContainer(..), HasStringRepr(..))
73
import qualified Ganeti.Path as Path
74
import Ganeti.THH
75 76
import Ganeti.Types (Hypervisor)
import qualified Ganeti.Types as Types
77
import Ganeti.Utils
Iustin Pop's avatar
Iustin Pop committed
78

79 80
-- * Reading individual ssconf entries

Iustin Pop's avatar
Iustin Pop committed
81 82 83 84
-- | Maximum ssconf file size we support.
maxFileSize :: Int
maxFileSize = 131072

85 86 87 88
-- | ssconf file prefix, re-exported from Constants.
sSFilePrefix :: FilePath
sSFilePrefix = C.ssconfFileprefix

89
$(declareLADT ''String "SSKey" (
90
  map (ssconfConstructorName &&& id) . CU.toList $ C.validSsKeys
91
  ))
Iustin Pop's avatar
Iustin Pop committed
92

93 94 95 96
instance HasStringRepr SSKey where
  fromStringRepr = sSKeyFromRaw
  toStringRepr = sSKeyToRaw

97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
-- | For a given hypervisor get the corresponding SSConf key that contains its
-- parameters.
--
-- The corresponding SSKeys are generated automatically by TH, but since we
-- don't have convenient infrastructure for generating this function, it's just
-- manual. All constructors must be given explicitly so that adding another
-- hypervisor will trigger "incomplete pattern" warning and force the
-- corresponding addition.
hvparamsSSKey :: Types.Hypervisor -> SSKey
hvparamsSSKey Types.Kvm = SSHvparamsKvm
hvparamsSSKey Types.XenPvm = SSHvparamsXenPvm
hvparamsSSKey Types.Chroot = SSHvparamsChroot
hvparamsSSKey Types.XenHvm = SSHvparamsXenHvm
hvparamsSSKey Types.Lxc = SSHvparamsLxc
hvparamsSSKey Types.Fake = SSHvparamsFake

Iustin Pop's avatar
Iustin Pop committed
113
-- | Convert a ssconf key into a (full) file path.
114 115 116
keyToFilename :: FilePath     -- ^ Config path root
              -> SSKey        -- ^ Ssconf key
              -> FilePath     -- ^ Full file name
Iustin Pop's avatar
Iustin Pop committed
117
keyToFilename cfgpath key =
118
  cfgpath </> sSFilePrefix ++ sSKeyToRaw key
Iustin Pop's avatar
Iustin Pop committed
119 120 121 122 123 124 125 126

-- | Runs an IO action while transforming any error into 'Bad'
-- values. It also accepts an optional value to use in case the error
-- is just does not exist.
catchIOErrors :: Maybe a         -- ^ Optional default
              -> IO a            -- ^ Action to run
              -> IO (Result a)
catchIOErrors def action =
127 128
  Control.Exception.catch
        (do
Iustin Pop's avatar
Iustin Pop committed
129 130 131 132 133 134 135 136 137 138 139 140 141
          result <- action
          return (Ok result)
        ) (\err -> let bad_result = Bad (show err)
                   in return $ if isDoesNotExistError err
                                 then maybe bad_result Ok def
                                 else bad_result)

-- | Read an ssconf file.
readSSConfFile :: Maybe FilePath            -- ^ Optional config path override
               -> Maybe String              -- ^ Optional default value
               -> SSKey                     -- ^ Desired ssconf key
               -> IO (Result String)
readSSConfFile optpath def key = do
Iustin Pop's avatar
Iustin Pop committed
142
  dpath <- Path.dataDir
143
  result <- catchIOErrors def . readFile .
Iustin Pop's avatar
Iustin Pop committed
144
            keyToFilename (fromMaybe dpath optpath) $ key
Iustin Pop's avatar
Iustin Pop committed
145 146
  return (liftM (take maxFileSize) result)

147 148 149 150 151 152 153 154
-- | Parses a key-value pair of the form "key=value" from 'str', fails
-- with 'desc' otherwise.
parseKeyValue :: Monad m => String -> String -> m (String, String)
parseKeyValue desc str =
  case sepSplit '=' str of
    [key, value] -> return (key, value)
    _ -> fail $ "Failed to parse key-value pair for " ++ desc

Iustin Pop's avatar
Iustin Pop committed
155 156
-- | Parses a string containing an IP family
parseIPFamily :: Int -> Result Socket.Family
157 158
parseIPFamily fam | fam == AutoConf.pyAfInet4 = Ok Socket.AF_INET
                  | fam == AutoConf.pyAfInet6 = Ok Socket.AF_INET6
Iustin Pop's avatar
Iustin Pop committed
159 160 161 162 163
                  | otherwise = Bad $ "Unknown af_family value: " ++ show fam

-- | Read the primary IP family.
getPrimaryIPFamily :: Maybe FilePath -> IO (Result Socket.Family)
getPrimaryIPFamily optpath = do
164 165 166
  result <- readSSConfFile optpath
                           (Just (show AutoConf.pyAfInet4))
                           SSPrimaryIpFamily
167
  return (liftM rStripSpace result >>=
Iustin Pop's avatar
Iustin Pop committed
168
          tryRead "Parsing af_family" >>= parseIPFamily)
169

170 171 172 173 174 175 176 177 178 179 180 181 182
-- | Parse the nodes vm capable value from a 'String'.
parseNodesVmCapable :: String -> Result [(String, Bool)]
parseNodesVmCapable str =
  forM (lines str) $ \line -> do
    (key, val) <- parseKeyValue "Parsing node_vm_capable" line
    val' <- tryRead "Parsing value of node_vm_capable" val
    return (key, val')

-- | Read and parse the nodes vm capable.
getNodesVmCapable :: Maybe FilePath -> IO (Result [(String, Bool)])
getNodesVmCapable optPath =
  (parseNodesVmCapable =<<) <$> readSSConfFile optPath Nothing SSNodeVmCapable

183 184 185 186 187
-- | Read the list of IP addresses of the master candidates of the cluster.
getMasterCandidatesIps :: Maybe FilePath -> IO (Result [String])
getMasterCandidatesIps optPath = do
  result <- readSSConfFile optPath Nothing SSMasterCandidatesIps
  return $ liftM lines result
188 189 190 191 192 193

-- | Read the name of the master node.
getMasterNode :: Maybe FilePath -> IO (Result String)
getMasterNode optPath = do
  result <- readSSConfFile optPath Nothing SSMasterNode
  return (liftM rStripSpace result)
194

195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215
-- | Parse the list of enabled hypervisors from a 'String'.
parseHypervisorList :: String -> Result [Hypervisor]
parseHypervisorList str =
  mapM Types.hypervisorFromRaw $ lines str

-- | Read and parse the list of enabled hypervisors.
getHypervisorList :: Maybe FilePath -> IO (Result [Hypervisor])
getHypervisorList optPath =
  (parseHypervisorList =<<) <$>
    readSSConfFile optPath Nothing SSHypervisorList

-- | Parse whether user shutdown is enabled from a 'String'.
parseEnabledUserShutdown :: String -> Result Bool
parseEnabledUserShutdown str =
  tryRead "Parsing enabled_user_shutdown" (rStripSpace str)

-- | Read and parse whether user shutdown is enabled.
getEnabledUserShutdown :: Maybe FilePath -> IO (Result Bool)
getEnabledUserShutdown optPath =
  (parseEnabledUserShutdown =<<) <$>
    readSSConfFile optPath Nothing SSEnabledUserShutdown
216

217 218 219 220 221 222 223 224 225 226 227 228
-- * Working with the whole ssconf map

-- | The data type used for representing the ssconf.
newtype SSConf = SSConf { getSSConf :: M.Map SSKey [String] }
  deriving (Eq, Ord, Show)

instance J.JSON SSConf where
  showJSON = J.showJSON . GenericContainer . getSSConf
  readJSON = liftM (SSConf . fromContainer) . J.readJSON

emptySSConf :: SSConf
emptySSConf = SSConf M.empty