root / src / Ganeti / UDSServer.hs @ c92b4671
History | View | Annotate | Download (12.1 kB)
1 | 71a4c605 | Petr Pudlak | {-# LANGUAGE TemplateHaskell #-} |
---|---|---|---|
2 | 71a4c605 | Petr Pudlak | |
3 | 71a4c605 | Petr Pudlak | {-| Implementation of the Ganeti Unix Domain Socket JSON server interface. |
4 | 71a4c605 | Petr Pudlak | |
5 | 71a4c605 | Petr Pudlak | -} |
6 | 71a4c605 | Petr Pudlak | |
7 | 71a4c605 | Petr Pudlak | {- |
8 | 71a4c605 | Petr Pudlak | |
9 | 71a4c605 | Petr Pudlak | Copyright (C) 2013 Google Inc. |
10 | 71a4c605 | Petr Pudlak | |
11 | 71a4c605 | Petr Pudlak | This program is free software; you can redistribute it and/or modify |
12 | 71a4c605 | Petr Pudlak | it under the terms of the GNU General Public License as published by |
13 | 71a4c605 | Petr Pudlak | the Free Software Foundation; either version 2 of the License, or |
14 | 71a4c605 | Petr Pudlak | (at your option) any later version. |
15 | 71a4c605 | Petr Pudlak | |
16 | 71a4c605 | Petr Pudlak | This program is distributed in the hope that it will be useful, but |
17 | 71a4c605 | Petr Pudlak | WITHOUT ANY WARRANTY; without even the implied warranty of |
18 | 71a4c605 | Petr Pudlak | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
19 | 71a4c605 | Petr Pudlak | General Public License for more details. |
20 | 71a4c605 | Petr Pudlak | |
21 | 71a4c605 | Petr Pudlak | You should have received a copy of the GNU General Public License |
22 | 71a4c605 | Petr Pudlak | along with this program; if not, write to the Free Software |
23 | 71a4c605 | Petr Pudlak | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
24 | 71a4c605 | Petr Pudlak | 02110-1301, USA. |
25 | 71a4c605 | Petr Pudlak | |
26 | 71a4c605 | Petr Pudlak | -} |
27 | 71a4c605 | Petr Pudlak | |
28 | 71a4c605 | Petr Pudlak | module Ganeti.UDSServer |
29 | 0fbc8447 | Petr Pudlak | ( ConnectConfig(..) |
30 | 0fbc8447 | Petr Pudlak | , Client |
31 | 0fbc8447 | Petr Pudlak | , Server |
32 | 71a4c605 | Petr Pudlak | , RecvResult(..) |
33 | 71a4c605 | Petr Pudlak | , MsgKeys(..) |
34 | 71a4c605 | Petr Pudlak | , strOfKey |
35 | cf51a981 | Jose A. Lopes | -- * Unix sockets |
36 | cf51a981 | Jose A. Lopes | , openClientSocket |
37 | cf51a981 | Jose A. Lopes | , closeClientSocket |
38 | cf51a981 | Jose A. Lopes | , openServerSocket |
39 | cf51a981 | Jose A. Lopes | , closeServerSocket |
40 | cf51a981 | Jose A. Lopes | , acceptSocket |
41 | cf51a981 | Jose A. Lopes | -- * Client and server |
42 | 0fbc8447 | Petr Pudlak | , connectClient |
43 | 0fbc8447 | Petr Pudlak | , connectServer |
44 | 71a4c605 | Petr Pudlak | , acceptClient |
45 | 71a4c605 | Petr Pudlak | , closeClient |
46 | 71a4c605 | Petr Pudlak | , closeServer |
47 | 71a4c605 | Petr Pudlak | , buildResponse |
48 | 6e47412f | Petr Pudlak | , parseCall |
49 | 71a4c605 | Petr Pudlak | , recvMsg |
50 | 71a4c605 | Petr Pudlak | , recvMsgExt |
51 | 71a4c605 | Petr Pudlak | , sendMsg |
52 | d79a6502 | Petr Pudlak | -- * Client handler |
53 | d79a6502 | Petr Pudlak | , Handler(..) |
54 | d79a6502 | Petr Pudlak | , HandlerResult |
55 | c7003a76 | Petr Pudlak | , listener |
56 | 71a4c605 | Petr Pudlak | ) where |
57 | 71a4c605 | Petr Pudlak | |
58 | 6e47412f | Petr Pudlak | import Control.Applicative |
59 | c7003a76 | Petr Pudlak | import Control.Concurrent (forkIO) |
60 | 71a4c605 | Petr Pudlak | import Control.Exception (catch) |
61 | 71a4c605 | Petr Pudlak | import Data.IORef |
62 | 71a4c605 | Petr Pudlak | import qualified Data.ByteString as B |
63 | 71a4c605 | Petr Pudlak | import qualified Data.ByteString.Lazy as BL |
64 | 71a4c605 | Petr Pudlak | import qualified Data.ByteString.UTF8 as UTF8 |
65 | 71a4c605 | Petr Pudlak | import qualified Data.ByteString.Lazy.UTF8 as UTF8L |
66 | 71a4c605 | Petr Pudlak | import Data.Word (Word8) |
67 | 71a4c605 | Petr Pudlak | import Control.Monad |
68 | 71a4c605 | Petr Pudlak | import qualified Network.Socket as S |
69 | 71a4c605 | Petr Pudlak | import System.Directory (removeFile) |
70 | 71a4c605 | Petr Pudlak | import System.IO (hClose, hFlush, hWaitForInput, Handle, IOMode(..)) |
71 | 71a4c605 | Petr Pudlak | import System.IO.Error (isEOFError) |
72 | 71a4c605 | Petr Pudlak | import System.Timeout |
73 | 6e47412f | Petr Pudlak | import Text.JSON (encodeStrict, decodeStrict) |
74 | 6e47412f | Petr Pudlak | import qualified Text.JSON as J |
75 | 71a4c605 | Petr Pudlak | import Text.JSON.Types |
76 | 71a4c605 | Petr Pudlak | |
77 | 6e47412f | Petr Pudlak | import Ganeti.BasicTypes |
78 | d79a6502 | Petr Pudlak | import Ganeti.Errors (GanetiException) |
79 | 6e47412f | Petr Pudlak | import Ganeti.JSON |
80 | c7003a76 | Petr Pudlak | import Ganeti.Logging |
81 | 71a4c605 | Petr Pudlak | import Ganeti.Runtime (GanetiDaemon(..), MiscGroup(..), GanetiGroup(..)) |
82 | 71a4c605 | Petr Pudlak | import Ganeti.THH |
83 | 71a4c605 | Petr Pudlak | import Ganeti.Utils |
84 | 71a4c605 | Petr Pudlak | |
85 | 71a4c605 | Petr Pudlak | |
86 | 71a4c605 | Petr Pudlak | -- * Utility functions |
87 | 71a4c605 | Petr Pudlak | |
88 | 71a4c605 | Petr Pudlak | -- | Wrapper over System.Timeout.timeout that fails in the IO monad. |
89 | 71a4c605 | Petr Pudlak | withTimeout :: Int -> String -> IO a -> IO a |
90 | 71a4c605 | Petr Pudlak | withTimeout secs descr action = do |
91 | 71a4c605 | Petr Pudlak | result <- timeout (secs * 1000000) action |
92 | 71a4c605 | Petr Pudlak | case result of |
93 | 71a4c605 | Petr Pudlak | Nothing -> fail $ "Timeout in " ++ descr |
94 | 71a4c605 | Petr Pudlak | Just v -> return v |
95 | 71a4c605 | Petr Pudlak | |
96 | 71a4c605 | Petr Pudlak | |
97 | 71a4c605 | Petr Pudlak | -- * Generic protocol functionality |
98 | 71a4c605 | Petr Pudlak | |
99 | 71a4c605 | Petr Pudlak | -- | Result of receiving a message from the socket. |
100 | 71a4c605 | Petr Pudlak | data RecvResult = RecvConnClosed -- ^ Connection closed |
101 | 71a4c605 | Petr Pudlak | | RecvError String -- ^ Any other error |
102 | 71a4c605 | Petr Pudlak | | RecvOk String -- ^ Successfull receive |
103 | 71a4c605 | Petr Pudlak | deriving (Show, Eq) |
104 | 71a4c605 | Petr Pudlak | |
105 | 71a4c605 | Petr Pudlak | |
106 | 71a4c605 | Petr Pudlak | -- | The end-of-message separator. |
107 | 71a4c605 | Petr Pudlak | eOM :: Word8 |
108 | 71a4c605 | Petr Pudlak | eOM = 3 |
109 | 71a4c605 | Petr Pudlak | |
110 | 71a4c605 | Petr Pudlak | -- | The end-of-message encoded as a ByteString. |
111 | 71a4c605 | Petr Pudlak | bEOM :: B.ByteString |
112 | 71a4c605 | Petr Pudlak | bEOM = B.singleton eOM |
113 | 71a4c605 | Petr Pudlak | |
114 | 71a4c605 | Petr Pudlak | -- | Valid keys in the requests and responses. |
115 | 71a4c605 | Petr Pudlak | data MsgKeys = Method |
116 | 71a4c605 | Petr Pudlak | | Args |
117 | 71a4c605 | Petr Pudlak | | Success |
118 | 71a4c605 | Petr Pudlak | | Result |
119 | 71a4c605 | Petr Pudlak | |
120 | 71a4c605 | Petr Pudlak | -- | The serialisation of MsgKeys into strings in messages. |
121 | 71a4c605 | Petr Pudlak | $(genStrOfKey ''MsgKeys "strOfKey") |
122 | 71a4c605 | Petr Pudlak | |
123 | 71a4c605 | Petr Pudlak | |
124 | 0fbc8447 | Petr Pudlak | data ConnectConfig = ConnectConfig |
125 | 0fbc8447 | Petr Pudlak | { connDaemon :: GanetiDaemon |
126 | 0fbc8447 | Petr Pudlak | , recvTmo :: Int |
127 | 0fbc8447 | Petr Pudlak | , sendTmo :: Int |
128 | 0fbc8447 | Petr Pudlak | } |
129 | 0fbc8447 | Petr Pudlak | |
130 | 0fbc8447 | Petr Pudlak | -- | A client encapsulation. |
131 | 71a4c605 | Petr Pudlak | data Client = Client { socket :: Handle -- ^ The socket of the client |
132 | 71a4c605 | Petr Pudlak | , rbuf :: IORef B.ByteString -- ^ Already received buffer |
133 | 0fbc8447 | Petr Pudlak | , clientConfig :: ConnectConfig |
134 | 71a4c605 | Petr Pudlak | } |
135 | 71a4c605 | Petr Pudlak | |
136 | 0fbc8447 | Petr Pudlak | -- | A server encapsulation. |
137 | 0fbc8447 | Petr Pudlak | data Server = Server { sSocket :: S.Socket -- ^ The bound server socket |
138 | 5e671e0e | Petr Pudlak | , sPath :: FilePath -- ^ The scoket's path |
139 | 0fbc8447 | Petr Pudlak | , serverConfig :: ConnectConfig |
140 | 0fbc8447 | Petr Pudlak | } |
141 | 0fbc8447 | Petr Pudlak | |
142 | cf51a981 | Jose A. Lopes | -- * Unix sockets |
143 | cf51a981 | Jose A. Lopes | |
144 | cf51a981 | Jose A. Lopes | -- | Creates a Unix socket and connects it to the specified @path@, |
145 | cf51a981 | Jose A. Lopes | -- where @timeout@ specifies the connection timeout. |
146 | cf51a981 | Jose A. Lopes | openClientSocket |
147 | cf51a981 | Jose A. Lopes | :: Int -- ^ connection timeout |
148 | cf51a981 | Jose A. Lopes | -> FilePath -- ^ socket path |
149 | cf51a981 | Jose A. Lopes | -> IO Handle |
150 | cf51a981 | Jose A. Lopes | openClientSocket tmo path = do |
151 | cf51a981 | Jose A. Lopes | sock <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
152 | cf51a981 | Jose A. Lopes | withTimeout tmo "creating a connection" $ |
153 | cf51a981 | Jose A. Lopes | S.connect sock (S.SockAddrUnix path) |
154 | cf51a981 | Jose A. Lopes | S.socketToHandle sock ReadWriteMode |
155 | cf51a981 | Jose A. Lopes | |
156 | cf51a981 | Jose A. Lopes | closeClientSocket :: Handle -> IO () |
157 | cf51a981 | Jose A. Lopes | closeClientSocket = hClose |
158 | cf51a981 | Jose A. Lopes | |
159 | cf51a981 | Jose A. Lopes | -- | Creates a Unix socket and binds it to the specified @path@. |
160 | cf51a981 | Jose A. Lopes | openServerSocket :: FilePath -> IO S.Socket |
161 | cf51a981 | Jose A. Lopes | openServerSocket path = do |
162 | cf51a981 | Jose A. Lopes | sock <- S.socket S.AF_UNIX S.Stream S.defaultProtocol |
163 | cf51a981 | Jose A. Lopes | S.bindSocket sock (S.SockAddrUnix path) |
164 | cf51a981 | Jose A. Lopes | return sock |
165 | cf51a981 | Jose A. Lopes | |
166 | cf51a981 | Jose A. Lopes | closeServerSocket :: S.Socket -> FilePath -> IO () |
167 | cf51a981 | Jose A. Lopes | closeServerSocket sock path = do |
168 | cf51a981 | Jose A. Lopes | S.sClose sock |
169 | cf51a981 | Jose A. Lopes | removeFile path |
170 | cf51a981 | Jose A. Lopes | |
171 | cf51a981 | Jose A. Lopes | acceptSocket :: S.Socket -> IO Handle |
172 | cf51a981 | Jose A. Lopes | acceptSocket sock = do |
173 | cf51a981 | Jose A. Lopes | -- ignore client socket address |
174 | cf51a981 | Jose A. Lopes | (clientSock, _) <- S.accept sock |
175 | cf51a981 | Jose A. Lopes | S.socketToHandle clientSock ReadWriteMode |
176 | cf51a981 | Jose A. Lopes | |
177 | cf51a981 | Jose A. Lopes | -- * Client and server |
178 | 0fbc8447 | Petr Pudlak | |
179 | 0fbc8447 | Petr Pudlak | -- | Connects to the master daemon and returns a Client. |
180 | 0fbc8447 | Petr Pudlak | connectClient |
181 | 0fbc8447 | Petr Pudlak | :: ConnectConfig -- ^ configuration for the client |
182 | 0fbc8447 | Petr Pudlak | -> Int -- ^ connection timeout |
183 | 0fbc8447 | Petr Pudlak | -> FilePath -- ^ socket path |
184 | 0fbc8447 | Petr Pudlak | -> IO Client |
185 | 0fbc8447 | Petr Pudlak | connectClient conf tmo path = do |
186 | cf51a981 | Jose A. Lopes | h <- openClientSocket tmo path |
187 | 71a4c605 | Petr Pudlak | rf <- newIORef B.empty |
188 | 0fbc8447 | Petr Pudlak | return Client { socket=h, rbuf=rf, clientConfig=conf } |
189 | 71a4c605 | Petr Pudlak | |
190 | 71a4c605 | Petr Pudlak | -- | Creates and returns a server endpoint. |
191 | 0fbc8447 | Petr Pudlak | connectServer :: ConnectConfig -> Bool -> FilePath -> IO Server |
192 | 0fbc8447 | Petr Pudlak | connectServer conf setOwner path = do |
193 | cf51a981 | Jose A. Lopes | s <- openServerSocket path |
194 | 0fbc8447 | Petr Pudlak | when setOwner . setOwnerAndGroupFromNames path (connDaemon conf) $ |
195 | 71a4c605 | Petr Pudlak | ExtraGroup DaemonsGroup |
196 | 71a4c605 | Petr Pudlak | S.listen s 5 -- 5 is the max backlog |
197 | 5e671e0e | Petr Pudlak | return Server { sSocket=s, sPath=path, serverConfig=conf } |
198 | 71a4c605 | Petr Pudlak | |
199 | 71a4c605 | Petr Pudlak | -- | Closes a server endpoint. |
200 | 5e671e0e | Petr Pudlak | closeServer :: Server -> IO () |
201 | cf51a981 | Jose A. Lopes | closeServer server = |
202 | cf51a981 | Jose A. Lopes | closeServerSocket (sSocket server) (sPath server) |
203 | 71a4c605 | Petr Pudlak | |
204 | 71a4c605 | Petr Pudlak | -- | Accepts a client |
205 | 0fbc8447 | Petr Pudlak | acceptClient :: Server -> IO Client |
206 | 71a4c605 | Petr Pudlak | acceptClient s = do |
207 | cf51a981 | Jose A. Lopes | handle <- acceptSocket (sSocket s) |
208 | 71a4c605 | Petr Pudlak | new_buffer <- newIORef B.empty |
209 | 0fbc8447 | Petr Pudlak | return Client { socket=handle |
210 | 0fbc8447 | Petr Pudlak | , rbuf=new_buffer |
211 | 0fbc8447 | Petr Pudlak | , clientConfig=serverConfig s |
212 | 0fbc8447 | Petr Pudlak | } |
213 | 71a4c605 | Petr Pudlak | |
214 | 71a4c605 | Petr Pudlak | -- | Closes the client socket. |
215 | 71a4c605 | Petr Pudlak | closeClient :: Client -> IO () |
216 | cf51a981 | Jose A. Lopes | closeClient = closeClientSocket . socket |
217 | 71a4c605 | Petr Pudlak | |
218 | 0fbc8447 | Petr Pudlak | -- | Sends a message over a transport. |
219 | 71a4c605 | Petr Pudlak | sendMsg :: Client -> String -> IO () |
220 | 0fbc8447 | Petr Pudlak | sendMsg s buf = withTimeout (sendTmo $ clientConfig s) "sending a message" $ do |
221 | 71a4c605 | Petr Pudlak | let encoded = UTF8L.fromString buf |
222 | 71a4c605 | Petr Pudlak | handle = socket s |
223 | 71a4c605 | Petr Pudlak | BL.hPut handle encoded |
224 | 71a4c605 | Petr Pudlak | B.hPut handle bEOM |
225 | 71a4c605 | Petr Pudlak | hFlush handle |
226 | 71a4c605 | Petr Pudlak | |
227 | 71a4c605 | Petr Pudlak | -- | Given a current buffer and the handle, it will read from the |
228 | 71a4c605 | Petr Pudlak | -- network until we get a full message, and it will return that |
229 | 71a4c605 | Petr Pudlak | -- message and the leftover buffer contents. |
230 | 0fbc8447 | Petr Pudlak | recvUpdate :: ConnectConfig -> Handle -> B.ByteString |
231 | 0fbc8447 | Petr Pudlak | -> IO (B.ByteString, B.ByteString) |
232 | 0fbc8447 | Petr Pudlak | recvUpdate conf handle obuf = do |
233 | 0fbc8447 | Petr Pudlak | nbuf <- withTimeout (recvTmo conf) "reading a response" $ do |
234 | 71a4c605 | Petr Pudlak | _ <- hWaitForInput handle (-1) |
235 | 71a4c605 | Petr Pudlak | B.hGetNonBlocking handle 4096 |
236 | 71a4c605 | Petr Pudlak | let (msg, remaining) = B.break (eOM ==) nbuf |
237 | 71a4c605 | Petr Pudlak | newbuf = B.append obuf msg |
238 | 71a4c605 | Petr Pudlak | if B.null remaining |
239 | 0fbc8447 | Petr Pudlak | then recvUpdate conf handle newbuf |
240 | 71a4c605 | Petr Pudlak | else return (newbuf, B.tail remaining) |
241 | 71a4c605 | Petr Pudlak | |
242 | 0fbc8447 | Petr Pudlak | -- | Waits for a message over a transport. |
243 | 71a4c605 | Petr Pudlak | recvMsg :: Client -> IO String |
244 | 71a4c605 | Petr Pudlak | recvMsg s = do |
245 | 71a4c605 | Petr Pudlak | cbuf <- readIORef $ rbuf s |
246 | 71a4c605 | Petr Pudlak | let (imsg, ibuf) = B.break (eOM ==) cbuf |
247 | 71a4c605 | Petr Pudlak | (msg, nbuf) <- |
248 | 71a4c605 | Petr Pudlak | if B.null ibuf -- if old buffer didn't contain a full message |
249 | 0fbc8447 | Petr Pudlak | -- then we read from network: |
250 | 0fbc8447 | Petr Pudlak | then recvUpdate (clientConfig s) (socket s) cbuf |
251 | 71a4c605 | Petr Pudlak | else return (imsg, B.tail ibuf) -- else we return data from our buffer |
252 | 71a4c605 | Petr Pudlak | writeIORef (rbuf s) nbuf |
253 | 71a4c605 | Petr Pudlak | return $ UTF8.toString msg |
254 | 71a4c605 | Petr Pudlak | |
255 | 71a4c605 | Petr Pudlak | -- | Extended wrapper over recvMsg. |
256 | 71a4c605 | Petr Pudlak | recvMsgExt :: Client -> IO RecvResult |
257 | 71a4c605 | Petr Pudlak | recvMsgExt s = |
258 | 71a4c605 | Petr Pudlak | Control.Exception.catch (liftM RecvOk (recvMsg s)) $ \e -> |
259 | 71a4c605 | Petr Pudlak | return $ if isEOFError e |
260 | 71a4c605 | Petr Pudlak | then RecvConnClosed |
261 | 71a4c605 | Petr Pudlak | else RecvError (show e) |
262 | 71a4c605 | Petr Pudlak | |
263 | 71a4c605 | Petr Pudlak | |
264 | 6e47412f | Petr Pudlak | -- | Parse the required keys out of a call. |
265 | d79a6502 | Petr Pudlak | parseCall :: (J.JSON mth, J.JSON args) => String -> Result (mth, args) |
266 | 6e47412f | Petr Pudlak | parseCall s = do |
267 | 6e47412f | Petr Pudlak | arr <- fromJResult "parsing top-level JSON message" $ |
268 | 6e47412f | Petr Pudlak | decodeStrict s :: Result (JSObject JSValue) |
269 | 6e47412f | Petr Pudlak | let keyFromObj :: (J.JSON a) => MsgKeys -> Result a |
270 | 6e47412f | Petr Pudlak | keyFromObj = fromObj (fromJSObject arr) . strOfKey |
271 | 6e47412f | Petr Pudlak | (,) <$> keyFromObj Method <*> keyFromObj Args |
272 | 6e47412f | Petr Pudlak | |
273 | 6e47412f | Petr Pudlak | |
274 | 71a4c605 | Petr Pudlak | -- | Serialize the response to String. |
275 | 71a4c605 | Petr Pudlak | buildResponse :: Bool -- ^ Success |
276 | 71a4c605 | Petr Pudlak | -> JSValue -- ^ The arguments |
277 | 71a4c605 | Petr Pudlak | -> String -- ^ The serialized form |
278 | 71a4c605 | Petr Pudlak | buildResponse success args = |
279 | 71a4c605 | Petr Pudlak | let ja = [ (strOfKey Success, JSBool success) |
280 | 71a4c605 | Petr Pudlak | , (strOfKey Result, args)] |
281 | 71a4c605 | Petr Pudlak | jo = toJSObject ja |
282 | 71a4c605 | Petr Pudlak | in encodeStrict jo |
283 | d79a6502 | Petr Pudlak | |
284 | c7003a76 | Petr Pudlak | -- | Logs an outgoing message. |
285 | c7003a76 | Petr Pudlak | logMsg |
286 | c7003a76 | Petr Pudlak | :: (Show e, J.JSON e, MonadLog m) |
287 | c7003a76 | Petr Pudlak | => Handler i o |
288 | c7003a76 | Petr Pudlak | -> i -- ^ the received request (used for logging) |
289 | c7003a76 | Petr Pudlak | -> GenericResult e J.JSValue -- ^ A message to be sent |
290 | c7003a76 | Petr Pudlak | -> m () |
291 | c7003a76 | Petr Pudlak | logMsg handler req (Bad err) = |
292 | c7003a76 | Petr Pudlak | logWarning $ "Failed to execute request " ++ hInputLogLong handler req ++ ": " |
293 | c7003a76 | Petr Pudlak | ++ show err |
294 | c7003a76 | Petr Pudlak | logMsg handler req (Ok result) = do |
295 | c7003a76 | Petr Pudlak | -- only log the first 2,000 chars of the result |
296 | c7003a76 | Petr Pudlak | logDebug $ "Result (truncated): " ++ take 2000 (J.encode result) |
297 | c7003a76 | Petr Pudlak | logInfo $ "Successfully handled " ++ hInputLogShort handler req |
298 | c7003a76 | Petr Pudlak | |
299 | c7003a76 | Petr Pudlak | -- | Prepares an outgoing message. |
300 | c7003a76 | Petr Pudlak | prepareMsg |
301 | c7003a76 | Petr Pudlak | :: (J.JSON e) |
302 | c7003a76 | Petr Pudlak | => GenericResult e J.JSValue -- ^ A message to be sent |
303 | c7003a76 | Petr Pudlak | -> (Bool, J.JSValue) |
304 | c7003a76 | Petr Pudlak | prepareMsg (Bad err) = (False, J.showJSON err) |
305 | c7003a76 | Petr Pudlak | prepareMsg (Ok result) = (True, result) |
306 | d79a6502 | Petr Pudlak | |
307 | d79a6502 | Petr Pudlak | |
308 | d79a6502 | Petr Pudlak | -- * Processing client requests |
309 | d79a6502 | Petr Pudlak | |
310 | d79a6502 | Petr Pudlak | type HandlerResult o = IO (Bool, GenericResult GanetiException o) |
311 | d79a6502 | Petr Pudlak | |
312 | d79a6502 | Petr Pudlak | data Handler i o = Handler |
313 | d79a6502 | Petr Pudlak | { hParse :: J.JSValue -> J.JSValue -> Result i |
314 | d79a6502 | Petr Pudlak | -- ^ parses method and its arguments into the input type |
315 | d79a6502 | Petr Pudlak | , hInputLogShort :: i -> String |
316 | d79a6502 | Petr Pudlak | -- ^ short description of an input, for the INFO logging level |
317 | d79a6502 | Petr Pudlak | , hInputLogLong :: i -> String |
318 | d79a6502 | Petr Pudlak | -- ^ long description of an input, for the DEBUG logging level |
319 | d79a6502 | Petr Pudlak | , hExec :: i -> HandlerResult o |
320 | d79a6502 | Petr Pudlak | -- ^ executes the handler on an input |
321 | d79a6502 | Petr Pudlak | } |
322 | c7003a76 | Petr Pudlak | |
323 | c7003a76 | Petr Pudlak | |
324 | c7003a76 | Petr Pudlak | handleJsonMessage |
325 | c7003a76 | Petr Pudlak | :: (J.JSON o) |
326 | c7003a76 | Petr Pudlak | => Handler i o -- ^ handler |
327 | c7003a76 | Petr Pudlak | -> i -- ^ parsed input |
328 | c7003a76 | Petr Pudlak | -> HandlerResult J.JSValue |
329 | c7003a76 | Petr Pudlak | handleJsonMessage handler req = do |
330 | c7003a76 | Petr Pudlak | (close, call_result) <- hExec handler req |
331 | c7003a76 | Petr Pudlak | return (close, fmap J.showJSON call_result) |
332 | c7003a76 | Petr Pudlak | |
333 | c7003a76 | Petr Pudlak | -- | Takes a request as a 'String', parses it, passes it to a handler and |
334 | c7003a76 | Petr Pudlak | -- formats its response. |
335 | c7003a76 | Petr Pudlak | handleRawMessage |
336 | c7003a76 | Petr Pudlak | :: (J.JSON o) |
337 | c7003a76 | Petr Pudlak | => Handler i o -- ^ handler |
338 | c7003a76 | Petr Pudlak | -> String -- ^ raw unparsed input |
339 | c7003a76 | Petr Pudlak | -> IO (Bool, String) |
340 | c7003a76 | Petr Pudlak | handleRawMessage handler payload = |
341 | c7003a76 | Petr Pudlak | case parseCall payload >>= uncurry (hParse handler) of |
342 | c7003a76 | Petr Pudlak | Bad err -> do |
343 | c7003a76 | Petr Pudlak | let errmsg = "Failed to parse request: " ++ err |
344 | c7003a76 | Petr Pudlak | logWarning errmsg |
345 | c7003a76 | Petr Pudlak | return (False, buildResponse False (J.showJSON errmsg)) |
346 | c7003a76 | Petr Pudlak | Ok req -> do |
347 | c7003a76 | Petr Pudlak | logDebug $ "Request: " ++ hInputLogLong handler req |
348 | c7003a76 | Petr Pudlak | (close, call_result_json) <- handleJsonMessage handler req |
349 | c7003a76 | Petr Pudlak | logMsg handler req call_result_json |
350 | c7003a76 | Petr Pudlak | let (status, response) = prepareMsg call_result_json |
351 | c7003a76 | Petr Pudlak | return (close, buildResponse status response) |
352 | c7003a76 | Petr Pudlak | |
353 | c7003a76 | Petr Pudlak | -- | Reads a request, passes it to a handler and sends a response back to the |
354 | c7003a76 | Petr Pudlak | -- client. |
355 | c7003a76 | Petr Pudlak | handleClient |
356 | c7003a76 | Petr Pudlak | :: (J.JSON o) |
357 | c7003a76 | Petr Pudlak | => Handler i o |
358 | c7003a76 | Petr Pudlak | -> Client |
359 | c7003a76 | Petr Pudlak | -> IO Bool |
360 | c7003a76 | Petr Pudlak | handleClient handler client = do |
361 | c7003a76 | Petr Pudlak | msg <- recvMsgExt client |
362 | c7003a76 | Petr Pudlak | logDebug $ "Received message: " ++ show msg |
363 | c7003a76 | Petr Pudlak | case msg of |
364 | c7003a76 | Petr Pudlak | RecvConnClosed -> logDebug "Connection closed" >> |
365 | c7003a76 | Petr Pudlak | return False |
366 | c7003a76 | Petr Pudlak | RecvError err -> logWarning ("Error during message receiving: " ++ err) >> |
367 | c7003a76 | Petr Pudlak | return False |
368 | c7003a76 | Petr Pudlak | RecvOk payload -> do |
369 | c7003a76 | Petr Pudlak | (close, outMsg) <- handleRawMessage handler payload |
370 | c7003a76 | Petr Pudlak | sendMsg client outMsg |
371 | c7003a76 | Petr Pudlak | return close |
372 | c7003a76 | Petr Pudlak | |
373 | c7003a76 | Petr Pudlak | -- | Main client loop: runs one loop of 'handleClient', and if that |
374 | c7003a76 | Petr Pudlak | -- doesn't report a finished (closed) connection, restarts itself. |
375 | c7003a76 | Petr Pudlak | clientLoop |
376 | c7003a76 | Petr Pudlak | :: (J.JSON o) |
377 | c7003a76 | Petr Pudlak | => Handler i o |
378 | c7003a76 | Petr Pudlak | -> Client |
379 | c7003a76 | Petr Pudlak | -> IO () |
380 | c7003a76 | Petr Pudlak | clientLoop handler client = do |
381 | c7003a76 | Petr Pudlak | result <- handleClient handler client |
382 | c7003a76 | Petr Pudlak | if result |
383 | c7003a76 | Petr Pudlak | then clientLoop handler client |
384 | c7003a76 | Petr Pudlak | else closeClient client |
385 | c7003a76 | Petr Pudlak | |
386 | c7003a76 | Petr Pudlak | -- | Main listener loop: accepts clients, forks an I/O thread to handle |
387 | c7003a76 | Petr Pudlak | -- that client. |
388 | c7003a76 | Petr Pudlak | listener |
389 | c7003a76 | Petr Pudlak | :: (J.JSON o) |
390 | c7003a76 | Petr Pudlak | => Handler i o |
391 | c7003a76 | Petr Pudlak | -> Server |
392 | c7003a76 | Petr Pudlak | -> IO () |
393 | c7003a76 | Petr Pudlak | listener handler server = do |
394 | c7003a76 | Petr Pudlak | client <- acceptClient server |
395 | c7003a76 | Petr Pudlak | _ <- forkIO $ clientLoop handler client |
396 | c7003a76 | Petr Pudlak | return () |