socket (empty) → 0.1.0.0
raw patch · 23 files changed
+1388/−0 lines, 23 filesdep +asyncdep +basedep +bytestringsetup-changed
Dependencies added: async, base, bytestring, socket
Files
- LICENSE +20/−0
- Setup.hs +2/−0
- cbits/misc.c +13/−0
- include/misc.h +5/−0
- socket.cabal +63/−0
- src/System/Socket.hsc +543/−0
- src/System/Socket/Address.hs +10/−0
- src/System/Socket/Address/SockAddrIn.hsc +50/−0
- src/System/Socket/Address/SockAddrIn6.hsc +60/−0
- src/System/Socket/Address/SockAddrUn.hsc +44/−0
- src/System/Socket/Internal/Event.hs +41/−0
- src/System/Socket/Internal/FFI.hs +55/−0
- src/System/Socket/Internal/Socket.hsc +193/−0
- src/System/Socket/Protocol.hs +12/−0
- src/System/Socket/Protocol/SCTP.hsc +11/−0
- src/System/Socket/Protocol/TCP.hsc +11/−0
- src/System/Socket/Protocol/UDP.hsc +11/−0
- src/System/Socket/Type.hs +9/−0
- src/System/Socket/Type/DGRAM.hsc +11/−0
- src/System/Socket/Type/SEQPACKET.hsc +11/−0
- src/System/Socket/Type/STREAM.hsc +11/−0
- src/System/Socket/Unsafe.hsc +111/−0
- tests/Basic.hs +91/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/misc.c view
@@ -0,0 +1,13 @@+#include <stdint.h>+#include <fcntl.h>+#include <sys/socket.h>+#include <netinet/in.h>++int setnonblocking(int fd) {+ int flags;++ if (-1 == (flags = fcntl(fd, F_GETFL, 0))) {+ flags = 0;+ }+ return fcntl(fd, F_SETFL, flags | O_NONBLOCK);+}
+ include/misc.h view
@@ -0,0 +1,5 @@+#include <stdint.h>+#include <sys/socket.h>+#include <netinet/in.h>++int setnonblocking(int fd);
+ socket.cabal view
@@ -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
+ src/System/Socket.hsc view
@@ -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)+
+ src/System/Socket/Address.hs view
@@ -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
+ src/System/Socket/Address/SockAddrIn.hsc view
@@ -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)
+ src/System/Socket/Address/SockAddrIn6.hsc view
@@ -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)
+ src/System/Socket/Address/SockAddrUn.hsc view
@@ -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
+ src/System/Socket/Internal/Event.hs view
@@ -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
+ src/System/Socket/Internal/FFI.hs view
@@ -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
+ src/System/Socket/Internal/Socket.hsc view
@@ -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)
+ src/System/Socket/Protocol.hs view
@@ -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
+ src/System/Socket/Protocol/SCTP.hsc view
@@ -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)
+ src/System/Socket/Protocol/TCP.hsc view
@@ -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)
+ src/System/Socket/Protocol/UDP.hsc view
@@ -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)
+ src/System/Socket/Type.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+module System.Socket.Type+ ( Type (..)+ ) where++import Foreign.C.Types++class Type t where+ typeNumber :: t -> CInt
+ src/System/Socket/Type/DGRAM.hsc view
@@ -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)
+ src/System/Socket/Type/SEQPACKET.hsc view
@@ -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)
+ src/System/Socket/Type/STREAM.hsc view
@@ -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)
+ src/System/Socket/Unsafe.hsc view
@@ -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)
+ tests/Basic.hs view
@@ -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)