{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash, UnboxedTuples #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} #include "HsNet.h" ##include "HsNetDef.h" module Network.Socket.Types ( -- * Socket type Socket , withFdSocket , unsafeFdSocket , touchSocket , socketToFd , fdSocket , mkSocket , invalidateSocket , close , close' , c_close -- * Types of socket , SocketType(GeneralSocketType, UnsupportedSocketType, NoSocketType , Stream, Datagram, Raw, RDM, SeqPacket) , isSupportedSocketType , packSocketType , unpackSocketType -- * Family , Family(GeneralFamily, UnsupportedFamily ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN) , isSupportedFamily , packFamily , unpackFamily -- * Socket address typeclass , SocketAddress(..) , withSocketAddress , withNewSocketAddress -- * Socket address type , SockAddr(..) , isSupportedSockAddr , HostAddress , hostAddressToTuple , tupleToHostAddress , HostAddress6 , hostAddress6ToTuple , tupleToHostAddress6 , FlowInfo , ScopeID , peekSockAddr , pokeSockAddr , withSockAddr -- * Unsorted , ProtocolNumber , defaultProtocol , PortNumber , defaultPort -- * Low-level helpers , zeroMemory , htonl , ntohl , In6Addr(..) ) where import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef', mkWeakIORef) import Foreign.C.Error (throwErrno) import Foreign.Marshal.Alloc import GHC.Conc (closeFdWith) import System.Posix.Types (Fd) import Control.DeepSeq (NFData (..)) import GHC.Exts (touch##) import GHC.IORef (IORef (..)) import GHC.STRef (STRef (..)) import GHC.IO (IO (..)) import qualified Text.Read as P #if defined(DOMAIN_SOCKET_SUPPORT) import Foreign.Marshal.Array #endif import Network.Socket.Imports ----- readshow module import import Network.Socket.ReadShow ----------------------------------------------------------------------------- -- | Basic type for a socket. data Socket = Socket !(IORef CInt) !CInt {- for Show -} instance Show Socket where show (Socket _ ofd) = "" instance Eq Socket where Socket ref1 _ == Socket ref2 _ = ref1 == ref2 {-# DEPRECATED fdSocket "Use withFdSocket or unsafeFdSocket instead" #-} -- | Currently, this is an alias of `unsafeFdSocket`. fdSocket :: Socket -> IO CInt fdSocket = unsafeFdSocket -- | Getting a file descriptor from a socket. -- -- If a 'Socket' is shared with multiple threads and -- one uses 'unsafeFdSocket', unexpected issues may happen. -- Consider the following scenario: -- -- 1) Thread A acquires a 'Fd' from 'Socket' by 'unsafeFdSocket'. -- -- 2) Thread B close the 'Socket'. -- -- 3) Thread C opens a new 'Socket'. Unfortunately it gets the same 'Fd' -- number which thread A is holding. -- -- In this case, it is safer for Thread A to clone 'Fd' by -- 'System.Posix.IO.dup'. But this would still suffer from -- a race condition between 'unsafeFdSocket' and 'close'. -- -- If you use this function, you need to guarantee that the 'Socket' does not -- get garbage-collected until after you finish using the file descriptor. -- 'touchSocket' can be used for this purpose. -- -- A safer option is to use 'withFdSocket' instead. unsafeFdSocket :: Socket -> IO CInt unsafeFdSocket (Socket ref _) = readIORef ref -- | Ensure that the given 'Socket' stays alive (i.e. not garbage-collected) -- at the given place in the sequence of IO actions. This function can be -- used in conjunction with 'unsafeFdSocket' to guarantee that the file -- descriptor is not prematurely freed. -- -- > fd <- unsafeFdSocket sock -- > -- using fd with blocking operations such as accept(2) -- > touchSocket sock touchSocket :: Socket -> IO () touchSocket (Socket ref _) = touch ref touch :: IORef a -> IO () touch (IORef (STRef mutVar)) = -- Thanks to a GHC issue, this touch# may not be quite guaranteed -- to work. There's talk of replacing the touch# primop with one -- that works better with the optimizer. But this seems to be the -- "right" way to do it for now. IO $ \s -> (## touch## mutVar s, () ##) -- | Get a file descriptor from a 'Socket'. The socket will never -- be closed automatically before @withFdSocket@ completes, but -- it may still be closed by an explicit call to 'close' or `close'`, -- either before or during the call. -- -- The file descriptor must not be used after @withFdSocket@ returns, because -- the 'Socket' may have been garbage-collected, invalidating the file -- descriptor. -- -- Since: 3.1.0.0 withFdSocket :: Socket -> (CInt -> IO r) -> IO r withFdSocket (Socket ref _) f = do fd <- readIORef ref -- Should we throw an exception if the socket is already invalid? -- That will catch some mistakes but certainly not all. r <- f fd touch ref return r -- | Socket is closed and a duplicated file descriptor is returned. -- The duplicated descriptor is no longer subject to the possibility -- of unexpectedly being closed if the socket is finalized. It is -- now the caller's responsibility to ultimately close the -- duplicated file descriptor. socketToFd :: Socket -> IO CInt socketToFd s = do #if defined(mingw32_HOST_OS) fd <- unsafeFdSocket s fd2 <- c_wsaDuplicate fd -- FIXME: throw error no if -1 close s return fd2 foreign import ccall unsafe "wsaDuplicate" c_wsaDuplicate :: CInt -> IO CInt #else fd <- unsafeFdSocket s -- FIXME: throw error no if -1 fd2 <- c_dup fd close s return fd2 foreign import ccall unsafe "dup" c_dup :: CInt -> IO CInt #endif -- | Creating a socket from a file descriptor. mkSocket :: CInt -> IO Socket mkSocket fd = do ref <- newIORef fd let s = Socket ref fd void $ mkWeakIORef ref $ close s return s invalidSocket :: CInt #if defined(mingw32_HOST_OS) invalidSocket = #const INVALID_SOCKET #else invalidSocket = -1 #endif invalidateSocket :: Socket -> (CInt -> IO a) -> (CInt -> IO a) -> IO a invalidateSocket (Socket ref _) errorAction normalAction = do oldfd <- atomicModifyIORef' ref $ \cur -> (invalidSocket, cur) if oldfd == invalidSocket then errorAction oldfd else normalAction oldfd ----------------------------------------------------------------------------- -- | Close the socket. This function does not throw exceptions even if -- the underlying system call returns errors. -- -- If multiple threads use the same socket and one uses 'unsafeFdSocket' and -- the other use 'close', unexpected behavior may happen. -- For more information, please refer to the documentation of 'unsafeFdSocket'. close :: Socket -> IO () close s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do -- closeFdWith avoids the deadlock of IO manager. closeFdWith closeFd (toFd oldfd) where toFd :: CInt -> Fd toFd = fromIntegral -- closeFd ignores the return value of c_close and -- does not throw exceptions closeFd :: Fd -> IO () closeFd = void . c_close . fromIntegral -- | Close the socket. This function throws exceptions if -- the underlying system call returns errors. close' :: Socket -> IO () close' s = invalidateSocket s (\_ -> return ()) $ \oldfd -> do -- closeFdWith avoids the deadlock of IO manager. closeFdWith closeFd (toFd oldfd) where toFd :: CInt -> Fd toFd = fromIntegral closeFd :: Fd -> IO () closeFd fd = do ret <- c_close $ fromIntegral fd when (ret == -1) $ throwErrno "Network.Socket.close'" #if defined(mingw32_HOST_OS) foreign import CALLCONV unsafe "closesocket" c_close :: CInt -> IO CInt #else foreign import ccall unsafe "close" c_close :: CInt -> IO CInt #endif ----------------------------------------------------------------------------- -- | Protocol number. type ProtocolNumber = CInt -- | This is the default protocol for a given service. -- -- >>> defaultProtocol -- 0 defaultProtocol :: ProtocolNumber defaultProtocol = 0 ----------------------------------------------------------------------------- -- Socket types -- There are a few possible ways to do this. The first is convert the -- structs used in the C library into an equivalent Haskell type. An -- other possible implementation is to keep all the internals in the C -- code and use an Int## and a status flag. The second method is used -- here since a lot of the C structures are not required to be -- manipulated. -- Originally the status was non-mutable so we had to return a new -- socket each time we changed the status. This version now uses -- mutable variables to avoid the need to do this. The result is a -- cleaner interface and better security since the application -- programmer now can't circumvent the status information to perform -- invalid operations on sockets. -- | Socket Types. -- -- Some of the defined patterns may be unsupported on some systems: -- see 'isSupportedSocketType'. newtype SocketType = SocketType { packSocketType :: CInt } deriving (Eq, Ord) unpackSocketType :: CInt -> SocketType unpackSocketType = SocketType {-# INLINE unpackSocketType #-} -- | Is the @SOCK_xxxxx@ constant corresponding to the given SocketType known -- on this system? 'GeneralSocketType' values, not equal to any of the named -- patterns or 'UnsupportedSocketType', will return 'True' even when not -- known on this system. isSupportedSocketType :: SocketType -> Bool isSupportedSocketType = (/= UnsupportedSocketType) -- | Pattern for a general socket type. pattern GeneralSocketType :: CInt -> SocketType pattern GeneralSocketType n = SocketType n #if __GLASGOW_HASKELL__ >= 806 {-# COMPLETE GeneralSocketType #-} #endif -- The actual constructor is not exported, which keeps the internal -- representation private, but for all purposes other than 'coerce' the -- above pattern is just as good. -- | Unsupported socket type, equal to any other types not supported on this -- system. pattern UnsupportedSocketType :: SocketType pattern UnsupportedSocketType = SocketType (-1) -- | Used in getAddrInfo hints, for example. pattern NoSocketType :: SocketType pattern NoSocketType = SocketType 0 pattern Stream :: SocketType #ifdef SOCK_STREAM pattern Stream = SocketType (#const SOCK_STREAM) #else pattern Stream = (-1) #endif pattern Datagram :: SocketType #ifdef SOCK_DGRAM pattern Datagram = SocketType (#const SOCK_DGRAM) #else pattern Datagram = (-1) #endif pattern Raw :: SocketType #ifdef SOCK_RAW pattern Raw = SocketType (#const SOCK_RAW) #else pattern Raw = (-1) #endif pattern RDM :: SocketType #ifdef SOCK_RDM pattern RDM = SocketType (#const SOCK_RDM) #else pattern RDM = (-1) #endif pattern SeqPacket :: SocketType #ifdef SOCK_SEQPACKET pattern SeqPacket = SocketType (#const SOCK_SEQPACKET) #else pattern SeqPacket = (-1) #endif ------------------------------------------------------------------------ -- Protocol Families. -- | Address families. The @AF_xxxxx@ constants are widely used as synonyms -- for the corresponding @PF_xxxxx@ protocol family values, to which they are -- numerically equal in mainstream socket API implementations. -- -- Strictly correct usage would be to pass the @PF_xxxxx@ constants as the first -- argument when creating a 'Socket', while the @AF_xxxxx@ constants should be -- used as @addrFamily@ values with 'getAddrInfo'. For now only the @AF_xxxxx@ -- constants are provided. -- -- Some of the defined patterns may be unsupported on some systems: -- see 'isSupportedFamily'. newtype Family = Family { packFamily :: CInt } deriving (Eq, Ord) -- | Does one of the AF_ constants correspond to a known address family on this -- system. 'GeneralFamily' values, not equal to any of the named @AF_xxxxx@ -- patterns or 'UnsupportedFamily', will return 'True' even when not known on -- this system. isSupportedFamily :: Family -> Bool isSupportedFamily f = case f of UnsupportedFamily -> False GeneralFamily _ -> True -- | Convert 'CInt' to 'Family'. unpackFamily :: CInt -> Family unpackFamily = Family {-# INLINE unpackFamily #-} -- | Pattern for a general protocol family (a.k.a. address family). -- -- @since 3.2.0.0 pattern GeneralFamily :: CInt -> Family pattern GeneralFamily n = Family n #if __GLASGOW_HASKELL__ >= 806 {-# COMPLETE GeneralFamily #-} #endif -- The actual constructor is not exported, which keeps the internal -- representation private, but for all purposes other than 'coerce' the -- above pattern is just as good. -- | Unsupported address family, equal to any other families that are not -- supported on the system. -- -- @since 3.2.0.0 pattern UnsupportedFamily :: Family pattern UnsupportedFamily = Family (-1) -- | unspecified pattern AF_UNSPEC :: Family pattern AF_UNSPEC = Family (#const AF_UNSPEC) -- | UNIX-domain pattern AF_UNIX :: Family #ifdef AF_UNIX pattern AF_UNIX = Family (#const AF_UNIX) #else pattern AF_UNIX = Family (-1) #endif -- | Internet Protocol version 4 pattern AF_INET :: Family #ifdef AF_INET pattern AF_INET = Family (#const AF_INET) #else pattern AF_INET = Family (-1) #endif -- | Internet Protocol version 6 pattern AF_INET6 :: Family #ifdef AF_INET6 pattern AF_INET6 = Family (#const AF_INET6) #else pattern AF_INET6 = Family (-1) #endif -- | Arpanet imp addresses pattern AF_IMPLINK :: Family #ifdef AF_IMPLINK pattern AF_IMPLINK = Family (#const AF_IMPLINK) #else pattern AF_IMPLINK = Family (-1) #endif -- | pup protocols: e.g. BSP pattern AF_PUP :: Family #ifdef AF_PUP pattern AF_PUP = Family (#const AF_PUP) #else pattern AF_PUP = Family (-1) #endif -- | mit CHAOS protocols pattern AF_CHAOS :: Family #ifdef AF_CHAOS pattern AF_CHAOS = Family (#const AF_CHAOS) #else pattern AF_CHAOS = Family (-1) #endif -- | XEROX NS protocols pattern AF_NS :: Family #ifdef AF_NS pattern AF_NS = Family (#const AF_NS) #else pattern AF_NS = Family (-1) #endif -- | nbs protocols pattern AF_NBS :: Family #ifdef AF_NBS pattern AF_NBS = Family (#const AF_NBS) #else pattern AF_NBS = Family (-1) #endif -- | european computer manufacturers pattern AF_ECMA :: Family #ifdef AF_ECMA pattern AF_ECMA = Family (#const AF_ECMA) #else pattern AF_ECMA = Family (-1) #endif -- | datakit protocols pattern AF_DATAKIT :: Family #ifdef AF_DATAKIT pattern AF_DATAKIT = Family (#const AF_DATAKIT) #else pattern AF_DATAKIT = Family (-1) #endif -- | CCITT protocols, X.25 etc pattern AF_CCITT :: Family #ifdef AF_CCITT pattern AF_CCITT = Family (#const AF_CCITT) #else pattern AF_CCITT = Family (-1) #endif -- | IBM SNA pattern AF_SNA :: Family #ifdef AF_SNA pattern AF_SNA = Family (#const AF_SNA) #else pattern AF_SNA = Family (-1) #endif -- | DECnet pattern AF_DECnet :: Family #ifdef AF_DECnet pattern AF_DECnet = Family (#const AF_DECnet) #else pattern AF_DECnet = Family (-1) #endif -- | Direct data link interface pattern AF_DLI :: Family #ifdef AF_DLI pattern AF_DLI = Family (#const AF_DLI) #else pattern AF_DLI = Family (-1) #endif -- | LAT pattern AF_LAT :: Family #ifdef AF_LAT pattern AF_LAT = Family (#const AF_LAT) #else pattern AF_LAT = Family (-1) #endif -- | NSC Hyperchannel pattern AF_HYLINK :: Family #ifdef AF_HYLINK pattern AF_HYLINK = Family (#const AF_HYLINK) #else pattern AF_HYLINK = Family (-1) #endif -- | Apple Talk pattern AF_APPLETALK :: Family #ifdef AF_APPLETALK pattern AF_APPLETALK = Family (#const AF_APPLETALK) #else pattern AF_APPLETALK = Family (-1) #endif -- | Internal Routing Protocol (aka AF_NETLINK) pattern AF_ROUTE :: Family #ifdef AF_ROUTE pattern AF_ROUTE = Family (#const AF_ROUTE) #else pattern AF_ROUTE = Family (-1) #endif -- | NetBios-style addresses pattern AF_NETBIOS :: Family #ifdef AF_NETBIOS pattern AF_NETBIOS = Family (#const AF_NETBIOS) #else pattern AF_NETBIOS = Family (-1) #endif -- | Network Interface Tap pattern AF_NIT :: Family #ifdef AF_NIT pattern AF_NIT = Family (#const AF_NIT) #else pattern AF_NIT = Family (-1) #endif -- | IEEE 802.2, also ISO 8802 pattern AF_802 :: Family #ifdef AF_802 pattern AF_802 = Family (#const AF_802) #else pattern AF_802 = Family (-1) #endif -- | ISO protocols pattern AF_ISO :: Family #ifdef AF_ISO pattern AF_ISO = Family (#const AF_ISO) #else pattern AF_ISO = Family (-1) #endif -- | umbrella of all families used by OSI pattern AF_OSI :: Family #ifdef AF_OSI pattern AF_OSI = Family (#const AF_OSI) #else pattern AF_OSI = Family (-1) #endif -- | DNA Network Management pattern AF_NETMAN :: Family #ifdef AF_NETMAN pattern AF_NETMAN = Family (#const AF_NETMAN) #else pattern AF_NETMAN = Family (-1) #endif -- | CCITT X.25 pattern AF_X25 :: Family #ifdef AF_X25 pattern AF_X25 = Family (#const AF_X25) #else pattern AF_X25 = Family (-1) #endif -- | AX25 pattern AF_AX25 :: Family #ifdef AF_AX25 pattern AF_AX25 = Family (#const AF_AX25) #else pattern AF_AX25 = Family (-1) #endif -- | AFI pattern AF_OSINET :: Family #ifdef AF_OSINET pattern AF_OSINET = Family (#const AF_OSINET) #else pattern AF_OSINET = Family (-1) #endif -- | US Government OSI pattern AF_GOSSIP :: Family #ifdef AF_GOSSIP pattern AF_GOSSIP = Family (#const AF_GOSSIP) #else pattern AF_GOSSIP = Family (-1) #endif -- | Novell Internet Protocol pattern AF_IPX :: Family #ifdef AF_IPX pattern AF_IPX = Family (#const AF_IPX) #else pattern AF_IPX = Family (-1) #endif -- | eXpress Transfer Protocol (no AF) pattern Pseudo_AF_XTP :: Family #ifdef Pseudo_AF_XTP pattern Pseudo_AF_XTP = Family (#const Pseudo_AF_XTP) #else pattern Pseudo_AF_XTP = Family (-1) #endif -- | Common Trace Facility pattern AF_CTF :: Family #ifdef AF_CTF pattern AF_CTF = Family (#const AF_CTF) #else pattern AF_CTF = Family (-1) #endif -- | Wide Area Network protocols pattern AF_WAN :: Family #ifdef AF_WAN pattern AF_WAN = Family (#const AF_WAN) #else pattern AF_WAN = Family (-1) #endif -- | SGI Data Link for DLPI pattern AF_SDL :: Family #ifdef AF_SDL pattern AF_SDL = Family (#const AF_SDL) #else pattern AF_SDL = Family (-1) #endif -- | Netware pattern AF_NETWARE :: Family #ifdef AF_NETWARE pattern AF_NETWARE = Family (#const AF_NETWARE) #else pattern AF_NETWARE = Family (-1) #endif -- | NDD pattern AF_NDD :: Family #ifdef AF_NDD pattern AF_NDD = Family (#const AF_NDD) #else pattern AF_NDD = Family (-1) #endif -- | Debugging use only pattern AF_INTF :: Family #ifdef AF_INTF pattern AF_INTF = Family (#const AF_INTF) #else pattern AF_INTF = Family (-1) #endif -- | connection-oriented IP, aka ST II pattern AF_COIP :: Family #ifdef AF_COIP pattern AF_COIP = Family (#const AF_COIP) #else pattern AF_COIP = Family (-1) #endif -- | Computer Network Technology pattern AF_CNT :: Family #ifdef AF_CNT pattern AF_CNT = Family (#const AF_CNT) #else pattern AF_CNT = Family (-1) #endif -- | Help Identify RTIP packets pattern Pseudo_AF_RTIP :: Family #ifdef Pseudo_AF_RTIP pattern Pseudo_AF_RTIP = Family (#const Pseudo_AF_RTIP) #else pattern Pseudo_AF_RTIP = Family (-1) #endif -- | Help Identify PIP packets pattern Pseudo_AF_PIP :: Family #ifdef Pseudo_AF_PIP pattern Pseudo_AF_PIP = Family (#const Pseudo_AF_PIP) #else pattern Pseudo_AF_PIP = Family (-1) #endif -- | Simple Internet Protocol pattern AF_SIP :: Family #ifdef AF_SIP pattern AF_SIP = Family (#const AF_SIP) #else pattern AF_SIP = Family (-1) #endif -- | Integrated Services Digital Network pattern AF_ISDN :: Family #ifdef AF_ISDN pattern AF_ISDN = Family (#const AF_ISDN) #else pattern AF_ISDN = Family (-1) #endif -- | Internal key-management function pattern Pseudo_AF_KEY :: Family #ifdef Pseudo_AF_KEY pattern Pseudo_AF_KEY = Family (#const Pseudo_AF_KEY) #else pattern Pseudo_AF_KEY = Family (-1) #endif -- | native ATM access pattern AF_NATM :: Family #ifdef AF_NATM pattern AF_NATM = Family (#const AF_NATM) #else pattern AF_NATM = Family (-1) #endif -- | ARP (RFC 826) pattern AF_ARP :: Family #ifdef AF_ARP pattern AF_ARP = Family (#const AF_ARP) #else pattern AF_ARP = Family (-1) #endif -- | Used by BPF to not rewrite hdrs in iface output pattern Pseudo_AF_HDRCMPLT :: Family #ifdef Pseudo_AF_HDRCMPLT pattern Pseudo_AF_HDRCMPLT = Family (#const Pseudo_AF_HDRCMPLT) #else pattern Pseudo_AF_HDRCMPLT = Family (-1) #endif -- | ENCAP pattern AF_ENCAP :: Family #ifdef AF_ENCAP pattern AF_ENCAP = Family (#const AF_ENCAP) #else pattern AF_ENCAP = Family (-1) #endif -- | Link layer interface pattern AF_LINK :: Family #ifdef AF_LINK pattern AF_LINK = Family (#const AF_LINK) #else pattern AF_LINK = Family (-1) #endif -- | Link layer interface pattern AF_RAW :: Family #ifdef AF_RAW pattern AF_RAW = Family (#const AF_RAW) #else pattern AF_RAW = Family (-1) #endif -- | raw interface pattern AF_RIF :: Family #ifdef AF_RIF pattern AF_RIF = Family (#const AF_RIF) #else pattern AF_RIF = Family (-1) #endif -- | Amateur radio NetROM pattern AF_NETROM :: Family #ifdef AF_NETROM pattern AF_NETROM = Family (#const AF_NETROM) #else pattern AF_NETROM = Family (-1) #endif -- | multiprotocol bridge pattern AF_BRIDGE :: Family #ifdef AF_BRIDGE pattern AF_BRIDGE = Family (#const AF_BRIDGE) #else pattern AF_BRIDGE = Family (-1) #endif -- | ATM PVCs pattern AF_ATMPVC :: Family #ifdef AF_ATMPVC pattern AF_ATMPVC = Family (#const AF_ATMPVC) #else pattern AF_ATMPVC = Family (-1) #endif -- | Amateur Radio X.25 PLP pattern AF_ROSE :: Family #ifdef AF_ROSE pattern AF_ROSE = Family (#const AF_ROSE) #else pattern AF_ROSE = Family (-1) #endif -- | Netbeui 802.2LLC pattern AF_NETBEUI :: Family #ifdef AF_NETBEUI pattern AF_NETBEUI = Family (#const AF_NETBEUI) #else pattern AF_NETBEUI = Family (-1) #endif -- | Security callback pseudo AF pattern AF_SECURITY :: Family #ifdef AF_SECURITY pattern AF_SECURITY = Family (#const AF_SECURITY) #else pattern AF_SECURITY = Family (-1) #endif -- | Packet family pattern AF_PACKET :: Family #ifdef AF_PACKET pattern AF_PACKET = Family (#const AF_PACKET) #else pattern AF_PACKET = Family (-1) #endif -- | Ash pattern AF_ASH :: Family #ifdef AF_ASH pattern AF_ASH = Family (#const AF_ASH) #else pattern AF_ASH = Family (-1) #endif -- | Acorn Econet pattern AF_ECONET :: Family #ifdef AF_ECONET pattern AF_ECONET = Family (#const AF_ECONET) #else pattern AF_ECONET = Family (-1) #endif -- | ATM SVCs pattern AF_ATMSVC :: Family #ifdef AF_ATMSVC pattern AF_ATMSVC = Family (#const AF_ATMSVC) #else pattern AF_ATMSVC = Family (-1) #endif -- | IRDA sockets pattern AF_IRDA :: Family #ifdef AF_IRDA pattern AF_IRDA = Family (#const AF_IRDA) #else pattern AF_IRDA = Family (-1) #endif -- | PPPoX sockets pattern AF_PPPOX :: Family #ifdef AF_PPPOX pattern AF_PPPOX = Family (#const AF_PPPOX) #else pattern AF_PPPOX = Family (-1) #endif -- | Wanpipe API sockets pattern AF_WANPIPE :: Family #ifdef AF_WANPIPE pattern AF_WANPIPE = Family (#const AF_WANPIPE) #else pattern AF_WANPIPE = Family (-1) #endif -- | bluetooth sockets pattern AF_BLUETOOTH :: Family #ifdef AF_BLUETOOTH pattern AF_BLUETOOTH = Family (#const AF_BLUETOOTH) #else pattern AF_BLUETOOTH = Family (-1) #endif -- | Controller Area Network pattern AF_CAN :: Family #ifdef AF_CAN pattern AF_CAN = Family (#const AF_CAN) #else pattern AF_CAN = Family (-1) #endif ------------------------------------------------------------------------ -- Port Numbers -- | Port number. -- Use the @Num@ instance (i.e. use a literal) to create a -- @PortNumber@ value. -- -- >>> 1 :: PortNumber -- 1 -- >>> read "1" :: PortNumber -- 1 -- >>> show (12345 :: PortNumber) -- "12345" -- >>> 50000 < (51000 :: PortNumber) -- True -- >>> 50000 < (52000 :: PortNumber) -- True -- >>> 50000 + (10000 :: PortNumber) -- 60000 newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Num, Enum, Bounded, Real, Integral) foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16 foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16 -- | Converts the from host byte order to network byte order. foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32 -- | Converts the from network byte order to host byte order. foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32 {-# DEPRECATED htonl "Use getAddrInfo instead" #-} {-# DEPRECATED ntohl "Use getAddrInfo instead" #-} instance Storable PortNumber where sizeOf _ = sizeOf (0 :: Word16) alignment _ = alignment (0 :: Word16) poke p (PortNum po) = poke (castPtr p) (htons po) peek p = PortNum . ntohs <$> peek (castPtr p) -- | Default port number. -- -- >>> defaultPort -- 0 defaultPort :: PortNumber defaultPort = 0 ------------------------------------------------------------------------ -- | The core typeclass to unify socket addresses. class SocketAddress sa where sizeOfSocketAddress :: sa -> Int peekSocketAddress :: Ptr sa -> IO sa pokeSocketAddress :: Ptr a -> sa -> IO () -- sizeof(struct sockaddr_storage) which has enough space to contain -- sockaddr_in, sockaddr_in6 and sockaddr_un. sockaddrStorageLen :: Int sockaddrStorageLen = 128 withSocketAddress :: SocketAddress sa => sa -> (Ptr sa -> Int -> IO a) -> IO a withSocketAddress addr f = do let sz = sizeOfSocketAddress addr if sz == 0 then f nullPtr 0 else allocaBytes sz $ \p -> pokeSocketAddress p addr >> f (castPtr p) sz withNewSocketAddress :: SocketAddress sa => (Ptr sa -> Int -> IO a) -> IO a withNewSocketAddress f = allocaBytes sockaddrStorageLen $ \ptr -> do zeroMemory ptr $ fromIntegral sockaddrStorageLen f ptr sockaddrStorageLen ------------------------------------------------------------------------ -- 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. -- | Flow information. type FlowInfo = Word32 -- | Scope identifier. type ScopeID = Word32 -- | Socket addresses. -- The existence of a constructor does not necessarily imply that -- that socket address type is supported on your system: see -- 'isSupportedSockAddr'. data SockAddr = SockAddrInet !PortNumber -- sin_port !HostAddress -- sin_addr (ditto) | SockAddrInet6 !PortNumber -- sin6_port !FlowInfo -- sin6_flowinfo (ditto) !HostAddress6 -- sin6_addr (ditto) !ScopeID -- sin6_scope_id (ditto) -- | The path must have fewer than 104 characters. All of these characters must have code points less than 256. | SockAddrUnix String -- sun_path deriving (Eq, Ord) instance NFData SockAddr where rnf (SockAddrInet _ _) = () rnf (SockAddrInet6 _ _ _ _) = () rnf (SockAddrUnix str) = rnf str -- | Is the socket address type supported on this system? isSupportedSockAddr :: SockAddr -> Bool isSupportedSockAddr addr = case addr of SockAddrInet{} -> True SockAddrInet6{} -> True #if defined(DOMAIN_SOCKET_SUPPORT) SockAddrUnix{} -> True #else SockAddrUnix{} -> False #endif instance SocketAddress SockAddr where sizeOfSocketAddress = sizeOfSockAddr peekSocketAddress = peekSockAddr pokeSocketAddress = pokeSockAddr #if defined(mingw32_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) # ifdef linux_HOST_OS -- http://man7.org/linux/man-pages/man7/unix.7.html says: -- "an abstract socket address is distinguished (from a -- pathname socket) by the fact that sun_path[0] is a null byte -- ('\0'). The socket's address in this namespace is given by the -- additional bytes in sun_path that are covered by the specified -- length of the address structure. (Null bytes in the name have no -- special significance.) The name has no connection with filesystem -- pathnames. When the address of an abstract socket is returned, -- the returned addrlen is greater than sizeof(sa_family_t) (i.e., -- greater than 2), and the name of the socket is contained in the -- first (addrlen - sizeof(sa_family_t)) bytes of sun_path." sizeOfSockAddr (SockAddrUnix path) = case path of '\0':_ -> (#const sizeof(sa_family_t)) + length path _ -> #const sizeof(struct sockaddr_un) # else sizeOfSockAddr SockAddrUnix{} = #const sizeof(struct sockaddr_un) # endif #else sizeOfSockAddr SockAddrUnix{} = error "sizeOfSockAddr: not supported" #endif sizeOfSockAddr SockAddrInet{} = #const sizeof(struct sockaddr_in) sizeOfSockAddr SockAddrInet6{} = #const sizeof(struct sockaddr_in6) -- | 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 -- We cannot bind sun_paths longer than than the space in the sockaddr_un -- structure, and attempting to do so could overflow the allocated storage -- space. This constant holds the maximum allowable path length. -- #if defined(DOMAIN_SOCKET_SUPPORT) unixPathMax :: Int unixPathMax = #const sizeof(((struct sockaddr_un *)NULL)->sun_path) #endif -- 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 sa@(SockAddrUnix path) = do when (length path > unixPathMax) $ error "pokeSockAddr: path is too long" zeroMemory p $ fromIntegral $ sizeOfSockAddr sa # 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 -- the buffer is already filled with nulls. pokeArray ((#ptr struct sockaddr_un, sun_path) p) pathC #else pokeSockAddr _ SockAddrUnix{} = error "pokeSockAddr: not supported" #endif pokeSockAddr p (SockAddrInet port addr) = do zeroMemory p (#const sizeof(struct sockaddr_in)) #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 pokeSockAddr p (SockAddrInet6 port flow addr scope) = do zeroMemory p (#const sizeof(struct sockaddr_in6)) # 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 (In6Addr addr) (#poke struct sockaddr_in6, sin6_scope_id) p scope -- | 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 <- peekCAString ((#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 port addr) (#const AF_INET6) -> do port <- (#peek struct sockaddr_in6, sin6_port) p flow <- (#peek struct sockaddr_in6, sin6_flowinfo) p In6Addr addr <- (#peek struct sockaddr_in6, sin6_addr) p scope <- (#peek struct sockaddr_in6, sin6_scope_id) p return (SockAddrInet6 port flow addr scope) _ -> ioError $ userError $ "Network.Socket.Types.peekSockAddr: address family '" ++ show family ++ "' not supported." ------------------------------------------------------------------------ -- | The raw network byte order number is read using host byte order. -- Therefore on little-endian architectures the byte order is swapped. For -- example @127.0.0.1@ is represented as @0x0100007f@ on little-endian hosts -- and as @0x7f000001@ on big-endian hosts. -- -- For direct manipulation prefer 'hostAddressToTuple' and -- 'tupleToHostAddress'. type HostAddress = Word32 -- | Converts 'HostAddress' to representation-independent IPv4 quadruple. -- For example for @127.0.0.1@ the function will return @(0x7f, 0, 0, 1)@ -- regardless of host endianness. -- {- -- prop> tow == hostAddressToTuple (tupleToHostAddress tow) -} hostAddressToTuple :: HostAddress -> (Word8, Word8, Word8, Word8) hostAddressToTuple ha' = let ha = htonl ha' byte i = fromIntegral (ha `shiftR` i) :: Word8 in (byte 24, byte 16, byte 8, byte 0) -- | Converts IPv4 quadruple to 'HostAddress'. tupleToHostAddress :: (Word8, Word8, Word8, Word8) -> HostAddress tupleToHostAddress (b3, b2, b1, b0) = let x `sl` i = fromIntegral x `shiftL` i :: Word32 in ntohl $ (b3 `sl` 24) .|. (b2 `sl` 16) .|. (b1 `sl` 8) .|. (b0 `sl` 0) -- | Independent of endianness. For example @::1@ is stored as @(0, 0, 0, 1)@. -- -- For direct manipulation prefer 'hostAddress6ToTuple' and -- 'tupleToHostAddress6'. type HostAddress6 = (Word32, Word32, Word32, Word32) -- | Converts 'HostAddress6' to representation-independent IPv6 octuple. -- {- -- prop> (w1,w2,w3,w4,w5,w6,w7,w8) == hostAddress6ToTuple (tupleToHostAddress6 (w1,w2,w3,w4,w5,w6,w7,w8)) -} hostAddress6ToTuple :: HostAddress6 -> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) hostAddress6ToTuple (w3, w2, w1, w0) = let high, low :: Word32 -> Word16 high w = fromIntegral (w `shiftR` 16) low w = fromIntegral w in (high w3, low w3, high w2, low w2, high w1, low w1, high w0, low w0) -- | Converts IPv6 octuple to 'HostAddress6'. tupleToHostAddress6 :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> HostAddress6 tupleToHostAddress6 (w7, w6, w5, w4, w3, w2, w1, w0) = let add :: Word16 -> Word16 -> Word32 high `add` low = (fromIntegral high `shiftL` 16) .|. (fromIntegral low) in (w7 `add` w6, w5 `add` w4, w3 `add` w2, w1 `add` w0) -- 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 i0 = do let i' = i0 * 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 i0 a = do let i' = i0 * 4 pokeByte n = pokeByteOff p (s6_addr_offset + i' + n) x `sr` i = fromIntegral (x `shiftR` i) :: Word8 pokeByte 0 (a `sr` 24) pokeByte 1 (a `sr` 16) pokeByte 2 (a `sr` 8) pokeByte 3 (a `sr` 0) -- | Private newtype proxy for the Storable instance. To avoid orphan instances. newtype In6Addr = In6Addr HostAddress6 #if __GLASGOW_HASKELL__ < 800 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) #endif instance Storable In6Addr where sizeOf _ = #const sizeof(struct in6_addr) alignment _ = #alignment struct in6_addr peek p = do a <- peek32 p 0 b <- peek32 p 1 c <- peek32 p 2 d <- peek32 p 3 return $ In6Addr (a, b, c, d) poke p (In6Addr (a, b, c, d)) = do poke32 p 0 a poke32 p 1 b poke32 p 2 c poke32 p 3 d ------------------------------------------------------------------------ -- Read and Show instance for pattern-based integral newtypes socktypeBijection :: Bijection SocketType String socktypeBijection = [ (UnsupportedSocketType, "UnsupportedSocketType") , (Stream, "Stream") , (Datagram, "Datagram") , (Raw, "Raw") , (RDM, "RDM") , (SeqPacket, "SeqPacket") , (NoSocketType, "NoSocketType") ] instance Show SocketType where showsPrec = bijectiveShow socktypeBijection def where gst = "GeneralSocketType" def = defShow gst packSocketType _showInt instance Read SocketType where readPrec = bijectiveRead socktypeBijection def where gst = "GeneralSocketType" def = defRead gst unpackSocketType _readInt familyBijection :: Bijection Family String familyBijection = [ (UnsupportedFamily, "UnsupportedFamily") , (AF_UNSPEC, "AF_UNSPEC") , (AF_UNIX, "AF_UNIX") , (AF_INET, "AF_INET") , (AF_INET6, "AF_INET6") , (AF_IMPLINK, "AF_IMPLINK") , (AF_PUP, "AF_PUP") , (AF_CHAOS, "AF_CHAOS") , (AF_NS, "AF_NS") , (AF_NBS, "AF_NBS") , (AF_ECMA, "AF_ECMA") , (AF_DATAKIT, "AF_DATAKIT") , (AF_CCITT, "AF_CCITT") , (AF_SNA, "AF_SNA") , (AF_DECnet, "AF_DECnet") , (AF_DLI, "AF_DLI") , (AF_LAT, "AF_LAT") , (AF_HYLINK, "AF_HYLINK") , (AF_APPLETALK, "AF_APPLETALK") , (AF_ROUTE, "AF_ROUTE") , (AF_NETBIOS, "AF_NETBIOS") , (AF_NIT, "AF_NIT") , (AF_802, "AF_802") , (AF_ISO, "AF_ISO") , (AF_OSI, "AF_OSI") , (AF_NETMAN, "AF_NETMAN") , (AF_X25, "AF_X25") , (AF_AX25, "AF_AX25") , (AF_OSINET, "AF_OSINET") , (AF_GOSSIP, "AF_GOSSIP") , (AF_IPX, "AF_IPX") , (Pseudo_AF_XTP, "Pseudo_AF_XTP") , (AF_CTF, "AF_CTF") , (AF_WAN, "AF_WAN") , (AF_SDL, "AF_SDL") , (AF_NETWARE, "AF_NETWARE") , (AF_NDD, "AF_NDD") , (AF_INTF, "AF_INTF") , (AF_COIP, "AF_COIP") , (AF_CNT, "AF_CNT") , (Pseudo_AF_RTIP, "Pseudo_AF_RTIP") , (Pseudo_AF_PIP, "Pseudo_AF_PIP") , (AF_SIP, "AF_SIP") , (AF_ISDN, "AF_ISDN") , (Pseudo_AF_KEY, "Pseudo_AF_KEY") , (AF_NATM, "AF_NATM") , (AF_ARP, "AF_ARP") , (Pseudo_AF_HDRCMPLT, "Pseudo_AF_HDRCMPLT") , (AF_ENCAP, "AF_ENCAP") , (AF_LINK, "AF_LINK") , (AF_RAW, "AF_RAW") , (AF_RIF, "AF_RIF") , (AF_NETROM, "AF_NETROM") , (AF_BRIDGE, "AF_BRIDGE") , (AF_ATMPVC, "AF_ATMPVC") , (AF_ROSE, "AF_ROSE") , (AF_NETBEUI, "AF_NETBEUI") , (AF_SECURITY, "AF_SECURITY") , (AF_PACKET, "AF_PACKET") , (AF_ASH, "AF_ASH") , (AF_ECONET, "AF_ECONET") , (AF_ATMSVC, "AF_ATMSVC") , (AF_IRDA, "AF_IRDA") , (AF_PPPOX, "AF_PPPOX") , (AF_WANPIPE, "AF_WANPIPE") , (AF_BLUETOOTH, "AF_BLUETOOTH") , (AF_CAN, "AF_CAN") ] instance Show Family where showsPrec = bijectiveShow familyBijection def where gf = "GeneralFamily" def = defShow gf packFamily _showInt instance Read Family where readPrec = bijectiveRead familyBijection def where gf = "GeneralFamily" def = defRead gf unpackFamily _readInt -- Print "n" instead of "PortNum n". instance Show PortNumber where showsPrec p (PortNum pn) = showsPrec p pn -- Read "n" instead of "PortNum n". instance Read PortNumber where readPrec = safeInt ------------------------------------------------------------------------ -- 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)