Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Confd / Server.hs @ 11e90588

History | View | Annotate | Download (10.5 kB)

1
{-| Implementation of the Ganeti confd server functionality.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2011, 2012, 2013 Google Inc.
8

    
9
This program is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2 of the License, or
12
(at your option) any later version.
13

    
14
This program is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17
General Public License for more details.
18

    
19
You should have received a copy of the GNU General Public License
20
along with this program; if not, write to the Free Software
21
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22
02110-1301, USA.
23

    
24
-}
25

    
26
module Ganeti.Confd.Server
27
  ( main
28
  , checkMain
29
  , prepMain
30
  ) where
31

    
32
import Control.Concurrent
33
import Control.Monad (forever, liftM)
34
import Data.IORef
35
import Data.List
36
import qualified Data.Map as M
37
import Data.Maybe (fromMaybe)
38
import qualified Network.Socket as S
39
import System.Exit
40
import System.IO
41
import qualified Text.JSON as J
42

    
43
import Ganeti.BasicTypes
44
import Ganeti.Errors
45
import Ganeti.Daemon
46
import Ganeti.JSON
47
import Ganeti.Objects
48
import Ganeti.Confd.Types
49
import Ganeti.Confd.Utils
50
import Ganeti.Config
51
import Ganeti.ConfigReader
52
import Ganeti.Hash
53
import Ganeti.Logging
54
import qualified Ganeti.Constants as C
55
import Ganeti.Utils
56

    
57
-- * Types and constants definitions
58

    
59
-- | What we store as configuration.
60
type CRef = IORef (Result (ConfigData, LinkIpMap))
61

    
62
-- | A small type alias for readability.
63
type StatusAnswer = (ConfdReplyStatus, J.JSValue)
64

    
65
-- | Unknown entry standard response.
66
queryUnknownEntry :: StatusAnswer
67
queryUnknownEntry = (ReplyStatusError, J.showJSON ConfdErrorUnknownEntry)
68

    
69
{- not used yet
70
-- | Internal error standard response.
71
queryInternalError :: StatusAnswer
72
queryInternalError = (ReplyStatusError, J.showJSON ConfdErrorInternal)
73
-}
74

    
75
-- | Argument error standard response.
76
queryArgumentError :: StatusAnswer
77
queryArgumentError = (ReplyStatusError, J.showJSON ConfdErrorArgument)
78

    
79
-- | Converter from specific error to a string format.
80
gntErrorToResult :: ErrorResult a -> Result a
81
gntErrorToResult (Bad err) = Bad (show err)
82
gntErrorToResult (Ok x) = Ok x
83

    
84
-- * Confd base functionality
85

    
86
-- | Computes the node role.
87
nodeRole :: ConfigData -> String -> Result ConfdNodeRole
88
nodeRole cfg name =
89
  let cmaster = clusterMasterNode . configCluster $ cfg
90
      mnode = M.lookup name . fromContainer . configNodes $ cfg
91
  in case mnode of
92
       Nothing -> Bad "Node not found"
93
       Just node | cmaster == name -> Ok NodeRoleMaster
94
                 | nodeDrained node -> Ok NodeRoleDrained
95
                 | nodeOffline node -> Ok NodeRoleOffline
96
                 | nodeMasterCandidate node -> Ok NodeRoleCandidate
97
       _ -> Ok NodeRoleRegular
98

    
99
-- | Does an instance ip -> instance -> primary node -> primary ip
100
-- transformation.
101
getNodePipByInstanceIp :: ConfigData
102
                       -> LinkIpMap
103
                       -> String
104
                       -> String
105
                       -> StatusAnswer
106
getNodePipByInstanceIp cfg linkipmap link instip =
107
  case M.lookup instip (M.findWithDefault M.empty link linkipmap) of
108
    Nothing -> queryUnknownEntry
109
    Just instname ->
110
      case getInstPrimaryNode cfg instname of
111
        Bad _ -> queryUnknownEntry -- either instance or node not found
112
        Ok node -> (ReplyStatusOk, J.showJSON (nodePrimaryIp node))
