------------------------------------------------------------------------
-- |
-- 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