socket 0.1.0.1 → 0.2.0.0
raw patch · 14 files changed
+596/−173 lines, 14 filesdep ~base
Dependency ranges changed: base
Files
- CHANGELOG.md +10/−0
- socket.cabal +10/−4
- src/System/Socket.hsc +112/−20
- src/System/Socket/Address.hs +2/−2
- src/System/Socket/Address/SockAddrIn.hsc +8/−1
- src/System/Socket/Address/SockAddrIn6.hsc +31/−1
- src/System/Socket/Address/SockAddrUn.hsc +2/−0
- src/System/Socket/Internal/AddrInfo.hsc +252/−0
- src/System/Socket/Internal/Event.hs +0/−7
- src/System/Socket/Internal/Exception.hs +122/−0
- src/System/Socket/Internal/FFI.hs +4/−10
- src/System/Socket/Internal/MsgFlags.hsc +40/−0
- src/System/Socket/Internal/Socket.hsc +1/−128
- src/System/Socket/Unsafe.hsc +2/−0
CHANGELOG.md view
@@ -1,3 +1,13 @@+0.2.0.0 Lars Petersen <info@lars-petersen.net> 2015-05-29++ * Added a sendAll operation+ * Exposed the Socket constructor+ * Added `getNameInfo` operation+ * Added msgWAITALL and fixed serious bug regarding all other MsgFlags+ * Nicer Show instances for SockAddrIn and SockAddrIn6+ * Hiding internal modules+ * Added `getAddrInfo` operation+ 0.1.0.1 Lars Petersen <info@lars-petersen.net> 2015-05-28 * Added CHANGELOG.md
socket.cabal view
@@ -1,5 +1,5 @@ name: socket-version: 0.1.0.1+version: 0.2.0.0 synopsis: A binding to the POSIX sockets interface description: This package provides access to the system's socket interface with POSIX semantics.@@ -9,6 +9,9 @@ It integrates with GHC's event management mechanism (which itself uses epoll, libev or similar) and makes all functions have blocking semantics without actually blocking the runtime system.+ .+ This is a community project :-) Don't hesitate to request features on the+ issue tracker or even implement some and send a pull request. license: MIT license-file: LICENSE author: Lars Petersen@@ -36,10 +39,13 @@ , System.Socket.Protocol.TCP , System.Socket.Protocol.SCTP , System.Socket.Unsafe- , System.Socket.Internal.FFI+ other-modules: System.Socket.Internal.FFI , System.Socket.Internal.Event , System.Socket.Internal.Socket- build-depends: base < 5+ , System.Socket.Internal.Exception+ , System.Socket.Internal.MsgFlags+ , System.Socket.Internal.AddrInfo+ build-depends: base >= 4.7 && < 5 , bytestring < 0.11 hs-source-dirs: src build-tools: hsc2hs@@ -55,7 +61,7 @@ main-is: Basic.hs type: exitcode-stdio-1.0 default-language: Haskell2010- build-depends: base < 5+ build-depends: base >= 4.7 && < 5 , bytestring < 0.11 , socket , async
src/System/Socket.hsc view
@@ -8,6 +8,9 @@ -- Maintainer : info@lars-petersen.net -- Stability : experimental --+-- This starts a TCP server on localhost, sends @"Hello world!"@ to+-- connecting peers and closes the connection immediately.+-- -- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- >@@ -15,6 +18,7 @@ -- > import Data.ByteString -- > import Control.Monad -- > import Control.Concurrent+-- > import Control.Exception -- > -- > main :: IO () -- > main = do@@ -24,13 +28,69 @@ -- > forever $ do -- > (peer,addr) <- accept s -- > forkIO $ do--- > send peer "Hello world!"--- > close peer+-- > sendAll peer "Hello world!" mempty `finally` close peer+--+-- This downloads the [Haskell website](http://www.haskell.org) and shows how to+-- handle exceptions. Note the use of IPv4-mapped IPv6 addresses: This will work+-- even if you don't have IPv6 connectivity yet and is the preferred method+-- when new applications.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > module Main where+-- > +-- > import Control.Monad+-- > import Control.Exception+-- > +-- > import Data.Function (fix)+-- > import qualified Data.ByteString as BS+-- > +-- > import System.IO+-- > import System.Exit+-- > import System.Socket+-- > +-- > main :: IO ()+-- > main = fetch+-- > `catch` (\e-> do+-- > hPutStr stderr "Something failed when resolving the name: "+-- > hPutStrLn stderr $ show (e :: AddrInfoException)+-- > exitFailure+-- > )+-- > `catch` (\e-> do+-- > hPutStr stderr "Something went wrong with the socket: "+-- > hPutStrLn stderr $ show (e :: SocketException)+-- > exitFailure+-- > )+-- > +-- > fetch :: IO ()+-- > fetch = do+-- > addrs <- getAddrInfo (Just "www.haskell.org") (Just "80") aiV4MAPPED :: IO [AddrInfo SockAddrIn6 STREAM TCP]+-- > case addrs of+-- > (addr:_) ->+-- > -- always use the `bracket` pattern to reliably release resources!+-- > bracket+-- > ( socket :: IO (Socket SockAddrIn6 STREAM TCP) )+-- > ( close )+-- > ( \s-> do connect s (addrAddress addr)+-- > sendAll s "GET / HTTP/1.0\r\nHost: www.haskell.org\r\n\r\n" mempty+-- > fix $ \recvMore-> do+-- > bs <- recv s 4096 mempty+-- > BS.putStr bs+-- > if BS.length bs == 0 -- an empty string means the peer terminated the connection+-- > then exitSuccess+-- > else recvMore+-- > )+-- > _ -> error "Illegal state: getAddrInfo yields non-empty list or exception." ----------------------------------------------------------------------------- module System.Socket (+ -- * Name Resolution+ AddrInfo (..)+ -- ** getAddrInfo+ , getAddrInfo+ -- ** getNameInfo+ , getNameInfo -- * Operations -- ** socket- socket+ , socket -- ** bind , bind -- ** listen@@ -41,6 +101,8 @@ , connect -- ** send , send+ -- ** sendAll+ , sendAll -- ** sendTo , sendTo -- ** recv@@ -51,21 +113,21 @@ , close -- * Sockets- , Socket ()+ , Socket (..) -- ** Addresses , Address (..)- -- *** SockAddrUn- , SockAddrUn (..) -- *** SockAddrIn , SockAddrIn (..) -- *** SockAddrIn6 , SockAddrIn6 (..)+ -- *** SockAddrUn+ , SockAddrUn (..) -- ** Types , Type (..)- -- *** STREAM- , STREAM -- *** DGRAM , DGRAM+ -- *** STREAM+ , STREAM -- *** SEQPACKET , SEQPACKET -- ** Protocols@@ -76,22 +138,39 @@ , TCP -- *** SCTP , SCTP- -- * MsgFlags- , MsgFlags- -- ** msgEOR- , msgEOR- -- ** msgOOB- , msgOOB- -- ** msgNOSIGNAL- , msgNOSIGNAL- -- * getSockOpt / setSockOpt+ -- * Exceptions+ -- ** SocketException+ , SocketException (..)+ -- ** AddrInfoException+ , AddrInfoException (..)+ -- * Options , GetSockOpt (..) , SetSockOpt (..)- -- * Generic socket options -- ** SO_ACCEPTCONN , SO_ACCEPTCONN (..)- -- * SocketException- , SocketException (..)+ -- * Flags+ -- ** MsgFlags+ , MsgFlags (..)+ , msgEOR+ , msgNOSIGNAL+ , msgOOB+ , msgWAITALL+ -- ** AddrInfoFlags+ , AddrInfoFlags (..)+ , aiADDRCONFIG+ , aiALL+ , aiCANONNAME+ , aiNUMERICHOST+ , aiNUMERICSERV+ , aiPASSIVE+ , aiV4MAPPED+ -- ** NameInfoFlags+ , NameInfoFlags (..)+ , niNAMEREQD+ , niDGRAM+ , niNOFQDN+ , niNUMERICHOST+ , niNUMERICSERV ) where import Control.Exception@@ -113,6 +192,9 @@ import System.Socket.Internal.Socket import System.Socket.Internal.Event import System.Socket.Internal.FFI+import System.Socket.Internal.Exception+import System.Socket.Internal.MsgFlags+import System.Socket.Internal.AddrInfo import System.Socket.Address import System.Socket.Address.SockAddrUn@@ -390,6 +472,16 @@ bytesSent <- BS.unsafeUseAsCStringLen bs $ \(bufPtr,bufSize)-> unsafeSend s bufPtr (fromIntegral bufSize) flags return (fromIntegral bytesSent)++-- | Like `send`, but continues until all data has been sent.+--+-- > sendAll sock data flags = do+-- > sent <- send sock data flags+-- > when (sent < length data) $ sendAll sock (drop sent data) flags+sendAll ::(Address a, Type t, Protocol p) => Socket a t p -> BS.ByteString -> MsgFlags -> IO ()+sendAll s bs flags = do+ sent <- send s bs flags+ when (sent < BS.length bs) $ sendAll s (BS.drop sent bs) flags -- | Send a message on a socket with a specific destination address. --
src/System/Socket/Address.hs view
@@ -6,5 +6,5 @@ import Foreign.C.Types import Foreign.Storable -class (Storable f) => Address f where- addressFamilyNumber :: f -> CInt+class (Storable a) => Address a where+ addressFamilyNumber :: a -> CInt
src/System/Socket/Address/SockAddrIn.hsc view
@@ -3,6 +3,7 @@ ) where import Data.Word+import Data.List import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS @@ -11,6 +12,7 @@ import Foreign.Marshal.Utils import System.Socket.Address+import System.Socket.Internal.FFI #include "sys/types.h" #include "sys/socket.h"@@ -25,8 +27,12 @@ = SockAddrIn { sinPort :: Word16 , sinAddr :: BS.ByteString- } deriving (Eq, Ord, Show)+ } deriving (Eq, Ord) +instance Show SockAddrIn where+ show (SockAddrIn p a) =+ "\"" ++ (concat $ intersperse "." $ map show $ BS.unpack a) ++ ":" ++ show p ++ "\""+ instance Storable SockAddrIn where sizeOf _ = (#size struct sockaddr_in) alignment _ = (#alignment struct sockaddr_in)@@ -39,6 +45,7 @@ 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+ c_memset ptr 0 (#const sizeof(struct sockaddr_in)) 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)
src/System/Socket/Address/SockAddrIn6.hsc view
@@ -11,6 +11,7 @@ import Foreign.Marshal.Utils import System.Socket.Address+import System.Socket.Internal.FFI #include "sys/types.h" #include "sys/socket.h"@@ -27,8 +28,36 @@ , sin6Flowinfo :: Word32 , sin6Addr :: BS.ByteString , sin6ScopeId :: Word32- } deriving (Eq, Ord, Show)+ } deriving (Eq, Ord) +instance Show SockAddrIn6 where+ show (SockAddrIn6 p _ addr _) = '"':'[':(tail $ t $ BS.unpack addr)+ where+ t [] = ']':':':(show p ++ "\"")+ t [x] = g x 0 (']':':':(show p) ++ "\"")+ t (x:y:xs) = g x y (t xs)+ g x y s = let (a,b) = quotRem x 16+ (c,d) = quotRem y 16+ in ':':(h a):(h b):(h c):(h d):s+ h :: Word8 -> Char+ h 0 = '0'+ h 1 = '1'+ h 2 = '2'+ h 3 = '3'+ h 4 = '4'+ h 5 = '5'+ h 6 = '6'+ h 7 = '7'+ h 8 = '8'+ h 9 = '9'+ h 10 = 'a'+ h 11 = 'b'+ h 12 = 'c'+ h 13 = 'd'+ h 14 = 'e'+ h 15 = 'f'+ h _ = '_'+ instance Storable SockAddrIn6 where sizeOf _ = (#size struct sockaddr_in6) alignment _ = (#alignment struct sockaddr_in6)@@ -45,6 +74,7 @@ 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+ c_memset ptr 0 (#const sizeof(struct sockaddr_in6)) poke (sin6_family ptr) ((#const AF_INET6) :: Word16) poke (sin6_flowinfo ptr) f poke (sin6_scope_id ptr) s
src/System/Socket/Address/SockAddrUn.hsc view
@@ -10,6 +10,7 @@ import Foreign.Marshal.Utils import System.Socket.Address+import System.Socket.Internal.FFI #include "sys/types.h" #include "sys/socket.h"@@ -34,6 +35,7 @@ where sun_path = (#ptr struct sockaddr_un, sun_path) poke ptr (SockAddrUn path) = do+ c_memset ptr 0 (#const sizeof(struct sockaddr_un)) -- useAsCString null-terminates the CString BS.useAsCString truncatedPath $ \cs-> do copyBytes (sun_path ptr) cs (BS.length truncatedPath + 1)-- copyBytes dest from count
+ src/System/Socket/Internal/AddrInfo.hsc view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module System.Socket.Internal.AddrInfo (+ AddrInfo (..)+ , AddrInfoException (..)+ , getAddrInfo+ , getNameInfo+ , AddrInfoFlags (..)+ , aiADDRCONFIG+ , aiALL+ , aiCANONNAME+ , aiNUMERICHOST+ , aiNUMERICSERV+ , aiPASSIVE+ , aiV4MAPPED+ , NameInfoFlags (..)+ , niNAMEREQD+ , niDGRAM+ , niNOFQDN+ , niNUMERICHOST+ , niNUMERICSERV+ ) where++import Control.Exception+import Control.Monad++import Data.Bits+import Data.Monoid+import Data.Typeable+import qualified Data.ByteString as BS++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Alloc++import System.Socket.Address+import System.Socket.Type+import System.Socket.Protocol+import System.Socket.Internal.FFI++#include "sys/types.h"+#include "sys/socket.h"+#include "netdb.h"+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++-------------------------------------------------------------------------------+-- AddrInfo+-------------------------------------------------------------------------------++data AddrInfo a t p+ = AddrInfo+ { addrInfoFlags :: AddrInfoFlags+ , addrAddress :: a+ , addrCanonName :: Maybe BS.ByteString+ } deriving (Eq, Show)++-------------------------------------------------------------------------------+-- AddrInfoException+-------------------------------------------------------------------------------++-- | Contains the error code that can be matched against and a readable+-- description taken from @eia_strerr@.+data AddrInfoException+ = AddrInfoException CInt String+ deriving (Eq, Show, Typeable)++instance Exception AddrInfoException++-- | Use the `Data.Monoid.Monoid` instance to combine several flags:+--+-- > mconcat [aiADDRCONFIG, aiV4MAPPED]+newtype AddrInfoFlags+ = AddrInfoFlags CInt+ deriving (Eq, Show)++instance Monoid AddrInfoFlags where+ mempty+ = AddrInfoFlags 0+ mappend (AddrInfoFlags a) (AddrInfoFlags b)+ = AddrInfoFlags (a .|. b)++aiADDRCONFIG :: AddrInfoFlags+aiADDRCONFIG = AddrInfoFlags (#const AI_ADDRCONFIG)++aiALL :: AddrInfoFlags+aiALL = AddrInfoFlags (#const AI_ALL)++aiCANONNAME :: AddrInfoFlags+aiCANONNAME = AddrInfoFlags (#const AI_CANONNAME)++aiNUMERICHOST :: AddrInfoFlags+aiNUMERICHOST = AddrInfoFlags (#const AI_NUMERICHOST)++aiNUMERICSERV :: AddrInfoFlags+aiNUMERICSERV = AddrInfoFlags (#const AI_NUMERICSERV)++aiPASSIVE :: AddrInfoFlags+aiPASSIVE = AddrInfoFlags (#const AI_PASSIVE)++aiV4MAPPED :: AddrInfoFlags+aiV4MAPPED = AddrInfoFlags (#const AI_V4MAPPED)++-- | Use the `Data.Monoid.Monoid` instance to combine several flags:+--+-- > mconcat [niNAMEREQD, niNOFQDN]+newtype NameInfoFlags+ = NameInfoFlags CInt+ deriving (Eq, Show)++instance Monoid NameInfoFlags where+ mempty+ = NameInfoFlags 0+ mappend (NameInfoFlags a) (NameInfoFlags b)+ = NameInfoFlags (a .|. b)++-- | Throw an exception if the hostname cannot be determined.+niNAMEREQD :: NameInfoFlags+niNAMEREQD = NameInfoFlags (#const NI_NAMEREQD)++-- | Service is datagram based (UDP) rather than stream based (TCP).+niDGRAM :: NameInfoFlags+niDGRAM = NameInfoFlags (#const NI_DGRAM)++-- | Return only the hostname part of the fully qualified domain name for local hosts.+niNOFQDN :: NameInfoFlags+niNOFQDN = NameInfoFlags (#const NI_NOFQDN)++-- | Return the numeric form of the host address.+niNUMERICHOST :: NameInfoFlags+niNUMERICHOST = NameInfoFlags (#const NI_NUMERICHOST)++-- | Return the numeric form of the service address.+niNUMERICSERV :: NameInfoFlags+niNUMERICSERV = NameInfoFlags (#const NI_NUMERICSERV)++-- | Maps names to addresses (i.e. by DNS lookup).+--+-- The operation throws `AddrInfoException`s.+--+-- Contrary to the underlying @getaddrinfo@ operation this wrapper is+-- typesafe and thus only returns records that match the address, type+-- and protocol encoded in the type. This is the price we have to pay+-- for typesafe sockets and extensibility.+--+-- If you need different types of records, you need to start several+-- queries. If you want to connect to both IPv4 and IPV6 addresses use+-- `aiV4MAPPED` and use IPv6-sockets.+--+-- > > getAddrInfo (Just "www.haskell.org") (Just "80") aiV4MAPPED :: IO [AddrInfo SockAddrIn6 STREAM TCP]+-- > [AddrInfo {addrInfoFlags = AddrInfoFlags 8, addrAddress = "[2400:cb00:2048:0001:0000:0000:6ca2:cc3c]:80", addrCanonName = Nothing}]+-- > > getAddrInfo (Just "darcs.haskell.org") Nothing aiV4MAPPED :: IO [AddrInfo SockAddrIn6 STREAM TCP]+-- > [AddrInfo {addrInfoFlags = AddrInfoFlags 8, addrAddress = "[0000:0000:0000:0000:0000:ffff:17fd:e1ad]:0", addrCanonName = Nothing}]+-- > > getAddrInfo (Just "darcs.haskell.org") Nothing mempty :: IO [AddrInfo SockAddrIn6 STREAM TCP]+-- > *** Exception: AddrInfoException (-2) "Name or service not known"+getAddrInfo :: (Address a, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddrInfoFlags -> IO [AddrInfo a t p]+getAddrInfo = getAddrInfo'+ where+ getAddrInfo' :: forall a t p. (Address a, Type t, Protocol p) => Maybe BS.ByteString -> Maybe BS.ByteString -> AddrInfoFlags -> IO [AddrInfo a t p]+ getAddrInfo' mnode mservice (AddrInfoFlags flags) = do+ alloca $ \resultPtrPtr-> do+ poke resultPtrPtr nullPtr+ allocaBytes (#size struct addrinfo) $ \addrInfoPtr-> do+ -- properly initialize the struct+ c_memset addrInfoPtr 0 (#const sizeof(struct addrinfo))+ poke (ai_flags addrInfoPtr) flags+ poke (ai_family addrInfoPtr) (addressFamilyNumber (undefined :: a))+ poke (ai_socktype addrInfoPtr) (typeNumber (undefined :: t))+ poke (ai_protocol addrInfoPtr) (protocolNumber (undefined :: p))+ fnode $ \nodePtr-> do+ fservice $ \servicePtr->+ bracket+ (c_getaddrinfo nodePtr servicePtr addrInfoPtr resultPtrPtr)+ (\_-> do resultPtr <- peek resultPtrPtr+ when (resultPtr /= nullPtr) (c_freeaddrinfo resultPtr)+ )+ (\e-> if e == 0 then do+ resultPtr <- peek resultPtrPtr+ peekAddrInfos resultPtr+ else do+ msgPtr <- c_gaistrerror e+ msg <- peekCString msgPtr+ throwIO (AddrInfoException e msg)+ )+ where+ ai_flags = (#ptr struct addrinfo, ai_flags) :: Ptr (AddrInfo a t p) -> Ptr CInt+ ai_family = (#ptr struct addrinfo, ai_family) :: Ptr (AddrInfo a t p) -> Ptr CInt+ ai_socktype = (#ptr struct addrinfo, ai_socktype) :: Ptr (AddrInfo a t p) -> Ptr CInt+ ai_protocol = (#ptr struct addrinfo, ai_protocol) :: Ptr (AddrInfo a t p) -> Ptr CInt+ ai_addr = (#ptr struct addrinfo, ai_addr) :: Ptr (AddrInfo a t p) -> Ptr (Ptr a)+ ai_canonname = (#ptr struct addrinfo, ai_canonname) :: Ptr (AddrInfo a t p) -> Ptr CString+ ai_next = (#ptr struct addrinfo, ai_next) :: Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo a t p))+ fnode = case mnode of+ Just node -> BS.useAsCString node+ Nothing -> \f-> f nullPtr+ fservice = case mservice of+ Just service -> BS.useAsCString service+ Nothing -> \f-> f nullPtr+ peekAddrInfos ptr = + if ptr == nullPtr+ then return []+ else do+ flag <- peek (ai_flags ptr)+ addr <- peek (ai_addr ptr) >>= peek+ cname <- do cnPtr <- peek (ai_canonname ptr)+ if cnPtr == nullPtr+ then return Nothing+ else BS.packCString cnPtr >>= return . Just+ as <- peek (ai_next ptr) >>= peekAddrInfos+ return ((AddrInfo (AddrInfoFlags flag) addr cname):as)++-- | Maps addresss to readable host- and service names.+--+-- The operation throws `AddrInfoException`s.+--+-- > > getNameInfo (SockAddrIn 80 $ pack [23,253,242,70]) mempty+-- > ("haskell.org","http")+getNameInfo :: (Address a) => a -> NameInfoFlags -> IO (BS.ByteString, BS.ByteString)+getNameInfo addr (NameInfoFlags flags) =+ alloca $ \addrPtr->+ allocaBytes (#const NI_MAXHOST) $ \hostPtr->+ allocaBytes (#const NI_MAXSERV) $ \servPtr-> do+ poke addrPtr addr+ e <- c_getnameinfo addrPtr (fromIntegral $ sizeOf addr)+ hostPtr (#const NI_MAXHOST)+ servPtr (#const NI_MAXSERV)+ flags+ if e == 0 then do+ host <- BS.packCString hostPtr+ serv <- BS.packCString servPtr+ return (host,serv)+ else do+ msgPtr <- c_gaistrerror e+ msg <- peekCString msgPtr+ throwIO (AddrInfoException e msg)++-------------------------------------------------------------------------------+-- FFI+-------------------------------------------------------------------------------++foreign import ccall safe "netdb.h getaddrinfo"+ c_getaddrinfo :: CString -> CString -> Ptr (AddrInfo a t p) -> Ptr (Ptr (AddrInfo a t p)) -> IO CInt++foreign import ccall unsafe "netdb.h freeaddrinfo"+ c_freeaddrinfo :: Ptr (AddrInfo a t p) -> IO ()++foreign import ccall safe "netdb.h getnameinfo"+ c_getnameinfo :: Ptr a -> CInt -> CString -> CInt -> CString -> CInt -> CInt -> IO CInt++foreign import ccall unsafe "netdb.h gai_strerror"+ c_gaistrerror :: CInt -> IO CString+
src/System/Socket/Internal/Event.hs view
@@ -2,16 +2,9 @@ ( threadWaitWrite', threadWaitRead' ) where -import Control.Concurrent.MVar-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
+ src/System/Socket/Internal/Exception.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}+module System.Socket.Internal.Exception (+ SocketException (..)+ ) where++import Control.Exception++import Data.Typeable++import Foreign.C.Error++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
src/System/Socket/Internal/FFI.hs view
@@ -1,21 +1,12 @@ 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+import System.Socket.Internal.MsgFlags -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@@ -53,3 +44,6 @@ foreign import ccall unsafe "misc.h setnonblocking" c_setnonblocking :: Fd -> IO CInt++foreign import ccall unsafe "string.h memset"+ c_memset :: Ptr a -> CInt -> CSize -> IO ()
+ src/System/Socket/Internal/MsgFlags.hsc view
@@ -0,0 +1,40 @@+module System.Socket.Internal.MsgFlags (+ MsgFlags (..)+ , msgEOR+ , msgNOSIGNAL+ , msgOOB+ , msgWAITALL+ ) where++import Data.Bits+import Data.Monoid++import Foreign.C.Types++#include "sys/socket.h"++-- | Use the `Data.Monoid.Monoid` instance to combine several flags:+--+-- > mconcat [msgNOSIGNAL, msgWAITALL]+newtype MsgFlags+ = MsgFlags CInt+ deriving (Eq, Show)++instance Monoid MsgFlags where+ mempty+ = MsgFlags 0+ mappend (MsgFlags a) (MsgFlags b)+ = MsgFlags (a .|. b)++msgEOR :: MsgFlags+msgEOR = MsgFlags (#const MSG_EOR)++msgNOSIGNAL :: MsgFlags+msgNOSIGNAL = MsgFlags (#const MSG_NOSIGNAL)++msgOOB :: MsgFlags+msgOOB = MsgFlags (#const MSG_OOB)++msgWAITALL :: MsgFlags+msgWAITALL = MsgFlags (#const MSG_WAITALL)+
src/System/Socket/Internal/Socket.hsc view
@@ -1,11 +1,5 @@-{-# LANGUAGE DeriveDataTypeable #-} module System.Socket.Internal.Socket ( Socket (..)- , SocketException (..)- , MsgFlags (..)- , msgEOR- , msgOOB- , msgNOSIGNAL , GetSockOpt (..) , SetSockOpt (..) , SO_ACCEPTCONN (..)@@ -14,8 +8,6 @@ import Control.Concurrent.MVar import Control.Exception -import Data.Typeable- import Foreign.Ptr import Foreign.Storable import Foreign.C.Error@@ -23,6 +15,7 @@ import System.Posix.Types import System.Socket.Internal.FFI+import System.Socket.Internal.Exception #include "sys/socket.h" @@ -50,126 +43,6 @@ -- 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
src/System/Socket/Unsafe.hsc view
@@ -23,6 +23,8 @@ import System.Socket.Internal.Socket import System.Socket.Internal.Event import System.Socket.Internal.FFI+import System.Socket.Internal.Exception+import System.Socket.Internal.MsgFlags import System.Socket.Address import System.Socket.Type import System.Socket.Protocol