Revision cc40185c

b/Makefile.am
61 61
	src/Ganeti/Block \
62 62
	src/Ganeti/Block/Drbd \
63 63
	src/Ganeti/Confd \
64
	src/Ganeti/Curl \
64 65
	src/Ganeti/DataCollectors \
65 66
	src/Ganeti/HTools \
66 67
	src/Ganeti/HTools/Backend \
......
122 123
	$(APIDOC_HS_DIR)/Ganeti/Block \
123 124
	$(APIDOC_HS_DIR)/Ganeti/Block/Drbd \
124 125
	$(APIDOC_HS_DIR)/Ganeti/Confd \
126
	$(APIDOC_HS_DIR)/Ganeti/Curl \
125 127
	$(APIDOC_HS_DIR)/Ganeti/DataCollectors \
126 128
	$(APIDOC_HS_DIR)/Ganeti/HTools \
127 129
	$(APIDOC_HS_DIR)/Ganeti/HTools/Backend \
......
492 494
	src/Ganeti/Confd/Types.hs \
493 495
	src/Ganeti/Confd/Utils.hs \
494 496
	src/Ganeti/Config.hs \
497
	src/Ganeti/Curl/Multi.hs \
495 498
	src/Ganeti/Daemon.hs \
496 499
	src/Ganeti/DataCollectors/CLI.hs \
497 500
	src/Ganeti/DataCollectors/Drbd.hs \
......
601 604
HS_BUILT_SRCS = \
602 605
	test/hs/Test/Ganeti/TestImports.hs \
603 606
	src/Ganeti/Constants.hs \
607
	src/Ganeti/Curl/Internal.hs \
604 608
	src/Ganeti/Version.hs
605
HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
609
HS_BUILT_SRCS_IN = \
610
	$(patsubst %,%.in,$(filter-out src/Ganeti/Curl/Internal.hs,$(HS_BUILT_SRCS))) \
611
	src/Ganeti/Curl/Internal.hsc
606 612

  
607 613
$(RUN_IN_TEMPDIR): | stamp-directories
608 614

  
......
1373 1379
	  PYTHONPATH=. $(RUN_IN_TEMPDIR) $(CURDIR)/$(CONVERT_CONSTANTS); \
1374 1380
	} > $@
1375 1381

  
1382
src/Ganeti/Curl/Internal.hs: src/Ganeti/Curl/Internal.hsc | stamp-directories
1383
	hsc2hs -o $@ $<
1384

  
1376 1385
test/hs/Test/Ganeti/TestImports.hs: test/hs/Test/Ganeti/TestImports.hs.in \
1377 1386
	$(built_base_sources)
1378 1387
	set -e; \
