Send answers strictly
[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, 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 encoded = UTF8.fromString buf
290 handle = wsocket s
291 B.hPut handle encoded
292 B.hPut handle bEOM
293 hFlush handle
294
295 -- | Given a current buffer and the handle, it will read from the
296 -- network until we get a full message, and it will return that
297 -- message and the leftover buffer contents.
298 recvUpdate :: ConnectConfig -> Handle -> B.ByteString
299 -> IO (B.ByteString, B.ByteString)
300 recvUpdate conf handle obuf = do
301 nbuf <- withTimeout (recvTmo conf) "reading a response" $ do
302 _ <- hWaitForInput handle (-1)
303 B.hGetNonBlocking handle 4096
304 let (msg, remaining) = B.break (eOM ==) nbuf
305 newbuf = B.append obuf msg
306 if B.null remaining
307 then recvUpdate conf handle newbuf
308 else return (newbuf, B.copy (B.tail remaining))
309
310 -- | Waits for a message over a transport.
311 recvMsg :: Client -> IO String
312 recvMsg s = do
313 cbuf <- readIORef $ rbuf s
314 let (imsg, ibuf) = B.break (eOM ==) cbuf
315 (msg, nbuf) <-
316 if B.null ibuf -- if old buffer didn't contain a full message
317 -- then we read from network:
318 then recvUpdate (clientConfig s) (rsocket s) cbuf
319 -- else we return data from our buffer, copying it so that the whole
320 -- message isn't retained and can be garbage collected
321 else return (imsg, B.copy (B.tail ibuf))
322 writeIORef (rbuf s) nbuf
323 return $ UTF8.toString msg
324
325 -- | Extended wrapper over recvMsg.
326 recvMsgExt :: Client -> IO RecvResult
327 recvMsgExt s =
328 Control.Exception.catch (liftM RecvOk (recvMsg s)) $ \e ->
329 return $ if isEOFError e
330 then RecvConnClosed
331 else RecvError (show e)
332
333
334 -- | Serialize a request to String.
335 buildCall :: (J.JSON mth, J.JSON args)
336 => mth -- ^ The method
337 -> args -- ^ The arguments
338 -> String -- ^ The serialized form
339 buildCall mth args =
340 let keyToObj :: (J.JSON a) => MsgKeys -> a -> (String, J.JSValue)
341 keyToObj k v = (strOfKey k, J.showJSON v)
342 in encodeStrict $ toJSObject [ keyToObj Method mth, keyToObj Args args ]
343
344 -- | Parse the required keys out of a call.
345 parseCall :: (J.JSON mth, J.JSON args) => String -> Result (mth, args)
346 parseCall s = do
347 arr <- fromJResult "parsing top-level JSON message" $
348 decodeStrict s :: Result (JSObject JSValue)
349 let keyFromObj :: (J.JSON a) => MsgKeys -> Result a
350 keyFromObj = fromObj (fromJSObject arr) . strOfKey
351 (,) <$> keyFromObj Method <*> keyFromObj Args
352
353
354 -- | Serialize the response to String.
355 buildResponse :: Bool -- ^ Success
356 -> JSValue -- ^ The arguments
357 -> String -- ^ The serialized form
358 buildResponse success args =
359 let ja = [ (strOfKey Success, JSBool success)
360 , (strOfKey Result, args)]
361 jo = toJSObject ja
362 in encodeStrict jo
363
364 -- | Try to decode an error from the server response. This function
365 -- will always fail, since it's called only on the error path (when
366 -- status is False).
367 decodeError :: JSValue -> ErrorResult JSValue
368 decodeError val =
369 case fromJVal val of
370 Ok e -> Bad e
371 Bad msg -> Bad $ GenericError msg
372
373 -- | Check that luxi responses contain the required keys and that the
374 -- call was successful.
375 parseResponse :: String -> ErrorResult JSValue
376 parseResponse s = do
377 when (UTF8.replacement_char `elem` s) $
378 failError "Failed to decode UTF-8,\
379 \ detected replacement char after decoding"
380 oarr <- fromJResultE "Parsing LUXI response" (decodeStrict s)
381 let arr = J.fromJSObject oarr
382 status <- fromObj arr (strOfKey Success)
383 result <- fromObj arr (strOfKey Result)
384 if status
385 then return result
386 else decodeError result
387
388 -- | Logs an outgoing message.
389 logMsg
390 :: (Show e, J.JSON e, MonadLog m)
391 => Handler i m o
392 -> i -- ^ the received request (used for logging)
393 -> GenericResult e J.JSValue -- ^ A message to be sent
394 -> m ()
395 logMsg handler req (Bad err) =
396 logWarning $ "Failed to execute request " ++ hInputLogLong handler req ++ ": "
397 ++ show err
398 logMsg handler req (Ok result) = do
399 -- only log the first 2,000 chars of the result
400 logDebug $ "Result (truncated): " ++ take 2000 (J.encode result)
401 logDebug $ "Successfully handled " ++ hInputLogShort handler req
402
403 -- | Prepares an outgoing message.
404 prepareMsg
405 :: (J.JSON e)
406 => GenericResult e J.JSValue -- ^ A message to be sent
407 -> (Bool, J.JSValue)
408 prepareMsg (Bad err) = (False, J.showJSON err)
409 prepareMsg (Ok result) = (True, result)
410
411
412 -- * Processing client requests
413
414 type HandlerResult m o = m (Bool, GenericResult GanetiException o)
415
416 data Handler i m o = Handler
417 { hParse :: J.JSValue -> J.JSValue -> Result i
418 -- ^ parses method and its arguments into the input type
419 , hInputLogShort :: i -> String
420 -- ^ short description of an input, for the INFO logging level
421 , hInputLogLong :: i -> String
422 -- ^ long description of an input, for the DEBUG logging level
423 , hExec :: i -> HandlerResult m o
424 -- ^ executes the handler on an input
425 }
426
427
428 handleJsonMessage
429 :: (J.JSON o, Monad m)
430 => Handler i m o -- ^ handler
431 -> i -- ^ parsed input
432 -> HandlerResult m J.JSValue
433 handleJsonMessage handler req = do
434 (close, call_result) <- hExec handler req
435 return (close, fmap J.showJSON call_result)
436
437 -- | Takes a request as a 'String', parses it, passes it to a handler and
438 -- formats its response.
439 handleRawMessage
440 :: (J.JSON o, MonadLog m)
441 => Handler i m o -- ^ handler
442 -> String -- ^ raw unparsed input
443 -> m (Bool, String)
444 handleRawMessage handler payload =
445 case parseCall payload >>= uncurry (hParse handler) of
446 Bad err -> do
447 let errmsg = "Failed to parse request: " ++ err
448 logWarning errmsg
449 return (False, buildResponse False (J.showJSON errmsg))
450 Ok req -> do
451 logDebug $ "Request: " ++ hInputLogLong handler req
452 (close, call_result_json) <- handleJsonMessage handler req
453 logMsg handler req call_result_json
454 let (status, response) = prepareMsg call_result_json
455 return (close, buildResponse status response)
456
457 isRisky :: RecvResult -> Bool
458 isRisky msg = case msg of
459 RecvOk payload -> any (`isInfixOf` payload) privateParametersBlacklist
460 _ -> False
461
462 -- | Reads a request, passes it to a handler and sends a response back to the
463 -- client.
464 handleClient
465 :: (J.JSON o, MonadBase IO m, MonadLog m)
466 => Handler i m o
467 -> Client
468 -> m Bool
469 handleClient handler client = do
470 msg <- liftBase $ recvMsgExt client
471
472 debugMode <- liftBase isDebugMode
473 when (debugMode && isRisky msg) $
474 logAlert "POSSIBLE LEAKING OF CONFIDENTIAL PARAMETERS. \
475 \Daemon is running in debug mode. \
476 \The text of the request has been logged."
477 logDebug $ "Received message (truncated): " ++ take 500 (show msg)
478
479 case msg of
480 RecvConnClosed -> logDebug "Connection closed" >>
481 return False
482 RecvError err -> logWarning ("Error during message receiving: " ++ err) >>
483 return False
484 RecvOk payload -> do
485 (close, outMsg) <- handleRawMessage handler payload
486 liftBase $ sendMsg client outMsg
487 return close
488
489
490 -- | Main client loop: runs one loop of 'handleClient', and if that
491 -- doesn't report a finished (closed) connection, restarts itself.
492 clientLoop
493 :: (J.JSON o, MonadBase IO m, MonadLog m)
494 => Handler i m o
495 -> Client
496 -> m ()
497 clientLoop handler client = do
498 result <- handleClient handler client
499 {- It's been observed sometimes that reading immediately after sending
500 a response leads to worse performance, as there is nothing to read and
501 the system calls are just wasted. Thus yielding before reading gives
502 other threads a chance to proceed and provides a natural pause, leading
503 to a bit more efficient communication.
504 -}
505 if result
506 then yield >> clientLoop handler client
507 else liftBase $ closeClient client
508
509 -- | Main listener loop: accepts clients, forks an I/O thread to handle
510 -- that client.
511 listener
512 :: (J.JSON o, MonadBaseControl IO m, MonadLog m)
513 => Handler i m o
514 -> Server
515 -> m ()
516 listener handler server = do
517 client <- liftBase $ acceptClient server
518 _ <- fork $ clientLoop handler client
519 return ()