{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
#include "HsNet.h"
module Network.Socket.Types
(
-- * Socket
Socket(..)
, sockFd
, sockFamily
, sockType
, sockProtocol
, sockStatus
, SocketStatus(..)
-- * Socket types
, SocketType(..)
, isSupportedSocketType
, packSocketType
, packSocketType'
, packSocketTypeOrThrow
, unpackSocketType
, unpackSocketType'
-- * Family
, Family(..)
, isSupportedFamily
, packFamily
, unpackFamily
-- * Socket addresses
, SockAddr(..)
, isSupportedSockAddr
, HostAddress
, hostAddressToTuple
, tupleToHostAddress
#if defined(IPV6_SOCKET_SUPPORT)
, HostAddress6
, hostAddress6ToTuple
, tupleToHostAddress6
, FlowInfo
, ScopeID
#endif
, peekSockAddr
, pokeSockAddr
, sizeOfSockAddr
, sizeOfSockAddrByFamily
, withSockAddr
, withNewSockAddr
-- * Unsorted
, ProtocolNumber
, PortNumber(..)
-- * Low-level helpers
, zeroMemory
) where
import Control.Concurrent.MVar
import Control.Monad
import Data.Bits
import Data.Maybe
import Data.Ratio
import Data.Typeable
import Data.Word
import Data.Int
import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
-- | Represents a socket. The fields are, respectively:
--
-- * File descriptor
-- * Socket family
-- * Socket type
-- * Protocol number
-- * Status flag
--
-- If you are calling the 'MkSocket' constructor directly you should ensure
-- you have called 'Network.withSocketsDo' and that the file descriptor is
-- in non-blocking mode. See 'Network.Socket.setNonBlockIfNeeded'.
data Socket
= MkSocket
CInt -- File Descriptor
Family
SocketType
ProtocolNumber -- Protocol Number
(MVar SocketStatus) -- Status Flag
deriving Typeable
sockFd :: Socket -> CInt
sockFd (MkSocket n _ _ _ _) = n
sockFamily :: Socket -> Family
sockFamily (MkSocket _ f _ _ _) = f
sockType :: Socket -> SocketType
sockType (MkSocket _ _ t _ _) = t
sockProtocol :: Socket -> ProtocolNumber
sockProtocol (MkSocket _ _ _ p _) = p
sockStatus :: Socket -> MVar SocketStatus
sockStatus (MkSocket _ _ _ _ s) = s
instance Eq Socket where
(MkSocket _ _ _ _ m1) == (MkSocket _ _ _ _ m2) = m1 == m2
instance Show Socket where
showsPrec _n (MkSocket fd _ _ _ _) =
showString "<socket: " . shows fd . showString ">"
type ProtocolNumber = CInt
-- | The status of the socket as /determined by this library/, not
-- necessarily reflecting the state of the connection itself.
--
-- For example, the 'Closed' status is applied when the 'close'
-- function is called.
data SocketStatus
-- Returned Status Function called
= NotConnected -- ^ Newly created, unconnected socket
| Bound -- ^ Bound, via 'bind'
| Listening -- ^ Listening, via 'listen'
| Connected -- ^ Connected or accepted, via 'connect' or 'accept'
| ConvertedToHandle -- ^ Is now a 'Handle' (via 'socketToHandle'), don't touch
| Closed -- ^ Closed was closed by 'close'
deriving (Eq, Show, Typeable)
-----------------------------------------------------------------------------
-- 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.
--
-- The existence of a constructor does not necessarily imply that that
-- socket type is supported on your system: see 'isSupportedSocketType'.
data SocketType
= NoSocketType -- ^ 0, used in getAddrInfo hints, for example
| Stream -- ^ SOCK_STREAM
| Datagram -- ^ SOCK_DGRAM
| Raw -- ^ SOCK_RAW
| RDM -- ^ SOCK_RDM
| SeqPacket -- ^ SOCK_SEQPACKET
deriving (Eq, Ord, Read, Show, Typeable)
-- | Does the SOCK_ constant corresponding to the given SocketType exist on
-- this system?
isSupportedSocketType :: SocketType -> Bool
isSupportedSocketType = isJust . packSocketType'
-- | Find the SOCK_ constant corresponding to the SocketType value.
packSocketType' :: SocketType -> Maybe CInt
packSocketType' stype = case Just stype of
-- the Just above is to disable GHC's overlapping pattern
-- detection: see comments for packSocketOption
Just NoSocketType -> Just 0
#ifdef SOCK_STREAM
Just Stream -> Just #const SOCK_STREAM
#endif
#ifdef SOCK_DGRAM
Just Datagram -> Just #const SOCK_DGRAM
#endif
#ifdef SOCK_RAW
Just Raw -> Just #const SOCK_RAW
#endif
#ifdef SOCK_RDM
Just RDM -> Just #const SOCK_RDM
#endif
#ifdef SOCK_SEQPACKET
Just SeqPacket -> Just #const SOCK_SEQPACKET
#endif
_ -> Nothing
packSocketType :: SocketType -> CInt
packSocketType stype = fromMaybe (error errMsg) (packSocketType' stype)
where
errMsg = concat ["Network.Socket.packSocketType: ",
"socket type ", show stype, " unsupported on this system"]
-- | Try packSocketType' on the SocketType, if it fails throw an error with
-- message starting "Network.Socket." ++ the String parameter
packSocketTypeOrThrow :: String -> SocketType -> IO CInt
packSocketTypeOrThrow caller stype = maybe err return (packSocketType' stype)
where
err = ioError . userError . concat $ ["Network.Socket.", caller, ": ",
"socket type ", show stype, " unsupported on this system"]
unpackSocketType:: CInt -> Maybe SocketType
unpackSocketType t = case t of
0 -> Just NoSocketType
#ifdef SOCK_STREAM
(#const SOCK_STREAM) -> Just Stream
#endif
#ifdef SOCK_DGRAM
(#const SOCK_DGRAM) -> Just Datagram
#endif
#ifdef SOCK_RAW
(#const SOCK_RAW) -> Just Raw
#endif
#ifdef SOCK_RDM
(#const SOCK_RDM) -> Just RDM
#endif
#ifdef SOCK_SEQPACKET
(#const SOCK_SEQPACKET) -> Just SeqPacket
#endif
_ -> Nothing
-- | Try unpackSocketType on the CInt, if it fails throw an error with
-- message starting "Network.Socket." ++ the String parameter
unpackSocketType' :: String -> CInt -> IO SocketType
unpackSocketType' caller ty = maybe err return (unpackSocketType ty)
where
err = ioError . userError . concat $ ["Network.Socket.", caller, ": ",
"socket type ", show ty, " unsupported on this system"]
------------------------------------------------------------------------
-- Protocol Families.
-- | Address families.
--
-- A constructor being present here does not mean it is supported by the
-- operating system: see 'isSupportedFamily'.
data Family
= AF_UNSPEC -- unspecified
| AF_UNIX -- local to host (pipes, portals
| AF_INET -- internetwork: UDP, TCP, etc
| AF_INET6 -- Internet Protocol version 6
| AF_IMPLINK -- arpanet imp addresses
| AF_PUP -- pup protocols: e.g. BSP
| AF_CHAOS -- mit CHAOS protocols
| AF_NS -- XEROX NS protocols
| AF_NBS -- nbs protocols
| AF_ECMA -- european computer manufacturers
| AF_DATAKIT -- datakit protocols
| AF_CCITT -- CCITT protocols, X.25 etc
| AF_SNA -- IBM SNA
| AF_DECnet -- DECnet
| AF_DLI -- Direct data link interface
| AF_LAT -- LAT
| AF_HYLINK -- NSC Hyperchannel
| AF_APPLETALK -- Apple Talk
| AF_ROUTE -- Internal Routing Protocol
| AF_NETBIOS -- NetBios-style addresses
| AF_NIT -- Network Interface Tap
| AF_802 -- IEEE 802.2, also ISO 8802
| AF_ISO -- ISO protocols
| AF_OSI -- umbrella of all families used by OSI
| AF_NETMAN -- DNA Network Management
| AF_X25 -- CCITT X.25
| AF_AX25
| AF_OSINET -- AFI
| AF_GOSSIP -- US Government OSI
| AF_IPX -- Novell Internet Protocol
| Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
| AF_CTF -- Common Trace Facility
| AF_WAN -- Wide Area Network protocols
| AF_SDL -- SGI Data Link for DLPI
| AF_NETWARE
| AF_NDD
| AF_INTF -- Debugging use only
| AF_COIP -- connection-oriented IP, aka ST II
| AF_CNT -- Computer Network Technology
| Pseudo_AF_RTIP -- Help Identify RTIP packets
| Pseudo_AF_PIP -- Help Identify PIP packets
| AF_SIP -- Simple Internet Protocol
| AF_ISDN -- Integrated Services Digital Network
| Pseudo_AF_KEY -- Internal key-management function
| AF_NATM -- native ATM access
| AF_ARP -- (rev.) addr. res. prot. (RFC 826)
| Pseudo_AF_HDRCMPLT -- Used by BPF to not rewrite hdrs in iface output
| AF_ENCAP
| AF_LINK -- Link layer interface
| AF_RAW -- Link layer interface
| AF_RIF -- raw interface
| AF_NETROM -- Amateur radio NetROM
| AF_BRIDGE -- multiprotocol bridge
| AF_ATMPVC -- ATM PVCs
| AF_ROSE -- Amateur Radio X.25 PLP
| AF_NETBEUI -- 802.2LLC
| AF_SECURITY -- Security callback pseudo AF
| AF_PACKET -- Packet family
| AF_ASH -- Ash
| AF_ECONET -- Acorn Econet
| AF_ATMSVC -- ATM SVCs
| AF_IRDA -- IRDA sockets
| AF_PPPOX -- PPPoX sockets
| AF_WANPIPE -- Wanpipe API sockets
| AF_BLUETOOTH -- bluetooth sockets
| AF_CAN -- Controller Area Network
deriving (Eq, Ord, Read, Show)
packFamily :: Family -> CInt
packFamily f = case packFamily' f of
Just fam -> fam
Nothing -> error $
"Network.Socket.packFamily: unsupported address family: " ++
show f
-- | Does the AF_ constant corresponding to the given family exist on this
-- system?
isSupportedFamily :: Family -> Bool
isSupportedFamily = isJust . packFamily'
packFamily' :: Family -> Maybe CInt
packFamily' f = case Just f of
-- the Just above is to disable GHC's overlapping pattern
-- detection: see comments for packSocketOption
Just AF_UNSPEC -> Just #const AF_UNSPEC
#ifdef AF_UNIX
Just AF_UNIX -> Just #const AF_UNIX
#endif
#ifdef AF_INET
Just AF_INET -> Just #const AF_INET
#endif
#ifdef AF_INET6
Just AF_INET6 -> Just #const AF_INET6
#endif
#ifdef AF_IMPLINK
Just AF_IMPLINK -> Just #const AF_IMPLINK
#endif
#ifdef AF_PUP
Just AF_PUP -> Just #const AF_PUP
#endif
#ifdef AF_CHAOS
Just AF_CHAOS -> Just #const AF_CHAOS
#endif
#ifdef AF_NS
Just AF_NS -> Just #const AF_NS
#endif
#ifdef AF_NBS
Just AF_NBS -> Just #const AF_NBS
#endif
#ifdef AF_ECMA
Just AF_ECMA -> Just #const AF_ECMA
#endif
#ifdef AF_DATAKIT
Just AF_DATAKIT -> Just #const AF_DATAKIT
#endif
#ifdef AF_CCITT
Just AF_CCITT -> Just #const AF_CCITT
#endif
#ifdef AF_SNA
Just AF_SNA -> Just #const AF_SNA
#endif
#ifdef AF_DECnet
Just AF_DECnet -> Just #const AF_DECnet
#endif
#ifdef AF_DLI
Just AF_DLI -> Just #const AF_DLI
#endif
#ifdef AF_LAT
Just AF_LAT -> Just #const AF_LAT
#endif
#ifdef AF_HYLINK
Just AF_HYLINK -> Just #const AF_HYLINK
#endif
#ifdef AF_APPLETALK
Just AF_APPLETALK -> Just #const AF_APPLETALK
#endif
#ifdef AF_ROUTE
Just AF_ROUTE -> Just #const AF_ROUTE
#endif
#ifdef AF_NETBIOS
Just AF_NETBIOS -> Just #const AF_NETBIOS
#endif
#ifdef AF_NIT
Just AF_NIT -> Just #const AF_NIT
#endif
#ifdef AF_802
Just AF_802 -> Just #const AF_802
#endif
#ifdef AF_ISO
Just AF_ISO -> Just #const AF_ISO
#endif
#ifdef AF_OSI
Just AF_OSI -> Just #const AF_OSI
#endif
#ifdef AF_NETMAN
Just AF_NETMAN -> Just #const AF_NETMAN
#endif
#ifdef AF_X25
Just AF_X25 -> Just #const AF_X25
#endif
#ifdef AF_AX25
Just AF_AX25 -> Just #const AF_AX25
#endif
#ifdef AF_OSINET
Just AF_OSINET -> Just #const AF_OSINET
#endif
#ifdef AF_GOSSIP
Just AF_GOSSIP -> Just #const AF_GOSSIP
#endif
#ifdef AF_IPX
Just AF_IPX -> Just #const AF_IPX
#endif
#ifdef Pseudo_AF_XTP
Just Pseudo_AF_XTP -> Just #const Pseudo_AF_XTP
#endif
#ifdef AF_CTF
Just AF_CTF -> Just #const AF_CTF
#endif
#ifdef AF_WAN
Just AF_WAN -> Just #const AF_WAN
#endif
#ifdef AF_SDL
Just AF_SDL -> Just #const AF_SDL
#endif
#ifdef AF_NETWARE
Just AF_NETWARE -> Just #const AF_NETWARE
#endif
#ifdef AF_NDD
Just AF_NDD -> Just #const AF_NDD
#endif
#ifdef AF_INTF
Just AF_INTF -> Just #const AF_INTF
#endif
#ifdef AF_COIP
Just AF_COIP -> Just #const AF_COIP
#endif
#ifdef AF_CNT
Just AF_CNT -> Just #const AF_CNT
#endif
#ifdef Pseudo_AF_RTIP
Just Pseudo_AF_RTIP -> Just #const Pseudo_AF_RTIP
#endif
#ifdef Pseudo_AF_PIP
Just Pseudo_AF_PIP -> Just #const Pseudo_AF_PIP
#endif
#ifdef AF_SIP
Just AF_SIP -> Just #const AF_SIP
#endif
#ifdef AF_ISDN
Just AF_ISDN -> Just #const AF_ISDN
#endif
#ifdef Pseudo_AF_KEY
Just Pseudo_AF_KEY -> Just #const Pseudo_AF_KEY
#endif
#ifdef AF_NATM
Just AF_NATM -> Just #const AF_NATM
#endif
#ifdef AF_ARP
Just AF_ARP -> Just #const AF_ARP
#endif
#ifdef Pseudo_AF_HDRCMPLT
Just Pseudo_AF_HDRCMPLT -> Just #const Pseudo_AF_HDRCMPLT
#endif
#ifdef AF_ENCAP
Just AF_ENCAP -> Just #const AF_ENCAP
#endif
#ifdef AF_LINK
Just AF_LINK -> Just #const AF_LINK
#endif
#ifdef AF_RAW
Just AF_RAW -> Just #const AF_RAW
#endif
#ifdef AF_RIF
Just AF_RIF -> Just #const AF_RIF
#endif
#ifdef AF_NETROM
Just AF_NETROM -> Just #const AF_NETROM
#endif
#ifdef AF_BRIDGE
Just AF_BRIDGE -> Just #const AF_BRIDGE
#endif
#ifdef AF_ATMPVC
Just AF_ATMPVC -> Just #const AF_ATMPVC
#endif
#ifdef AF_ROSE
Just AF_ROSE -> Just #const AF_ROSE
#endif
#ifdef AF_NETBEUI
Just AF_NETBEUI -> Just #const AF_NETBEUI
#endif
#ifdef AF_SECURITY
Just AF_SECURITY -> Just #const AF_SECURITY
#endif
#ifdef AF_PACKET
Just AF_PACKET -> Just #const AF_PACKET
#endif
#ifdef AF_ASH
Just AF_ASH -> Just #const AF_ASH
#endif
#ifdef AF_ECONET
Just AF_ECONET -> Just #const AF_ECONET
#endif
#ifdef AF_ATMSVC
Just AF_ATMSVC -> Just #const AF_ATMSVC
#endif
#ifdef AF_IRDA
Just AF_IRDA -> Just #const AF_IRDA
#endif
#ifdef AF_PPPOX
Just AF_PPPOX -> Just #const AF_PPPOX
#endif
#ifdef AF_WANPIPE
Just AF_WANPIPE -> Just #const AF_WANPIPE
#endif
#ifdef AF_BLUETOOTH
Just AF_BLUETOOTH -> Just #const AF_BLUETOOTH
#endif
#ifdef AF_CAN
Just AF_CAN -> Just #const AF_CAN
#endif
_ -> Nothing
--------- ----------
unpackFamily :: CInt -> Family
unpackFamily f = case f of
(#const AF_UNSPEC) -> AF_UNSPEC
#ifdef AF_UNIX
(#const AF_UNIX) -> AF_UNIX
#endif
#ifdef AF_INET
(#const AF_INET) -> AF_INET
#endif
#ifdef AF_INET6
(#const AF_INET6) -> AF_INET6
#endif
#ifdef AF_IMPLINK
(#const AF_IMPLINK) -> AF_IMPLINK
#endif
#ifdef AF_PUP
(#const AF_PUP) -> AF_PUP
#endif
#ifdef AF_CHAOS
(#const AF_CHAOS) -> AF_CHAOS
#endif
#ifdef AF_NS
(#const AF_NS) -> AF_NS
#endif
#ifdef AF_NBS
(#const AF_NBS) -> AF_NBS
#endif
#ifdef AF_ECMA
(#const AF_ECMA) -> AF_ECMA
#endif
#ifdef AF_DATAKIT
(#const AF_DATAKIT) -> AF_DATAKIT
#endif
#ifdef AF_CCITT
(#const AF_CCITT) -> AF_CCITT
#endif
#ifdef AF_SNA
(#const AF_SNA) -> AF_SNA
#endif
#ifdef AF_DECnet
(#const AF_DECnet) -> AF_DECnet
#endif
#ifdef AF_DLI
(#const AF_DLI) -> AF_DLI
#endif
#ifdef AF_LAT
(#const AF_LAT) -> AF_LAT
#endif
#ifdef AF_HYLINK
(#const AF_HYLINK) -> AF_HYLINK
#endif
#ifdef AF_APPLETALK
(#const AF_APPLETALK) -> AF_APPLETALK
#endif
#ifdef AF_ROUTE
(#const AF_ROUTE) -> AF_ROUTE
#endif
#ifdef AF_NETBIOS
(#const AF_NETBIOS) -> AF_NETBIOS
#endif
#ifdef AF_NIT
(#const AF_NIT) -> AF_NIT
#endif
#ifdef AF_802
(#const AF_802) -> AF_802
#endif
#ifdef AF_ISO
(#const AF_ISO) -> AF_ISO
#endif
#ifdef AF_OSI
# if (!defined(AF_ISO)) || (defined(AF_ISO) && (AF_ISO != AF_OSI))
(#const AF_OSI) -> AF_OSI
# endif
#endif
#ifdef AF_NETMAN
(#const AF_NETMAN) -> AF_NETMAN
#endif
#ifdef AF_X25
(#const AF_X25) -> AF_X25
#endif
#ifdef AF_AX25
(#const AF_AX25) -> AF_AX25
#endif
#ifdef AF_OSINET
(#const AF_OSINET) -> AF_OSINET
#endif
#ifdef AF_GOSSIP
(#const AF_GOSSIP) -> AF_GOSSIP
#endif
#if defined(AF_IPX) && (!defined(AF_NS) || AF_NS != AF_IPX)
(#const AF_IPX) -> AF_IPX
#endif
#ifdef Pseudo_AF_XTP
(#const Pseudo_AF_XTP) -> Pseudo_AF_XTP
#endif
#ifdef AF_CTF
(#const AF_CTF) -> AF_CTF
#endif
#ifdef AF_WAN
(#const AF_WAN) -> AF_WAN
#endif
#ifdef AF_SDL
(#const AF_SDL) -> AF_SDL
#endif
#ifdef AF_NETWARE
(#const AF_NETWARE) -> AF_NETWARE
#endif
#ifdef AF_NDD
(#const AF_NDD) -> AF_NDD
#endif
#ifdef AF_INTF
(#const AF_INTF) -> AF_INTF
#endif
#ifdef AF_COIP
(#const AF_COIP) -> AF_COIP
#endif
#ifdef AF_CNT
(#const AF_CNT) -> AF_CNT
#endif
#ifdef Pseudo_AF_RTIP
(#const Pseudo_AF_RTIP) -> Pseudo_AF_RTIP
#endif
#ifdef Pseudo_AF_PIP
(#const Pseudo_AF_PIP) -> Pseudo_AF_PIP
#endif
#ifdef AF_SIP
(#const AF_SIP) -> AF_SIP
#endif
#ifdef AF_ISDN
(#const AF_ISDN) -> AF_ISDN
#endif
#ifdef Pseudo_AF_KEY
(#const Pseudo_AF_KEY) -> Pseudo_AF_KEY
#endif
#ifdef AF_NATM
(#const AF_NATM) -> AF_NATM
#endif
#ifdef AF_ARP
(#const AF_ARP) -> AF_ARP
#endif
#ifdef Pseudo_AF_HDRCMPLT
(#const Pseudo_AF_HDRCMPLT) -> Pseudo_AF_HDRCMPLT
#endif
#ifdef AF_ENCAP
(#const AF_ENCAP) -> AF_ENCAP
#endif
#ifdef AF_LINK
(#const AF_LINK) -> AF_LINK
#endif
#ifdef AF_RAW
(#const AF_RAW) -> AF_RAW
#endif
#ifdef AF_RIF
(#const AF_RIF) -> AF_RIF
#endif
#ifdef AF_NETROM
(#const AF_NETROM) -> AF_NETROM
#endif
#ifdef AF_BRIDGE
(#const AF_BRIDGE) -> AF_BRIDGE
#endif
#ifdef AF_ATMPVC
(#const AF_ATMPVC) -> AF_ATMPVC
#endif
#ifdef AF_ROSE
(#const AF_ROSE) -> AF_ROSE
#endif
#ifdef AF_NETBEUI
(#const AF_NETBEUI) -> AF_NETBEUI
#endif
#ifdef AF_SECURITY
(#const AF_SECURITY) -> AF_SECURITY
#endif
#ifdef AF_PACKET
(#const AF_PACKET) -> AF_PACKET
#endif
#ifdef AF_ASH
(#const AF_ASH) -> AF_ASH
#endif
#ifdef AF_ECONET
(#const AF_ECONET) -> AF_ECONET
#endif
#ifdef AF_ATMSVC
(#const AF_ATMSVC) -> AF_ATMSVC
#endif
#ifdef AF_IRDA
(#const AF_IRDA) -> AF_IRDA
#endif
#ifdef AF_PPPOX
(#const AF_PPPOX) -> AF_PPPOX
#endif
#ifdef AF_WANPIPE
(#const AF_WANPIPE) -> AF_WANPIPE
#endif
#ifdef AF_BLUETOOTH
(#const AF_BLUETOOTH) -> AF_BLUETOOTH
#endif
#ifdef AF_CAN
(#const AF_CAN) -> AF_CAN
#endif
unknown -> error $
"Network.Socket.Types.unpackFamily: unknown address family: " ++
show unknown
------------------------------------------------------------------------
-- Port Numbers
-- | Use the @Num@ instance (i.e. use a literal) to create a
-- @PortNumber@ value with the correct network-byte-ordering. You
-- should not use the PortNum constructor. It will be removed in the
-- next release.
--
-- >>> 1 :: PortNumber
-- 1
-- >>> read "1" :: PortNumber
-- 1
newtype PortNumber = PortNum Word16 deriving (Eq, Ord, Typeable)
-- newtyped to prevent accidental use of sane-looking
-- port numbers that haven't actually been converted to
-- network-byte-order first.
{-# DEPRECATED PortNum "Do not use the PortNum constructor. Use the Num instance. PortNum will be removed in the next release." #-}
instance Show PortNumber where
showsPrec p pn = showsPrec p (portNumberToInt pn)
instance Read PortNumber where
readsPrec n = map (\(x,y) -> (intToPortNumber x, y)) . readsPrec n
intToPortNumber :: Int -> PortNumber
intToPortNumber v = PortNum (htons (fromIntegral v))
portNumberToInt :: PortNumber -> Int
portNumberToInt (PortNum po) = fromIntegral (ntohs po)
foreign import CALLCONV unsafe "ntohs" ntohs :: Word16 -> Word16
foreign import CALLCONV unsafe "htons" htons :: Word16 -> Word16
foreign import CALLCONV unsafe "ntohl" ntohl :: Word32 -> Word32
foreign import CALLCONV unsafe "htonl" htonl :: Word32 -> Word32
instance Enum PortNumber where
toEnum = intToPortNumber
fromEnum = portNumberToInt
instance Num PortNumber where
fromInteger i = intToPortNumber (fromInteger i)
-- for completeness.
(+) x y = intToPortNumber (portNumberToInt x + portNumberToInt y)
(-) x y = intToPortNumber (portNumberToInt x - portNumberToInt y)
negate x = intToPortNumber (-portNumberToInt x)
(*) x y = intToPortNumber (portNumberToInt x * portNumberToInt y)
abs n = intToPortNumber (abs (portNumberToInt n))
signum n = intToPortNumber (signum (portNumberToInt n))
instance Real PortNumber where
toRational x = toInteger x % 1
instance Integral PortNumber where
quotRem a b = let (c,d) = quotRem (portNumberToInt a) (portNumberToInt b) in
(intToPortNumber c, intToPortNumber d)
toInteger a = toInteger (portNumberToInt a)
instance Storable PortNumber where
sizeOf _ = sizeOf (undefined :: Word16)
alignment _ = alignment (undefined :: Word16)
poke p (PortNum po) = poke (castPtr p) po
peek p = PortNum `liftM` peek (castPtr p)
------------------------------------------------------------------------
-- 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
-- | The existence of a constructor does not necessarily imply that
-- that socket address type is supported on your system: see
-- 'isSupportedSockAddr'.
data SockAddr -- C Names
= SockAddrInet
PortNumber -- sin_port (network byte order)
HostAddress -- sin_addr (ditto)
| SockAddrInet6
PortNumber -- sin6_port (network byte order)
FlowInfo -- sin6_flowinfo (ditto)
HostAddress6 -- sin6_addr (ditto)
ScopeID -- sin6_scope_id (ditto)
| SockAddrUnix
String -- sun_path
| SockAddrCan
Int32 -- can_ifindex (can be get by Network.BSD.ifNameToIndex "can0")
-- TODO: Extend this to include transport protocol information
deriving (Eq, Ord, Typeable)
-- | Is the socket address type supported on this system?
isSupportedSockAddr :: SockAddr -> Bool
isSupportedSockAddr addr = case addr of
SockAddrInet {} -> True
#if defined(IPV6_SOCKET_SUPPORT)
SockAddrInet6 {} -> True
#endif
#if defined(DOMAIN_SOCKET_SUPPORT)
SockAddrUnix{} -> True
#endif
#if defined(CAN_SOCKET_SUPPORT)
SockAddrCan{} -> True
#endif
#if !(defined(IPV6_SOCKET_SUPPORT) \
&& defined(DOMAIN_SOCKET_SUPPORT) && defined(CAN_SOCKET_SUPPORT))
_ -> False
#endif
#if defined(WITH_WINSOCK)
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
#if defined(CAN_SOCKET_SUPPORT)
sizeOfSockAddr (SockAddrCan _) = #const sizeof(struct sockaddr_can)
#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)
#if defined(CAN_SOCKET_SUPPORT)
sizeOfSockAddrByFamily AF_CAN = #const sizeof(struct sockaddr_can)
#endif
sizeOfSockAddrByFamily family = error $
"Network.Socket.Types.sizeOfSockAddrByFamily: address family '" ++
show family ++ "' not supported."
-- | 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_HOST_OS)
zeroMemory p (#const sizeof(struct sockaddr_un))
#else
case path of
('\0':_) -> zeroMemory p (#const sizeof(struct sockaddr_un))
_ -> return ()
#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_HOST_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_HOST_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 (In6Addr addr)
(#poke struct sockaddr_in6, sin6_scope_id) p scope
#endif
#if defined(CAN_SOCKET_SUPPORT)
pokeSockAddr p (SockAddrCan ifIndex) = do
#if defined(darwin_HOST_OS)
zeroMemory p (#const sizeof(struct sockaddr_can))
#endif
(#poke struct sockaddr_can, can_ifindex) p ifIndex
#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
In6Addr 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
#if defined(CAN_SOCKET_SUPPORT)
(#const AF_CAN) -> do
ifidx <- (#peek struct sockaddr_can, can_ifindex) p
return (SockAddrCan ifidx)
#endif
_ -> 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.
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)
#if defined(IPV6_SOCKET_SUPPORT)
-- | 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)
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)
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
#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)