{-# LANGUAGE ScopedTypeVariables #-} {-- Copyright (c) 2006, Peng Li 2006, Stephan A. Zdancewic All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright owners nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --} module Network.TCP.LTS.Out ( tcp_output_all , tcp_output , tcp_close , tcp_drop_and_close ) where import Hans.Message.Tcp import Data.List as List import Network.TCP.Aux.Output import Network.TCP.Aux.Misc import Network.TCP.Type.Base import Network.TCP.Type.Syscall import Network.TCP.Type.Socket import Hans.Layer.Tcp.Monad import Network.TCP.Aux.SockMonad import Control.Monad import Control.Exception import Foreign import Network.TCP.Type.Timer import Network.TCP.Type.Datagram as Datagram import Network.TCP.Aux.Param tcp_output_all :: SMonad t () tcp_output_all = do h <- get_host_ sock <- get_sock let scb = cb_snd sock tcb = cb sock when ((st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, FIN_WAIT_2, CLOSING, LAST_ACK, TIME_WAIT] && (snd_una scb /= iss tcb)) -- does this make sense? || ( st sock `elem` [SYN_SENT, SYN_RECEIVED] && cantsndmore tcb && (tf_shouldacknow $ cb_rcv sock))) $ output_loop h sock output_loop h sock = let (sock1, outsegs) = tcp_output_really (clock h) False (ticks h) sock in if List.null outsegs then put_sock sock1 else do --debug $ "tcp_output_all: " ++ (show outsegs) emit_segs_ $! outsegs output_loop h sock1 {-# INLINE tcp_output_all #-} {-# INLINE output_loop #-} {-# INLINE tcp_output_really #-} tcp_output_really (curr_time :: Time) (window_probe::Bool) (ts_val'::Timestamp) tcp_sock = let tcb = cb tcp_sock scb = cb_snd tcp_sock rcb = cb_rcv tcp_sock in assert ((rcv_adv rcb) >= (rcv_nxt rcb)) $ assert ((snd_nxt scb) >= (snd_una scb)) $ let snd_cwnd' = if snd_max scb == snd_una scb && (t_idletime $ cb_time tcp_sock) - curr_time >= (computed_rxtcur $ t_rttinf scb) then (t_maxseg tcb) * ss_fltsz -- has been idle for a while, slowstart else snd_cwnd scb win0 = min (snd_wnd scb) snd_cwnd' win = if window_probe && win0==0 then 1 else win0 snd_wnd_unused ::Int = win - ((snd_nxt scb) `seq_diff` (snd_una scb)) syn_not_acked = (st tcp_sock `elem` [SYN_SENT, SYN_RECEIVED]) fin_required = (cantsndmore tcb && st tcp_sock `notElem` [FIN_WAIT_2, TIME_WAIT]) last_sndq_data_seq = (snd_una scb) `seq_plus` (bufc_length $ sndq scb) last_sndq_data_and_fin_seq = last_sndq_data_seq `seq_plus` (if fin_required then 1 else 0) `seq_plus` (if syn_not_acked then 1 else 0) have_data_to_send = (snd_nxt scb) < last_sndq_data_seq have_data_or_fin_to_send = (snd_nxt scb) < last_sndq_data_and_fin_seq window_update_delta = (min (tcp_maxwin `shiftL` (rcv_scale tcb)) (freebsd_so_rcvbuf - (bufc_length $ rcvq rcb)) ) - ( (rcv_adv rcb) `seq_diff` (rcv_nxt rcb)) need_to_send_a_window_update = (window_update_delta >= 2 * (t_maxseg tcb)) || (2*window_update_delta >= freebsd_so_rcvbuf) do_output = ( have_data_or_fin_to_send && (if have_data_to_send then snd_wnd_unused>0 else True) ) || need_to_send_a_window_update -- sndurp tcp_sock /= Nothing || tf_shouldacknow rcb cant_send = (not do_output) && (bufc_length (sndq scb) > 0 ) && mode_of (tt_rexmt scb) == Nothing window_shrunk = win==0 && snd_wnd_unused <0 && st tcp_sock /= SYN_SENT tcp_sock0 = if cant_send then tcp_sock { cb_snd = scb {tt_rexmt = start_tt_persist 0 (t_rttinf scb) curr_time}} else if window_shrunk then tcp_sock { cb_snd = scb { tt_rexmt = case tt_rexmt scb of Just(Timed (Persist, shift) d ) -> Just (Timed (Persist, 0) d) _ -> start_tt_persist 0 (t_rttinf scb) curr_time , snd_nxt = snd_una scb }} else tcp_sock in if (not do_output) then (tcp_sock0, []) else ------------ really do it --------------------------------------------- let tcp_sock = tcp_sock0 scb = cb_snd tcp_sock data' = bufferchain_drop (snd_nxt scb `seq_diff` (snd_una scb)) (sndq scb) data_to_send = bufferchain_take (min (snd_wnd_unused) ( t_maxseg tcb)) data' bFIN = fin_required && (snd_nxt scb) `seq_plus` (bufc_length data_to_send) >= last_sndq_data_seq bACK = if bFIN && st tcp_sock == SYN_SENT then False else True snd_nxt' = if bFIN && ((snd_nxt scb `seq_plus` (bufc_length data_to_send) == last_sndq_data_seq `seq_plus` 1 && snd_una scb /= iss tcb ) || (snd_nxt scb) `seq_diff` (iss tcb) == 2) then snd_nxt scb `seq_minus` 1 else snd_nxt scb bPSH = bufc_length data_to_send > 0 && snd_nxt scb `seq_plus` (bufc_length data_to_send) == last_sndq_data_seq rcv_wnd'' = calculate_bsd_rcv_wnd tcp_sock rcv_wnd' = max (rcv_adv rcb `seq_diff` (rcv_nxt rcb)) (min (tcp_maxwin `shiftL` (rcv_scale tcb)) (if rcv_wnd'' < (freebsd_so_rcvbuf `div` 4) && rcv_wnd'' < (t_maxseg tcb) then 0 else rcv_wnd'')) want_tstmp = if st tcp_sock == SYN_SENT then tf_req_tstmp tcb else tf_doing_tstmp tcb ts_ = do_tcp_options curr_time want_tstmp (ts_recent $ cb_time tcp_sock) ts_val' in let win_ = rcv_wnd' `shiftR` (rcv_scale tcb) hdr = set_tcp_ts ts_ emptyTcpHeader { tcpSeqNum = TcpSeqNum (seq_val snd_nxt') , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt rcb)) , tcpAck = bACK , tcpPsh = bPSH , tcpFin = bFIN , tcpWindow = fromIntegral win_ } seg = mkTCPSegment' (local_addr tcb) (remote_addr tcb) hdr data_to_send st' = if bFIN then case st tcp_sock of ESTABLISHED -> FIN_WAIT_1 CLOSE_WAIT -> LAST_ACK xxx -> xxx else st tcp_sock snd_nxt'' = snd_nxt' `seq_plus` (bufc_length data_to_send) `seq_plus` (if bFIN then 1 else 0) snd_max' = max (snd_max scb) snd_nxt'' tt_rexmt' = if (mode_of (tt_rexmt scb) == Nothing || (mode_of (tt_rexmt scb) == Just Persist && not window_probe)) && snd_nxt'' > (snd_una scb) then start_tt_rexmt 0 False (t_rttinf scb) curr_time else if (window_probe {-- || sndurp tcp_sock /= Nothing --} ) && win0 /= 0 && mode_of (tt_rexmt scb) == Just Persist then Nothing else tt_rexmt scb t_rttseg' = if t_rttseg scb == Nothing && (bufc_length data_to_send > 0 || bFIN) && snd_nxt'' > (snd_max scb) && not window_probe then Just (ts_val', snd_nxt') else t_rttseg scb tcp_sock' = tcp_sock { st = st' , cb_snd = scb { tt_rexmt = tt_rexmt' , snd_cwnd = snd_cwnd' , t_rttseg = t_rttseg' , snd_max = snd_max' , snd_nxt = snd_nxt'' } , cb_rcv = rcb { last_ack_sent = rcv_nxt rcb , rcv_adv = rcv_nxt rcb `seq_plus` rcv_wnd' , tt_delack = False , rcv_wnd = rcv_wnd' , tf_rxwin0sent = (rcv_wnd' == 0) , tf_shouldacknow = False } } outsegs' = [TCPMessage seg] in (tcp_sock', outsegs') {-# INLINE tcp_output #-} tcp_output :: Bool -> SMonad t () tcp_output win_probe = do sock <- get_sock h <- get_host_ let (newsock, segs) = tcp_output_really (clock h) win_probe (ticks h) sock put_sock newsock emit_segs_ segs --if List.null segs then return () else debug $ "tcp_output: " ++ (show segs)