module Network.Socket.Internal(
Socket(..)
, SocketStatus(..)
, socket
, connect
, bind
, listen
, accept
, ShutdownCmd(..)
, close
, shutdown
, isConnected
, isBound
, isListening
, isReadable
, isWritable
, SocketType(..)
, isSupportedSocketType
, ProtocolNumber
, defaultProtocol
, ForAction(..)
, getConnectedHansSocket
, getBoundUdpPort
, getNextUdpPacket
, SockAddr(..)
, hansUdpSockAddr, hansTcpSockAddr
, PortNumber(..)
, Family(..)
, HostAddress
, HostAddress6
, getNetworkHansStack
, setNetworkHansStack
, getNextSockIdent
)
where
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Data.Typeable
import Data.ByteString(ByteString)
import Data.Word(Word64, Word32,Word16)
import Foreign.C.Types
import Foreign.Storable
import Hans.Address.IP4
import Hans.Message.Tcp(getPort)
import Hans.Message.Udp(getUdpPort)
import Hans.NetworkStack(NetworkStack)
import qualified Hans.NetworkStack as NS
import System.IO.Unsafe
type ProtocolNumber = CInt
defaultProtocol :: ProtocolNumber
defaultProtocol = 6
data Socket = Socket {
sockState :: MVar SockState
, sockNStack :: NetworkStack
, sockIdent :: Word64
}
data ForAction = ForNeither | ForRead | ForWrite | ForBoth
deriving (Eq)
getConnectedHansSocket :: Socket -> ForAction -> IO NS.Socket
getConnectedHansSocket sock forWrite =
do state <- readMVar (sockState sock)
case state of
SockConnected s c -> checkDone c forWrite >> return s
_ -> throwIO (userError "Socket not in connected state.")
where
checkDone Nothing _ =
return ()
checkDone (Just ShutdownReceive) x
| x `elem` [ForRead, ForBoth] =
throwIO (userError "Read on Socket set shutdown/receive.")
| otherwise =
return ()
checkDone (Just ShutdownSend) x
| x `elem` [ForWrite, ForBoth] =
throwIO (userError "Write on Socket set shutdown/send.")
| otherwise =
return ()
checkDone (Just ShutdownBoth) x
| x /= ForNeither =
throwIO (userError "Read or write on shutdown socket.")
| otherwise =
return ()
getBoundUdpPort :: Socket -> IO (NetworkStack, Maybe NS.UdpPort)
getBoundUdpPort sock =
do state <- readMVar (sockState sock)
case state of
SockBoundUdp mp _ -> return (sockNStack sock, mp)
_ -> throwIO (userError "Socket not bound to UDP.")
getNextUdpPacket :: Socket -> IO (ByteString, SockAddr)
getNextUdpPacket sock =
do state <- readMVar (sockState sock)
case state of
SockBoundUdp _ c -> readChan c
_ -> throwIO (userError "Socket not bound to UDP.")
instance Eq Socket where
a == b = sockIdent a == sockIdent b
data SocketStatus = NotConnected
| Bound
| Listening
| Connected
| ConvertedToHandle
| Closed
deriving (Eq, Show)
data SocketType = NoSocketType
| Stream
| Datagram
| Raw
| RDM
| SeqPacket
deriving (Eq, Ord, Read, Show, Typeable)
isSupportedSocketType :: SocketType -> Bool
isSupportedSocketType Stream = True
isSupportedSocketType Datagram = True
data SockState = SockInitialUdp
| SockInitialTcp
| SockConnected NS.Socket (Maybe ShutdownCmd)
| SockBoundUdp (Maybe NS.UdpPort) (Chan (ByteString, SockAddr))
| SockBoundTcp IP4 NS.TcpPort
| SockListening NS.Socket
| SockClosed
instance Eq SockState where
SockInitialTcp == SockInitialTcp = True
SockInitialUdp == SockInitialUdp = True
SockClosed == SockClosed = True
_ == _ = False
socket :: Family -> SocketType -> ProtocolNumber -> IO Socket
socket AF_INET Stream 6 =
do sockState <- newMVar SockInitialTcp
sockNStack <- getNetworkHansStack
sockIdent <- getNextSockIdent
return Socket { .. }
socket AF_INET Datagram 17 =
do sockState <- newMVar SockInitialUdp
sockNStack <- getNetworkHansStack
sockIdent <- getNextSockIdent
return Socket { .. }
socket _ _ _ =
throwIO (userError "ERROR: Unsupported socket options.")
connect :: Socket -> SockAddr -> IO ()
connect sock (SockAddrInet (PortNum port) addr) =
do state <- takeMVar (sockState sock)
unless (state == SockInitialTcp) $
throwIO (userError "Attempt to connect() on a non-TCP socket.")
let dest = convertFromWord32 addr
dport = fromIntegral port
ns = sockNStack sock
catch (do hsock <- NS.connect ns dest dport Nothing
putMVar (sockState sock) (SockConnected hsock Nothing))
(\ e ->
do putMVar (sockState sock) state
throwIO (e :: SomeException))
bind :: Socket -> SockAddr -> IO ()
bind sock (SockAddrInet (PortNum port) addr) =
do state <- takeMVar (sockState sock)
case state of
SockInitialUdp ->
do chan <- newChan
let port' = fromIntegral port
NS.addUdpHandler (sockNStack sock) port' (udpHandler chan)
let state' = SockBoundUdp (Just port') chan
putMVar (sockState sock) state'
SockInitialTcp ->
do let port' = fromIntegral port
addr' = convertFromWord32 addr
putMVar (sockState sock) (SockBoundTcp addr' port')
_ ->
do putMVar (sockState sock) state
throwIO (userError "Bind called on incompatible socket.")
where
udpHandler :: Chan (ByteString, SockAddr) -> IP4 -> NS.UdpPort -> ByteString -> IO ()
udpHandler chan addr port bstr =
let sport = PortNum (fromIntegral (getUdpPort port))
saddr = convertToWord32 addr
in writeChan chan (bstr, SockAddrInet sport saddr)
listen :: Socket -> Int -> IO ()
listen sock _ =
do state <- takeMVar (sockState sock)
case state of
SockBoundTcp addr port ->
do nsock <- NS.listen (sockNStack sock) addr port
putMVar (sockState sock) (SockListening nsock)
_ ->
throwIO (userError "Listen called on unbound or non-TCP socket.")
accept :: Socket -> IO (Socket, SockAddr)
accept sock =
do state <- readMVar (sockState sock)
case state of
SockListening lsock ->
do newsock <- NS.accept lsock
state <- newMVar (SockConnected newsock Nothing)
newid <- getNextSockIdent
let sock' = Socket state (sockNStack sock) newid
oaddr = convertToWord32 (NS.sockRemoteHost newsock)
oport = fromIntegral (getPort (NS.sockRemotePort newsock))
return (sock', SockAddrInet oport oaddr)
data ShutdownCmd = ShutdownReceive | ShutdownSend | ShutdownBoth
deriving (Typeable, Eq)
shutdown :: Socket -> ShutdownCmd -> IO ()
shutdown so cmd =
do state <- takeMVar (sockState so)
case state of
SockConnected sock oshtd ->
do let shtd = advanceShutdown oshtd cmd
if shtd == ShutdownBoth
then do putMVar (sockState so) SockClosed
NS.close sock
else putMVar (sockState so) (SockConnected sock (Just shtd))
advanceShutdown :: Maybe ShutdownCmd -> ShutdownCmd -> ShutdownCmd
advanceShutdown Nothing x = x
advanceShutdown _ ShutdownBoth = ShutdownBoth
advanceShutdown (Just ShutdownReceive) ShutdownSend = ShutdownBoth
advanceShutdown (Just ShutdownSend) ShutdownReceive = ShutdownBoth
advanceShutdown (Just y) x = y
close :: Socket -> IO ()
close so =
do state <- takeMVar (sockState so)
case state of
SockConnected sock _ -> NS.close sock
SockBoundUdp (Just port) _ -> NS.removeUdpHandler (sockNStack so) port
SockListening sock -> NS.close sock
_ -> return ()
putMVar (sockState so) SockClosed
isConnected :: Socket -> IO Bool
isConnected so =
do state <- readMVar (sockState so)
case state of
SockConnected _ _ -> return True
_ -> return False
isBound :: Socket -> IO Bool
isBound so =
do state <- readMVar (sockState so)
case state of
SockBoundUdp _ _ -> return True
SockBoundTcp _ _ -> return True
_ -> return False
isListening :: Socket -> IO Bool
isListening so =
do state <- readMVar (sockState so)
case state of
SockListening _ -> return True
_ -> return False
isReadable :: Socket -> IO Bool
isReadable so =
do state <- readMVar (sockState so)
case state of
SockBoundUdp _ _ -> return True
SockConnected _ (Just ShutdownReceive) -> return False
SockConnected _ _ -> return True
_ -> return False
isWritable :: Socket -> IO Bool
isWritable so =
do state <- readMVar (sockState so)
case state of
SockBoundUdp _ _ -> return True
SockConnected _ (Just ShutdownSend) -> return False
SockConnected _ _ -> return True
_ -> return False
data SockAddr = SockAddrInet PortNumber HostAddress
deriving (Eq, Ord, Show, Typeable)
hansUdpSockAddr :: SockAddr -> (IP4, NS.UdpPort)
hansUdpSockAddr (SockAddrInet (PortNum pn) addr) =
(convertFromWord32 addr, fromIntegral pn)
hansTcpSockAddr :: SockAddr -> (IP4, NS.TcpPort)
hansTcpSockAddr (SockAddrInet (PortNum pn) addr) =
(convertFromWord32 addr, fromIntegral pn)
newtype PortNumber = PortNum Word16
deriving (Enum, Eq, Integral, Num, Ord, Real, Show, Typeable, Storable)
data Family
= 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
deriving (Eq, Ord, Read, Show)
type HostAddress = Word32
type HostAddress6 = (Word32, Word32, Word32, Word32)
{-# NOINLINE evilNSMVar #-}
evilNSMVar :: MVar NetworkStack
evilNSMVar =
unsafePerformIO (newMVar (error "Access before set of network stack!"))
getNetworkHansStack :: IO NetworkStack
getNetworkHansStack = readMVar evilNSMVar
setNetworkHansStack :: NetworkStack -> IO ()
setNetworkHansStack ns = swapMVar evilNSMVar ns >> return ()
{-# NOINLINE evilSockIdentMVar #-}
evilSockIdentMVar :: MVar Word64
evilSockIdentMVar = unsafePerformIO (newMVar 0)
getNextSockIdent :: IO Word64
getNextSockIdent = modifyMVar evilSockIdentMVar (\ x -> return (x + 1, x))