b/src/Ganeti/Curl/Internal.hsc
1
{-# LANGUAGE ForeignFunctionInterface #-}
2
{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
3
-- the above is needed due to the fact that hsc2hs generates code also
4
-- compatible with older compilers; see
5
-- http://hackage.haskell.org/trac/ghc/ticket/3844
6

  
7
{-| Hsc2hs definitions for 'Storable' interfaces.
8

  
9
-}
10

  
11
{-
12

  
13
Copyright (C) 2013 Google Inc.
14

  
15
This program is free software; you can redistribute it and/or modify
16
it under the terms of the GNU General Public License as published by
17
the Free Software Foundation; either version 2 of the License, or
18
(at your option) any later version.
19

  
20
This program is distributed in the hope that it will be useful, but
21
WITHOUT ANY WARRANTY; without even the implied warranty of
22
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
23
General Public License for more details.
24

  
25
You should have received a copy of the GNU General Public License
26
along with this program; if not, write to the Free Software
27
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28
02110-1301, USA.
29

  
30
-}
31

  
32
module Ganeti.Curl.Internal
33
  ( CurlMsgCode(..)
34
  , toMsgCode
35
  , fromMsgCode
36
  , CurlMsg(..)
37
  , errorBufferSize
38
  , CurlMCode(..)
39
  , toMCode
40
  ) where
41

  
42
import Foreign
43
import Foreign.C.Types
44

  
45
import Network.Curl
46

  
47
#include <curl/curl.h>
48

  
49
-- | Data representing a @CURLMSG@ enum.
50
data CurlMsgCode = CurlMsgNone
51
                 | CurlMsgDone
52
                 | CurlMsgUnknown CInt -- ^ Haskell specific code for
53
                                       -- unknown codes
54
                   deriving (Show, Eq)
55

  
56
-- | Data representing a @struct CURLMsg@.
57
data CurlMsg = CurlMsg
58
  { cmMessage :: CurlMsgCode -- ^ The message type
59
  , cmHandle  :: CurlH       -- ^ The internal curl handle to which it applies
60
  , cmResult  :: CurlCode    -- ^ The message-specific result
61
  }
62

  
63
-- | Partial 'Storable' instance for 'CurlMsg'; we do not extract all
64
-- fields, only the one we are interested in.
65
instance Storable CurlMsg where
66
  sizeOf    _ = (#size CURLMsg)
67
  alignment _ = alignment (undefined :: CInt)
68
  peek ptr = do
69
    msg <- (#peek CURLMsg, msg) ptr
70
    handle <- (#peek CURLMsg, easy_handle) ptr
71
    result <- (#peek CURLMsg, data.result) ptr
72
    return $ CurlMsg (toMsgCode msg) handle (toCode result)
73
  poke ptr (CurlMsg msg handle result) = do
74
    (#poke CURLMsg, msg) ptr (fromMsgCode msg)
75
    (#poke CURLMsg, easy_handle) ptr handle
76
    (#poke CURLMsg, data.result) ptr ((fromIntegral $ fromEnum result)::CInt)
77

  
78
-- | Minimum buffer size for 'CurlErrorBuffer'.
79
errorBufferSize :: Int
80
errorBufferSize = (#const CURL_ERROR_SIZE)
81

  
82
-- | Multi interface error codes.
83
data CurlMCode = CurlmCallMultiPerform
84
               | CurlmOK
85
               | CurlmBadHandle
86
               | CurlmBadEasyHandle
87
               | CurlmOutOfMemory
88
               | CurlmInternalError
89
               | CurlmBadSocket
90
               | CurlmUnknownOption
91
               | CurlmUnknown CInt -- ^ Haskell specific code denoting
92
                                   -- undefined codes (e.g. when
93
                                   -- libcurl has defined new codes
94
                                   -- that are not implemented yet)
95
                 deriving (Show, Eq)
96

  
97
-- | Convert a CInt CURLMSG code (as returned by the C library) to a
98
-- 'CurlMsgCode'. When an unknown code is received, the special
99
-- 'CurlMsgUnknown' constructor will be used.
100
toMsgCode :: CInt -> CurlMsgCode
101
toMsgCode (#const CURLMSG_NONE) = CurlMsgNone
102
toMsgCode (#const CURLMSG_DONE) = CurlMsgDone
103
toMsgCode v = CurlMsgUnknown v
104

  
105
-- | Convert a CurlMsgCode to a CInt.
106
fromMsgCode :: CurlMsgCode -> CInt
107
fromMsgCode CurlMsgNone = (#const CURLMSG_NONE)
108
fromMsgCode CurlMsgDone = (#const CURLMSG_DONE)
109
fromMsgCode (CurlMsgUnknown v) = v
110

  
111
-- | Convert a CInt CURLMcode (as returned by the C library) to a
112
-- 'CurlMCode'. When an unknown code is received, the special
113
-- 'CurlmUnknown' constructor will be used.
114
toMCode :: CInt -> CurlMCode
115
toMCode (#const CURLM_CALL_MULTI_PERFORM) = CurlmCallMultiPerform
116
toMCode (#const CURLM_OK)                 = CurlmOK
117
toMCode (#const CURLM_BAD_HANDLE)         = CurlmBadHandle
118
toMCode (#const CURLM_BAD_EASY_HANDLE)    = CurlmBadEasyHandle
119
toMCode (#const CURLM_OUT_OF_MEMORY)      = CurlmOutOfMemory
120
toMCode (#const CURLM_INTERNAL_ERROR)     = CurlmInternalError
121
toMCode (#const CURLM_BAD_SOCKET)         = CurlmBadSocket
122
toMCode (#const CURLM_UNKNOWN_OPTION)     = CurlmUnknownOption
123
toMCode v = CurlmUnknown v
b/src/Ganeti/Curl/Multi.hs
1
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
2

  
3
{-| Ganeti-specific implementation of the Curl multi interface
4
(<http://curl.haxx.se/libcurl/c/libcurl-multi.html>).
5

  
6
TODO: Evaluate implementing and switching to
7
curl_multi_socket_action(3) interface, which is deemed to be more
8
performant for high-numbers of connections (but this is not the case
9
for Ganeti).
10

  
11
-}
12

  
13
{-
14

  
15
Copyright (C) 2013 Google Inc.
16

  
17
This program is free software; you can redistribute it and/or modify
18
it under the terms of the GNU General Public License as published by
19
the Free Software Foundation; either version 2 of the License, or
20
(at your option) any later version.
21

  
22
This program is distributed in the hope that it will be useful, but
23
WITHOUT ANY WARRANTY; without even the implied warranty of
24
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
25
General Public License for more details.
26

  
27
You should have received a copy of the GNU General Public License
28
along with this program; if not, write to the Free Software
29
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
30
02110-1301, USA.
31

  
32
-}
33

  
34
module Ganeti.Curl.Multi where
35

  
36
import Control.Concurrent
37
import Control.Monad
38
import Data.IORef
39
import qualified Data.Map as Map
40
import Foreign.C.String
41
import Foreign.C.Types
42
import Foreign.Marshal
43
import Foreign.Ptr
44
import Foreign.Storable
45
import Network.Curl
46

  
47
import Ganeti.Curl.Internal
48
import Ganeti.Logging
49

  
50
-- * Data types
51

  
52
-- | Empty data type denoting a Curl multi handle. Naming is similar to
53
-- "Network.Curl" types.
54
data CurlM_
55

  
56
-- | Type alias for a pointer to a Curl multi handle.
57
type CurlMH = Ptr CurlM_
58

  
59
-- | Our type alias for maps indexing 'CurlH' handles to the 'IORef'
60
-- for the Curl code.
61
type HandleMap = Map.Map CurlH (IORef CurlCode)
62

  
63
-- * FFI declarations
64

  
65
foreign import ccall
66
  "curl_multi_init" curl_multi_init :: IO CurlMH
67

  
68
foreign import ccall
69
  "curl_multi_cleanup" curl_multi_cleanup :: CurlMH -> IO CInt
70

  
71
foreign import ccall
72
  "curl_multi_add_handle" curl_multi_add_handle :: CurlMH -> CurlH -> IO CInt
73

  
74
foreign import ccall
75
  "curl_multi_remove_handle" curl_multi_remove_handle :: CurlMH -> CurlH ->
76
                                                         IO CInt
77

  
78
foreign import ccall
79
  "curl_multi_perform" curl_multi_perform :: CurlMH -> Ptr CInt -> IO CInt
80

  
81
foreign import ccall
82
  "curl_multi_info_read" curl_multi_info_read :: CurlMH -> Ptr CInt
83
                                              -> IO (Ptr CurlMsg)
84

  
85
-- * Wrappers over FFI functions
86

  
87
-- | Adds an easy handle to a multi handle. This is a nicer wrapper
88
-- over 'curl_multi_add_handle' that fails for wrong codes.
89
curlMultiAddHandle :: CurlMH -> Curl -> IO ()
90
curlMultiAddHandle multi easy = do
91
  r <- curlPrim easy $ \_ x -> curl_multi_add_handle multi x
92
  when (toMCode r /= CurlmOK) .
93
    fail $ "Failed adding easy handle to multi handle: " ++ show r
94

  
95
-- | Nice wrapper over 'curl_multi_info_read' that massages the
96
-- results into Haskell types.
97
curlMultiInfoRead :: CurlMH -> IO (Maybe CurlMsg, CInt)
98
curlMultiInfoRead multi =
99
  alloca $ \ppending -> do
100
    pmsg <- curl_multi_info_read multi ppending
101
    pending <- peek ppending
102
    msg <- if pmsg == nullPtr
103
             then return Nothing
104
             else Just `fmap` peek pmsg
105
    return (msg, pending)
106

  
107
-- | Nice wrapper over 'curl_multi_perform'.
108
curlMultiPerform :: CurlMH -> IO (CurlMCode, CInt)
109
curlMultiPerform multi =
110
  alloca $ \running -> do
111
    mcode <- curl_multi_perform multi running
112
    running' <- peek running
113
    return (toMCode mcode, running')
114

  
115
-- * Helper functions
116

  
117
-- | Magical constant for the polling delay. This needs to be chosen such that:
118
--
119
-- * we don't poll too often; a slower poll allows the RTS to schedule
120
--   other threads, and let them work
121
--
122
-- * we don't want to pool too slow, so that Curl gets to act on the
123
--   handles that need it
124
pollDelayInterval :: Int
125
pollDelayInterval = 10000
126

  
127
-- | Writes incoming curl data to a list of strings, stored in an 'IORef'.
128
writeHandle :: IORef [String] -> Ptr CChar -> CInt -> CInt -> Ptr () -> IO CInt
129
writeHandle bufref cstr sz nelems _ = do
130
  let full_sz = sz * nelems
131
  hs_str <- peekCStringLen (cstr, fromIntegral full_sz)
132
  modifyIORef bufref (hs_str:)
133
  return full_sz
134

  
135
-- | Loops and extracts all pending messages from a Curl multi handle.
136
readMessages :: CurlMH -> HandleMap -> IO ()
137
readMessages mh hmap = do
138
  (cmsg, pending) <- curlMultiInfoRead mh
139
  case cmsg of
140
    Nothing -> return ()
141
    Just (CurlMsg msg eh res) -> do
142
      logDebug $ "Got msg! msg " ++ show msg ++ " res " ++ show res ++
143
               ", " ++ show pending ++ " messages left"
144
      let cref = (Map.!) hmap eh
145
      writeIORef cref res
146
      _ <- curl_multi_remove_handle mh eh
147
      when (pending > 0) $ readMessages mh hmap
148

  
149
-- | Loops and polls curl until there are no more remaining handles.
150
performMulti :: CurlMH -> HandleMap -> CInt -> IO ()
151
performMulti mh hmap expected = do
152
  (mcode, running) <- curlMultiPerform mh
153
  delay <- case mcode of
154
             CurlmCallMultiPerform -> return $ return ()
155
             CurlmOK -> return $ threadDelay pollDelayInterval
156
             code -> error $ "Received bad return code from" ++
157
                     "'curl_multi_perform': " ++ show code
158
  logDebug $ "mcode: " ++ show mcode ++ ", remaining: " ++ show running
159
  -- check if any handles are done and then retrieve their messages
160
  when (expected /= running) $ readMessages mh hmap
161
  -- and if we still have handles running, loop
162
  when (running > 0) $ delay >> performMulti mh hmap running
163

  
164
-- | Template for the Curl error buffer.
165
errorBuffer :: String
166
errorBuffer = replicate errorBufferSize '\0'
167

  
168
-- | Allocate a NULL-initialised error buffer.
169
mallocErrorBuffer :: IO CString
170
mallocErrorBuffer = fst `fmap` newCStringLen errorBuffer
171

  
172
-- | Initialise a curl handle. This is just a wrapper over the
173
-- "Network.Curl" function 'initialize', plus adding our options.
174
makeEasyHandle :: (IORef [String], Ptr CChar, ([CurlOption], URLString))
175
               -> IO Curl
176
makeEasyHandle (f, e, (opts, url)) = do
177
  h <- initialize
178
  setopts h opts
179
  setopts h [ CurlWriteFunction (writeHandle f)
180
            , CurlErrorBuffer e
181
            , CurlURL url
182
            , CurlFailOnError True
183
            , CurlNoSignal True
184
            , CurlProxy ""
185
            ]
186
  return h
187

  
188
-- * Main multi-call work function
189

  
190
-- | Perform a multi-call against a list of nodes.
191
execMultiCall :: [([CurlOption], String)] -> IO [(CurlCode, String)]
192
execMultiCall ous = do
193
  -- error buffers
194
  errorbufs <- mapM (\_ -> mallocErrorBuffer) ous
195
  -- result buffers
196
  outbufs <- mapM (\_ -> newIORef []) ous
197
  -- handles
198
  ehandles <- mapM makeEasyHandle $ zip3 outbufs errorbufs ous
199
  -- data.map holding handles to error code iorefs
200
  hmap <- foldM (\m h -> curlPrim h (\_ hnd -> do
201
                                       ccode <- newIORef CurlOK
202
                                       return $ Map.insert hnd ccode m
203
                                    )) Map.empty ehandles
204
  mh <- curl_multi_init
205
  mapM_ (curlMultiAddHandle mh) ehandles
206
  performMulti mh hmap (fromIntegral $ length ehandles)
207
  -- dummy code to keep the handles alive until here
208
  mapM_ (\h -> curlPrim h (\_ _ -> return ())) ehandles
209
  -- cleanup the multi handle
210
  mh_cleanup <- toMCode `fmap` curl_multi_cleanup mh
211
  when (mh_cleanup /= CurlmOK) .
212
    logError $ "Non-OK return from multi_cleanup: " ++ show mh_cleanup
213
  -- and now extract the data from the IORefs
214
  mapM (\(e, b, h) -> do
215
          s <- peekCString e
216
          free e
217
          cref <- curlPrim h (\_ hnd -> return $ (Map.!) hmap hnd)
218
          ccode <- readIORef cref
219
          result <- if ccode == CurlOK
220
                      then (concat . reverse) `fmap` readIORef b
221
                      else return s
222
          return (ccode, result)
223
       ) $ zip3 errorbufs outbufs ehandles

Also available in: Unified diff