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