diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Lars Petersen + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/misc.c b/cbits/misc.c new file mode 100644 --- /dev/null +++ b/cbits/misc.c @@ -0,0 +1,13 @@ +#include +#include +#include +#include + +int setnonblocking(int fd) { + int flags; + + if (-1 == (flags = fcntl(fd, F_GETFL, 0))) { + flags = 0; + } + return fcntl(fd, F_SETFL, flags | O_NONBLOCK); +} diff --git a/include/misc.h b/include/misc.h new file mode 100644 --- /dev/null +++ b/include/misc.h @@ -0,0 +1,5 @@ +#include +#include +#include + +int setnonblocking(int fd); diff --git a/socket.cabal b/socket.cabal new file mode 100644 --- /dev/null +++ b/socket.cabal @@ -0,0 +1,63 @@ +name: socket +version: 0.1.0.0 +synopsis: A binding to the POSIX sockets interface +description: + This package provides access to the system's socket interface with POSIX semantics. + . + The library is designed to be threadsafe and establishes a thin layer on + top of the underlying ccalls to help with the development of concurrent applications. + It integrates with GHC's event management mechanism (which itself uses epoll + or libev or similar) and makes all functions have blocking semantics + without actually blocking the runtime system. +license: MIT +license-file: LICENSE +author: Lars Petersen +maintainer: info@lars-petersen.net +category: System, Network +build-type: Simple +cabal-version: >=1.10 +homepage: https://github.com/lpeterse/haskell-socket +bug-reports: https://github.com/lpeterse/haskell-socket/issues + +library + exposed-modules: System.Socket + , System.Socket.Address + , System.Socket.Address.SockAddrUn + , System.Socket.Address.SockAddrIn + , System.Socket.Address.SockAddrIn6 + , System.Socket.Type + , System.Socket.Type.DGRAM + , System.Socket.Type.STREAM + , System.Socket.Type.SEQPACKET + , System.Socket.Protocol + , System.Socket.Protocol.UDP + , System.Socket.Protocol.TCP + , System.Socket.Protocol.SCTP + , System.Socket.Unsafe + , System.Socket.Internal.FFI + , System.Socket.Internal.Event + , System.Socket.Internal.Socket + build-depends: base < 5 + , bytestring + hs-source-dirs: src + build-tools: hsc2hs + default-language: Haskell2010 + ghc-options: -Wall + c-sources: cbits/misc.c + include-dirs: include + includes: misc.h + install-includes: misc.h + +test-suite basic + hs-source-dirs: tests + main-is: Basic.hs + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base < 5 + , bytestring + , socket + , async + +source-repository head + type: git + location: git://github.com/lpeterse/haskell-socket.git diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket.hsc @@ -0,0 +1,543 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts, ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Socket +-- Copyright : (c) Lars Petersen 2015 +-- License : MIT +-- +-- Maintainer : info@lars-petersen.net +-- Stability : experimental +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > module Main where +-- > +-- > import System.Socket +-- > import Data.ByteString +-- > import Control.Monad +-- > import Control.Concurrent +-- > +-- > main :: IO () +-- > main = do +-- > s <- socket :: IO (Socket SockAddrIn STREAM TCP) +-- > bind s (SockAddrIn 8080 (pack [127,0,0,1])) +-- > listen s 5 +-- > forever $ do +-- > (peer,addr) <- accept s +-- > forkIO $ do +-- > send peer "Hello world!" +-- > close peer +----------------------------------------------------------------------------- +module System.Socket ( + -- * Operations + -- ** socket + socket + -- ** bind + , bind + -- ** listen + , listen + -- ** accept + , accept + -- ** connect + , connect + -- ** send + , send + -- ** sendTo + , sendTo + -- ** recv + , recv + -- ** recvFrom + , recvFrom + -- ** close + , close + + -- * Sockets + , Socket () + -- ** Addresses + , Address (..) + -- *** SockAddrUn + , SockAddrUn (..) + -- *** SockAddrIn + , SockAddrIn (..) + -- *** SockAddrIn6 + , SockAddrIn6 (..) + -- ** Types + , Type (..) + -- *** STREAM + , STREAM + -- *** DGRAM + , DGRAM + -- *** SEQPACKET + , SEQPACKET + -- ** Protocols + , Protocol (..) + -- *** UDP + , UDP + -- *** TCP + , TCP + -- *** SCTP + , SCTP + -- * MsgFlags + , MsgFlags + -- ** msgEOR + , msgEOR + -- ** msgOOB + , msgOOB + -- ** msgNOSIGNAL + , msgNOSIGNAL + -- * getSockOpt / setSockOpt + , GetSockOpt (..) + , SetSockOpt (..) + -- * Generic socket options + -- ** SO_ACCEPTCONN + , SO_ACCEPTCONN (..) + -- * SocketException + , SocketException (..) + ) where + +import Control.Exception +import Control.Monad +import Control.Concurrent.MVar + +import Data.Function +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import GHC.Conc (closeFdWith) + +import Foreign.C.Error +import Foreign.Storable +import Foreign.Marshal.Alloc + +import System.Socket.Unsafe + +import System.Socket.Internal.Socket +import System.Socket.Internal.Event +import System.Socket.Internal.FFI + +import System.Socket.Address +import System.Socket.Address.SockAddrUn +import System.Socket.Address.SockAddrIn +import System.Socket.Address.SockAddrIn6 + +import System.Socket.Type +import System.Socket.Type.STREAM +import System.Socket.Type.DGRAM +import System.Socket.Type.SEQPACKET + +import System.Socket.Protocol +import System.Socket.Protocol.UDP +import System.Socket.Protocol.TCP +import System.Socket.Protocol.SCTP + +#include "sys/socket.h" + +-- | Creates a new socket. +-- +-- Whereas the underlying POSIX socket function takes 3 parameters, this library +-- encodes this information in the type variables. This rules out several +-- kinds of errors and escpecially simplifies the handling of addresses (by using +-- associated type families). Examples: +-- +-- > -- create a IPv4-UDP-datagram socket +-- > sock <- socket :: IO (Socket SockAddrIn DGRAM UDP) +-- > -- create a IPv6-TCP-streaming socket +-- > sock6 <- socket :: IO (Socket SockAddrIn6 STREAM TCP) +-- +-- - This operation sets up a finalizer that automatically closes the socket +-- when the garbage collection decides to collect it. This is just a +-- fail-safe. You might still run out of file descriptors as there's +-- no guarantee about when the finalizer is run. You're advised to +-- manually `close` the socket when it's no longer needed. +-- - This operation configures the socket non-blocking to work seamlessly +-- with the runtime system's event notification mechanism. +-- - This operation can safely deal with asynchronous exceptions without +-- leaking file descriptors. +-- - This operation throws `SocketException`s: +-- +-- [@EAFNOSUPPORT@] The socket domain is not supported. +-- [@EMFILE@] The process is out file descriptors. +-- [@ENFILE@] The system is out file descriptors. +-- [@EPROTONOSUPPORT@] The socket protocol is not supported (for this socket domain). +-- [@EPROTOTYPE@] The socket type is not supported by the protocol. +-- [@EACCES@] The process is lacking necessary privileges. +-- [@ENOMEM@] Insufficient memory. +socket :: (Address a, Type t, Protocol p) => IO (Socket a t p) +socket = socket' + where + socket' :: forall a t p. (Address a, Type t, Protocol p) => IO (Socket a t p) + socket' = do + bracketOnError + -- Try to acquire the socket resource. This part has exceptions masked. + ( c_socket (addressFamilyNumber (undefined :: a)) (typeNumber (undefined :: t)) (protocolNumber (undefined :: p)) ) + -- On failure after the c_socket call we try to close the socket to not leak file descriptors. + -- If closing fails we cannot really do something about it. We tried at least. + -- This part has exceptions masked as well. c_close is an unsafe FFI call. + ( \fd-> when (fd >= 0) (c_close fd >> return ()) ) + -- If an exception is raised, it is reraised after the socket has been closed. + -- This part has async exceptions unmasked (via restore). + ( \fd-> if fd < 0 then do + getErrno >>= throwIO . SocketException + else do + -- setNonBlockingFD calls c_fcntl_write which is an unsafe FFI call. + i <- c_setnonblocking fd + if i < 0 then do + getErrno >>= throwIO . SocketException + else do + mfd <- newMVar fd + let s = Socket mfd + _ <- mkWeakMVar mfd (close s) + return s + ) + +-- | Bind a socket to an address. +-- +-- - Calling `bind` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - It is assumed that `c_bind` never blocks and therefore @EINPROGRESS@, @EALREADY@ and @EINTR@ don't occur. +-- This assumption is supported by the fact that the Linux manpage doesn't mention any of these errors, +-- the Posix manpage doesn't mention the last one and even MacOS' implementation will never +-- fail with any of these when the socket is configured non-blocking as +-- [argued here](http://stackoverflow.com/a/14485305). +-- - The following `SocketException`s are relevant and might be thrown (see @man bind@ for more exceptions regarding SockAddrUn sockets): +-- +-- [@EADDRINUSE@] The address is in use. +-- [@EADDRNOTAVAIL@] The address is not available. +-- [@EBADF@] Not a valid file descriptor. +-- [@EINVAL@] Socket is already bound and cannot be re-bound or the socket has been shut down. +-- [@ENOBUFS@] Insufficient resources. +-- [@EOPNOTSUPP@] The socket type does not support binding. +-- [@EACCES@] The address is protected and the process is lacking permission. +-- [@EISCONN@] The socket is already connected. +-- [@ELOOP@] More than {SYMLOOP_MAX} symbolic links were encountered during resolution of the pathname in address. +-- [@ENAMETOOLONG@] The length of a pathname exceeds {PATH_MAX}, or pathname resolution of a symbolic link produced an intermediate result with a length that exceeds {PATH_MAX}. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EAFNOSUPPORT@] The address family is invalid. +-- [@ENOTSOCK@] The file descriptor is not a socket. +-- [@EINVAL@] Address length does not match address family. +bind :: (Address a, Type t, Protocol p) => Socket a t p -> a -> IO () +bind (Socket mfd) addr = do + alloca $ \addrPtr-> do + poke addrPtr addr + withMVar mfd $ \fd-> do + i <- c_bind fd addrPtr (fromIntegral $ sizeOf addr) + if i < 0 + then getErrno >>= throwIO . SocketException + else return () + +-- | Accept connections on a connection-mode socket. +-- +-- - Calling `listen` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - The second parameter is called /backlog/ and sets a limit on how many +-- unaccepted connections the socket implementation shall queue. A value +-- of @0@ leaves the decision to the implementation. +-- - This operation throws `SocketException`s: +-- +-- [@EBADF@] Not a valid file descriptor (only after socket has been closed). +-- [@EDESTADDRREQ@] The socket is not bound and the protocol does not support listening on an unbound socket. +-- [@EINVAL@] The socket is already connected or has been shut down. +-- [@ENOTSOCK@] The file descriptor is not a socket (should be impossible). +-- [@EOPNOTSUPP@] The protocol does not support listening. +-- [@EACCES@] The process is lacking privileges. +-- [@ENOBUFS@] Insufficient resources. +listen :: (Address a, Type t, Protocol p) => Socket a t p -> Int -> IO () +listen (Socket ms) backlog = do + i <- withMVar ms $ \s-> do + c_listen s (fromIntegral backlog) + if i < 0 then do + getErrno >>= throwIO . SocketException + else do + return () + +-- | Accept a new connection. +-- +-- - Calling `accept` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - This operation configures the new socket non-blocking (TODO: use `accept4` if available). +-- - This operation sets up a finalizer for the new socket that automatically closes the socket +-- when the garbage collection decides to collect it. This is just a +-- fail-safe. You might still run out of file descriptors as there's +-- no guarantee about when the finalizer is run. You're advised to +-- manually `close` the socket when it's no longer needed. +-- - This operation catches @EAGAIN@, @EWOULDBLOCK@ and @EINTR@ internally and retries automatically. +-- - This operation throws `SocketException`s: +-- +-- [@EBADF@] Not a valid file descriptor (only after the socket has been closed). +-- [@ECONNABORTED@] A connection has been aborted. +-- [@EINVAL@] The socket is not accepting/listening. +-- [@EMFILE@] The process is out file descriptors. +-- [@ENFILE@] The system is out file descriptors. +-- [@ENOBUFS@] No buffer space available. +-- [@ENOMEM@] Out of memory. +-- [@ENOSOCK@] Not a valid socket descriptor (should be impossible). +-- [@EOPNOTSUPP@] The socket type does not support accepting connections. +-- [@EPROTO@] Generic protocol error. +accept :: (Address a, Type t, Protocol p) => Socket a t p -> IO (Socket a t p, a) +accept s@(Socket mfd) = accept' + where + accept' :: forall a t p. (Address a, Type t, Protocol p) => IO (Socket a t p, a) + accept' = do + -- Allocate local (!) memory for the address. + alloca $ \addrPtr-> do + alloca $ \addrPtrLen-> do + poke addrPtrLen (fromIntegral $ sizeOf (undefined :: a)) + fix $ \again-> do + -- We mask asynchronous exceptions during this critical section. + ews <- withMVarMasked mfd $ \fd-> do + fix $ \retry-> do + ft <- c_accept fd addrPtr addrPtrLen + if ft < 0 then do + e <- getErrno + if e == eWOULDBLOCK || e == eAGAIN + then threadWaitRead' fd >>= return . Left + else if e == eINTR + -- On EINTR it is good practice to just retry. + then retry + else throwIO (SocketException e) + -- This is the critical section: We got a valid descriptor we have not yet returned. + else do + i <- c_setnonblocking ft + if i < 0 then do + getErrno >>= throwIO . SocketException + else do + -- This peek operation might be a little expensive, but I don't see an alternative. + addr <- peek addrPtr :: IO (a) + -- newMVar is guaranteed to be not interruptible. + mft <- newMVar ft + -- Register a finalizer on the new socket. + _ <- mkWeakMVar mft (close (Socket mft `asTypeOf` s)) + return (Right (Socket mft, addr)) + -- If ews is Left we got EAGAIN or EWOULDBLOCK and retry after the next event. + case ews of + Left wait -> wait >> again + Right sock -> return sock + +-- | Connects to an remote address. +-- +-- - Calling `connect` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - This function returns as soon as a connection has either been established +-- or refused. A failed connection attempt does not throw an exception +-- if @EINTR@ or @EINPROGRESS@ were caught internally. The operation +-- just unblocks and returns in this case. The approach is to +-- just try to read or write the socket and eventually fail there instead. +-- Also see [these considerations](http://cr.yp.to/docs/connect.html) for an explanation. +-- @EINTR@ and @EINPROGRESS@ are handled internally and won't be thrown. +-- - The following `SocketException`s are relevant and might be thrown if the +-- OS was able to decide the connection request synchronously: +-- +-- [@EADDRNOTAVAIL@] The address is not available. +-- [@EBADF@] The file descriptor is invalid. +-- [@ECONNREFUSED@] The target was not listening or refused the connection. +-- [@EISCONN@] The socket is already connected. +-- [@ENETUNREACH@] The network is unreachable. +-- [@ETIMEDOUT@] The connect timed out before a connection was established. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EAFNOTSUPPORT@] Address family does not match the socket. +-- [@ENOTSOCK@] The descriptor is not a socket. +-- [@EPROTOTYPE@] The address type does not match the socket. +connect :: (Address a, Type t, Protocol p) => Socket a t p -> a -> IO () +connect (Socket mfd) addr = do + mwait <- withMVar mfd $ \fd-> do + when (fd < 0) $ do + throwIO (SocketException eBADF) + alloca $ \addrPtr-> do + poke addrPtr addr + i <- c_connect fd addrPtr (fromIntegral $ sizeOf addr) + if i < 0 then do + e <- getErrno + if e == eINPROGRESS || e == eINTR then do + -- The manpage says that in this case the connection + -- shall be established asynchronously and one is + -- supposed to wait. + wait <- threadWaitWrite' fd + return (Just wait) + else do + throwIO (SocketException e) + else do + -- This should not be the case on non-blocking socket, but better safe than sorry. + return Nothing + case mwait of + Just wait -> wait + Nothing -> return () + +-- | Send a message on a connected socket. +-- +-- - Calling `send` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - The operation returns the number of bytes sent. +-- - @EAGAIN@, @EWOULDBLOCK@ and @EINTR@ and handled internally and won't be thrown. +-- - The flag @MSG_NOSIGNAL@ is set to supress signals which are pointless. +-- - The following `SocketException`s are relevant and might be thrown: +-- +-- [@EBADF@] The file descriptor is invalid. +-- [@ECONNRESET@] The peer forcibly closed the connection. +-- [@EDESTADDREQ@] Remote address has not been set, but is required. +-- [@EMSGSIZE@] The message is too large to be sent all at once, but the protocol requires this. +-- [@ENOTCONN@] The socket is not connected. +-- [@EPIPE@] The socket is shut down for writing or the socket is not connected anymore. +-- [@EACCESS@] The process is lacking permissions. +-- [@EIO@] An I/O error occured while writing to the filesystem. +-- [@ENETDOWN@] The local network interface is down. +-- [@ENETUNREACH@] No route to network. +-- [@ENOBUFS@] Insufficient resources to fulfill the request. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EOPNOTSUPP@] The specified flags are not supported. +-- [@ENOTSOCK@] The descriptor does not refer to a socket. +send :: (Address a, Type t, Protocol p) => Socket a t p -> BS.ByteString -> MsgFlags -> IO Int +send s bs flags = do + bytesSent <- BS.unsafeUseAsCStringLen bs $ \(bufPtr,bufSize)-> + unsafeSend s bufPtr (fromIntegral bufSize) flags + return (fromIntegral bytesSent) + +-- | Send a message on a socket with a specific destination address. +-- +-- - Calling `sendTo` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - The operation returns the number of bytes sent. +-- - @EAGAIN@, @EWOULDBLOCK@ and @EINTR@ and handled internally and won't be thrown. +-- - The flag @MSG_NOSIGNAL@ is set to supress signals which are pointless. +-- - The following `SocketException`s are relevant and might be thrown: +-- +-- [@EBADF@] The file descriptor is invalid. +-- [@ECONNRESET@] The peer forcibly closed the connection. +-- [@EDESTADDREQ@] Remote address has not been set, but is required. +-- [@EMSGSIZE@] The message is too large to be sent all at once, but the protocol requires this. +-- [@ENOTCONN@] The socket is not connected. +-- [@EPIPE@] The socket is shut down for writing or the socket is not connected anymore. +-- [@EACCESS@] The process is lacking permissions. +-- [@EDESTADDRREQ@] The destination address is required. +-- [@EHOSTUNREACH@] The destination host cannot be reached. +-- [@EIO@] An I/O error occured. +-- [@EISCONN@] The socket is already connected. +-- [@ENETDOWN@] The local network is down. +-- [@ENETUNREACH@] No route to the network. +-- [@ENUBUFS@] Insufficient resources to fulfill the request. +-- [@ENOMEM@] Insufficient memory to fulfill the request. +-- [@ELOOP@] @AF_UNIX@ only. +-- [@ENAMETOOLONG@] @AF_UNIX@ only. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EAFNOTSUPP@] The address family does not match. +-- [@EOPNOTSUPP@] The specified flags are not supported. +-- [@ENOTSOCK@] The descriptor does not refer to a socket. +-- [@EINVAL@] The address len does not match. +sendTo :: (Address a, Type t, Protocol p) => Socket a t p -> BS.ByteString -> MsgFlags -> a -> IO Int +sendTo s bs flags addr = do + bytesSent <- alloca $ \addrPtr-> do + poke addrPtr addr + BS.unsafeUseAsCStringLen bs $ \(bufPtr,bufSize)-> + unsafeSendTo s bufPtr (fromIntegral bufSize) flags addrPtr (fromIntegral $ sizeOf addr) + return (fromIntegral bytesSent) + +-- | Receive a message on a connected socket. +-- +-- - Calling `recv` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - The operation takes a buffer size in bytes a first parameter which +-- limits the maximum length of the returned `Data.ByteString.ByteString`. +-- - @EAGAIN@, @EWOULDBLOCK@ and @EINTR@ and handled internally and won't be thrown. +-- - The following `SocketException`s are relevant and might be thrown: +-- +-- [@EBADF@] The file descriptor is invalid. +-- [@ECONNRESET@] The peer forcibly closed the connection. +-- [@ENOTCONN@] The socket is not connected. +-- [@ETIMEDOUT@] The connection timed out. +-- [@EIO@] An I/O error occured while writing to the filesystem. +-- [@ENOBUFS@] Insufficient resources to fulfill the request. +-- [@ENONMEM@] Insufficient memory to fulfill the request. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EOPNOTSUPP@] The specified flags are not supported. +-- [@ENOTSOCK@] The descriptor does not refer to a socket. +recv :: (Address a, Type t, Protocol p) => Socket a t p -> Int -> MsgFlags -> IO BS.ByteString +recv s bufSize flags = + bracketOnError + ( mallocBytes bufSize ) + (\bufPtr-> free bufPtr ) + (\bufPtr-> do + bytesReceived <- unsafeRecv s bufPtr (fromIntegral bufSize) flags + BS.unsafePackMallocCStringLen (bufPtr, fromIntegral bytesReceived) + ) + +-- | Receive a message on a socket and additionally yield the peer address. +-- +-- - Calling `recvFrom` on a `close`d socket throws @EBADF@ even if the former file descriptor has been reassigned. +-- - The operation takes a buffer size in bytes a first parameter which +-- limits the maximum length of the returned `Data.ByteString.ByteString`. +-- - @EAGAIN@, @EWOULDBLOCK@ and @EINTR@ and handled internally and won't be thrown. +-- - The following `SocketException`s are relevant and might be thrown: +-- +-- [@EBADF@] The file descriptor is invalid. +-- [@ECONNRESET@] The peer forcibly closed the connection. +-- [@ENOTCONN@] The socket is not connected. +-- [@ETIMEDOUT@] The connection timed out. +-- [@EIO@] An I/O error occured while writing to the filesystem. +-- [@ENOBUFS@] Insufficient resources to fulfill the request. +-- [@ENONMEM@] Insufficient memory to fulfill the request. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EOPNOTSUPP@] The specified flags are not supported. +-- [@ENOTSOCK@] The descriptor does not refer to a socket. +recvFrom :: forall a t p. (Address a, Type t, Protocol p) => Socket a t p -> Int -> MsgFlags -> IO (BS.ByteString, a) +recvFrom s bufSize flags = + alloca $ \addrPtr-> do + alloca $ \addrSizePtr-> do + poke addrSizePtr (fromIntegral $ sizeOf (undefined :: a)) + bracketOnError + ( mallocBytes bufSize ) + (\bufPtr-> free bufPtr ) + (\bufPtr-> do + bytesReceived <- unsafeRecvFrom s bufPtr (fromIntegral bufSize) flags addrPtr addrSizePtr + addr <- peek addrPtr + bs <- BS.unsafePackMallocCStringLen (bufPtr, fromIntegral bytesReceived) + return (bs, addr) + ) + +-- | Closes a socket. +-- +-- - This operation is idempotent and thus can be performed more than once without throwing an exception. +-- If it throws an exception it is presumably a not recoverable situation and the process should exit. +-- - This operation does not block. +-- - This operation wakes up all threads that are currently blocking on this +-- socket. All other threads are guaranteed not to block on operations on this socket in the future. +-- Threads that perform operations other than `close` on this socket will fail with @EBADF@ +-- after the socket has been closed (`close` replaces the +-- `System.Posix.Types.Fd` in the `Control.Concurrent.MVar.MVar` with @-1@ +-- to reliably avoid use-after-free situations). +-- - The following `SocketException`s are relevant and might be thrown: +-- +-- [@EIO@] An I/O error occured while writing to the filesystem. +-- +-- - The following `SocketException`s are theoretically possible, but should not occur if the library is correct: +-- +-- [@EBADF@] The file descriptor is invalid. +close :: (Address a, Type t, Protocol p) => Socket a t p -> IO () +close (Socket mfd) = do + modifyMVarMasked_ mfd $ \fd-> do + if fd < 0 then do + return fd + else do + -- closeFdWith does not throw even on invalid file descriptors. + -- It just assures no thread is blocking on the fd anymore and then executes the IO action. + closeFdWith + -- The c_close operation may (according to Posix documentation) fails with EINTR or EBADF or EIO. + -- EBADF: Should be ruled out by the library's design. + -- EINTR: It is best practice to just retry the operation what we do here. + -- EIO: Only occurs when filesystem is involved (?). + -- Conclusion: Our close should never fail. If it does, something is horribly wrong. + ( const $ fix $ \retry-> do + i <- c_close fd + if i < 0 then do + e <- getErrno + if e == eINTR + then retry + else throwIO (SocketException e) + else return () + ) fd + -- When we arrive here, no exception has been thrown and the descriptor has been closed. + -- We put an invalid file descriptor into the MVar. + return (-1) + diff --git a/src/System/Socket/Address.hs b/src/System/Socket/Address.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Address.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +module System.Socket.Address + ( Address (..) + ) where + +import Foreign.C.Types +import Foreign.Storable + +class (Storable f) => Address f where + addressFamilyNumber :: f -> CInt diff --git a/src/System/Socket/Address/SockAddrIn.hsc b/src/System/Socket/Address/SockAddrIn.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Address/SockAddrIn.hsc @@ -0,0 +1,50 @@ +module System.Socket.Address.SockAddrIn + ( SockAddrIn (..) + ) where + +import Data.Word +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Utils + +import System.Socket.Address + +#include "sys/types.h" +#include "sys/socket.h" +#include "sys/un.h" +#include "netinet/in.h" +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +instance Address SockAddrIn where + addressFamilyNumber _ = (#const AF_INET) + +data SockAddrIn + = SockAddrIn + { sinPort :: Word16 + , sinAddr :: BS.ByteString + } deriving (Eq, Ord, Show) + +instance Storable SockAddrIn where + sizeOf _ = (#size struct sockaddr_in) + alignment _ = (#alignment struct sockaddr_in) + peek ptr = do + ph <- peekByteOff (sin_port ptr) 0 :: IO Word8 + pl <- peekByteOff (sin_port ptr) 1 :: IO Word8 + a <- BS.packCStringLen (sin_addr ptr, 4) :: IO BS.ByteString + return (SockAddrIn (fromIntegral ph * 256 + fromIntegral pl) a) + where + sin_port = (#ptr struct sockaddr_in, sin_port) + sin_addr = (#ptr struct in_addr, s_addr) . (#ptr struct sockaddr_in, sin_addr) + poke ptr (SockAddrIn p a) = do + poke (sin_family ptr) ((#const AF_INET) :: Word16) + pokeByteOff (sin_port ptr) 0 (fromIntegral $ rem (quot p 256) 256 :: Word8) + pokeByteOff (sin_port ptr) 1 (fromIntegral $ rem p 256 :: Word8) + BS.unsafeUseAsCString a $ \a'-> do + copyBytes (sin_addr ptr) a' (min 4 $ BS.length a)-- copyBytes dest from count + where + sin_family = (#ptr struct sockaddr_in, sin_family) + sin_port = (#ptr struct sockaddr_in, sin_port) + sin_addr = (#ptr struct in_addr, s_addr) . (#ptr struct sockaddr_in, sin_addr) diff --git a/src/System/Socket/Address/SockAddrIn6.hsc b/src/System/Socket/Address/SockAddrIn6.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Address/SockAddrIn6.hsc @@ -0,0 +1,60 @@ +module System.Socket.Address.SockAddrIn6 + ( SockAddrIn6 (..) + ) where + +import Data.Word +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS + +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Utils + +import System.Socket.Address + +#include "sys/types.h" +#include "sys/socket.h" +#include "sys/un.h" +#include "netinet/in.h" +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +instance Address SockAddrIn6 where + addressFamilyNumber _ = (#const AF_INET6) + +data SockAddrIn6 + = SockAddrIn6 + { sin6Port :: Word16 + , sin6Flowinfo :: Word32 + , sin6Addr :: BS.ByteString + , sin6ScopeId :: Word32 + } deriving (Eq, Ord, Show) + +instance Storable SockAddrIn6 where + sizeOf _ = (#size struct sockaddr_in6) + alignment _ = (#alignment struct sockaddr_in6) + peek ptr = do + f <- peek (sin6_flowinfo ptr) :: IO Word32 + ph <- peekByteOff (sin6_port ptr) 0 :: IO Word8 + pl <- peekByteOff (sin6_port ptr) 1 :: IO Word8 + a <- BS.packCStringLen (sin6_addr ptr, 16) :: IO BS.ByteString + s <- peek (sin6_scope_id ptr) :: IO Word32 + return (SockAddrIn6 (fromIntegral ph * 256 + fromIntegral pl) f a s) + where + sin6_flowinfo = (#ptr struct sockaddr_in6, sin6_flowinfo) + sin6_scope_id = (#ptr struct sockaddr_in6, sin6_scope_id) + sin6_port = (#ptr struct sockaddr_in6, sin6_port) + sin6_addr = (#ptr struct in6_addr, s6_addr) . (#ptr struct sockaddr_in6, sin6_addr) + poke ptr (SockAddrIn6 p f a s) = do + poke (sin6_family ptr) ((#const AF_INET6) :: Word16) + poke (sin6_flowinfo ptr) f + poke (sin6_scope_id ptr) s + pokeByteOff (sin6_port ptr) 0 (fromIntegral $ rem (quot p 256) 256 :: Word8) + pokeByteOff (sin6_port ptr) 1 (fromIntegral $ rem p 256 :: Word8) + BS.unsafeUseAsCString a $ \a'-> do + copyBytes (sin6_addr ptr) a' (min 16 $ BS.length a)-- copyBytes dest from count + where + sin6_family = (#ptr struct sockaddr_in6, sin6_family) + sin6_flowinfo = (#ptr struct sockaddr_in6, sin6_flowinfo) + sin6_scope_id = (#ptr struct sockaddr_in6, sin6_scope_id) + sin6_port = (#ptr struct sockaddr_in6, sin6_port) + sin6_addr = (#ptr struct in6_addr, s6_addr) . (#ptr struct sockaddr_in6, sin6_addr) diff --git a/src/System/Socket/Address/SockAddrUn.hsc b/src/System/Socket/Address/SockAddrUn.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Address/SockAddrUn.hsc @@ -0,0 +1,44 @@ +module System.Socket.Address.SockAddrUn + ( SockAddrUn (..) + ) where + +import Data.Word +import qualified Data.ByteString as BS + +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Utils + +import System.Socket.Address + +#include "sys/types.h" +#include "sys/socket.h" +#include "sys/un.h" +#include "netinet/in.h" +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +instance Address SockAddrUn where + addressFamilyNumber _ = (#const AF_UNIX) + +data SockAddrUn + = SockAddrUn + { sunPath :: BS.ByteString + } deriving (Eq, Ord, Show) + +instance Storable SockAddrUn where + sizeOf _ = (#size struct sockaddr_un) + alignment _ = (#alignment struct sockaddr_un) + peek ptr = do + path <- BS.packCString (sun_path ptr) :: IO BS.ByteString + return (SockAddrUn path) + where + sun_path = (#ptr struct sockaddr_un, sun_path) + poke ptr (SockAddrUn path) = do + -- useAsCString null-terminates the CString + BS.useAsCString truncatedPath $ \cs-> do + copyBytes (sun_path ptr) cs (BS.length truncatedPath + 1)-- copyBytes dest from count + where + sun_path = (#ptr struct sockaddr_un, sun_path) + truncatedPath = BS.take ( sizeOf (undefined :: SockAddrUn) + - sizeOf (undefined :: Word16) + - 1 ) path diff --git a/src/System/Socket/Internal/Event.hs b/src/System/Socket/Internal/Event.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/Event.hs @@ -0,0 +1,41 @@ +module System.Socket.Internal.Event + ( threadWaitReadMVar, threadWaitWriteMVar, threadWaitWrite', threadWaitRead' + ) where + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad + +import Foreign.C.Error + +import GHC.Conc (threadWaitReadSTM, threadWaitWriteSTM, atomically) + +import System.Posix.Types ( Fd(..) ) + +import System.Socket.Internal.Socket + +------------------------------------------------------------------------------- +-- Helpers for threadsafe event registration on file descriptors +------------------------------------------------------------------------------- + +threadWaitReadMVar :: MVar Fd -> IO () +threadWaitReadMVar mfd = do + wait <- withMVar mfd $ \fd-> do + when (fd < 0) $ throwIO (SocketException eBADF) + threadWaitReadSTM fd >>= return . atomically . fst + wait `onException` throwIO (SocketException eBADF) + +threadWaitWriteMVar :: MVar Fd -> IO () +threadWaitWriteMVar mfd = do + wait <- withMVar mfd $ \fd-> do + when (fd < 0) $ throwIO (SocketException eBADF) + threadWaitWriteSTM fd >>= return . atomically . fst + wait `onException` throwIO (SocketException eBADF) + +threadWaitWrite' :: Fd -> IO (IO ()) +threadWaitWrite' fd = do + threadWaitWriteSTM fd >>= return . atomically . fst + +threadWaitRead' :: Fd -> IO (IO ()) +threadWaitRead' fd = do + threadWaitReadSTM fd >>= return . atomically . fst diff --git a/src/System/Socket/Internal/FFI.hs b/src/System/Socket/Internal/FFI.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/FFI.hs @@ -0,0 +1,55 @@ +module System.Socket.Internal.FFI where + +import Data.Bits +import Data.Monoid + +import Foreign.Ptr +import Foreign.C.Types + +import System.Posix.Types ( Fd(..) ) + +newtype MsgFlags + = MsgFlags CInt + +instance Monoid MsgFlags where + mempty + = MsgFlags 0 + mappend (MsgFlags a) (MsgFlags b) + = MsgFlags (a .|. b) + +foreign import ccall unsafe "sys/socket.h socket" + c_socket :: CInt -> CInt -> CInt -> IO Fd + +foreign import ccall unsafe "unistd.h close" + c_close :: Fd -> IO CInt + +foreign import ccall unsafe "sys/socket.h bind" + c_bind :: Fd -> Ptr a -> CInt -> IO CInt + +foreign import ccall unsafe "sys/socket.h connect" + c_connect :: Fd -> Ptr a -> CSize -> IO CInt + +foreign import ccall unsafe "sys/socket.h accept" + c_accept :: Fd -> Ptr a -> Ptr CInt -> IO Fd + +foreign import ccall unsafe "sys/socket.h listen" + c_listen :: Fd -> CInt -> IO CInt + +foreign import ccall unsafe "sys/socket.h send" + c_send :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CInt + +foreign import ccall unsafe "sys/socket.h sendto" + c_sendto :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> CInt -> IO CInt + +foreign import ccall unsafe "sys/socket.h recv" + c_recv :: Fd -> Ptr a -> CSize -> MsgFlags -> IO CInt + +-- socklen_t is an int not a size_t! +foreign import ccall unsafe "sys/socket.h recvfrom" + c_recvfrom :: Fd -> Ptr a -> CSize -> MsgFlags -> Ptr b -> Ptr CInt -> IO CInt + +foreign import ccall unsafe "sys/socket.h getsockopt" + c_getsockopt :: Fd -> CInt -> CInt -> Ptr a -> Ptr Int -> IO CInt + +foreign import ccall unsafe "misc.h setnonblocking" + c_setnonblocking :: Fd -> IO CInt diff --git a/src/System/Socket/Internal/Socket.hsc b/src/System/Socket/Internal/Socket.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/Socket.hsc @@ -0,0 +1,193 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module System.Socket.Internal.Socket ( + Socket (..) + , SocketException (..) + , MsgFlags (..) + , msgEOR + , msgOOB + , msgNOSIGNAL + , GetSockOpt (..) + , SetSockOpt (..) + , SO_ACCEPTCONN (..) + ) where + +import Control.Concurrent.MVar +import Control.Exception + +import Data.Typeable + +import Foreign.Ptr +import Foreign.Storable +import Foreign.C.Error +import Foreign.Marshal.Alloc +import System.Posix.Types + +import System.Socket.Internal.FFI + +#include "sys/socket.h" + +-- | A generic socket type. Also see `socket` for details. +-- +-- The socket is just an `Control.Concurrent.MVar.MVar`-wrapped file descriptor. +-- It is exposed in order to make this library easily extensible, but it is +-- usually not necessary nor advised to work directly on the file descriptor. +-- If you do, the following rules must be obeyed: +-- +-- - Make sure not to deadlock. Use `Control.Concurrent.MVar.withMVar` or similar. +-- - The lock __must not__ be held during a blocking call. This would make it impossible +-- to send and receive simultaneously or to close the socket. +-- - The lock __must__ be held when calling operations that use the file descriptor. +-- Otherwise the socket might get closed or even reused by another +-- thread/capability which might result in reading from or writing +-- totally different connection. This is a security nightmare! +-- - The socket is non-blocking and all the code relies on that assumption. +-- You need to use GHC's eventing mechanism primitives to block until +-- something happens. The former rules forbid to use `GHC.Conc.threadWaitRead` as it +-- does not seperate between registering the file descriptor (for which +-- the lock __must__ be held) and the actual waiting (for which you must +-- __not__ hold the lock). +-- Also see [this](https://mail.haskell.org/pipermail/haskell-cafe/2014-September/115823.html) +-- thread and read the library code to see how the problem is currently circumvented. +newtype Socket d t p + = Socket (MVar Fd) + +msgOOB :: MsgFlags +msgOOB = MsgFlags (#const MSG_NOSIGNAL) + +msgEOR :: MsgFlags +msgEOR = MsgFlags (#const MSG_NOSIGNAL) + +msgNOSIGNAL :: MsgFlags +msgNOSIGNAL = MsgFlags (#const MSG_NOSIGNAL) + +newtype SocketException = SocketException Errno + deriving Typeable + +instance Exception SocketException + +instance Show SocketException where + show (SocketException e) = "SocketException " ++ strerr e + where + strerr errno + | errno == eOK = "EOK" + | errno == e2BIG = "E2BIG" + | errno == eACCES = "EACCES" + | errno == eADDRINUSE = "EADDRINUSE" + | errno == eADDRNOTAVAIL = "EADDRNOTAVAIL" + | errno == eADV = "EADV" + | errno == eAFNOSUPPORT = "EAFNOSUPPORT" + | errno == eAGAIN = "EAGAIN" + | errno == eALREADY = "EALREADY" + | errno == eBADF = "EBADF" + | errno == eBADMSG = "EBADMSG" + | errno == eBADRPC = "EBADRPC" + | errno == eBUSY = "EBUSY" + | errno == eCHILD = "ECHILD" + | errno == eCOMM = "ECOMM" + | errno == eCONNABORTED = "ECONNABORTED" + | errno == eCONNREFUSED = "ECONNREFUSED" + | errno == eCONNRESET = "ECONNRESET" + | errno == eDEADLK = "EDEADLK" + | errno == eDESTADDRREQ = "EDESTADDRREQ" + | errno == eDIRTY = "EDIRTY" + | errno == eDOM = "EDOM" + | errno == eDQUOT = "EDQUOT" + | errno == eEXIST = "EEXIST" + | errno == eFAULT = "EFAULT" + | errno == eFBIG = "EFBIG" + | errno == eFTYPE = "EFTYPE" + | errno == eHOSTDOWN = "EHOSTDOWN" + | errno == eHOSTUNREACH = "EHOSTUNREACH" + | errno == eIDRM = "EIDRM" + | errno == eILSEQ = "EILSEQ" + | errno == eINPROGRESS = "EINPROGRESS" + | errno == eINTR = "EINTR" + | errno == eINVAL = "EINVAL" + | errno == eIO = "EIO" + | errno == eISCONN = "EISCONN" + | errno == eISDIR = "EISDIR" + | errno == eLOOP = "ELOOP" + | errno == eMFILE = "EMFILE" + | errno == eMLINK = "EMLINK" + | errno == eMSGSIZE = "EMSGSIZE" + | errno == eMULTIHOP = "EMULTIHOP" + | errno == eNAMETOOLONG = "ENAMETOOLONG" + | errno == eNETDOWN = "ENETDOWN" + | errno == eNETRESET = "ENETRESET" + | errno == eNETUNREACH = "ENETUNREACH" + | errno == eNFILE = "ENFILE" + | errno == eNOBUFS = "ENOBUFS" + | errno == eNODATA = "ENODATA" + | errno == eNODEV = "ENODEV" + | errno == eNOENT = "ENOENT" + | errno == eNOEXEC = "ENOEXEC" + | errno == eNOLCK = "ENOLCK" + | errno == eNOLINK = "ENOLINK" + | errno == eNOMEM = "ENOMEM" + | errno == eNOMSG = "ENOMSG" + | errno == eNONET = "ENONET" + | errno == eNOPROTOOPT = "ENOPROTOOPT" + | errno == eNOSPC = "ENOSPC" + | errno == eNOSR = "ENOSR" + | errno == eNOSTR = "ENOSTR" + | errno == eNOSYS = "ENOSYS" + | errno == eNOTBLK = "ENOTBLK" + | errno == eNOTCONN = "ENOTCONN" + | errno == eNOTDIR = "ENOTDIR" + | errno == eNOTEMPTY = "ENOTEMPTY" + | errno == eNOTSOCK = "ENOTSOCK" + | errno == eNOTTY = "ENOTTY" + | errno == eNXIO = "ENXIO" + | errno == eOPNOTSUPP = "EOPNOTSUPP" + | errno == ePERM = "EPERM" + | errno == ePFNOSUPPORT = "EPFNOSUPPORT" + | errno == ePIPE = "EPIPE" + | errno == ePROCLIM = "EPROCLIM" + | errno == ePROCUNAVAIL = "EPROCUNAVAIL" + | errno == ePROGMISMATCH = "EPROGMISMATCH" + | errno == ePROGUNAVAIL = "EPROGUNAVAIL" + | errno == ePROTO = "EPROTO" + | errno == ePROTONOSUPPORT = "EPROTONOSUPPORT" + | errno == ePROTOTYPE = "EPROTOTYPE" + | errno == eRANGE = "ERANGE" + | errno == eREMCHG = "EREMCHG" + | errno == eREMOTE = "EREMOTE" + | errno == eROFS = "EROFS" + | errno == eRPCMISMATCH = "ERPCMISMATCH" + | errno == eRREMOTE = "ERREMOTE" + | errno == eSHUTDOWN = "ESHUTDOWN" + | errno == eSOCKTNOSUPPORT = "ESOCKTNOSUPPORT" + | errno == eSPIPE = "ESPIPE" + | errno == eSRCH = "ESRCH" + | errno == eSRMNT = "ESRMNT" + | errno == eSTALE = "ESTALE" + | errno == eTIME = "ETIME" + | errno == eTIMEDOUT = "ETIMEDOUT" + | errno == eTOOMANYREFS = "ETOOMANYREFS" + | errno == eTXTBSY = "ETXTBSY" + | errno == eUSERS = "EUSERS" + | errno == eWOULDBLOCK = "EWOULDBLOCK" + | errno == eXDEV = "EXDEV" + | otherwise = let Errno i = errno + in show i + +class GetSockOpt o where + getSockOpt :: Socket f t p -> IO o + +class SetSockOpt o where + setSockOpt :: Socket f t p -> o -> IO () + +data SO_ACCEPTCONN + = SO_ACCEPTCONN Bool + +instance GetSockOpt SO_ACCEPTCONN where + getSockOpt (Socket mfd) = do + withMVar mfd $ \fd-> + alloca $ \vPtr-> do + alloca $ \lPtr-> do + i <- c_getsockopt fd (#const SOL_SOCKET) (#const SO_ACCEPTCONN) (vPtr :: Ptr Int) (lPtr :: Ptr Int) + if i < 0 then do + throwIO . SocketException =<< getErrno + else do + v <- peek vPtr + return $ SO_ACCEPTCONN (v == 1) diff --git a/src/System/Socket/Protocol.hs b/src/System/Socket/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +module System.Socket.Protocol + ( Protocol (..) + ) where + +import Foreign.C.Types + +class Protocol p where + protocolNumber :: p -> CInt + +instance Protocol () where + protocolNumber _ = 0 diff --git a/src/System/Socket/Protocol/SCTP.hsc b/src/System/Socket/Protocol/SCTP.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/SCTP.hsc @@ -0,0 +1,11 @@ +module System.Socket.Protocol.SCTP where + +import System.Socket.Protocol + +#include "sys/socket.h" +#include "netinet/in.h" + +data SCTP + +instance Protocol SCTP where + protocolNumber _ = (#const IPPROTO_SCTP) diff --git a/src/System/Socket/Protocol/TCP.hsc b/src/System/Socket/Protocol/TCP.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/TCP.hsc @@ -0,0 +1,11 @@ +module System.Socket.Protocol.TCP where + +import System.Socket.Protocol + +#include "sys/socket.h" +#include "netinet/in.h" + +data TCP + +instance Protocol TCP where + protocolNumber _ = (#const IPPROTO_TCP) diff --git a/src/System/Socket/Protocol/UDP.hsc b/src/System/Socket/Protocol/UDP.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Protocol/UDP.hsc @@ -0,0 +1,11 @@ +module System.Socket.Protocol.UDP where + +import System.Socket.Protocol + +#include "sys/socket.h" +#include "netinet/in.h" + +data UDP + +instance Protocol UDP where + protocolNumber _ = (#const IPPROTO_UDP) diff --git a/src/System/Socket/Type.hs b/src/System/Socket/Type.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Type.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +module System.Socket.Type + ( Type (..) + ) where + +import Foreign.C.Types + +class Type t where + typeNumber :: t -> CInt diff --git a/src/System/Socket/Type/DGRAM.hsc b/src/System/Socket/Type/DGRAM.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Type/DGRAM.hsc @@ -0,0 +1,11 @@ +module System.Socket.Type.DGRAM where + +import System.Socket.Type + +#include "sys/socket.h" +#include "netinet/in.h" + +data DGRAM + +instance Type DGRAM where + typeNumber _ = (#const SOCK_DGRAM) diff --git a/src/System/Socket/Type/SEQPACKET.hsc b/src/System/Socket/Type/SEQPACKET.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Type/SEQPACKET.hsc @@ -0,0 +1,11 @@ +module System.Socket.Type.SEQPACKET where + +import System.Socket.Type + +#include "sys/socket.h" +#include "netinet/in.h" + +data SEQPACKET + +instance Type SEQPACKET where + typeNumber _ = (#const SOCK_SEQPACKET) diff --git a/src/System/Socket/Type/STREAM.hsc b/src/System/Socket/Type/STREAM.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Type/STREAM.hsc @@ -0,0 +1,11 @@ +module System.Socket.Type.STREAM where + +import System.Socket.Type + +#include "sys/socket.h" +#include "netinet/in.h" + +data STREAM + +instance Type STREAM where + typeNumber _ = (#const SOCK_STREAM) diff --git a/src/System/Socket/Unsafe.hsc b/src/System/Socket/Unsafe.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Unsafe.hsc @@ -0,0 +1,111 @@ +module System.Socket.Unsafe ( + -- * unsafeSend + unsafeSend + -- * unsafeSendTo + , unsafeSendTo + -- * unsafeRecv + , unsafeRecv + -- * unsafeRecvFrom + , unsafeRecvFrom + ) where + +import Data.Function + +import Control.Monad +import Control.Exception +import Control.Concurrent.MVar + +import Foreign.C.Error +import Foreign.C.Types +import Foreign.Ptr + +import System.Socket.Internal.Socket +import System.Socket.Internal.Event +import System.Socket.Internal.FFI +import System.Socket.Address +import System.Socket.Type +import System.Socket.Protocol + +#include "sys/socket.h" + +unsafeSend :: (Address a, Type t, Protocol p) => Socket a t p -> Ptr b -> CSize -> MsgFlags -> IO CInt +unsafeSend (Socket mfd) bufPtr bufSize flags = do + fix $ \again-> do + ewb <- withMVar mfd $ \fd-> do + when (fd < 0) $ do + throwIO (SocketException eBADF) + fix $ \retry-> do + i <- c_send fd bufPtr bufSize (flags `mappend` msgNOSIGNAL) + if (i < 0) then do + e <- getErrno + if e == eWOULDBLOCK || e == eAGAIN + then threadWaitRead' fd >>= return . Left + else if e == eINTR + then retry + else throwIO (SocketException e) + -- Send succeeded. Return the bytes send. + else return (Right i) + case ewb of + Left wait -> wait >> again + Right bytesSent -> return bytesSent + +unsafeSendTo :: (Address a, Type t, Protocol p) => Socket a t p -> Ptr b -> CSize -> MsgFlags -> Ptr a -> CInt -> IO CInt +unsafeSendTo (Socket mfd) bufPtr bufSize flags addrPtr addrSize = do + fix $ \again-> do + ewb <- withMVar mfd $ \fd-> do + when (fd < 0) $ do + throwIO (SocketException eBADF) + fix $ \retry-> do + i <- c_sendto fd bufPtr (fromIntegral bufSize) (flags `mappend` msgNOSIGNAL) addrPtr addrSize + if (i < 0) then do + e <- getErrno + if e == eWOULDBLOCK || e == eAGAIN + then threadWaitRead' fd >>= return . Left + else if e == eINTR + then retry + else throwIO (SocketException e) + -- Send succeeded. Return the bytes send. + else return (Right i) + case ewb of + Left wait -> wait >> again + Right bytesSent -> return (fromIntegral bytesSent) + +unsafeRecv :: (Address a, Type t, Protocol p) => Socket a t p -> Ptr b -> CSize -> MsgFlags -> IO CInt +unsafeRecv (Socket mfd) bufPtr bufSize flags = + fix $ \again-> do + ewb <- withMVar mfd $ \fd-> do + when (fd < 0) $ do + throwIO (SocketException eBADF) + fix $ \retry-> do + i <- c_recv fd bufPtr bufSize flags + if (i < 0) then do + e <- getErrno + if e == eWOULDBLOCK || e == eAGAIN then do + threadWaitRead' fd >>= return . Left + else if e == eINTR + then retry + else throwIO (SocketException e) + else return (Right i) + case ewb of + Left wait -> wait >> again + Right bytesReceived -> return bytesReceived + +unsafeRecvFrom :: (Address a, Type t, Protocol p) => Socket a t p -> Ptr b -> CSize -> MsgFlags -> Ptr a -> Ptr CInt -> IO CInt +unsafeRecvFrom (Socket mfd) bufPtr bufSize flags addrPtr addrSizePtr = do + fix $ \again-> do + ewb <- withMVar mfd $ \fd-> do + when (fd < 0) $ do + throwIO (SocketException eBADF) + fix $ \retry-> do + i <- c_recvfrom fd bufPtr bufSize flags addrPtr addrSizePtr + if (i < 0) then do + e <- getErrno + if e == eWOULDBLOCK || e == eAGAIN then do + threadWaitRead' fd >>= return . Left + else if e == eINTR + then retry + else throwIO (SocketException e) + else return (Right i) + case ewb of + Left wait -> wait >> again + Right bytesReceived -> return (fromIntegral bytesReceived) diff --git a/tests/Basic.hs b/tests/Basic.hs new file mode 100644 --- /dev/null +++ b/tests/Basic.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, TypeFamilies #-} +module Main where + +import Data.Monoid +import Data.ByteString (pack) +import Control.Monad +import Control.Exception +import Control.Concurrent.Async +import Foreign.C.Error +import System.Socket +import System.Exit + +main :: IO () +main = do + test "test0001.01" $ test0001 (undefined :: Socket SockAddrIn STREAM TCP) localhost + test "test0001.02" $ test0001 (undefined :: Socket SockAddrIn6 STREAM TCP) localhost6 + test "test0001.03" $ test0001 (undefined :: Socket SockAddrIn STREAM SCTP) localhost + test "test0001.04" $ test0001 (undefined :: Socket SockAddrIn6 STREAM SCTP) localhost6 + test "test0002.01" $ test0002 (undefined :: Socket SockAddrIn DGRAM UDP) localhost + test "test0002.02" $ test0002 (undefined :: Socket SockAddrIn6 DGRAM UDP) localhost6 + +-- Test connection oriented sockets (i.e. TCP). +test0001 :: (Address a, Type t, Protocol p) => Socket a t p -> a -> IO (Either String String) +test0001 dummy addr = do + eServer <- try (socket `asTypeOf` return dummy) + case eServer of + Left e@(SocketException er) -> if er == ePROTONOSUPPORT + then return (Right "Protocol not supported. System dependant.") + else throwIO e + Right server -> do + bind server addr + listen server 5 + serverRecv <- async $ do + (peerSock, peerAddr) <- accept server + recv peerSock 4096 mempty + client <- socket `asTypeOf` return server + connect client addr + send client helloWorld mempty + msg <- wait serverRecv + close server + close client + if (msg /= helloWorld) + then return (Left "Received message was bogus.") + else return (Right "") + where + helloWorld = "Hello world!" + +-- Test stateless sockets (i.e. UDP). +test0002 :: (Address a, Type t, Protocol p) => Socket a t p -> a -> IO (Either String String) +test0002 dummy addr = do + server <- socket `asTypeOf` return dummy + bind server addr + serverRecv <- async $ do + recvFrom server 4096 mempty + client <- socket `asTypeOf` return server + sendTo client helloWorld mempty addr + (msg,peerAddr) <- wait serverRecv + close server + close client + if (msg /= helloWorld) + then return (Left "Received message was bogus.") + else return (Right "") + where + helloWorld = "Hello world!" + +localhost :: SockAddrIn +localhost = + SockAddrIn + { sinPort = 7777 + , sinAddr = pack [127,0,0,1] + } + +localhost6 :: SockAddrIn6 +localhost6 = + SockAddrIn6 + { sin6Port = 7777 + , sin6Addr = pack [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,1] + , sin6Flowinfo = 0 + , sin6ScopeId = 0 + } + +test :: String -> IO (Either String String) -> IO () +test n t = do + putStr ("Test " ++ show n ++ ": ") + catch + ( do r <- t + case r of + Left x -> putStr "FAIL " >> putStrLn x >> exitFailure + Right x -> putStr "OK " >> putStrLn x + ) + (\e-> putStr "EXCP " >> putStrLn (show (e :: SomeException)) >> exitFailure)