113

    
114
-- | Builds the response to a given query.
115
buildResponse :: (ConfigData, LinkIpMap) -> ConfdRequest -> Result StatusAnswer
116
buildResponse (cfg, _) (ConfdRequest { confdRqType = ReqPing }) =
117
  return (ReplyStatusOk, J.showJSON (configVersion cfg))
118

    
119
buildResponse cdata req@(ConfdRequest { confdRqType = ReqClusterMaster }) =
120
  case confdRqQuery req of
121
    EmptyQuery -> return (ReplyStatusOk, J.showJSON master_name)
122
    PlainQuery _ -> return queryArgumentError
123
    DictQuery reqq -> do
124
      mnode <- gntErrorToResult $ getNode cfg master_name
125
      let fvals = map (\field -> case field of
126
                                   ReqFieldName -> master_name
127
                                   ReqFieldIp -> clusterMasterIp cluster
128
                                   ReqFieldMNodePip -> nodePrimaryIp mnode
129
                      ) (confdReqQFields reqq)
130
      return (ReplyStatusOk, J.showJSON fvals)
131
    where master_name = clusterMasterNode cluster
132
          cluster = configCluster cfg
133
          cfg = fst cdata
134

    
135
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeRoleByName }) = do
136
  node_name <- case confdRqQuery req of
137
                 PlainQuery str -> return str
138
                 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
139
  role <- nodeRole (fst cdata) node_name
140
  return (ReplyStatusOk, J.showJSON role)
141

    
142
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipList }) =
143
  -- note: we use foldlWithKey because that's present accross more
144
  -- versions of the library
145
  return (ReplyStatusOk, J.showJSON $
146
          M.foldlWithKey (\accu _ n -> nodePrimaryIp n:accu) []
147
          (fromContainer . configNodes . fst $ cdata))
148

    
149
buildResponse cdata (ConfdRequest { confdRqType = ReqMcPipList }) =
150
  -- note: we use foldlWithKey because that's present accross more
151
  -- versions of the library
152
  return (ReplyStatusOk, J.showJSON $
153
          M.foldlWithKey (\accu _ n -> if nodeMasterCandidate n
154
                                         then nodePrimaryIp n:accu
155
                                         else accu) []
156
          (fromContainer . configNodes . fst $ cdata))
157

    
158
buildResponse (cfg, linkipmap)
159
              req@(ConfdRequest { confdRqType = ReqInstIpsList }) = do
160
  link <- case confdRqQuery req of
161
            PlainQuery str -> return str
162
            EmptyQuery -> return (getDefaultNicLink cfg)
163
            _ -> fail "Invalid query type"
164
  return (ReplyStatusOk, J.showJSON $ getInstancesIpByLink linkipmap link)
165

    
166
buildResponse cdata (ConfdRequest { confdRqType = ReqNodePipByInstPip
167
                                  , confdRqQuery = DictQuery query}) =
168
  let (cfg, linkipmap) = cdata
169
      link = fromMaybe (getDefaultNicLink cfg) (confdReqQLink query)
170
  in case confdReqQIp query of
171
       Just ip -> return $ getNodePipByInstanceIp cfg linkipmap link ip
172
       Nothing -> return (ReplyStatusOk,
173
                          J.showJSON $
174
                           map (getNodePipByInstanceIp cfg linkipmap link)
175
                           (confdReqQIpList query))
176

    
177
buildResponse _ (ConfdRequest { confdRqType = ReqNodePipByInstPip }) =
178
  return queryArgumentError
179

    
180
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeDrbd }) = do
181
  let cfg = fst cdata
182
  node_name <- case confdRqQuery req of
183
                 PlainQuery str -> return str
184
                 _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
185
  node <- gntErrorToResult $ getNode cfg node_name
186
  let minors = concatMap (getInstMinorsForNode (nodeName node)) .
187
               M.elems . fromContainer . configInstances $ cfg
188
      encoded = [J.JSArray [J.showJSON a, J.showJSON b, J.showJSON c,
189
                             J.showJSON d, J.showJSON e, J.showJSON f] |
190
                 (a, b, c, d, e, f) <- minors]
191
  return (ReplyStatusOk, J.showJSON encoded)
192

    
193
buildResponse cdata req@(ConfdRequest { confdRqType = ReqNodeInstances }) = do
194
  let cfg = fst cdata
