packages feed

network-socket-options (empty) → 0.1

raw patch · 6 files changed

+682/−0 lines, 6 filesdep +basedep +networksetup-changed

Dependencies added: base, network

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Joseph Adams++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.++    * Neither the name of Joseph Adams nor the names of other+      contributors may 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.
+ Network/Socket/Options.hsc view
@@ -0,0 +1,311 @@+------------------------------------------------------------------------+-- |+-- Module:       Network.Socket.Options+-- Copyright:    (c) Joseph Adams 2012+-- License:      BSD3+-- Maintainer:   joeyadams3.14159@gmail.com+--+-- Documentation is currently lacking.  For now, see @man 7 socket@ and+-- @man 7 tcp@ of the Linux man-pages, or look up setsockopt in MSDN.+{-# LANGUAGE ForeignFunctionInterface #-}+module Network.Socket.Options+    (+    -- * Getting options+    getAcceptConn,+    getBroadcast,+    getDebug,+    getDontRoute,+    getError,+    getKeepAlive,+    getLinger,+    getOOBInline,+    getRecvBuf,+    getRecvTimeout,+    getReuseAddr,+    getSendBuf,+    getSendTimeout,+    getType,++    -- ** TCP+    getTcpNoDelay,++    -- * Setting options+    setBroadcast,+    setDebug,+    setDontRoute,+    setKeepAlive,+    setLinger,+    setOOBInline,+    setRecvBuf,+    setRecvTimeout,+    setReuseAddr,+    setSendBuf,+    setSendTimeout,++    -- ** TCP+    setTcpNoDelay,++    -- * Types+    HasSocket(..),+    Seconds,+    Microseconds,+    ) where++#if mingw32_HOST_OS+#include <winsock2.h>+#else+#include <netinet/in.h>+#include <netinet/tcp.h>+#include <sys/socket.h>+#include <sys/types.h>+#endif++import Data.Int (Int64)+import Foreign.C.Types+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr)+import Foreign.Storable (peek)+import Network.Socket (Socket, SocketType(..), fdSocket)+import Network.Socket.Internal (throwSocketErrorIfMinus1_)+import System.Posix.Types (Fd(Fd))++#ifdef __GLASGOW_HASKELL__+import qualified GHC.IO.FD as FD+#endif++-- | The getters and setters in this module can be used not only on 'Socket's,+-- but on raw 'Fd's (file descriptors) as well.+class HasSocket a where+    getSocket :: a -> CInt++instance HasSocket Fd where+    getSocket (Fd n) = n++instance HasSocket Socket where+    getSocket = fdSocket++#ifdef __GLASGOW_HASKELL__+instance HasSocket FD.FD where+    getSocket = FD.fdFD+#endif++type Seconds        = Int+type Microseconds   = Int64++{-+It would be cute to have:++    data SocketOption a = ...++so we can say:++    setSocketOption :: Socket -> SocketOption a -> a -> IO ()+    getSocketOption :: Socket -> SocketOption a -> IO a++However, that's probably less convenient to use, and it bars socket options+that support get but not set or vice versa (e.g. SO_ACCEPTCONN and SO_TYPE).+-}++------------------------------------------------------------------------+-- Getting options++-- | This option is get-only.+getAcceptConn :: HasSocket sock => sock -> IO Bool+getAcceptConn = getBool #{const SOL_SOCKET} #{const SO_ACCEPTCONN}++getBroadcast :: HasSocket sock => sock -> IO Bool+getBroadcast = getBool #{const SOL_SOCKET} #{const SO_BROADCAST}++getDebug :: HasSocket sock => sock -> IO Bool+getDebug = getBool #{const SOL_SOCKET} #{const SO_DEBUG}++getDontRoute :: HasSocket sock => sock -> IO Bool+getDontRoute = getBool #{const SOL_SOCKET} #{const SO_DONTROUTE}++-- | This option is get-only.+getError :: HasSocket sock => sock -> IO Int+getError = getInt #{const SOL_SOCKET} #{const SO_ERROR}++getKeepAlive :: HasSocket sock => sock -> IO Bool+getKeepAlive = getBool #{const SOL_SOCKET} #{const SO_KEEPALIVE}++getLinger :: HasSocket sock => sock -> IO (Maybe Seconds)+getLinger sock =+    alloca $ \l_onoff_ptr ->+    alloca $ \l_linger_ptr -> do+        throwSocketErrorIfMinus1_ "getsockopt" $+            c_getsockopt_linger (getSocket sock) l_onoff_ptr l_linger_ptr+        onoff <- peek l_onoff_ptr+        if onoff /= 0+            then (Just . fromIntegral) `fmap` peek l_linger_ptr+            else return Nothing++getOOBInline :: HasSocket sock => sock -> IO Bool+getOOBInline = getBool #{const SOL_SOCKET} #{const SO_OOBINLINE}++getRecvBuf :: HasSocket sock => sock -> IO Int+getRecvBuf = getInt #{const SOL_SOCKET} #{const SO_RCVBUF}++getRecvTimeout :: HasSocket sock => sock -> IO Microseconds+getRecvTimeout = getTime #{const SOL_SOCKET} #{const SO_RCVTIMEO}++getReuseAddr :: HasSocket sock => sock -> IO Bool+getReuseAddr = getBool #{const SOL_SOCKET} #{const SO_REUSEADDR}++getSendBuf :: HasSocket sock => sock -> IO Int+getSendBuf = getInt #{const SOL_SOCKET} #{const SO_SNDBUF}++getSendTimeout :: HasSocket sock => sock -> IO Microseconds+getSendTimeout = getTime #{const SOL_SOCKET} #{const SO_SNDTIMEO}++-- | This option is get-only.+getType :: HasSocket sock => sock -> IO SocketType+getType sock =+    toSocketType `fmap` getCInt #{const SOL_SOCKET} #{const SO_TYPE} sock++toSocketType :: CInt -> SocketType+toSocketType t = case t of+#ifdef SOCK_STREAM+    #{const SOCK_STREAM} -> Stream+#endif+#ifdef SOCK_DGRAM+    #{const SOCK_DGRAM} -> Datagram+#endif+#ifdef SOCK_RAW+    #{const SOCK_RAW} -> Raw+#endif+#ifdef SOCK_RDM+    #{const SOCK_RDM} -> RDM+#endif+#ifdef SOCK_SEQPACKET+    #{const SOCK_SEQPACKET} -> SeqPacket+#endif+    _ -> error $ "Network.Socket.Options.getType: Unknown socket type #" ++ show t++getTcpNoDelay :: HasSocket sock => sock -> IO Bool+getTcpNoDelay = getBool #{const IPPROTO_TCP} #{const TCP_NODELAY}++------------------------------------------------------------------------+-- Setting options++setBroadcast :: HasSocket sock => sock -> Bool -> IO ()+setBroadcast = setBool #{const SOL_SOCKET} #{const SO_BROADCAST}++setDebug :: HasSocket sock => sock -> Bool -> IO ()+setDebug = setBool #{const SOL_SOCKET} #{const SO_DEBUG}++setDontRoute :: HasSocket sock => sock -> Bool -> IO ()+setDontRoute = setBool #{const SOL_SOCKET} #{const SO_DONTROUTE}++setKeepAlive :: HasSocket sock => sock -> Bool -> IO ()+setKeepAlive = setBool #{const SOL_SOCKET} #{const SO_KEEPALIVE}++-- | On Windows, the 'Seconds' value is truncated to 16 bits.  This means if a+-- linger time of more than 65535 seconds (about 18.2 hours) is given, it will+-- wrap around.+setLinger :: HasSocket sock => sock -> Maybe Seconds -> IO ()+setLinger sock (Just linger) =+    throwSocketErrorIfMinus1_ "setsockopt" $+        c_setsockopt_linger (getSocket sock) 1 (fromIntegral linger)+setLinger sock Nothing =+    throwSocketErrorIfMinus1_ "setsockopt" $+        c_setsockopt_linger (getSocket sock) 0 0++setOOBInline :: HasSocket sock => sock -> Bool -> IO ()+setOOBInline = setBool #{const SOL_SOCKET} #{const SO_OOBINLINE}++setRecvBuf :: HasSocket sock => sock -> Int -> IO ()+setRecvBuf = setInt #{const SOL_SOCKET} #{const SO_RCVBUF}++-- | Note the following about timeout values:+--+--  * A value of 0 or less means the operation will never time out+--+--  * On Windows, the timeout is truncated to milliseconds, 32-bit.  However,+--    if the number of microseconds is from 1 to 999, it will be rounded up to+--    one millisecond, to prevent it from being treated as \"never time out\".+setRecvTimeout :: HasSocket sock => sock -> Microseconds -> IO ()+setRecvTimeout = setTime #{const SOL_SOCKET} #{const SO_RCVTIMEO}++setReuseAddr :: HasSocket sock => sock -> Bool -> IO ()+setReuseAddr = setBool #{const SOL_SOCKET} #{const SO_REUSEADDR}++setSendBuf :: HasSocket sock => sock -> Int -> IO ()+setSendBuf = setInt #{const SOL_SOCKET} #{const SO_SNDBUF}++setSendTimeout :: HasSocket sock => sock -> Microseconds -> IO ()+setSendTimeout = setTime #{const SOL_SOCKET} #{const SO_SNDTIMEO}++setTcpNoDelay :: HasSocket sock => sock -> Bool -> IO ()+setTcpNoDelay = setBool #{const IPPROTO_TCP} #{const TCP_NODELAY}++------------------------------------------------------------------------+-- Wrappers++type SockFd     = CInt+type Level      = CInt+type OptName    = CInt++getBool :: HasSocket sock => Level -> OptName -> sock -> IO Bool+getBool level optname sock =+    (/= 0) `fmap` getCInt level optname sock++setBool :: HasSocket sock => Level -> OptName -> sock -> Bool -> IO ()+setBool level optname sock b =+    setCInt level optname sock (fromIntegral $ fromEnum b)++getInt :: HasSocket sock => Level -> OptName -> sock -> IO Int+getInt level optname sock =+    fromIntegral `fmap` getCInt level optname sock++setInt :: HasSocket sock => Level -> OptName -> sock -> Int -> IO ()+setInt level optname sock n =+    setCInt level optname sock (fromIntegral n)++getCInt :: HasSocket sock => Level -> OptName -> sock -> IO CInt+getCInt level optname sock =+    alloca $ \ptr -> do+        throwSocketErrorIfMinus1_ "getsockopt" $+            c_getsockopt_int (getSocket sock) level optname ptr+        peek ptr++setCInt :: HasSocket sock => Level -> OptName -> sock -> CInt -> IO ()+setCInt level optname sock n =+    throwSocketErrorIfMinus1_ "setsockopt" $+        c_setsockopt_int (getSocket sock) level optname n++getTime :: HasSocket sock => Level -> OptName -> sock -> IO Microseconds+getTime level optname sock =+    alloca $ \ptr -> do+        throwSocketErrorIfMinus1_ "getsockopt" $+            c_getsockopt_time (getSocket sock) level optname ptr+        peek ptr++setTime :: HasSocket sock => Level -> OptName -> sock -> Microseconds -> IO ()+setTime level optname sock usec =+    throwSocketErrorIfMinus1_ "setsockopt" $+        c_setsockopt_time (getSocket sock) level optname usec++foreign import ccall+    c_getsockopt_int :: SockFd -> Level -> OptName -> Ptr CInt -> IO CInt++foreign import ccall+    c_setsockopt_int :: SockFd -> Level -> OptName -> CInt -> IO CInt++foreign import ccall+    c_getsockopt_time :: SockFd -> Level -> OptName -> Ptr Int64 -> IO CInt++foreign import ccall+    c_setsockopt_time :: SockFd -> Level -> OptName -> Int64 -> IO CInt++foreign import ccall+    c_getsockopt_linger :: SockFd+                        -> Ptr CInt -- ^ l_onoff+                        -> Ptr CInt -- ^ l_linger+                        -> IO CInt++foreign import ccall+    c_setsockopt_linger :: SockFd+                        -> CInt     -- ^ l_onoff+                        -> CInt     -- ^ l_linger+                        -> IO CInt
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/sockopt.c view
@@ -0,0 +1,107 @@+#include <stdint.h>++#if unix++#include <netinet/in.h>+#include <netinet/tcp.h>+#include <sys/socket.h>+#include <sys/types.h>++typedef socklen_t my_socklen_t;++#else++#include <winsock2.h>++typedef int my_socklen_t;++#endif+++int c_getsockopt_int(int sockfd, int level, int optname, int *opt_out)+{+    my_socklen_t optlen = sizeof(*opt_out);+    return getsockopt(sockfd, level, optname, (void *) opt_out, &optlen);+}++int c_setsockopt_int(int sockfd, int level, int optname, int optval)+{+    return setsockopt(sockfd, level, optname, (const void *) &optval, sizeof(optval));+}++int c_getsockopt_time(int sockfd, int level, int optname, int64_t *usec_out)+{+#if unix+    struct timeval tv;+    my_socklen_t optlen = sizeof(tv);+    int rc = getsockopt(sockfd, level, optname, (void *) &tv, &optlen);++    if (rc != -1)+        *usec_out = (int64_t)tv.tv_sec * 1000000 + tv.tv_usec;++    return rc;+#else+    DWORD msec;+    my_socklen_t optlen = sizeof(msec);+    int rc = getsockopt(sockfd, level, optname, (void *) &msec, &optlen);++    if (rc != -1)+        *usec_out = (int64_t)msec * 1000;++    return rc;+#endif+}++int c_setsockopt_time(int sockfd, int level, int optname, int64_t usec)+{+#if unix+    struct timeval tv;++    if (usec <= 0) {+        tv.tv_sec  = 0;+        tv.tv_usec = 0;+    } else {+        tv.tv_sec  = usec / 1000000;+        tv.tv_usec = usec % 1000000;+    }++    return setsockopt(sockfd, level, optname, (const void *) &tv, sizeof(tv));+#else+    DWORD msec;++    if (usec <= 0) {+        msec = 0;+    } else {+        msec = usec / 1000;++        /* Prevent non-zero usec value from being treated as "never time out". */+        if (msec == 0)+            msec = 1;+    }++    return setsockopt(sockfd, level, optname, (const void *) &msec, sizeof(msec));+#endif+}++int c_getsockopt_linger(int sockfd, int *l_onoff, int *l_linger)+{+    struct linger linger;+    my_socklen_t optlen = sizeof(linger);+    int rc = getsockopt(sockfd, SOL_SOCKET, SO_LINGER, (void *) &linger, &optlen);++    if (rc != -1) {+        *l_onoff  = linger.l_onoff;+        *l_linger = linger.l_linger;+    }++    return rc;+}++int c_setsockopt_linger(int sockfd, int l_onoff, int l_linger)+{+    struct linger linger = {+        l_onoff  = l_onoff,+        l_linger = l_linger,+    };+    return setsockopt(sockfd, SOL_SOCKET, SO_LINGER, (const void *) &linger, sizeof(linger));+}
+ network-socket-options.cabal view
@@ -0,0 +1,44 @@+name:                network-socket-options+version:             0.1+synopsis:            Type-safe, portable alternative to getSocketOption/setSocketOption+description:+    The network package provides getSocketOption and setSocketOption functions.+    These work fine for socket options represented using the @int@ type+    (namely, all boolean options, and a few quantity options).  However, it+    doesn't work for, say, @SO_LINGER@, @SO_RCVTIMEO@, and @SO_SNDTIMEO@, as+    these use different, platform-specific representations.+    .+    This package implements the getters and setters as separate functions.  At+    the moment, it only provides socket options that are available for both+    Unix and Windows.+homepage:            https://github.com/joeyadams/haskell-network-socket-options+license:             BSD3+license-file:        LICENSE+author:              Joey Adams+maintainer:          joeyadams3.14159@gmail.com+copyright:           Copyright (c) Joseph Adams 2012+category:            Network+build-type:          Simple+cabal-version:       >=1.8++extra-source-files:+    testing/trivial.hs++source-repository head+    type:       git+    location:   git://github.com/joeyadams/haskell-network-socket-options.git++library+    exposed-modules:+        Network.Socket.Options++    c-sources: cbits/sockopt.c++    build-tools: hsc2hs++    ghc-options: -Wall -fwarn-tabs++    other-extensions: ForeignFunctionInterface++    build-depends: base == 4.*+                 , network
+ testing/trivial.hs view
@@ -0,0 +1,188 @@+-- Make sure getting and setting work.  This doesn't test if the options+-- actually do anything, it just makes sure getsockopt reflects changes by+-- setsockopt.+--+-- TODO: Add test for getError+{-# LANGUAGE CPP #-}+import qualified Network.Socket.Options as Opt++import Prelude hiding (catch, last)++import Control.Exception+import Control.Monad+import Network.Socket++type Getter a = Socket -> IO a+type Setter a = Socket -> a -> IO ()++test_getType :: IO ()+test_getType = runTest "getType" $ do+    f AF_INET Stream    0+    f AF_INET Datagram  0+    f AF_INET Raw       1+    where+        f domain type_ protocol = do+            e <- try $ socket domain type_ protocol+            case e of+                Left ex ->+                    not_ok (show type_) $ show (ex :: SomeException)+                Right sock -> do+                    t <- Opt.getType sock+                    if t == type_+                        then ok     (show type_)+                        else not_ok (show type_) $ "getType returned " ++ show t ++ " instead"++test_getAcceptConn :: IO ()+test_getAcceptConn = runTest "getAcceptConn" $ do+    sock <- socket AF_INET Stream defaultProtocol+    a1 <- Opt.getAcceptConn sock+    expect (a1 == False) "getAcceptConn returns False for a fresh socket"++    bindSocket sock $ SockAddrInet 1234 iNADDR_ANY+    a2 <- Opt.getAcceptConn sock+    expect (a2 == False) "getAcceptConn returns False after bindSocket"++    listen sock 5+    a3 <- Opt.getAcceptConn sock+    expect (a3 == True) "getAcceptConn returns True after listen is called"++testBool :: String -> Getter Bool -> Setter Bool -> IO ()+testBool = testBoolWithSocketType Stream++testBoolWithSocketType :: SocketType -> String -> Getter Bool -> Setter Bool -> IO ()+testBoolWithSocketType type_ name get set = runTest name $ do+    sock <- socket AF_INET type_ defaultProtocol++    v1 <- get sock+    ok $ "Initial value: " ++ show v1++    set sock (not v1)+    v2 <- get sock+    expect (v2 == not v1) "setsockopt changed result of getsockopt"++    set sock v1+    v3 <- get sock+    expect (v3 == v1) "setsockopt changed result of getsockopt again"++testInt :: String -> Getter Int -> Setter Int -> IO ()+testInt name get set = runTest name $ do+    sock <- socket AF_INET Stream defaultProtocol++    v1 <- get sock+    ok $ "Initial value: " ++ show v1++    let setTo last v = do+            set sock v+            actual <- get sock+            if actual /= last+                then ok     ("set " ++ show v ++ ", got " ++ show actual)+                else not_ok (show v) ("value did not change")+            return actual++    _ <- foldM setTo v1 [0, 10000, 1, 1000000, 0]+    return ()++testMicroseconds+    :: String+    -> Getter Opt.Microseconds+    -> Setter Opt.Microseconds+    -> IO ()+testMicroseconds name get set = runTest name $ do+    sock <- socket AF_INET Stream defaultProtocol++    v1 <- get sock+    ok $ "Initial value: " ++ show v1+    +    let setTo (setval, getval) = do+            set sock setval+            actual <- get sock+            if actual == getval+                then ok     ("set " ++ show setval ++ ", get " ++ show getval)+                else not_ok ("set " ++ show setval ++ ", get " ++ show getval)+                            ("actually got " ++ show actual)++    mapM_ setTo+#if mingw32_HOST_OS+        [ (0,0)+        , (1, 1000)+        , (10000, 10000)+        , (12345, 12000)+        , (4000000000000, 4000000000000)+        , (0,0)+        ]+#else+        [ (0,0)+        , (1,10000)+        , (50000, 50000)+        , (1234567, 1240000)+        , (4000000000000, 4000000000000)+        , (0,0)+        ]+#endif++test_linger :: IO ()+test_linger = runTest "SO_LINGER" $ do+    sock <- socket AF_INET Stream defaultProtocol++    linger <- Opt.getLinger sock+    ok $ "Initial value: " ++ show linger++    let v1 = Nothing+        v2 = Just 1+        v3 = Just 30000++        setTo v = do+            Opt.setLinger sock v+            actual <- Opt.getLinger sock+            if actual == v+                then ok     (show v)+                else not_ok (show v) ("getLinger returned " ++ show actual ++ " instead")++    mapM_ setTo [v1, v2, v3, v1]++runTest :: String -> IO () -> IO ()+runTest name action = do+    putStrLn $ name ++ ":"+    action `catch` \ex -> do+        putStrLn ""+        putStrLn $ "Test " ++ name ++ " encountered an exception:\n    "+                ++ show (ex :: SomeException)+    putStrLn ""++ok :: String -> IO ()+ok msg = putStrLn $ "    ok:     " ++ msg++not_ok :: String -> String -> IO ()+not_ok msg reason = do+    putStrLn $ "    not ok: " ++ msg+    putStrLn $ "        reason: " ++ reason++expect :: Bool -> String -> IO ()+expect b msg =+    if b+        then putStrLn $ "    ok:     " ++ msg+        else putStrLn $ "    not ok: " ++ msg++main :: IO ()+main = do+    test_getType+    test_getAcceptConn++    testBoolWithSocketType Datagram+             "SO_BROADCAST" Opt.getBroadcast    Opt.setBroadcast+    testBool "SO_DEBUG"     Opt.getDebug        Opt.setDebug+    testBool "SO_DONTROUTE" Opt.getDontRoute    Opt.setDontRoute+    testBool "SO_KEEPALIVE" Opt.getKeepAlive    Opt.setKeepAlive+    testBool "SO_OOBINLINE" Opt.getOOBInline    Opt.setOOBInline+    testBool "SO_REUSEADDR" Opt.getReuseAddr    Opt.setReuseAddr+    testBool "TCP_NODELAY"  Opt.getTcpNoDelay   Opt.setTcpNoDelay++    testInt  "SO_RCVBUF"    Opt.getRecvBuf      Opt.setRecvBuf+    testInt  "SO_SNDBUF"    Opt.getSendBuf      Opt.setSendBuf++    testMicroseconds "SO_RCVTIMEO" Opt.getRecvTimeout Opt.setRecvTimeout+    testMicroseconds "SO_SNDTIMEO" Opt.getSendTimeout Opt.setSendTimeout++    test_linger++    putStrLn "Tests finished."