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