195
  node_name <- case confdRqQuery req of
196
                PlainQuery str -> return str
197
                _ -> fail $ "Invalid query type " ++ show (confdRqQuery req)
198
  let instances = getNodeInstances cfg node_name
199
  return (ReplyStatusOk, J.showJSON instances)
200

    
201
-- | Creates a ConfdReply from a given answer.
202
serializeResponse :: Result StatusAnswer -> ConfdReply
203
serializeResponse r =
204
    let (status, result) = case r of
205
                    Bad err -> (ReplyStatusError, J.showJSON err)
206
                    Ok (code, val) -> (code, val)
207
    in ConfdReply { confdReplyProtocol = 1
208
                  , confdReplyStatus   = status
209
                  , confdReplyAnswer   = result
210
                  , confdReplySerial   = 0 }
211

    
212
-- ** Client input/output handlers
213

    
214
-- | Main loop for a given client.
215
responder :: CRef -> S.Socket -> HashKey -> String -> S.SockAddr -> IO ()
216
responder cfgref socket hmac msg peer = do
217
  ctime <- getCurrentTime
218
  case parseRequest hmac msg ctime of
219
    Ok (origmsg, rq) -> do
220
              logDebug $ "Processing request: " ++ rStripSpace origmsg
221
              mcfg <- readIORef cfgref
222
              let response = respondInner mcfg hmac rq
223
              _ <- S.sendTo socket response peer
224
              return ()
225
    Bad err -> logInfo $ "Failed to parse incoming message: " ++ err
226
  return ()
227

    
228
-- | Inner helper function for a given client. This generates the
229
-- final encoded message (as a string), ready to be sent out to the
230
-- client.
231
respondInner :: Result (ConfigData, LinkIpMap) -> HashKey
232
             -> ConfdRequest -> String
233
respondInner cfg hmac rq =
234
  let rsalt = confdRqRsalt rq
235
      innermsg = serializeResponse (cfg >>= flip buildResponse rq)
236
      innerserialised = J.encodeStrict innermsg
237
      outermsg = signMessage hmac rsalt innerserialised
238
      outerserialised = confdMagicFourcc ++ J.encodeStrict outermsg
239
  in outerserialised
240

    
241
-- | Main listener loop.
242
listener :: S.Socket -> HashKey
243
         -> (S.Socket -> HashKey -> String -> S.SockAddr -> IO ())
244
         -> IO ()
245
listener s hmac resp = do
246
  (msg, _, peer) <- S.recvFrom s 4096
247
  if confdMagicFourcc `isPrefixOf` msg
248
    then forkIO (resp s hmac (drop 4 msg) peer) >> return ()
249
    else logDebug "Invalid magic code!" >> return ()
250
  return ()
251

    
252
-- | Type alias for prepMain results
253
type PrepResult = (S.Socket, IORef (Result (ConfigData, LinkIpMap)))
254

    
255
-- | Check function for confd.
256
checkMain :: CheckFn (S.Family, S.SockAddr)
257
checkMain opts = do
258
  parseresult <- parseAddress opts C.defaultConfdPort
259
  case parseresult of
260
    Bad msg -> do
261
      hPutStrLn stderr $ "parsing bind address: " ++ msg
262
      return . Left $ ExitFailure 1
263
    Ok v -> return $ Right v
264

    
265
-- | Prepare function for confd.
266
prepMain :: PrepFn (S.Family, S.SockAddr) PrepResult
267
prepMain _ (af_family, bindaddr) = do
268
  s <- S.socket af_family S.Datagram S.defaultProtocol
269
  S.bindSocket s bindaddr
270
  cref <- newIORef (Bad "Configuration not yet loaded")
271
  return (s, cref)
272

    
273
-- | Main function.
274
main :: MainFn (S.Family, S.SockAddr) PrepResult
275
main _ _ (s, cref) = do
276
  let cfg_transform :: Result ConfigData -> Result (ConfigData, LinkIpMap)
277
      cfg_transform = liftM (\cfg -> (cfg, buildLinkIpInstnameMap cfg))
278
  initConfigReader cfg_transform cref
279

    
280
  hmac <- getClusterHmac
281
  -- enter the responder loop
282
  forever $ listener s hmac (responder cref)