module Network.TCP.Aux.Output where
import Network.TCP.Type.Base
import Network.TCP.Type.Timer
import Network.TCP.Type.Datagram as Datagram
import Network.TCP.Type.Socket
import Network.TCP.Type.Syscall
import Network.TCP.Aux.Param
import Network.TCP.Aux.Misc
import Network.TCP.Aux.HostMonad
import Foreign
import Control.Exception
import Control.Monad
make_syn_segment :: Time -> TCPSocket t -> Timestamp -> TCPSegment
make_syn_segment curr_time sock (ts_val::Timestamp) =
let ws = request_r_scale $ cb sock
mss = t_advmss $ cb $ sock
ts = do_tcp_options curr_time (tf_req_tstmp $ cb sock) (ts_recent $ cb_time $ sock ) ts_val
in
TCPSegment
{ tcp_src = local_addr $ cb sock
, tcp_dst = remote_addr $ cb sock
, tcp_seq = iss $ cb sock
, tcp_ack = SeqForeign 0
, tcp_URG = False
, tcp_ACK = False
, tcp_PSH = False
, tcp_RST = False
, tcp_SYN = True
, tcp_FIN = False
, tcp_win = (rcv_wnd $ cb_rcv sock)
, tcp_urp = 0
, tcp_data = bufferchain_empty
, tcp_ws = ws
, tcp_mss = mss
, tcp_ts = ts
}
make_syn_ack_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) =
let urp_any = 0
tcb = cb sock
win = (rcv_wnd $ cb_rcv sock)
ws = if tf_doing_ws tcb then Just (rcv_scale tcb) else Nothing
mss = t_advmss tcb
ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val
in
TCPSegment
{ tcp_src = addrfrom
, tcp_dst = addrto
, tcp_seq = iss tcb
, tcp_ack = rcv_nxt $ cb_rcv $ sock
, tcp_URG = False
, tcp_ACK = True
, tcp_PSH = False
, tcp_RST = False
, tcp_SYN = True
, tcp_FIN = False
, tcp_win = win
, tcp_urp = urp_any
, tcp_data = bufferchain_empty
, tcp_ws = ws
, tcp_mss = mss
, tcp_ts = ts
}
make_ack_segment curr_time sock (fin::Bool) (ts_val::Timestamp) =
let urp_garbage = 0
tcb = cb sock
win = (rcv_wnd $ cb_rcv sock) `shiftR` (rcv_scale tcb)
ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val
in
TCPSegment
{ tcp_src = local_addr $ tcb
, tcp_dst = remote_addr $ tcb
, tcp_seq = (if fin then snd_una else snd_nxt) $ cb_snd sock
, tcp_ack = rcv_nxt $ cb_rcv sock
, tcp_URG = False
, tcp_ACK = True
, tcp_PSH = False
, tcp_RST = False
, tcp_SYN = False
, tcp_FIN = fin
, tcp_win = win
, tcp_urp = urp_garbage
, tcp_data = bufferchain_empty
, tcp_ws = Nothing
, tcp_mss = Nothing
, tcp_ts = ts
}
bsd_make_phantom_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) (cantsendmore::Bool) =
let urp_garbage = 0
tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock
win = (rcv_wnd rcb) `shiftR` (rcv_scale tcb)
fin = (cantsendmore && seq_lt (snd_una scb) (seq_minus (snd_max scb) 1))
ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val
in
TCPSegment
{ tcp_src = addrfrom
, tcp_dst = addrto
, tcp_seq = if fin then snd_una scb else snd_max scb
, tcp_ack = rcv_nxt rcb
, tcp_URG = False
, tcp_ACK = False
, tcp_PSH = False
, tcp_RST = False
, tcp_SYN = False
, tcp_FIN = fin
, tcp_win = win
, tcp_urp = urp_garbage
, tcp_data = bufferchain_empty
, tcp_ws = Nothing
, tcp_mss = Nothing
, tcp_ts = ts
}
make_rst_segment_from_cb sock (addrfrom::TCPAddr) (addrto::TCPAddr) =
TCPSegment
{ tcp_src = addrfrom
, tcp_dst = addrto
, tcp_seq = snd_nxt $ cb_snd sock
, tcp_ack = rcv_nxt $ cb_rcv sock
, tcp_URG = False
, tcp_ACK = True
, tcp_PSH = False
, tcp_RST = True
, tcp_SYN = False
, tcp_FIN = False
, tcp_win = 0
, tcp_urp = 0
, tcp_data = bufferchain_empty
, tcp_ws = Nothing
, tcp_mss = Nothing
, tcp_ts = Nothing
}
make_rst_segment_from_seg (seg::TCPSegment) =
let tcp_ACK' = not (tcp_ACK seg)
seq' = if (tcp_ACK seg) then seq_flip_ftol (tcp_ack seg) else SeqLocal 0
ack' = if tcp_ACK'
then let s1 = seq_flip_ltof (tcp_seq seg)
in s1 `seq_plus` (bufc_length $ tcp_data seg) `seq_plus` ( if tcp_SYN seg then 1 else 0)
else SeqForeign 0
in
TCPSegment
{ tcp_src = tcp_src seg
, tcp_dst = tcp_dst seg
, tcp_seq = seq'
, tcp_ack = ack'
, tcp_URG = False
, tcp_ACK = tcp_ACK'
, tcp_PSH = False
, tcp_RST = True
, tcp_SYN = False
, tcp_FIN = False
, tcp_win = 0
, tcp_urp = 0
, tcp_data = bufferchain_empty
, tcp_ws = Nothing
, tcp_mss = Nothing
, tcp_ts = Nothing
}
dropwithreset (seg::TCPSegment) =
if tcp_RST seg then []
else let seg' = make_rst_segment_from_seg seg in [TCPMessage seg']
dropwithreset_ignore_or_fail = dropwithreset
tcp_close_temp sock =
sock { cb = (cb sock) { cantrcvmore = True
, cantsndmore = True
, local_addr = TCPAddr (IPAddr 0,0)
, remote_addr = TCPAddr (IPAddr 0,0)
, bsd_cantconnect = True
}
, st = CLOSED
, cb_snd = (cb_snd sock) { sndq = bufferchain_empty }
}
tcp_close :: SocketID -> HMonad t ()
tcp_close sid =
do b <- has_sock sid
when b $ do
sock <- lookup_sock sid
let pending_tasks = waiting_list sock
has_parent = (get_local_port $ parent_id $ cb sock) /= 0
let result = map (\(_,cont) -> cont (SockError "tcpclose")) pending_tasks
emit_ready result
delete_sock sid
when (not has_parent) $ free_local_port $ get_local_port sid
tcp_drop_and_close :: SocketID -> HMonad t ()
tcp_drop_and_close sid =
do b <- has_sock sid
when b $ do
sock <- lookup_sock sid
let outsegs = if st sock `notElem` [CLOSED,LISTEN,SYN_SENT]
then [TCPMessage $ make_rst_segment_from_cb
(sock) (local_addr $ cb sock) (remote_addr $ cb sock)]
else []
emit_segs outsegs
tcp_close sid
alloc_local_port :: HMonad t (Maybe Port)
alloc_local_port = do
h <- get_host
case local_ports h of
[] -> return Nothing
port:rest -> do put_host $ h { local_ports = rest }
return $ Just port
free_local_port port =
modify_host $ \h -> h { local_ports = port:(local_ports h) }