module Network.TCP.LTS.InData where
import Foreign
import Foreign.C
import Control.Exception
import Control.Monad
import Data.List as List
import Network.TCP.Type.Base
import Network.TCP.Type.Timer
import Network.TCP.Type.Socket
import Network.TCP.Type.Datagram as Datagram
import Network.TCP.Type.Syscall
import Network.TCP.Aux.Param
import Network.TCP.Aux.Misc
import Network.TCP.Aux.Output
import Network.TCP.Aux.HostMonad
import Network.TCP.Aux.SockMonad
import Network.TCP.LTS.User
import Network.TCP.LTS.Out
deliver_in_3 seg =
do sock <- get_sock
h <- get_host_
let tcb = cb sock
scb = cb_snd sock
acknum = seq_flip_ftol $ tcp_ack seg
seqnum = (seq_flip_ltof $ tcp_seq seg) `seq_plus` (if tcp_SYN seg then 1 else 0)
seg_win = (tcp_win seg) `shiftL` (snd_scale tcb)
let wesentafin = (snd_max scb) > (snd_una scb `seq_plus` (bufc_length $ sndq scb))
ourfinisacked = wesentafin && tcp_ACK seg && acknum >= (snd_max scb)
drop_it <- di3_topstuff seg seqnum acknum h
when (not drop_it) $ do
ack_ok <- di3_ackstuff seg seqnum acknum seg_win h ourfinisacked
when ack_ok $ do
fin_reass <- di3_datastuff seg seqnum acknum seg_win h ourfinisacked
di3_ststuff fin_reass h ourfinisacked acknum
tcp_wakeup
tcp_output_all
get_sock
di3_topstuff seg seqnum acknum h =
do sock <- get_sock
let tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock
let rseq = seqnum `seq_plus` (bufc_length $ tcp_data seg)
let seg_ts = tcp_ts seg
let paws_failed = False
let rcv_wnd' = calculate_bsd_rcv_wnd sock
let segment_off_right_hand_edge =
(seqnum >= (rcv_nxt rcb `seq_plus` rcv_wnd'))
&& (rseq > (rcv_nxt rcb `seq_plus` rcv_wnd'))
&& (rcv_wnd' /= 0)
let drop_it = paws_failed || segment_off_right_hand_edge
let Just seg_ts_val = seg_ts
let (tt_keep', tt_fin_wait_2') = update_idle (clock h) sock
let ts_recent'' = if not drop_it && seg_ts /= Nothing && seqnum <= (last_ack_sent rcb)
then create_timewindow (clock h) dtsinval (fst $ seg_ts_val)
else ts_recent $ cb_time sock
modify_cb_time $ \t -> t { tt_keep = tt_keep'
, tt_fin_wait_2 = tt_fin_wait_2'
, t_idletime = clock h
, ts_recent = ts_recent''
}
return drop_it
di3_ackstuff seg seqnum acknum seg_win h ourfinisacked =
do sock <- get_sock
let scb = cb_snd sock
if acknum > snd_max scb then return False
else if acknum > snd_una scb
then di3_newackstuff sock seg acknum h ourfinisacked
else di3_oldackstuff sock seg seqnum acknum seg_win h
di3_oldackstuff sock seg seqnum acknum seg_win h =
let tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock in
let has_data = bufc_length (tcp_data seg) > 0
&& (rcv_nxt rcb) < (seqnum `seq_plus` (bufc_length $ tcp_data seg))
&& seqnum < ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb)) in
let maybe_dup_ack = not has_data
&& seg_win == (snd_wnd scb)
&& mode_of (tt_rexmt scb) == Just Rexmt in
if not maybe_dup_ack then do
modify_cb_snd $ \c -> c { t_dupacks = 0 }
return True
else
let t_dupacks' = t_dupacks scb + 1 in
if acknum < (snd_una scb) then
do modify_cb_snd $ \c -> c { t_dupacks = 0}
return False
else if t_dupacks' < 3 then
do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks'}
return True
else if t_dupacks' > 3 || (t_dupacks' == 3 && tcp_do_newreno && acknum < (snd_recover tcb)) then
do modify_cb_snd $ \c -> c { t_dupacks = if t_dupacks' == 3 then 0 else t_dupacks'
, snd_cwnd = (snd_cwnd scb) + (t_maxseg tcb)
}
tcp_output False
return False
else
do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks'
, tt_rexmt = Nothing
, t_rttseg = Nothing
, snd_nxt = acknum
, snd_cwnd = t_maxseg tcb
}
modify_cb $ \c -> c { snd_ssthresh = (max 2 ( (min (snd_wnd scb) (snd_cwnd scb))
`div` 2 `div` (t_maxseg tcb)))
* (t_maxseg tcb)
, snd_recover = if tcp_do_newreno then snd_max scb else snd_recover c
}
tcp_output False
modify_cb_snd $ \c -> c { snd_cwnd = (snd_ssthresh tcb) + (t_maxseg tcb) * t_dupacks'
, snd_nxt = max (snd_nxt scb) (snd_nxt c)
}
return False
di3_newackstuff sock seg acknum h ourfinisacked =
do let seg_ts = tcp_ts seg
let tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock
if (not tcp_do_newreno) || t_dupacks scb < 3 then
modify_cb_snd $ \c->c { t_dupacks = 0
, snd_cwnd = if t_dupacks c >= 3
then min (snd_cwnd c) (snd_ssthresh tcb)
else snd_cwnd c }
else if acknum < (snd_recover tcb) then
do modify_cb_snd $ \c -> c { tt_rexmt = Nothing
, t_rttseg = Nothing
, snd_nxt = acknum
, snd_cwnd = t_maxseg tcb }
tcp_output False
modify_cb_snd $ \c->c{ snd_cwnd = (snd_cwnd c(acknum `seq_diff` (snd_una c))+(t_maxseg tcb))
, snd_nxt = snd_nxt scb }
else
modify_cb_snd $ \c -> c { t_dupacks = 0
, snd_cwnd = if snd_max c `seq_diff` acknum < (snd_ssthresh tcb)
then snd_max c `seq_diff` acknum + (t_maxseg tcb)
else snd_ssthresh tcb }
let revert_rexmt = mode_of (tt_rexmt scb) `elem` [ Just Rexmt, Just RexmtSyn ]
&& shift_of (tt_rexmt scb) == 1
&& timewindow_open (clock h) (t_badrxtwin $ cb_time sock)
when revert_rexmt $ do
modify_cb_snd $ \c -> c { snd_cwnd = snd_cwnd_prev tcb
, snd_nxt = snd_max scb
}
modify_cb_time $ \c -> c { t_badrxtwin = Nothing }
modify_cb $ \c -> c { snd_ssthresh = snd_ssthresh_prev tcb }
let emission_time = case (seg_ts, t_rttseg scb) of
(Just (ts_val, ts_ecr), _ ) -> Just (ts_ecr `seq_minus` 1)
(Nothing, Just (ts0, seq0)) -> if acknum > seq0 then Just ts0 else Nothing
(Nothing, Nothing) -> Nothing
let t_rttinf' = case emission_time of
Just emtime -> assert ((ticks h) >= emtime) $
update_rtt ( ((ticks h) `seq_diff` emtime)*10*1000 ) (t_rttinf scb)
Nothing -> t_rttinf scb
let tt_rexmt' = if acknum == snd_max scb then
Nothing
else case mode_of (tt_rexmt scb) of
Nothing -> start_tt_rexmt 0 True t_rttinf' (clock h)
Just Rexmt -> start_tt_rexmt 0 True t_rttinf' (clock h)
_ -> tt_rexmt scb
let (snd_wnd', sndq') = if ourfinisacked then
(snd_wnd scb (bufc_length $ sndq scb), bufferchain_empty)
else
(snd_wnd scb (acknum `seq_diff` (snd_una scb)),
bufferchain_drop (acknum `seq_diff` (snd_una scb)) (sndq scb))
modify_cb_snd $ \c -> c { t_rttinf = t_rttinf'
, tt_rexmt = tt_rexmt'
, t_rttseg = if emission_time == Nothing then t_rttseg c else Nothing
, snd_cwnd = if not tcp_do_newreno || t_dupacks scb == 0 then
expand_cwnd (snd_ssthresh tcb)
(t_maxseg tcb)
(tcp_maxwin `shiftL` (snd_scale tcb))
(snd_cwnd c)
else snd_cwnd c
, snd_wnd = snd_wnd'
, snd_una = acknum
, snd_nxt = max acknum (snd_nxt c)
, sndq = sndq'
}
when (st sock == TIME_WAIT) $
modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl))}
if (st sock == LAST_ACK) && ourfinisacked then do
modify_sock tcp_close_temp
return False
else return True
di3_datastuff seg seqnum acknum seg_win h ourfinisacked = do
sock <- get_sock
let tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock
let update_send_window =
tcp_ACK seg
&& seqnum <= ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb) )
&& ( snd_wl1 scb < seqnum
|| ( snd_wl1 scb == seqnum
&& ( snd_wl2 scb < acknum
|| ( snd_wl2 scb == acknum && seg_win > snd_wnd scb )
)
)
|| (st sock == SYN_RECEIVED && not (tcp_FIN seg) )
)
let seq_trimmed = max seqnum (min (rcv_nxt rcb) (seqnum `seq_plus` (bufc_length $ tcp_data seg)))
when update_send_window $
modify_cb_snd $ \c -> c { snd_wnd = seg_win
, snd_wl1 = seq_trimmed
, snd_wl2 = acknum
}
if st sock == TIME_WAIT || (st sock == CLOSING && ourfinisacked)
then do modify_cb $ \c -> c { rcv_up = max (rcv_up c) (rcv_nxt rcb) }
return False
else di3_datastuff_really seg seqnum acknum seg_win h
di3_datastuff_really seg seqnum acknum seg_win h =
do let dat = tcp_data seg
sock <- get_sock
let tcb = cb sock
scb = cb_snd sock
rcb = cb_rcv sock
let trim_amt_left = if rcv_nxt rcb > seqnum
then min (rcv_nxt rcb `seq_diff` seqnum) (bufc_length dat)
else 0
data_trimmed_left = bufferchain_drop trim_amt_left dat
seq_trimmed = seqnum `seq_plus` trim_amt_left
let data_trimmed_left_right = bufferchain_take (rcv_wnd rcb) data_trimmed_left
fin_trimmed = if bufc_length data_trimmed_left_right ==
bufc_length data_trimmed_left then tcp_FIN seg else False
let rseg = TCPReassSegment { trs_seq = seq_trimmed
, trs_FIN = fin_trimmed
, trs_data = data_trimmed_left_right
}
if seq_trimmed == rcv_nxt rcb
&& seq_trimmed `seq_plus` (bufc_length data_trimmed_left_right)
`seq_plus` (if fin_trimmed then 1 else 0) > (rcv_nxt rcb)
&& rcv_wnd rcb > 0
then do
let have_stuff_to_ack = bufc_length data_trimmed_left_right >0 || fin_trimmed
let delay_ack = st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, FIN_WAIT_2, CLOSING, LAST_ACK]
&& have_stuff_to_ack && not fin_trimmed && List.null (t_segq rcb)
&& not (tf_rxwin0sent rcb)
&& tt_delack rcb == False
let rsegq = rseg:(t_segq rcb)
let (data_reass, rcv_nxt', fin_reass0, t_segq') = tcp_reass (rcv_nxt rcb) rsegq
let rcvq' = bufferchain_concat (rcvq rcb) data_reass
let rcv_wnd' = rcv_wnd rcb (bufc_length data_reass)
modify_cb_rcv $ \c -> c
{ tt_delack = if delay_ack then True else tt_delack c
, tf_shouldacknow = if have_stuff_to_ack then not delay_ack else tf_shouldacknow c
, t_segq = t_segq'
, rcv_nxt = rcv_nxt'
, rcv_wnd = rcv_wnd'
, rcvq = rcvq'
}
return fin_reass0
else if seq_trimmed > (rcv_nxt rcb)
&& seq_trimmed < ((rcv_nxt rcb) `seq_plus` (rcv_wnd rcb))
&& bufc_length data_trimmed_left_right + (if fin_trimmed then 1 else 0) > 0
&& rcv_wnd rcb > 0
then do
modify_cb_rcv $ \c -> c { t_segq = rseg:(t_segq c)
, tf_shouldacknow = True
}
return False
else if tcp_ACK seg && seq_trimmed == rcv_nxt rcb
&& bufc_length dat + (if tcp_FIN seg then 1 else 0) == 0 then
return False
else do
modify_cb_rcv $ \c -> c { tf_shouldacknow = True }
return False
di3_ststuff fin_reass h ourfinisacked acknum =
do sock <- get_sock
let tcb = cb sock
let enter_TIME_WAIT = do
modify_sock $ \s -> s { st = TIME_WAIT }
modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl))
, tt_keep = Nothing
, tt_conn_est = Nothing
, tt_fin_wait_2 = Nothing
}
modify_cb_snd $ \c -> c { tt_rexmt = Nothing }
modify_cb_rcv $ \c -> c { tt_delack = False }
when fin_reass $
modify_cb $ \s -> s { cantrcvmore = True }
case (st sock, fin_reass) of
(SYN_RECEIVED,False) -> when (acknum >= (iss tcb) `seq_plus` 1 ) $
modify_sock $ \s -> s
{ st = if not (cantsndmore tcb) then ESTABLISHED else
if ourfinisacked then FIN_WAIT_2 else FIN_WAIT_1
}
(SYN_RECEIVED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT }
(ESTABLISHED, False) -> return ()
(ESTABLISHED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT }
(CLOSE_WAIT, _ ) -> return ()
(FIN_WAIT_1, False) -> when ourfinisacked $ do
modify_sock $ \s -> s { st = FIN_WAIT_2 }
when (cantrcvmore tcb) $
modify_cb_time $ \c -> c { tt_fin_wait_2 =
Just (create_timer (clock h) (tcptv_maxidle)) }
(FIN_WAIT_1, True) -> if ourfinisacked then enter_TIME_WAIT
else modify_sock $ \s->s { st=CLOSING }
(FIN_WAIT_2, False) -> return ()
(FIN_WAIT_2, True) -> enter_TIME_WAIT
(CLOSING, _) -> when ourfinisacked enter_TIME_WAIT
(LAST_ACK, False) -> return ()
(LAST_ACK, True) -> error "di3_ststuff"
(TIME_WAIT, _ ) -> return ()