module Network.TCP.LTS.User
( tcp_process_user_request
, tcp_wakeup
)
where
import Foreign.C
import Data.List as List
import Control.Monad
import Data.Maybe
import Network.TCP.Type.Base
import Network.TCP.Type.Datagram
import Network.TCP.Type.Syscall
import Network.TCP.Type.Socket
import Network.TCP.Aux.HostMonad
import Network.TCP.Aux.SockMonad
import Network.TCP.Aux.Misc
import Network.TCP.Aux.Param
import Network.TCP.Aux.Output
import Network.TCP.LTS.Out
tcp_process_user_request :: (SockReq,SockRsp->t) -> HMonad t (Maybe t)
tcp_process_user_request (req, cont) =
case req of
SockListen addr -> process_listen addr cont
SockClose sid -> process_close sid cont
SockConnect local addr -> process_connect local addr cont
SockAccept sid -> process_accept sid cont
SockSend sid d -> process_send sid d cont
SockRecv sid -> process_recv sid cont
tcp_wakeup_request req cont =
case req of
SockConnect local addr -> wakeup_connect cont
SockAccept sid -> wakeup_accept sid cont
SockSend sid d -> wakeup_send sid d cont
SockRecv sid -> wakeup_recv sid cont
tcp_wakeup =
do sock <- get_sock
case waiting_list sock of
[] -> return ()
(req,cont):reqs -> do
res <- tcp_wakeup_request req cont
case res of
Nothing -> return ()
Just th -> do
emit_ready_ [th]
modify_sock $ \s -> s {waiting_list = reqs}
process_listen :: Port -> (SockRsp->t) -> HMonad t (Maybe t)
process_listen port cont =
do let sock_id = SocketID (port, TCPAddr (IPAddr 0,0))
h <- get_host
if port `elem` (local_ports h) then
do let listen = SocketListen [] [] listen_qlimit
let newsock = initial_tcp_socket
{ cb = (cb initial_tcp_socket) { local_addr = TCPAddr (IPAddr 0,port), self_id=sock_id }
, st = LISTEN
, sock_listen = listen
}
insert_sock sock_id newsock
modify_host $ \h -> h { local_ports = List.delete port (local_ports h) }
return $ Just $ cont $ SockNew sock_id
else
return $ Just $ cont $ SockError "Port not available"
process_close :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t)
process_close sid cont =
do ok <- has_sock sid
if not ok then
return $ Just $ cont $ SockError "Socket not found"
else do
sock <- lookup_sock sid
if st sock `elem` [CLOSED,SYN_SENT,SYN_RECEIVED] then do
tcp_close sid
return $ Just $ cont $ SockOK
else if st sock /= LISTEN then runSMonad sid $ do
modify_sock $ \sock-> sock { cb = (cb sock) { cantsndmore=True, cantrcvmore=True}
, cb_rcv = (cb_rcv sock) { rcvq=bufferchain_empty }
}
tcp_output_all
return $ Just $ cont $ SockOK
else do
return $ Just $ cont $ SockError "not implemented yet: close_8 : closing a LISTEN socket"
process_accept :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t)
process_accept sid cont =
do ok <- has_sock sid
if not ok then
return $ Just $ cont $ SockError "Socket not found"
else runSMonad sid $ do
res <- try_accept cont
when (isNothing res) $
modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockAccept sid, cont)] }
return res
wakeup_accept sid cont
= try_accept cont
try_accept :: (SockRsp->t) -> SMonad t (Maybe t)
try_accept cont =
do sock <- get_sock
if st sock /= LISTEN then
return $ Just $ cont $ SockError "Socket not in LISTEN state"
else do
let listen = sock_listen sock
case lis_q listen of
[] -> return Nothing
(sid2:qs) -> do
modify_sock $ \sock -> sock { sock_listen = listen { lis_q = qs } }
return $ Just $ cont $ SockNew sid2
process_recv :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t)
process_recv sid cont =
do ok <- has_sock sid
if not ok then
return $ Just $ cont $ SockError "Socket not found"
else runSMonad sid $ do
res <- try_recv cont
when (isNothing res) $
modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockRecv sid, cont)] }
return res
wakeup_recv sid cont =
try_recv cont
try_recv :: (SockRsp->t) -> SMonad t (Maybe t)
try_recv cont =
do sock <- get_sock
let q = rcvq $ cb_rcv sock
if st sock `elem` [ CLOSED, SYN_SENT, SYN_RECEIVED] then
return $ Just $ cont $ SockError "Socket not in synchronized state"
else if bufc_length q == 0 then
if cantrcvmore $ cb sock
then return $ Just $ cont $ SockData buffer_empty
else return Nothing
else do
put_sock $ sock { cb_rcv = (cb_rcv sock) {rcvq = bufferchain_tail q }}
return $ Just $ cont $ SockData $ bufferchain_head q
process_send :: SocketID -> Buffer -> (SockRsp->t) -> HMonad t (Maybe t)
process_send sid d cont =
do ok <- has_sock sid
if not ok then
return $ Just $ cont $ SockError "Socket not found"
else runSMonad sid $ do
(res,remain) <- try_send d cont
when (isNothing res) $
modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockSend sid remain, cont)] }
return res
wakeup_send sid d cont =
do (res,remain) <- try_send d cont
when (isNothing res) $
modify_sock $ \sock -> sock {waiting_list = (tail $ waiting_list sock)++[(SockSend sid remain, cont)] }
return res
try_send :: Buffer -> (SockRsp->t) -> SMonad t (Maybe t, Buffer)
try_send d cont =
do sock <- get_sock
if st sock `notElem` [ ESTABLISHED, CLOSE_WAIT] then
return (Just $ cont $ SockError "Socket not in synchronized state", buffer_empty )
else if cantsndmore $ cb sock then
return (Just $ cont $ SockError "Socket cantsndmore=true, cannot send...", buffer_empty)
else do
let max_can_send = freebsd_so_sndbuf (bufc_length $ sndq $ cb_snd sock)
num_to_send = min max_can_send (buf_len d)
(d1,d2) = buffer_split num_to_send d
modify_cb_snd $ \c -> c { sndq = (sndq c) `bufferchain_append` d1 }
tcp_output_all
if buf_len d2 == 0 then return (Just $ cont $ SockOK, d2)
else return (Nothing, d2)
process_connect :: IPAddr -> TCPAddr -> (SockRsp->t) -> HMonad t (Maybe t)
process_connect local addr cont = do
h <- get_host
m_port <- alloc_local_port
if m_port == Nothing then return $ Just $ cont $ SockError "cannot allocate local port" else do
let (Just port) = m_port
sock_id = SocketID (port, addr)
newiss = SeqLocal 1000
request_r_scale' = 0
rcv_wnd' = freebsd_so_rcvbuf
adv_mss = Just mssdflt
tf_req_tstmp' = False
t_rttseg' = Just (ticks h, newiss)
let { newsock = initial_tcp_socket
{ st = SYN_SENT
, cb_time = initial_cb_time
{ tt_conn_est = Just (create_timer (clock h) tcptv_keep_init)
}
, cb_snd = initial_cb_snd
{ tt_rexmt = start_tt_rexmtsyn 0 False (t_rttinf initial_cb_snd) (clock h)
, snd_una = newiss
, snd_nxt = newiss `seq_plus` 1
, snd_max = newiss `seq_plus` 1
, t_rttseg = t_rttseg'
}
, cb_rcv = initial_cb_rcv
{ rcv_wnd = rcv_wnd'
, rcv_adv = (rcv_nxt initial_cb_rcv) `seq_plus` rcv_wnd'
, tf_rxwin0sent = (rcv_wnd' == 0)
}
, cb = initial_cb_misc
{ local_addr = TCPAddr (local,port)
, remote_addr = addr
, self_id=sock_id
, cantsndmore = False
, cantrcvmore = False
, iss = newiss
, request_r_scale = Just request_r_scale'
, t_advmss = adv_mss
, tf_req_tstmp = tf_req_tstmp'
}
}}
insert_sock sock_id newsock
emit_segs $ [TCPMessage $ make_syn_segment (clock h) newsock (ticks h)]
return $ Nothing
wakeup_connect :: (SockRsp->t) -> SMonad t (Maybe t)
wakeup_connect cont = do
sock <- get_sock
if st sock == SYN_SENT
then return Nothing
else return $ Just $ cont $ SockNew $ self_id $ cb sock