root / src / Ganeti / Curl / Multi.hs @ 32be18fc
History | View | Annotate | Download (7.7 kB)
1 | cc40185c | Iustin Pop | {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} |
---|---|---|---|
2 | cc40185c | Iustin Pop | |
3 | cc40185c | Iustin Pop | {-| Ganeti-specific implementation of the Curl multi interface |
4 | cc40185c | Iustin Pop | (<http://curl.haxx.se/libcurl/c/libcurl-multi.html>). |
5 | cc40185c | Iustin Pop | |
6 | cc40185c | Iustin Pop | TODO: Evaluate implementing and switching to |
7 | cc40185c | Iustin Pop | curl_multi_socket_action(3) interface, which is deemed to be more |
8 | cc40185c | Iustin Pop | performant for high-numbers of connections (but this is not the case |
9 | cc40185c | Iustin Pop | for Ganeti). |
10 | cc40185c | Iustin Pop | |
11 | cc40185c | Iustin Pop | -} |
12 | cc40185c | Iustin Pop | |
13 | cc40185c | Iustin Pop | {- |
14 | cc40185c | Iustin Pop | |
15 | cc40185c | Iustin Pop | Copyright (C) 2013 Google Inc. |
16 | cc40185c | Iustin Pop | |
17 | cc40185c | Iustin Pop | This program is free software; you can redistribute it and/or modify |
18 | cc40185c | Iustin Pop | it under the terms of the GNU General Public License as published by |
19 | cc40185c | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
20 | cc40185c | Iustin Pop | (at your option) any later version. |
21 | cc40185c | Iustin Pop | |
22 | cc40185c | Iustin Pop | This program is distributed in the hope that it will be useful, but |
23 | cc40185c | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
24 | cc40185c | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
25 | cc40185c | Iustin Pop | General Public License for more details. |
26 | cc40185c | Iustin Pop | |
27 | cc40185c | Iustin Pop | You should have received a copy of the GNU General Public License |
28 | cc40185c | Iustin Pop | along with this program; if not, write to the Free Software |
29 | cc40185c | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
30 | cc40185c | Iustin Pop | 02110-1301, USA. |
31 | cc40185c | Iustin Pop | |
32 | cc40185c | Iustin Pop | -} |
33 | cc40185c | Iustin Pop | |
34 | cc40185c | Iustin Pop | module Ganeti.Curl.Multi where |
35 | cc40185c | Iustin Pop | |
36 | cc40185c | Iustin Pop | import Control.Concurrent |
37 | cc40185c | Iustin Pop | import Control.Monad |
38 | cc40185c | Iustin Pop | import Data.IORef |
39 | cc40185c | Iustin Pop | import qualified Data.Map as Map |
40 | cc40185c | Iustin Pop | import Foreign.C.String |
41 | cc40185c | Iustin Pop | import Foreign.C.Types |
42 | cc40185c | Iustin Pop | import Foreign.Marshal |
43 | cc40185c | Iustin Pop | import Foreign.Ptr |
44 | cc40185c | Iustin Pop | import Foreign.Storable |
45 | cc40185c | Iustin Pop | import Network.Curl |
46 | cc40185c | Iustin Pop | |
47 | cc40185c | Iustin Pop | import Ganeti.Curl.Internal |
48 | cc40185c | Iustin Pop | import Ganeti.Logging |
49 | cc40185c | Iustin Pop | |
50 | cc40185c | Iustin Pop | -- * Data types |
51 | cc40185c | Iustin Pop | |
52 | cc40185c | Iustin Pop | -- | Empty data type denoting a Curl multi handle. Naming is similar to |
53 | cc40185c | Iustin Pop | -- "Network.Curl" types. |
54 | cc40185c | Iustin Pop | data CurlM_ |
55 | cc40185c | Iustin Pop | |
56 | cc40185c | Iustin Pop | -- | Type alias for a pointer to a Curl multi handle. |
57 | cc40185c | Iustin Pop | type CurlMH = Ptr CurlM_ |
58 | cc40185c | Iustin Pop | |
59 | cc40185c | Iustin Pop | -- | Our type alias for maps indexing 'CurlH' handles to the 'IORef' |
60 | cc40185c | Iustin Pop | -- for the Curl code. |
61 | cc40185c | Iustin Pop | type HandleMap = Map.Map CurlH (IORef CurlCode) |
62 | cc40185c | Iustin Pop | |
63 | cc40185c | Iustin Pop | -- * FFI declarations |
64 | cc40185c | Iustin Pop | |
65 | cc40185c | Iustin Pop | foreign import ccall |
66 | cc40185c | Iustin Pop | "curl_multi_init" curl_multi_init :: IO CurlMH |
67 | cc40185c | Iustin Pop | |
68 | cc40185c | Iustin Pop | foreign import ccall |
69 | cc40185c | Iustin Pop | "curl_multi_cleanup" curl_multi_cleanup :: CurlMH -> IO CInt |
70 | cc40185c | Iustin Pop | |
71 | cc40185c | Iustin Pop | foreign import ccall |
72 | cc40185c | Iustin Pop | "curl_multi_add_handle" curl_multi_add_handle :: CurlMH -> CurlH -> IO CInt |
73 | cc40185c | Iustin Pop | |
74 | cc40185c | Iustin Pop | foreign import ccall |
75 | cc40185c | Iustin Pop | "curl_multi_remove_handle" curl_multi_remove_handle :: CurlMH -> CurlH -> |
76 | cc40185c | Iustin Pop | IO CInt |
77 | cc40185c | Iustin Pop | |
78 | cc40185c | Iustin Pop | foreign import ccall |
79 | cc40185c | Iustin Pop | "curl_multi_perform" curl_multi_perform :: CurlMH -> Ptr CInt -> IO CInt |
80 | cc40185c | Iustin Pop | |
81 | cc40185c | Iustin Pop | foreign import ccall |
82 | cc40185c | Iustin Pop | "curl_multi_info_read" curl_multi_info_read :: CurlMH -> Ptr CInt |
83 | cc40185c | Iustin Pop | -> IO (Ptr CurlMsg) |
84 | cc40185c | Iustin Pop | |
85 | cc40185c | Iustin Pop | -- * Wrappers over FFI functions |
86 | cc40185c | Iustin Pop | |
87 | cc40185c | Iustin Pop | -- | Adds an easy handle to a multi handle. This is a nicer wrapper |
88 | cc40185c | Iustin Pop | -- over 'curl_multi_add_handle' that fails for wrong codes. |
89 | cc40185c | Iustin Pop | curlMultiAddHandle :: CurlMH -> Curl -> IO () |
90 | cc40185c | Iustin Pop | curlMultiAddHandle multi easy = do |
91 | cc40185c | Iustin Pop | r <- curlPrim easy $ \_ x -> curl_multi_add_handle multi x |
92 | cc40185c | Iustin Pop | when (toMCode r /= CurlmOK) . |
93 | cc40185c | Iustin Pop | fail $ "Failed adding easy handle to multi handle: " ++ show r |
94 | cc40185c | Iustin Pop | |
95 | cc40185c | Iustin Pop | -- | Nice wrapper over 'curl_multi_info_read' that massages the |
96 | cc40185c | Iustin Pop | -- results into Haskell types. |
97 | cc40185c | Iustin Pop | curlMultiInfoRead :: CurlMH -> IO (Maybe CurlMsg, CInt) |
98 | cc40185c | Iustin Pop | curlMultiInfoRead multi = |
99 | cc40185c | Iustin Pop | alloca $ \ppending -> do |
100 | cc40185c | Iustin Pop | pmsg <- curl_multi_info_read multi ppending |
101 | cc40185c | Iustin Pop | pending <- peek ppending |
102 | cc40185c | Iustin Pop | msg <- if pmsg == nullPtr |
103 | cc40185c | Iustin Pop | then return Nothing |
104 | cc40185c | Iustin Pop | else Just `fmap` peek pmsg |
105 | cc40185c | Iustin Pop | return (msg, pending) |
106 | cc40185c | Iustin Pop | |
107 | cc40185c | Iustin Pop | -- | Nice wrapper over 'curl_multi_perform'. |
108 | cc40185c | Iustin Pop | curlMultiPerform :: CurlMH -> IO (CurlMCode, CInt) |
109 | cc40185c | Iustin Pop | curlMultiPerform multi = |
110 | cc40185c | Iustin Pop | alloca $ \running -> do |
111 | cc40185c | Iustin Pop | mcode <- curl_multi_perform multi running |
112 | cc40185c | Iustin Pop | running' <- peek running |
113 | cc40185c | Iustin Pop | return (toMCode mcode, running') |
114 | cc40185c | Iustin Pop | |
115 | cc40185c | Iustin Pop | -- * Helper functions |
116 | cc40185c | Iustin Pop | |
117 | cc40185c | Iustin Pop | -- | Magical constant for the polling delay. This needs to be chosen such that: |
118 | cc40185c | Iustin Pop | -- |
119 | cc40185c | Iustin Pop | -- * we don't poll too often; a slower poll allows the RTS to schedule |
120 | cc40185c | Iustin Pop | -- other threads, and let them work |
121 | cc40185c | Iustin Pop | -- |
122 | cc40185c | Iustin Pop | -- * we don't want to pool too slow, so that Curl gets to act on the |
123 | cc40185c | Iustin Pop | -- handles that need it |
124 | cc40185c | Iustin Pop | pollDelayInterval :: Int |
125 | cc40185c | Iustin Pop | pollDelayInterval = 10000 |
126 | cc40185c | Iustin Pop | |
127 | cc40185c | Iustin Pop | -- | Writes incoming curl data to a list of strings, stored in an 'IORef'. |
128 | cc40185c | Iustin Pop | writeHandle :: IORef [String] -> Ptr CChar -> CInt -> CInt -> Ptr () -> IO CInt |
129 | cc40185c | Iustin Pop | writeHandle bufref cstr sz nelems _ = do |
130 | cc40185c | Iustin Pop | let full_sz = sz * nelems |
131 | cc40185c | Iustin Pop | hs_str <- peekCStringLen (cstr, fromIntegral full_sz) |
132 | cc40185c | Iustin Pop | modifyIORef bufref (hs_str:) |
133 | cc40185c | Iustin Pop | return full_sz |
134 | cc40185c | Iustin Pop | |
135 | cc40185c | Iustin Pop | -- | Loops and extracts all pending messages from a Curl multi handle. |
136 | cc40185c | Iustin Pop | readMessages :: CurlMH -> HandleMap -> IO () |
137 | cc40185c | Iustin Pop | readMessages mh hmap = do |
138 | cc40185c | Iustin Pop | (cmsg, pending) <- curlMultiInfoRead mh |
139 | cc40185c | Iustin Pop | case cmsg of |
140 | cc40185c | Iustin Pop | Nothing -> return () |
141 | cc40185c | Iustin Pop | Just (CurlMsg msg eh res) -> do |
142 | cc40185c | Iustin Pop | logDebug $ "Got msg! msg " ++ show msg ++ " res " ++ show res ++ |
143 | cc40185c | Iustin Pop | ", " ++ show pending ++ " messages left" |
144 | cc40185c | Iustin Pop | let cref = (Map.!) hmap eh |
145 | cc40185c | Iustin Pop | writeIORef cref res |
146 | cc40185c | Iustin Pop | _ <- curl_multi_remove_handle mh eh |
147 | cc40185c | Iustin Pop | when (pending > 0) $ readMessages mh hmap |
148 | cc40185c | Iustin Pop | |
149 | cc40185c | Iustin Pop | -- | Loops and polls curl until there are no more remaining handles. |
150 | cc40185c | Iustin Pop | performMulti :: CurlMH -> HandleMap -> CInt -> IO () |
151 | cc40185c | Iustin Pop | performMulti mh hmap expected = do |
152 | cc40185c | Iustin Pop | (mcode, running) <- curlMultiPerform mh |
153 | cc40185c | Iustin Pop | delay <- case mcode of |
154 | cc40185c | Iustin Pop | CurlmCallMultiPerform -> return $ return () |
155 | cc40185c | Iustin Pop | CurlmOK -> return $ threadDelay pollDelayInterval |
156 | cc40185c | Iustin Pop | code -> error $ "Received bad return code from" ++ |
157 | cc40185c | Iustin Pop | "'curl_multi_perform': " ++ show code |
158 | cc40185c | Iustin Pop | logDebug $ "mcode: " ++ show mcode ++ ", remaining: " ++ show running |
159 | cc40185c | Iustin Pop | -- check if any handles are done and then retrieve their messages |
160 | cc40185c | Iustin Pop | when (expected /= running) $ readMessages mh hmap |
161 | cc40185c | Iustin Pop | -- and if we still have handles running, loop |
162 | cc40185c | Iustin Pop | when (running > 0) $ delay >> performMulti mh hmap running |
163 | cc40185c | Iustin Pop | |
164 | cc40185c | Iustin Pop | -- | Template for the Curl error buffer. |
165 | cc40185c | Iustin Pop | errorBuffer :: String |
166 | cc40185c | Iustin Pop | errorBuffer = replicate errorBufferSize '\0' |
167 | cc40185c | Iustin Pop | |
168 | cc40185c | Iustin Pop | -- | Allocate a NULL-initialised error buffer. |
169 | cc40185c | Iustin Pop | mallocErrorBuffer :: IO CString |
170 | cc40185c | Iustin Pop | mallocErrorBuffer = fst `fmap` newCStringLen errorBuffer |
171 | cc40185c | Iustin Pop | |
172 | cc40185c | Iustin Pop | -- | Initialise a curl handle. This is just a wrapper over the |
173 | cc40185c | Iustin Pop | -- "Network.Curl" function 'initialize', plus adding our options. |
174 | cc40185c | Iustin Pop | makeEasyHandle :: (IORef [String], Ptr CChar, ([CurlOption], URLString)) |
175 | cc40185c | Iustin Pop | -> IO Curl |
176 | cc40185c | Iustin Pop | makeEasyHandle (f, e, (opts, url)) = do |
177 | cc40185c | Iustin Pop | h <- initialize |
178 | cc40185c | Iustin Pop | setopts h opts |
179 | cc40185c | Iustin Pop | setopts h [ CurlWriteFunction (writeHandle f) |
180 | cc40185c | Iustin Pop | , CurlErrorBuffer e |
181 | cc40185c | Iustin Pop | , CurlURL url |
182 | cc40185c | Iustin Pop | , CurlFailOnError True |
183 | cc40185c | Iustin Pop | , CurlNoSignal True |
184 | cc40185c | Iustin Pop | , CurlProxy "" |
185 | cc40185c | Iustin Pop | ] |
186 | cc40185c | Iustin Pop | return h |
187 | cc40185c | Iustin Pop | |
188 | cc40185c | Iustin Pop | -- * Main multi-call work function |
189 | cc40185c | Iustin Pop | |
190 | cc40185c | Iustin Pop | -- | Perform a multi-call against a list of nodes. |
191 | cc40185c | Iustin Pop | execMultiCall :: [([CurlOption], String)] -> IO [(CurlCode, String)] |
192 | cc40185c | Iustin Pop | execMultiCall ous = do |
193 | cc40185c | Iustin Pop | -- error buffers |
194 | ffc18bb2 | Thomas Thrainer | errorbufs <- mapM (const mallocErrorBuffer) ous |
195 | cc40185c | Iustin Pop | -- result buffers |
196 | cc40185c | Iustin Pop | outbufs <- mapM (\_ -> newIORef []) ous |
197 | cc40185c | Iustin Pop | -- handles |
198 | cc40185c | Iustin Pop | ehandles <- mapM makeEasyHandle $ zip3 outbufs errorbufs ous |
199 | cc40185c | Iustin Pop | -- data.map holding handles to error code iorefs |
200 | cc40185c | Iustin Pop | hmap <- foldM (\m h -> curlPrim h (\_ hnd -> do |
201 | cc40185c | Iustin Pop | ccode <- newIORef CurlOK |
202 | cc40185c | Iustin Pop | return $ Map.insert hnd ccode m |
203 | cc40185c | Iustin Pop | )) Map.empty ehandles |
204 | cc40185c | Iustin Pop | mh <- curl_multi_init |
205 | cc40185c | Iustin Pop | mapM_ (curlMultiAddHandle mh) ehandles |
206 | cc40185c | Iustin Pop | performMulti mh hmap (fromIntegral $ length ehandles) |
207 | cc40185c | Iustin Pop | -- dummy code to keep the handles alive until here |
208 | cc40185c | Iustin Pop | mapM_ (\h -> curlPrim h (\_ _ -> return ())) ehandles |
209 | cc40185c | Iustin Pop | -- cleanup the multi handle |
210 | cc40185c | Iustin Pop | mh_cleanup <- toMCode `fmap` curl_multi_cleanup mh |
211 | cc40185c | Iustin Pop | when (mh_cleanup /= CurlmOK) . |
212 | cc40185c | Iustin Pop | logError $ "Non-OK return from multi_cleanup: " ++ show mh_cleanup |
213 | cc40185c | Iustin Pop | -- and now extract the data from the IORefs |
214 | cc40185c | Iustin Pop | mapM (\(e, b, h) -> do |
215 | cc40185c | Iustin Pop | s <- peekCString e |
216 | cc40185c | Iustin Pop | free e |
217 | cc40185c | Iustin Pop | cref <- curlPrim h (\_ hnd -> return $ (Map.!) hmap hnd) |
218 | cc40185c | Iustin Pop | ccode <- readIORef cref |
219 | cc40185c | Iustin Pop | result <- if ccode == CurlOK |
220 | cc40185c | Iustin Pop | then (concat . reverse) `fmap` readIORef b |
221 | cc40185c | Iustin Pop | else return s |
222 | cc40185c | Iustin Pop | return (ccode, result) |
223 | cc40185c | Iustin Pop | ) $ zip3 errorbufs outbufs ehandles |