diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +0.2.0.0 Lars Petersen 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 2015-05-28 * Added CHANGELOG.md diff --git a/socket.cabal b/socket.cabal --- a/socket.cabal +++ b/socket.cabal @@ -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 diff --git a/src/System/Socket.hsc b/src/System/Socket.hsc --- a/src/System/Socket.hsc +++ b/src/System/Socket.hsc @@ -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. -- diff --git a/src/System/Socket/Address.hs b/src/System/Socket/Address.hs --- a/src/System/Socket/Address.hs +++ b/src/System/Socket/Address.hs @@ -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 diff --git a/src/System/Socket/Address/SockAddrIn.hsc b/src/System/Socket/Address/SockAddrIn.hsc --- a/src/System/Socket/Address/SockAddrIn.hsc +++ b/src/System/Socket/Address/SockAddrIn.hsc @@ -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) diff --git a/src/System/Socket/Address/SockAddrIn6.hsc b/src/System/Socket/Address/SockAddrIn6.hsc --- a/src/System/Socket/Address/SockAddrIn6.hsc +++ b/src/System/Socket/Address/SockAddrIn6.hsc @@ -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 diff --git a/src/System/Socket/Address/SockAddrUn.hsc b/src/System/Socket/Address/SockAddrUn.hsc --- a/src/System/Socket/Address/SockAddrUn.hsc +++ b/src/System/Socket/Address/SockAddrUn.hsc @@ -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 diff --git a/src/System/Socket/Internal/AddrInfo.hsc b/src/System/Socket/Internal/AddrInfo.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/AddrInfo.hsc @@ -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 + diff --git a/src/System/Socket/Internal/Event.hs b/src/System/Socket/Internal/Event.hs --- a/src/System/Socket/Internal/Event.hs +++ b/src/System/Socket/Internal/Event.hs @@ -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 diff --git a/src/System/Socket/Internal/Exception.hs b/src/System/Socket/Internal/Exception.hs new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/Exception.hs @@ -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 diff --git a/src/System/Socket/Internal/FFI.hs b/src/System/Socket/Internal/FFI.hs --- a/src/System/Socket/Internal/FFI.hs +++ b/src/System/Socket/Internal/FFI.hs @@ -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 () diff --git a/src/System/Socket/Internal/MsgFlags.hsc b/src/System/Socket/Internal/MsgFlags.hsc new file mode 100644 --- /dev/null +++ b/src/System/Socket/Internal/MsgFlags.hsc @@ -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) + diff --git a/src/System/Socket/Internal/Socket.hsc b/src/System/Socket/Internal/Socket.hsc --- a/src/System/Socket/Internal/Socket.hsc +++ b/src/System/Socket/Internal/Socket.hsc @@ -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 diff --git a/src/System/Socket/Unsafe.hsc b/src/System/Socket/Unsafe.hsc --- a/src/System/Socket/Unsafe.hsc +++ b/src/System/Socket/Unsafe.hsc @@ -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