a374f69554ff5c5c4744805c8d571a2b3be553c8
[ganeti-github.git] / src / Ganeti / UDSServer.hs
1 {-# LANGUAGE TemplateHaskell #-}
2 {-# LANGUAGE FlexibleContexts #-}
3
4 {-| Implementation of the Ganeti Unix Domain Socket JSON server interface.
5
6 -}
7
8 {-
9
10 Copyright (C) 2013 Google Inc.
11 All rights reserved.
12
13 Redistribution and use in source and binary forms, with or without
14 modification, are permitted provided that the following conditions are
15 met:
16
17 1. Redistributions of source code must retain the above copyright notice,
18 this list of conditions and the following disclaimer.
19
20 2. Redistributions in binary form must reproduce the above copyright
21 notice, this list of conditions and the following disclaimer in the
22 documentation and/or other materials provided with the distribution.
23
24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
25 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
26 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
28 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
29 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
30 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
31 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
32 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
36 -}
37
38 module Ganeti.UDSServer
39 ( ConnectConfig(..)
40 , ServerConfig(..)
41 , Client
42 , Server
43 , RecvResult(..)
44 , MsgKeys(..)
45 , strOfKey
46 -- * Unix sockets
47 , openClientSocket
48 , closeClientSocket
49 , openServerSocket
50 , closeServerSocket
51 , acceptSocket
52 -- * Client and server
53 , connectClient
54 , connectServer
55 , pipeClient
56 , acceptClient
57 , closeClient
58 , clientToFd
59 , closeServer
60 , buildResponse
61 , parseResponse
62 , buildCall
63 , parseCall
64 , recvMsg
65 , recvMsgExt
66 , sendMsg
67 -- * Client handler
68 , Handler(..)
69 , HandlerResult
70 , listener
71 ) where
72
73 import Control.Applicative
74 import Control.Concurrent.Lifted (fork, yield)
75 import Control.Monad.Base
76 import Control.Monad.Trans.Control
77 import Control.Exception (catch)
78 import Control.Monad
79 import qualified Data.ByteString as B
80 import qualified Data.ByteString.UTF8 as UTF8
81 import Data.IORef
82 import Data.List
83 import Data.Word (Word8)
84 import qualified Network.Socket as S
85 import System.Directory (removeFile)
86 import System.IO (hClose, hFlush, hPutStr, hWaitForInput, Handle, IOMode(..))
87 import System.IO.Error (isEOFError)
88 import System.Posix.Types (Fd)
89 import System.Posix.IO (createPipe, fdToHandle, handleToFd)
90 import System.Timeout
91 import Text.JSON (encodeStrict, decodeStrict)
92 import qualified Text.JSON as J
93 import Text.JSON.Types
94
95 import Ganeti.BasicTypes
96 import Ganeti.Errors (GanetiException(..), ErrorResult)
97 import Ganeti.JSON
98 import Ganeti.Logging
99 import Ganeti.THH
100 import Ganeti.Utils
101 import Ganeti.Constants (privateParametersBlacklist)
102
103 -- * Utility functions
104
105 -- | Wrapper over System.Timeout.timeout that fails in the IO monad.
106 withTimeout :: Int -> String -> IO a -> IO a
107 withTimeout secs descr action = do
108 result <- timeout (secs * 1000000) action
109 case result of
110 Nothing -> fail $ "Timeout in " ++ descr
111 Just v -> return v
112
113
114 -- * Generic protocol functionality
115
116 -- | Result of receiving a message from the socket.
117 data RecvResult = RecvConnClosed -- ^ Connection closed
118 | RecvError String -- ^ Any other error
119 | RecvOk String -- ^ Successfull receive
120 deriving (Show, Eq)
121
122
123 -- | The end-of-message separator.
124 eOM :: Word8
125 eOM = 3
126
127 -- | The end-of-message encoded as a ByteString.
128 bEOM :: B.ByteString
129 bEOM = B.singleton eOM
130
131 -- | Valid keys in the requests and responses.
132 data MsgKeys = Method
133 | Args
134 | Success
135 | Result
136
137 -- | The serialisation of MsgKeys into strings in messages.
138 $(genStrOfKey ''MsgKeys "strOfKey")
139
140
141 -- Information required for creating a server connection.
142 data ServerConfig = ServerConfig
143 { connPermissions :: FilePermissions
144 , connConfig :: ConnectConfig
145 }
146
147 -- Information required for creating a client or server connection.
148 data ConnectConfig = ConnectConfig
149 { recvTmo :: Int
150 , sendTmo :: Int
151 }
152
153 -- | A client encapsulation. Note that it has separate read and write handle.
154 -- For sockets it is the same handle. It is required for bi-directional
155 -- inter-process pipes though.
156 data Client = Client { rsocket :: Handle -- ^ The read part of
157 -- the client socket
158 , wsocket :: Handle -- ^ The write part of
159 -- the client socket
160 , rbuf :: IORef B.ByteString -- ^ Already received buffer
161 , clientConfig :: ConnectConfig
162 }
163
164 -- | A server encapsulation.
165 data Server = Server { sSocket :: S.Socket -- ^ The bound server socket
166 , sPath :: FilePath -- ^ The scoket's path
167 , serverConfig :: ConnectConfig
168 }
169
170 -- * Unix sockets
171
172 -- | Creates a Unix socket and connects it to the specified @path@,
173 -- where @timeout@ specifies the connection timeout.
174 openClientSocket
175 :: Int -- ^ connection timeout
176 -> FilePath -- ^ socket path
177 -> IO Handle
178 openClientSocket tmo path = do
179 sock <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
180 withTimeout tmo "creating a connection" $
181 S.connect sock (S.SockAddrUnix path)
182 S.socketToHandle sock ReadWriteMode
183
184 -- | Closes the handle.
185 -- Performing the operation on a handle that has already been closed has no
186 -- effect; doing so is not an error.
187 -- All other operations on a closed handle will fail.
188 closeClientSocket :: Handle -> IO ()
189 closeClientSocket = hClose
190
191 -- | Creates a Unix socket and binds it to the specified @path@.
192 openServerSocket :: FilePath -> IO S.Socket
193 openServerSocket path = do
194 sock <- S.socket S.AF_UNIX S.Stream S.defaultProtocol
195 S.bindSocket sock (S.SockAddrUnix path)
196 return sock
197
198 closeServerSocket :: S.Socket -> FilePath -> IO ()
199 closeServerSocket sock path = do
200 S.sClose sock
201 removeFile path
202
203 acceptSocket :: S.Socket -> IO Handle
204 acceptSocket sock = do
205 -- ignore client socket address
206 (clientSock, _) <- S.accept sock
207 S.socketToHandle clientSock ReadWriteMode
208
209 -- * Client and server
210
211 -- | Connects to the master daemon and returns a Client.
212 connectClient
213 :: ConnectConfig -- ^ configuration for the client
214 -> Int -- ^ connection timeout
215 -> FilePath -- ^ socket path
216 -> IO Client
217 connectClient conf tmo path = do
218 h <- openClientSocket tmo path
219 rf <- newIORef B.empty
220 return Client { rsocket=h, wsocket=h, rbuf=rf, clientConfig=conf }
221
222 -- | Creates and returns a server endpoint.
223 connectServer :: ServerConfig -> Bool -> FilePath -> IO Server
224 connectServer sconf setOwner path = do
225 s <- openServerSocket path
226 when setOwner $ do
227 res <- ensurePermissions path (connPermissions sconf)
228 exitIfBad "Error - could not set socket properties" res
229
230 S.listen s 5 -- 5 is the max backlog
231 return Server { sSocket = s, sPath = path, serverConfig = connConfig sconf }
232
233 -- | Creates a new bi-directional client pipe. The two returned clients
234 -- talk to each other through the pipe.
235 pipeClient :: ConnectConfig -> IO (Client, Client)
236 pipeClient conf =
237 let newClient r w = do
238 rf <- newIORef B.empty
239 rh <- fdToHandle r
240 wh <- fdToHandle w
241 return Client { rsocket = rh, wsocket = wh
242 , rbuf = rf, clientConfig = conf }
243 in do
244 (r1, w1) <- createPipe
245 (r2, w2) <- createPipe
246 (,) <$> newClient r1 w2 <*> newClient r2 w1
247
248 -- | Closes a server endpoint.
249 closeServer :: (MonadBase IO m) => Server -> m ()
250 closeServer server =
251 liftBase $ closeServerSocket (sSocket server) (sPath server)
252
253 -- | Accepts a client
254 acceptClient :: Server -> IO Client
255 acceptClient s = do
256 handle <- acceptSocket (sSocket s)
257 new_buffer <- newIORef B.empty
258 return Client { rsocket=handle
259 , wsocket=handle
260 , rbuf=new_buffer
261 , clientConfig=serverConfig s
262 }
263
264 -- | Closes the client socket.
265 -- Performing the operation on a client that has already been closed has no
266 -- effect; doing so is not an error.
267 -- All other operations on a closed client will fail with an exception.
268 closeClient :: Client -> IO ()
269 closeClient client = do
270 closeClientSocket . wsocket $ client
271 closeClientSocket . rsocket $ client
272
273 -- | Extracts the read (the first) and the write (the second) file descriptor
274 -- of a client. This closes the underlying 'Handle's, therefore the original
275 -- client is closed and unusable after the call.
276 --
277 -- The purpose of this function is to keep the communication channel open,
278 -- while replacing a 'Client' with some other means.
279 clientToFd :: Client -> IO (Fd, Fd)
280 clientToFd client | rh == wh = join (,) <$> handleToFd rh
281 | otherwise = (,) <$> handleToFd rh <*> handleToFd wh
282 where
283 rh = rsocket client
284 wh = wsocket client
285
286 -- | Sends a message over a transport.
287 sendMsg :: Client -> String -> IO ()
288 sendMsg s buf = withTimeout (sendTmo $ clientConfig s) "sending a message" $ do
289 let handle = wsocket s
290 hPutStr handle buf
291 B.hPut handle bEOM
292 hFlush handle
293
294 -- | Given a current buffer and the handle, it will read from the
295 -- network until we get a full message, and it will return that
296 -- message and the leftover buffer contents.
297 recvUpdate :: ConnectConfig -> Handle -> B.ByteString
298 -> IO (B.ByteString, B.ByteString)
299 recvUpdate conf handle obuf = do
300 nbuf <- withTimeout (recvTmo conf) "reading a response" $ do
301 _ <- hWaitForInput handle (-1)
302 B.hGetNonBlocking handle 4096
303 let (msg, remaining) = B.break (eOM ==) nbuf
304 newbuf = B.append obuf msg
305 if B.null remaining
306 then recvUpdate conf handle newbuf
307 else return (newbuf, B.copy (B.tail remaining))
308
309 -- | Waits for a message over a transport.
310 recvMsg :: Client -> IO String
311 recvMsg s = do
312 cbuf <- readIORef $ rbuf s
313 let (imsg, ibuf) = B.break (eOM ==) cbuf
314 (msg, nbuf) <-
315 if B.null ibuf -- if old buffer didn't contain a full message
316 -- then we read from network:
317 then recvUpdate (clientConfig s) (rsocket s) cbuf
318 -- else we return data from our buffer, copying it so that the whole
319 -- message isn't retained and can be garbage collected
320 else return (imsg, B.copy (B.tail ibuf))
321 writeIORef (rbuf s) nbuf
322 return $ UTF8.toString msg
323
324 -- | Extended wrapper over recvMsg.
325 recvMsgExt :: Client -> IO RecvResult
326 recvMsgExt s =
327 Control.Exception.catch (liftM RecvOk (recvMsg s)) $ \e ->
328 return $ if isEOFError e
329 then RecvConnClosed
330 else RecvError (show e)
331
332
333 -- | Serialize a request to String.
334 buildCall :: (J.JSON mth, J.JSON args)
335 => mth -- ^ The method
336 -> args -- ^ The arguments
337 -> String -- ^ The serialized form
338 buildCall mth args =
339 let keyToObj :: (J.JSON a) => MsgKeys -> a -> (String, J.JSValue)
340 keyToObj k v = (strOfKey k, J.showJSON v)
341 in encodeStrict $ toJSObject [ keyToObj Method mth, keyToObj Args args ]
342
343 -- | Parse the required keys out of a call.
344 parseCall :: (J.JSON mth, J.JSON args) => String -> Result (mth, args)
345 parseCall s = do
346 arr <- fromJResult "parsing top-level JSON message" $
347 decodeStrict s :: Result (JSObject JSValue)
348 let keyFromObj :: (J.JSON a) => MsgKeys -> Result a
349 keyFromObj = fromObj (fromJSObject arr) . strOfKey
350 (,) <$> keyFromObj Method <*> keyFromObj Args
351
352
353 -- | Serialize the response to String.
354 buildResponse :: Bool -- ^ Success
355 -> JSValue -- ^ The arguments
356 -> String -- ^ The serialized form
357 buildResponse success args =
358 let ja = [ (strOfKey Success, JSBool success)
359 , (strOfKey Result, args)]
360 jo = toJSObject ja
361 in encodeStrict jo
362
363 -- | Try to decode an error from the server response. This function
364 -- will always fail, since it's called only on the error path (when
365 -- status is False).
366 decodeError :: JSValue -> ErrorResult JSValue
367 decodeError val =
368 case fromJVal val of
369 Ok e -> Bad e
370 Bad msg -> Bad $ GenericError msg
371
372 -- | Check that luxi responses contain the required keys and that the
373 -- call was successful.
374 parseResponse :: String -> ErrorResult JSValue
375 parseResponse s = do
376 when (UTF8.replacement_char `elem` s) $
377 failError "Failed to decode UTF-8,\
378 \ detected replacement char after decoding"
379 oarr <- fromJResultE "Parsing LUXI response" (decodeStrict s)
380 let arr = J.fromJSObject oarr
381 status <- fromObj arr (strOfKey Success)
382 result <- fromObj arr (strOfKey Result)
383 if status
384 then return result
385 else decodeError result
386
387 -- | Logs an outgoing message.
388 logMsg
389 :: (Show e, J.JSON e, MonadLog m)
390 => Handler i m o
391 -> i -- ^ the received request (used for logging)
392 -> GenericResult e J.JSValue -- ^ A message to be sent
393 -> m ()
394 logMsg handler req (Bad err) =
395 logWarning $ "Failed to execute request " ++ hInputLogLong handler req ++ ": "
396 ++ show err
397 logMsg handler req (Ok result) = do
398 -- only log the first 2,000 chars of the result
399 logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
400 logDebug $ "Successfully handled " ++ hInputLogShort handler req
401
402 -- | Prepares an outgoing message.
403 prepareMsg
404 :: (J.JSON e)
405 => GenericResult e J.JSValue -- ^ A message to be sent
406 -> (Bool, J.JSValue)
407 prepareMsg (Bad err) = (False, J.showJSON err)
408 prepareMsg (Ok result) = (True, result)
409
410
411 -- * Processing client requests
412
413 type HandlerResult m o = m (Bool, GenericResult GanetiException o)
414
415 data Handler i m o = Handler
416 { hParse :: J.JSValue -> J.JSValue -> Result i
417 -- ^ parses method and its arguments into the input type
418 , hInputLogShort :: i -> String
419 -- ^ short description of an input, for the INFO logging level
420 , hInputLogLong :: i -> String
421 -- ^ long description of an input, for the DEBUG logging level
422 , hExec :: i -> HandlerResult m o
423 -- ^ executes the handler on an input
424 }
425
426
427 handleJsonMessage
428 :: (J.JSON o, Monad m)
429 => Handler i m o -- ^ handler
430 -> i -- ^ parsed input
431 -> HandlerResult m J.JSValue
432 handleJsonMessage handler req = do
433 (close, call_result) <- hExec handler req
434 return (close, fmap J.showJSON call_result)
435
436 -- | Takes a request as a 'String', parses it, passes it to a handler and
437 -- formats its response.
438 handleRawMessage
439 :: (J.JSON o, MonadLog m)
440 => Handler i m o -- ^ handler
441 -> String -- ^ raw unparsed input
442 -> m (Bool, String)
443 handleRawMessage handler payload =
444 case parseCall payload >>= uncurry (hParse handler) of
445 Bad err -> do
446 let errmsg = "Failed to parse request: " ++ err
447 logWarning errmsg
448 return (False, buildResponse False (J.showJSON errmsg))
449 Ok req -> do
450 logDebug $ "Request: " ++ hInputLogLong handler req
451 (close, call_result_json) <- handleJsonMessage handler req
452 logMsg handler req call_result_json
453 let (status, response) = prepareMsg call_result_json
454 return (close, buildResponse status response)
455
456 isRisky :: RecvResult -> Bool
457 isRisky msg = case msg of
458 RecvOk payload -> any (`isInfixOf` payload) privateParametersBlacklist
459 _ -> False
460
461 -- | Reads a request, passes it to a handler and sends a response back to the
462 -- client.
463 handleClient
464 :: (J.JSON o, MonadBase IO m, MonadLog m)
465 => Handler i m o
466 -> Client
467 -> m Bool
468 handleClient handler client = do
469 msg <- liftBase $ recvMsgExt client
470
471 debugMode <- liftBase isDebugMode
472 when (debugMode && isRisky msg) $
473 logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \
474 \Daemon is running in debug mode. \
475 \The text of the request has been logged."
476 logDebug $ "Received message (truncated): " ++ take 500 (show msg)
477
478 case msg of
479 RecvConnClosed -> logDebug "Connection closed" >>
480 return False
481 RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
482 return False
483 RecvOk payload -> do
484 (close, outMsg) <- handleRawMessage handler payload
485 liftBase $ sendMsg client outMsg
486 return close
487
488
489 -- | Main client loop: runs one loop of 'handleClient', and if that
490 -- doesn't report a finished (closed) connection, restarts itself.
491 clientLoop
492 :: (J.JSON o, MonadBase IO m, MonadLog m)
493 => Handler i m o
494 -> Client
495 -> m ()
496 clientLoop handler client = do
497 result <- handleClient handler client
498 {- It's been observed sometimes that reading immediately after sending
499 a response leads to worse performance, as there is nothing to read and
500 the system calls are just wasted. Thus yielding before reading gives
501 other threads a chance to proceed and provides a natural pause, leading
502 to a bit more efficient communication.
503 -}
504 if result
505 then yield >> clientLoop handler client
506 else liftBase $ closeClient client
507
508 -- | Main listener loop: accepts clients, forks an I/O thread to handle
509 -- that client.
510 listener
511 :: (J.JSON o, MonadBaseControl IO m, MonadLog m)
512 => Handler i m o
513 -> Server
514 -> m ()
515 listener handler server = do
516 client <- liftBase $ acceptClient server
517 _ <- fork $ clientLoop handler client
518 return ()