{-# LANGUAGE CPP, FlexibleInstances, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Network.Socket.Internal -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/network/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- A module containing semi-public 'Network.Socket' internals. -- Modules which extend the 'Network.Socket' module will need to use -- this module while ideally most users will be able to make do with -- the public interface. -- ----------------------------------------------------------------------------- #include "HsNet.h" module Network.Socket.Internal ( -- * Socket addresses HostAddress, #if defined(IPV6_SOCKET_SUPPORT) HostAddress6, FlowInfo, ScopeID, #endif PortNumber(..), SockAddr(..), peekSockAddr, pokeSockAddr, sizeOfSockAddr, sizeOfSockAddrByFamily, withSockAddr, withNewSockAddr, -- * Protocol families Family(..), -- * Socket error functions #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) c_getLastError, #endif throwSocketError, -- * Guards for socket operations that may fail throwSocketErrorIfMinus1_, throwSocketErrorIfMinus1Retry, throwSocketErrorIfMinus1RetryMayBlock, -- * Initialization withSocketsDo, -- * Low-level helpers zeroMemory, ) where import Data.Bits ( (.|.), shiftL, shiftR ) import Data.Word ( Word8, Word16, Word32 ) import Foreign.C.Error (throwErrno, throwErrnoIfMinus1Retry, throwErrnoIfMinus1RetryMayBlock, throwErrnoIfMinus1_) import Foreign.C.String ( castCharToCChar, peekCString ) import Foreign.C.Types ( CInt, CSize ) import Foreign.Marshal.Alloc ( allocaBytes ) import Foreign.Marshal.Array ( pokeArray, pokeArray0 ) import Foreign.Ptr ( Ptr, castPtr, plusPtr ) import Foreign.Storable ( Storable(..) ) #if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) import Control.Exception ( finally ) # if __GLASGOW_HASKELL__ import GHC.IOBase ( IOErrorType(..) ) # endif import Foreign.C.Types ( CChar ) import System.IO.Error ( ioeSetErrorString, mkIOError ) #endif ------------------------------------------------------------------------ type HostAddress = Word32 #if defined(IPV6_SOCKET_SUPPORT) type HostAddress6 = (Word32, Word32, Word32, Word32) -- The peek32 and poke32 functions work around the fact that the RFCs -- don't require 32-bit-wide address fields to be present. We can -- only portably rely on an 8-bit field, s6_addr. s6_addr_offset :: Int s6_addr_offset = (#offset struct in6_addr, s6_addr) peek32 :: Ptr a -> Int -> IO Word32 peek32 p i = do let i' = i * 4 peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8 a `sl` i = fromIntegral a `shiftL` i a0 <- peekByte 0 a1 <- peekByte 1 a2 <- peekByte 2 a3 <- peekByte 3 return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0)) poke32 :: Ptr a -> Int -> Word32 -> IO () poke32 p i a = do let i' = i * 4 pokeByte n = pokeByteOff p (s6_addr_offset + i' + n) a `sr` i = fromIntegral (a `shiftR` i) :: Word8 pokeByte 0 (a `sr` 24) pokeByte 1 (a `sr` 16) pokeByte 2 (a `sr` 8) pokeByte 3 (a `sr` 0) instance Storable HostAddress6 where sizeOf _ = (#const sizeof(struct in6_addr)) alignment _ = alignment (undefined :: CInt) peek p = do a <- peek32 p 0 b <- peek32 p 1 c <- peek32 p 2 d <- peek32 p 3 return (a, b, c, d) poke p (a, b, c, d) = do poke32 p 0 a poke32 p 1 b poke32 p 2 c poke32 p 3 d #endif ------------------------------------------------------------------------ -- Port Numbers -- -- newtyped to prevent accidental use of sane-looking -- port numbers that haven't actually been converted to -- network-byte-order first. -- newtype PortNumber = PortNum Word16 deriving ( Eq, Ord ) ------------------------------------------------------------------------ -- Socket addresses -- The scheme used for addressing sockets is somewhat quirky. The -- calls in the BSD socket API that need to know the socket address -- all operate in terms of struct sockaddr, a `virtual' type of -- socket address. -- The Internet family of sockets are addressed as struct sockaddr_in, -- so when calling functions that operate on struct sockaddr, we have -- to type cast the Internet socket address into a struct sockaddr. -- Instances of the structure for different families might *not* be -- the same size. Same casting is required of other families of -- sockets such as Xerox NS. Similarly for Unix domain sockets. -- To represent these socket addresses in Haskell-land, we do what BSD -- didn't do, and use a union/algebraic type for the different -- families. Currently only Unix domain sockets and the Internet -- families are supported. #if defined(IPV6_SOCKET_SUPPORT) type FlowInfo = Word32 type ScopeID = Word32 #endif data SockAddr -- C Names = SockAddrInet PortNumber -- sin_port (network byte order) HostAddress -- sin_addr (ditto) #if defined(IPV6_SOCKET_SUPPORT) | SockAddrInet6 PortNumber -- sin6_port (network byte order) FlowInfo -- sin6_flowinfo (ditto) HostAddress6 -- sin6_addr (ditto) ScopeID -- sin6_scope_id (ditto) #endif #if defined(DOMAIN_SOCKET_SUPPORT) | SockAddrUnix String -- sun_path #endif deriving (Eq) #if defined(WITH_WINSOCK) || defined(cygwin32_HOST_OS) type CSaFamily = (#type unsigned short) #elif defined(darwin_HOST_OS) type CSaFamily = (#type u_char) #else type CSaFamily = (#type sa_family_t) #endif -- | Computes the storage requirements (in bytes) of the given -- 'SockAddr'. This function differs from 'Foreign.Storable.sizeOf' -- in that the value of the argument /is/ used. sizeOfSockAddr :: SockAddr -> Int #if defined(DOMAIN_SOCKET_SUPPORT) sizeOfSockAddr (SockAddrUnix path) = case path of '\0':_ -> (#const sizeof(sa_family_t)) + length path _ -> #const sizeof(struct sockaddr_un) #endif sizeOfSockAddr (SockAddrInet _ _) = #const sizeof(struct sockaddr_in) #if defined(IPV6_SOCKET_SUPPORT) sizeOfSockAddr (SockAddrInet6 _ _ _ _) = #const sizeof(struct sockaddr_in6) #endif -- | Computes the storage requirements (in bytes) required for a -- 'SockAddr' with the given 'Family'. sizeOfSockAddrByFamily :: Family -> Int #if defined(DOMAIN_SOCKET_SUPPORT) sizeOfSockAddrByFamily AF_UNIX = #const sizeof(struct sockaddr_un) #endif #if defined(IPV6_SOCKET_SUPPORT) sizeOfSockAddrByFamily AF_INET6 = #const sizeof(struct sockaddr_in6) #endif sizeOfSockAddrByFamily AF_INET = #const sizeof(struct sockaddr_in) -- | Use a 'SockAddr' with a function requiring a pointer to a -- 'SockAddr' and the length of that 'SockAddr'. withSockAddr :: SockAddr -> (Ptr SockAddr -> Int -> IO a) -> IO a withSockAddr addr f = do let sz = sizeOfSockAddr addr allocaBytes sz $ \p -> pokeSockAddr p addr >> f (castPtr p) sz -- | Create a new 'SockAddr' for use with a function requiring a -- pointer to a 'SockAddr' and the length of that 'SockAddr'. withNewSockAddr :: Family -> (Ptr SockAddr -> Int -> IO a) -> IO a withNewSockAddr family f = do let sz = sizeOfSockAddrByFamily family allocaBytes sz $ \ptr -> f ptr sz -- We can't write an instance of 'Storable' for 'SockAddr' because -- @sockaddr@ is a sum type of variable size but -- 'Foreign.Storable.sizeOf' is required to be constant. -- Note that on Darwin, the sockaddr structure must be zeroed before -- use. -- | Write the given 'SockAddr' to the given memory location. pokeSockAddr :: Ptr a -> SockAddr -> IO () #if defined(DOMAIN_SOCKET_SUPPORT) pokeSockAddr p (SockAddrUnix path) = do #if defined(darwin_TARGET_OS) zeroMemory p (#const sizeof(struct sockaddr_un)) #endif #if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_un, sun_len) p ((#const sizeof(struct sockaddr_un)) :: Word8) #endif (#poke struct sockaddr_un, sun_family) p ((#const AF_UNIX) :: CSaFamily) let pathC = map castCharToCChar path poker = case path of ('\0':_) -> pokeArray; _ -> pokeArray0 0 poker ((#ptr struct sockaddr_un, sun_path) p) pathC #endif pokeSockAddr p (SockAddrInet (PortNum port) addr) = do #if defined(darwin_TARGET_OS) zeroMemory p (#const sizeof(struct sockaddr_in)) #endif #if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_in, sin_len) p ((#const sizeof(struct sockaddr_in)) :: Word8) #endif (#poke struct sockaddr_in, sin_family) p ((#const AF_INET) :: CSaFamily) (#poke struct sockaddr_in, sin_port) p port (#poke struct sockaddr_in, sin_addr) p addr #if defined(IPV6_SOCKET_SUPPORT) pokeSockAddr p (SockAddrInet6 (PortNum port) flow addr scope) = do #if defined(darwin_TARGET_OS) zeroMemory p (#const sizeof(struct sockaddr_in6)) #endif #if defined(HAVE_STRUCT_SOCKADDR_SA_LEN) (#poke struct sockaddr_in6, sin6_len) p ((#const sizeof(struct sockaddr_in6)) :: Word8) #endif (#poke struct sockaddr_in6, sin6_family) p ((#const AF_INET6) :: CSaFamily) (#poke struct sockaddr_in6, sin6_port) p port (#poke struct sockaddr_in6, sin6_flowinfo) p flow (#poke struct sockaddr_in6, sin6_addr) p addr (#poke struct sockaddr_in6, sin6_scope_id) p scope #endif -- | Read a 'SockAddr' from the given memory location. peekSockAddr :: Ptr SockAddr -> IO SockAddr peekSockAddr p = do family <- (#peek struct sockaddr, sa_family) p case family :: CSaFamily of #if defined(DOMAIN_SOCKET_SUPPORT) (#const AF_UNIX) -> do str <- peekCString ((#ptr struct sockaddr_un, sun_path) p) return (SockAddrUnix str) #endif (#const AF_INET) -> do addr <- (#peek struct sockaddr_in, sin_addr) p port <- (#peek struct sockaddr_in, sin_port) p return (SockAddrInet (PortNum port) addr) #if defined(IPV6_SOCKET_SUPPORT) (#const AF_INET6) -> do port <- (#peek struct sockaddr_in6, sin6_port) p flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p addr <- (#peek struct sockaddr_in6, sin6_addr) p scope <- (#peek struct sockaddr_in6, sin6_scope_id) p return (SockAddrInet6 (PortNum port) flow addr scope) #endif ------------------------------------------------------------------------ -- Protocol Families. -- | This data type might have different constructors depending on -- what is supported by the operating system. data Family = AF_UNSPEC -- unspecified #ifdef AF_UNIX | AF_UNIX -- local to host (pipes, portals #endif #ifdef AF_INET | AF_INET -- internetwork: UDP, TCP, etc #endif #ifdef AF_INET6 | AF_INET6 -- Internet Protocol version 6 #endif #ifdef AF_IMPLINK | AF_IMPLINK -- arpanet imp addresses #endif #ifdef AF_PUP | AF_PUP -- pup protocols: e.g. BSP #endif #ifdef AF_CHAOS | AF_CHAOS -- mit CHAOS protocols #endif #ifdef AF_NS | AF_NS -- XEROX NS protocols #endif #ifdef AF_NBS | AF_NBS -- nbs protocols #endif #ifdef AF_ECMA | AF_ECMA -- european computer manufacturers #endif #ifdef AF_DATAKIT | AF_DATAKIT -- datakit protocols #endif #ifdef AF_CCITT | AF_CCITT -- CCITT protocols, X.25 etc #endif #ifdef AF_SNA | AF_SNA -- IBM SNA #endif #ifdef AF_DECnet | AF_DECnet -- DECnet #endif #ifdef AF_DLI | AF_DLI -- Direct data link interface #endif #ifdef AF_LAT | AF_LAT -- LAT #endif #ifdef AF_HYLINK | AF_HYLINK -- NSC Hyperchannel #endif #ifdef AF_APPLETALK | AF_APPLETALK -- Apple Talk #endif #ifdef AF_ROUTE | AF_ROUTE -- Internal Routing Protocol #endif #ifdef AF_NETBIOS | AF_NETBIOS -- NetBios-style addresses #endif #ifdef AF_NIT | AF_NIT -- Network Interface Tap #endif #ifdef AF_802 | AF_802 -- IEEE 802.2, also ISO 8802 #endif #ifdef AF_ISO | AF_ISO -- ISO protocols #endif #ifdef AF_OSI | AF_OSI -- umbrella of all families used by OSI #endif #ifdef AF_NETMAN | AF_NETMAN -- DNA Network Management #endif #ifdef AF_X25 | AF_X25 -- CCITT X.25 #endif #ifdef AF_AX25 | AF_AX25 #endif #ifdef AF_OSINET | AF_OSINET -- AFI #endif #ifdef AF_GOSSIP | AF_GOSSIP -- US Government OSI #endif #ifdef AF_IPX | AF_IPX -- Novell Internet Protocol #endif #ifdef Pseudo_AF_XTP | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF) #endif #ifdef AF_CTF | AF_CTF -- Common Trace Facility #endif #ifdef AF_WAN | AF_WAN -- Wide Area Network protocols #endif #ifdef AF_SDL | AF_SDL -- SGI Data Link for DLPI #endif #ifdef AF_NETWARE | AF_NETWARE #endif #ifdef AF_NDD | AF_NDD #endif #ifdef AF_INTF | AF_INTF -- Debugging use only #endif #ifdef AF_COIP | AF_COIP -- connection-oriented IP, aka ST II #endif #ifdef AF_CNT | AF_CNT -- Computer Network Technology #endif #ifdef Pseudo_AF_RTIP | Pseudo_AF_RTIP -- Help Identify RTIP packets #endif #ifdef Pseudo_AF_PIP | Pseudo_AF_PIP -- Help Identify PIP packets #endif #ifdef AF_SIP | AF_SIP -- Simple Internet Protocol #endif #ifdef AF_ISDN | AF_ISDN -- Integrated Services Digital Network #endif #ifdef Pseudo_AF_KEY | Pseudo_AF_KEY -- Internal key-management function #endif #ifdef AF_NATM | AF_NATM -- native ATM access #endif #ifdef AF_ARP | AF_ARP -- (rev.) addr. res. prot. (RFC 826) #endif #ifdef Pseudo_AF_HDRCMPLT | Pseudo_AF_HDRCMPLT -- Used by BPF to not rewrite hdrs in iface output #endif #ifdef AF_ENCAP | AF_ENCAP #endif #ifdef AF_LINK | AF_LINK -- Link layer interface #endif #ifdef AF_RAW | AF_RAW -- Link layer interface #endif #ifdef AF_RIF | AF_RIF -- raw interface #endif #ifdef AF_NETROM | AF_NETROM -- Amateur radio NetROM #endif #ifdef AF_BRIDGE | AF_BRIDGE -- multiprotocol bridge #endif #ifdef AF_ATMPVC | AF_ATMPVC -- ATM PVCs #endif #ifdef AF_ROSE | AF_ROSE -- Amateur Radio X.25 PLP #endif #ifdef AF_NETBEUI | AF_NETBEUI -- 802.2LLC #endif #ifdef AF_SECURITY | AF_SECURITY -- Security callback pseudo AF #endif #ifdef AF_PACKET | AF_PACKET -- Packet family #endif #ifdef AF_ASH | AF_ASH -- Ash #endif #ifdef AF_ECONET | AF_ECONET -- Acorn Econet #endif #ifdef AF_ATMSVC | AF_ATMSVC -- ATM SVCs #endif #ifdef AF_IRDA | AF_IRDA -- IRDA sockets #endif #ifdef AF_PPPOX | AF_PPPOX -- PPPoX sockets #endif #ifdef AF_WANPIPE | AF_WANPIPE -- Wanpipe API sockets #endif #ifdef AF_BLUETOOTH | AF_BLUETOOTH -- bluetooth sockets #endif deriving (Eq, Ord, Read, Show) -- --------------------------------------------------------------------- -- Guards for socket operations that may fail -- | Throw an 'IOError' corresponding to the current socket error. throwSocketError :: String -- ^ textual description of the error location -> IO a -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@. Discards the result of the -- IO action after error handling. throwSocketErrorIfMinus1_ :: Num a => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO () {-# SPECIALIZE throwSocketErrorIfMinus1_ :: String -> IO CInt -> IO () #-} -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@, but retries in case of an -- interrupted operation. throwSocketErrorIfMinus1Retry :: Num a => String -- ^ textual description of the location -> IO a -- ^ the 'IO' operation to be executed -> IO a {-# SPECIALIZE throwSocketErrorIfMinus1Retry :: String -> IO CInt -> IO CInt #-} -- | Throw an 'IOError' corresponding to the current socket error if -- the IO action returns a result of @-1@, but retries in case of an -- interrupted operation. Checks for operations that would block and -- executes an alternative action before retrying in that case. throwSocketErrorIfMinus1RetryMayBlock :: Num a => String -- ^ textual description of the location -> IO b -- ^ action to execute before retrying if an -- immediate retry would block -> IO a -- ^ the 'IO' operation to be executed -> IO a {-# SPECIALIZE throwSocketErrorIfMinus1RetryMayBlock :: String -> IO b -> IO CInt -> IO CInt #-} #if defined(__GLASGOW_HASKELL__) && (!defined(HAVE_WINSOCK2_H) || defined(cygwin32_HOST_OS)) throwSocketErrorIfMinus1RetryMayBlock name on_block act = throwErrnoIfMinus1RetryMayBlock name act on_block throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry throwSocketErrorIfMinus1_ = throwErrnoIfMinus1_ throwSocketError = throwErrno #else throwSocketErrorIfMinus1RetryMayBlock name _ act = throwSocketErrorIfMinus1Retry name act throwSocketErrorIfMinus1_ name act = do throwSocketErrorIfMinus1Retry name act return () # if defined(HAVE_WINSOCK2_H) && !defined(cygwin32_HOST_OS) throwSocketErrorIfMinus1Retry name act = do r <- act if (r == -1) then do rc <- c_getLastError case rc of 10093 -> do -- WSANOTINITIALISED withSocketsDo (return ()) r <- act if (r == -1) then throwSocketError name else return r _ -> throwSocketError name else return r throwSocketError name = do rc <- c_getLastError pstr <- c_getWSError rc str <- peekCString pstr # if __GLASGOW_HASKELL__ ioError (ioeSetErrorString (mkIOError OtherError name Nothing Nothing) str) # else ioError (userError (name ++ ": socket error - " ++ str)) # endif foreign import CALLCONV unsafe "WSAGetLastError" c_getLastError :: IO CInt foreign import ccall unsafe "getWSErrorDescr" c_getWSError :: CInt -> IO (Ptr CChar) # else throwSocketErrorIfMinus1Retry = throwErrnoIfMinus1Retry throwSocketError = throwErrno # endif #endif /* __GLASGOW_HASKELL */ -- --------------------------------------------------------------------------- -- WinSock support {-| On Windows operating systems, the networking subsystem has to be initialised using 'withSocketsDo' before any networking operations can be used. eg. > main = withSocketsDo $ do {...} Although this is only strictly necessary on Windows platforms, it is harmless on other platforms, so for portability it is good practice to use it all the time. -} withSocketsDo :: IO a -> IO a #if !defined(WITH_WINSOCK) withSocketsDo x = x #else withSocketsDo act = do x <- initWinSock if x /= 0 then ioError (userError "Failed to initialise WinSock") else act `finally` shutdownWinSock foreign import ccall unsafe "initWinSock" initWinSock :: IO Int foreign import ccall unsafe "shutdownWinSock" shutdownWinSock :: IO () #endif ------------------------------------------------------------------------ -- Helper functions foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () -- | Zero a structure. zeroMemory :: Ptr a -> CSize -> IO () zeroMemory dest nbytes = memset dest 0 (fromIntegral nbytes)