Commits

Bryan O'Sullivan committed e6b1893

Add TCP_CORK / TCP_NOPUSH support

Comments (0)

Files changed (3)

     Network.Riak.Monoid
     Network.Riak.Protocol.Link
     Network.Riak.Connection.Internal
+    Network.Riak.Connection.NoPush
     Network.Riak.Protocol.Content
     Network.Riak.Tag
     Network.Riak.Types.Internal

src/Network/Riak/Connection/Internal.hs

 import Data.Binary.Put (Put, putWord32be, runPut)
 import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)
 import Data.Int (Int64)
+import Network.Riak.Connection.NoPush (setNoPush)
 import Network.Riak.Debug as Debug
 import Network.Riak.Protocol.ErrorResponse
 import Network.Riak.Protocol.SetClientIDRequest
     sendRequest conn req
     recvResponse_ conn (expectedResponse req)
 
+sendAll :: Socket -> L.ByteString -> IO ()
+sendAll sock bs = do
+  setNoPush sock True
+  L.sendAll sock bs
+  setNoPush sock False
+
 sendRequest :: (Request req) => Connection -> req -> IO ()
-sendRequest Connection{..} = L.sendAll connSock . runPut . putRequest
+sendRequest Connection{..} = sendAll connSock . runPut . putRequest
 
 recvResponse :: (Response a) => Connection -> IO a
 recvResponse conn = debugRecv showM $ go undefined where
     then forM_ reqs $ \req -> debug "pipe" $ ">>> " ++ showM req
     else debug "pipe" $ ">>> " ++ show numReqs ++ "x " ++ tag
   onIOException ("pipe " ++ tag) .
-    L.sendAll connSock . runPut . mapM_ putRequest $ reqs
+    sendAll connSock . runPut . mapM_ putRequest $ reqs
   replicateM numReqs $ readChan ch
 
 -- | Send a series of requests to the server, back to back, and
     then forM_ reqs $ \req -> debug "pipe" $ ">>> " ++ showM req
     else debug "pipe" $ ">>> " ++ show (length reqs) ++ "x " ++
                         show (messageTag (head reqs))
-  L.sendAll connSock . runPut . mapM_ putRequest $ reqs
+  sendAll connSock . runPut . mapM_ putRequest $ reqs
   takeMVar done
 
 onIOException :: String -> IO a -> IO a

src/Network/Riak/Connection/NoPush.hsc

+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- |
+-- Module:      Network.Riak.Connection.NoPush
+-- Copyright:   (c) 2011 MailRank, Inc.
+-- License:     Apache
+-- Maintainer:  Bryan O'Sullivan <bos@mailrank.com>
+-- Stability:   experimental
+-- Portability: portable
+--
+-- TCP madness.
+
+module Network.Riak.Connection.NoPush (setNoPush) where
+
+#include <sys/socket.h>
+#include <netinet/tcp.h>
+#include <netinet/in.h>
+
+import Foreign.C.Error (throwErrnoIfMinus1_)
+import Foreign.C.Types (CInt)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (sizeOf)
+import Network.Socket (Socket(..))
+
+noPush :: CInt
+#if defined(TCP_NOPUSH)
+noPush = #const TCP_NOPUSH
+#elif defined(TCP_CORK)
+noPush = #const TCP_CORK
+#else
+noPush = 0
+#endif
+
+setNoPush :: Socket -> Bool -> IO ()
+setNoPush _ _ | noPush == 0 = return ()
+setNoPush (MkSocket fd _ _ _ _) onOff = do
+  let v = if onOff then 1 else 0
+  with v $ \ptr ->
+    throwErrnoIfMinus1_ "setNoPush" $
+      c_setsockopt fd (#const IPPROTO_TCP) noPush ptr (fromIntegral (sizeOf v))
+
+foreign import ccall unsafe "setsockopt"
+  c_setsockopt :: CInt -> CInt -> CInt -> Ptr CInt -> CInt -> IO CInt
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.