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