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