diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2012, Cetin Sert + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/splice.cabal b/splice.cabal new file mode 100644 --- /dev/null +++ b/splice.cabal @@ -0,0 +1,53 @@ +name: splice +version: 0.1 +stability: stable on Linux, experimental on other operating systems +synopsis: Socket to Socket Data Splicing +description: A library that implements efficient socket to socket + data transfer loops for proxy servers. + . + On Linux, it uses the zero-copy splice() system call: + . + . + On all other operating systems, it currently falls back + to a portable Haskell implementation that allocates a + constant-sized memory buffer before it enters an inner + loop which then uses hGetBufSome and hPutBuf; this avoids + lots of tiny allocations as would otherwise be caused by + recv and sendAll functions from Network.Socket.ByteString. + . + This work has been funded by Corsis Research and is used + in PortFusion: +license: BSD3 +license-file: LICENSE +author: Cetin Sert +maintainer: Cetin Sert +homepage: http://fusion.corsis.eu +category: Network +build-type: Simple +cabal-version: >=1.2 +copyright: Copyright © 2012 Cetin Sert +tested-with: GHC >= 7.4.3 + + +flag portable + description: explicitly enable portable splice implemented in Haskell + default : False + + +library + + hs-source-dirs: src + + exposed-modules: Network.Socket.Splice + + if os(linux) && !flag(portable) + build-depends: base >= 4 && <= 6, + network >= 2 && <= 4, + unix >= 2 && <= 4 + cpp-options: -DLINUX_SPLICE + ghc-options: -O2 -O3 -fllvm -optlo-O3 + else + build-depends: base >= 4 && <= 6, + network >= 2 && <= 4 + cpp-options: -ULINUX_SPLICE + ghc-options: -O2 -O3 diff --git a/src/Network/Socket/Splice.hsc b/src/Network/Socket/Splice.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Socket/Splice.hsc @@ -0,0 +1,173 @@ +-- | +-- Module : Network.Socket.Splice +-- Copyright : (c) Cetin Sert 2012 +-- License : BSD-style +-- +-- Maintainer : fusion@corsis.eu +-- Stability : stable +-- Portability : GHC-only + +#ifdef LINUX_SPLICE +#include +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +#endif + +module Network.Socket.Splice ( + Length + , zeroCopy + , loopSplice +#ifdef LINUX_SPLICE + , c_splice +#endif + ) where + +import Data.Word +import Foreign.Ptr + +import Network.Socket +import Control.Monad +import Control.Exception +import System.IO +import System.Posix.Types +import System.Posix.Internals +import GHC.IO.Handle.FD + +#ifdef LINUX_SPLICE +import Data.Int +import Data.Bits +import Unsafe.Coerce +import Foreign.C.Types +import Foreign.C.Error +import System.Posix.IO +#else +import Foreign.Marshal.Alloc +#endif + + +-- | Indicates whether 'loopSplice' uses zero copy system calls +-- or the portable user mode Haskell substitue implementation. +zeroCopy :: Bool -- ^ True: system calls; otherwise: portable. +zeroCopy = +#ifdef LINUX_SPLICE + True +#else + False +#endif + + +-------------------------------------------------------------------------------- + + +type Length = +#ifdef LINUX_SPLICE + (#type size_t) +#else + Int +#endif + +try_ :: IO () -> IO () +try_ a = (try a :: IO (Either SomeException ())) >> return () + + +-- | The 'loopSplice' function pipes data from +-- one socket to another in an infinite loop. +-- On Linux this happens in kernel space with +-- zero copying, between kernel and user space. +-- On other operating systems, a portable +-- implementation utilizes a user space buffer +-- and works on handles instead of file descriptors. +loopSplice + :: Length -- ^ Splice length + -> Socket -- ^ Source socket + -> Socket -- ^ Target socket + -> IO () +loopSplice len sIn sOut = do + + let throwRecv0 = error "Network.Socket.Splice.splice ended" + + let fdIn = fdSocket sIn + let fdOut = fdSocket sOut + +#ifdef LINUX_SPLICE + + print "LINUX-SPLICE" + + (r,w) <- createPipe -- r: read end of pipe + print ('+',r,w) -- w: write end of pipe + let s = Fd fdIn -- s: source socket + let t = Fd fdOut -- t: target socket + let n = nullPtr + let u = unsafeCoerce :: (#type ssize_t) -> (#type size_t) + let check = throwErrnoIfMinus1 "Network.Socket.Splice.splice" + let flags = sPLICE_F_MOVE .|. sPLICE_F_MORE + let setNonBlockingMode v = do setNonBlockingFD fdIn v + setNonBlockingFD fdOut v + + setNonBlockingMode False + finally + (forever $ do + bytes <- check $ c_splice s n w n len flags + if bytes > 0 + then c_splice r n t n (u bytes) flags + else throwRecv0) + (do closeFd r + closeFd w + try_ $ setNonBlockingMode True + print ('-',r,w)) + +#else + + s <- fdToHandle fdIn + t <- fdToHandle fdOut + hSetBuffering s NoBuffering + hSetBuffering t NoBuffering + a <- mallocBytes len :: IO (Ptr Word8) + + print "PORTABLE-SPLICE" + + finally + (forever $ do + bytes <- hGetBufSome s a len + if bytes > 0 + then hPutBuf t a bytes + else throwRecv0) + (do free a + try_ $ hClose s + try_ $ hClose t) + +#endif + + +-------------------------------------------------------------------------------- + + +#ifdef LINUX_SPLICE +-- SPLICE + +-- fcntl.h +-- ssize_t splice( +-- int fd_in, +-- loff_t* off_in, +-- int fd_out, +-- loff_t* off_out, +-- size_t len, +-- unsigned int flags +-- ); + +foreign import ccall "splice" + c_splice + :: Fd + -> Ptr (#type loff_t) + -> Fd + -> Ptr (#type loff_t) + -> (#type size_t) + -> Word + -> IO (#type ssize_t) + +sPLICE_F_MOVE :: Word +sPLICE_F_MOVE = (#const "SPLICE_F_MOVE") + +sPLICE_F_MORE :: Word +sPLICE_F_MORE = (#const "SPLICE_F_MORE") +#endif