{-# LANGUAGE FlexibleContexts #-}

module Net.TCP_Client(
    initialize,Active(..),tx,rx,Passive(..),Interface(..),Peer,Port(..)
  ) where

-- Transmission Control Protocol
-- See http://www.networksorcery.com/enp/protocol/tcp.htm
--     http://www.networksorcery.com/enp/rfc/rfc793.txt

import Net.Concurrent
import Control.Monad(when)
import Control.Monad.State
import Control.Monad.Trans(lift)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.List((\\))
import Data.Word(Word8,Word16,Word32)

import Net.TCP as TCP
import Net.PortNumber
import qualified Net.IPv4 as IPv4
import qualified Net.Interface as Net
import Net.Utils as Util(doReq,contents,checksum,bytes_to_words_big)
import Net.Packet(InPacket,len,dropInPack,
		  OutPacket,outLen,outBytes,emptyInPack,
		  emptyOutPack,appendOutPack,splitOutPack)
import Net.PacketParsing(doUnparse)
import Monad.Util

data Active  m = Active  { forall (m :: * -> *). Active m -> m ()
close:: m (), forall (m :: * -> *). Active m -> Interface m InPacket OutPacket
io::Net.Interface m InPacket OutPacket }
data Passive m = Passive { forall (m :: * -> *). Passive m -> m (Peer, Active m)
accept::m (Peer,Active m), forall (m :: * -> *). Passive m -> m ()
unlisten::m () }
type Peer = (IPv4.Addr,Port)

tx :: Active m -> OutPacket -> m ()
tx = Interface m InPacket OutPacket -> OutPacket -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx (Interface m InPacket OutPacket -> OutPacket -> m ())
-> (Active m -> Interface m InPacket OutPacket)
-> Active m
-> OutPacket
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Active m -> Interface m InPacket OutPacket
forall (m :: * -> *). Active m -> Interface m InPacket OutPacket
io
rx :: Active m -> m InPacket
rx = Interface m InPacket OutPacket -> m InPacket
forall (m :: * -> *) i o. Interface m i o -> m i
Net.rx (Interface m InPacket OutPacket -> m InPacket)
-> (Active m -> Interface m InPacket OutPacket)
-> Active m
-> m InPacket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Active m -> Interface m InPacket OutPacket
forall (m :: * -> *). Active m -> Interface m InPacket OutPacket
io

data Interface m
  = Interface {
      forall (m :: * -> *). Interface m -> Port -> m (Passive m)
listen  :: Port -> m (Passive m),
      forall (m :: * -> *). Interface m -> Peer -> m (Maybe (Active m))
connect :: Peer -> m (Maybe (Active m))
    }

--------------------------------------------------------------------------------

data Req m
  = Listen  Port (Passive m->m ())
  | Unlisten Port
  | Connect Peer (Maybe (Active m) ->m ())
  | Disconnect Port Peer -- from connection handling thread
  | FromNetwork TCPPacketIn

data State m = T { forall (m :: * -> *). State m -> Listeners m
listeners::Listeners m, forall (m :: * -> *). State m -> Connections m
connections::Connections m }
type Connections m = Map (Port,Peer) (TCPPacketIn->m ())
type Listeners m = Map Port (Listening m)
type Listening m = (Peer,Active m)->m ()

type TCPPacketIn = TCPPacket InPacket
type TCPPacketOut = TCPPacket OutPacket
type TCPPacket contents = IPv4.Packet (Packet contents)

type TCPIPLink m = Net.Interface m TCPPacketIn TCPPacketOut

{-# NOINLINE initialize #-}
initialize :: ([Char] -> io ())
-> Addr
-> Interface io TCPPacketIn (Packet (Packet OutPacket))
-> io (Interface io)
initialize [Char] -> io ()
putStrLn Addr
myIP Interface io TCPPacketIn (Packet (Packet OutPacket))
iface =
  do c (Req io)
reqChan <- io (c (Req io))
forall a. io (c a)
forall (c :: * -> *) (io :: * -> *) a. ChannelIO c io => io (c a)
newChan
     io () -> io ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (io () -> io ThreadId) -> io () -> io ThreadId
forall a b. (a -> b) -> a -> b
$ io () -> io ()
forall {m :: * -> *} {a} {b}. Monad m => m a -> m b
loop (io () -> io ()) -> io () -> io ()
forall a b. (a -> b) -> a -> b
$ c (Req io) -> Req io -> io ()
forall a. c a -> a -> io ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Req io)
reqChan (Req io -> io ())
-> (TCPPacketIn -> Req io) -> TCPPacketIn -> io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCPPacketIn -> Req io
forall (m :: * -> *). TCPPacketIn -> Req m
FromNetwork (TCPPacketIn -> io ()) -> io TCPPacketIn -> io ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Interface io TCPPacketIn (Packet (Packet OutPacket))
-> io TCPPacketIn
forall (m :: * -> *) i o. Interface m i o -> m i
Net.rx Interface io TCPPacketIn (Packet (Packet OutPacket))
iface
     io () -> io ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (io () -> io ThreadId) -> io () -> io ThreadId
forall a b. (a -> b) -> a -> b
$ ([Char] -> io ())
-> Addr
-> Interface io TCPPacketIn (Packet (Packet OutPacket))
-> c (Req io)
-> io ()
forall {m :: * -> *} {c :: * -> *} {v :: * -> *} {i} {a}.
(ForkIO m, ChannelIO c m, MVarIO v m, DelayIO m) =>
([Char] -> m ())
-> Addr
-> Interface m i (Packet (Packet OutPacket))
-> c (Req m)
-> m a
server [Char] -> io ()
debug Addr
myIP Interface io TCPPacketIn (Packet (Packet OutPacket))
iface c (Req io)
reqChan
     Interface io -> io (Interface io)
forall a. a -> io a
forall (m :: * -> *) a. Monad m => a -> m a
return (Interface io -> io (Interface io))
-> Interface io -> io (Interface io)
forall a b. (a -> b) -> a -> b
$ Interface { listen :: Port -> io (Passive io)
listen = c (Req io) -> ((Passive io -> io ()) -> Req io) -> io (Passive io)
forall {c :: * -> *} {m :: * -> *} {v :: * -> *} {io :: * -> *} {a}
       {b}.
(ChannelIO c m, MVarIO v m, MVarIO v io) =>
c a -> ((b -> io ()) -> a) -> m b
doReq c (Req io)
reqChan (((Passive io -> io ()) -> Req io) -> io (Passive io))
-> (Port -> (Passive io -> io ()) -> Req io)
-> Port
-> io (Passive io)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> (Passive io -> io ()) -> Req io
forall (m :: * -> *). Port -> (Passive m -> m ()) -> Req m
Listen,
			  connect :: Peer -> io (Maybe (Active io))
connect = c (Req io)
-> ((Maybe (Active io) -> io ()) -> Req io)
-> io (Maybe (Active io))
forall {c :: * -> *} {m :: * -> *} {v :: * -> *} {io :: * -> *} {a}
       {b}.
(ChannelIO c m, MVarIO v m, MVarIO v io) =>
c a -> ((b -> io ()) -> a) -> m b
doReq c (Req io)
reqChan (((Maybe (Active io) -> io ()) -> Req io)
 -> io (Maybe (Active io)))
-> (Peer -> (Maybe (Active io) -> io ()) -> Req io)
-> Peer
-> io (Maybe (Active io))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Peer -> (Maybe (Active io) -> io ()) -> Req io
forall (m :: * -> *). Peer -> (Maybe (Active m) -> m ()) -> Req m
Connect
			}
  where
    debug :: [Char] -> io ()
debug = [Char] -> io ()
putStrLn ([Char] -> io ()) -> ([Char] -> [Char]) -> [Char] -> io ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"TCP: "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

server :: ([Char] -> m ())
-> Addr
-> Interface m i (Packet (Packet OutPacket))
-> c (Req m)
-> m a
server [Char] -> m ()
debugIO Addr
myIP Interface m i (Packet (Packet OutPacket))
iface c (Req m)
reqChan =
    (StateT (State m) m a -> State m -> m a)
-> State m -> StateT (State m) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (State m) m a -> State m -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT State m
forall {m :: * -> *}. State m
init (StateT (State m) m a -> m a) -> StateT (State m) m a -> m a
forall a b. (a -> b) -> a -> b
$ StateT (State m) m () -> StateT (State m) m a
forall {m :: * -> *} {a} {b}. Monad m => m a -> m b
loop (Req m -> StateT (State m) m ()
handle(Req m -> StateT (State m) m ())
-> StateT (State m) m (Req m) -> StateT (State m) m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<m (Req m) -> StateT (State m) m (Req m)
forall (m :: * -> *) a. Monad m => m a -> StateT (State m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (c (Req m) -> m (Req m)
forall a. c a -> m a
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> io a
readChan c (Req m)
reqChan))
  where
    -- _ = iface::TCPIPLink

    init :: State m
init = T {listeners :: Listeners m
listeners=Listeners m
forall k a. Map k a
Map.empty, connections :: Connections m
connections=Connections m
forall k a. Map k a
Map.empty}
    debug :: [Char] -> t m ()
debug [Char]
msg = m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Char] -> m ()
debugIO [Char]
msg)

    handle :: Req m -> StateT (State m) m ()
handle Req m
req =
      case Req m
req of
        FromNetwork TCPPacketIn
ipPacket  -> TCPPacketIn -> StateT (State m) m ()
forall {t :: (* -> *) -> * -> *}.
(MonadState (State m) (t m), MonadTrans t) =>
TCPPacketIn -> t m ()
handlePacket TCPPacketIn
ipPacket
        Listen     Port
port Passive m -> m ()
reply -> Port -> (Passive m -> m ()) -> StateT (State m) m ()
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {m :: * -> *} {a}.
(MonadTrans t, MonadState (State m) (t m), ChannelIO c m,
 ChannelIO c m) =>
Port -> (Passive m -> m a) -> t m ()
addListener Port
port Passive m -> m ()
reply
	Connect    Peer
peer Maybe (Active m) -> m ()
reply -> Peer
-> ((Peer, Peer)
    -> ([Char] -> m ())
    -> (InPacket -> m ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m ())
-> StateT (State m) m ()
forall {m :: * -> *} {io :: * -> *} {a}.
(MVarIO v m, ChannelIO c io, ChannelIO c m) =>
Peer
-> ((Peer, Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> StateT (State m) m ()
activate Peer
peer ((Maybe (Active m) -> m ())
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m ()
forall {m :: * -> *} {v :: * -> *} {a}.
(DelayIO m, MVarIO v m) =>
(Maybe a -> m ())
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> a
-> m ()
sendSyn Maybe (Active m) -> m ()
reply)
        Unlisten   Port
port       -> (State m -> State m) -> StateT (State m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> StateT (State m) m ())
-> (State m -> State m) -> StateT (State m) m ()
forall a b. (a -> b) -> a -> b
$ Port -> State m -> State m
forall {m :: * -> *}. Port -> State m -> State m
unlisten Port
port
        Disconnect Port
port Peer
peer  -> (State m -> State m) -> StateT (State m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> StateT (State m) m ())
-> (State m -> State m) -> StateT (State m) m ()
forall a b. (a -> b) -> a -> b
$ (Port, Peer) -> State m -> State m
forall {m :: * -> *}. (Port, Peer) -> State m -> State m
disconnect (Port
port,Peer
peer)

    -- State updates:
    listen :: Port -> Listening m -> State m -> State m
listen   Port
port Listening m
accept s :: State m
s@T{listeners :: forall (m :: * -> *). State m -> Listeners m
listeners=Listeners m
l} = State m
s{listeners=Map.insert port accept l}
    unlisten :: Port -> State m -> State m
unlisten Port
port        s :: State m
s@T{listeners :: forall (m :: * -> *). State m -> Listeners m
listeners=Listeners m
l} = State m
s{listeners=Map.delete port l}
    connect :: (Port, Peer) -> (TCPPacketIn -> m ()) -> State m -> State m
connect    (Port, Peer)
c TCPPacketIn -> m ()
fwd  s :: State m
s@T{connections :: forall (m :: * -> *). State m -> Connections m
connections=Connections m
cs} = State m
s{connections=Map.insert c fwd cs}
    disconnect :: (Port, Peer) -> State m -> State m
disconnect (Port, Peer)
c      s :: State m
s@T{connections :: forall (m :: * -> *). State m -> Connections m
connections=Connections m
cs} = State m
s{connections=Map.delete c cs}

    addListener :: Port -> (Passive m -> m a) -> t m ()
addListener Port
port Passive m -> m a
reply =
      do -- check that port is not already listening
	 c (Peer, Active m)
acceptCh <- m (c (Peer, Active m)) -> t m (c (Peer, Active m))
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (c (Peer, Active m))
forall a. m (c a)
forall (c :: * -> *) (io :: * -> *) a. ChannelIO c io => io (c a)
newChan
	 m a -> t m a
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> t m a) -> m a -> t m a
forall a b. (a -> b) -> a -> b
$
	   Passive m -> m a
reply Passive { accept :: m (Peer, Active m)
accept=c (Peer, Active m) -> m (Peer, Active m)
forall a. c a -> m a
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> io a
readChan c (Peer, Active m)
acceptCh,
			   unlisten :: m ()
unlisten=c (Req m) -> Req m -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Req m)
reqChan (Port -> Req m
forall (m :: * -> *). Port -> Req m
Unlisten Port
port) }
	 let accept :: (Peer, Active m) -> m ()
accept = c (Peer, Active m) -> (Peer, Active m) -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Peer, Active m)
acceptCh
	 (State m -> State m) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> t m ()) -> (State m -> State m) -> t m ()
forall a b. (a -> b) -> a -> b
$ Port -> ((Peer, Active m) -> m ()) -> State m -> State m
forall {m :: * -> *}. Port -> Listening m -> State m -> State m
listen Port
port (Peer, Active m) -> m ()
accept

    handlePacket :: TCPPacketIn -> t m ()
handlePacket TCPPacketIn
ipPacket =
      if TCPPacketIn -> Bool
forall {a}. Unparse a => Packet a -> Bool
okTCPchksum TCPPacketIn
ipPacket
      then TCPPacketIn -> t m ()
forall {t :: (* -> *) -> * -> *}.
(MonadState (State m) (t m), MonadTrans t) =>
TCPPacketIn -> t m ()
handleOkPacket TCPPacketIn
ipPacket
      else [Char] -> t m ()
forall {t :: (* -> *) -> * -> *}. MonadTrans t => [Char] -> t m ()
debug [Char]
"Dropping packet with bad checksum"
    handleOkPacket :: TCPPacketIn -> t m ()
handleOkPacket TCPPacketIn
ipPacket =
      do let packet :: Packet InPacket
packet = TCPPacketIn -> Packet InPacket
forall content. Packet content -> content
IPv4.content TCPPacketIn
ipPacket
	     peer :: Peer
peer = (TCPPacketIn -> Addr
forall content. Packet content -> Addr
IPv4.source TCPPacketIn
ipPacket,Packet InPacket -> Port
forall content. Packet content -> Port
sourcePort Packet InPacket
packet)
	     me :: Peer
me   = (TCPPacketIn -> Addr
forall content. Packet content -> Addr
IPv4.dest TCPPacketIn
ipPacket,Port
port)
	     c :: (Peer, Peer)
c    = (Peer
me,Peer
peer)
	     port :: Port
port = Packet InPacket -> Port
forall content. Packet content -> Port
destPort Packet InPacket
packet
	     CB{ack :: ControlBits -> Bool
ack=Bool
a,syn :: ControlBits -> Bool
syn=Bool
s} = Packet InPacket -> ControlBits
forall content. Packet content -> ControlBits
controlBits Packet InPacket
packet
	     acknr :: Word32
acknr = Packet InPacket -> Word32
forall content. Packet content -> Word32
ackNr Packet InPacket
packet
	     dropit :: t m ()
dropit =
	       [Char] -> t m ()
forall {t :: (* -> *) -> * -> *}. MonadTrans t => [Char] -> t m ()
debug ([Char] -> t m ()) -> [Char] -> t m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Dropped packet from "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Peer -> [Char]
forall a. Show a => a -> [Char]
show Peer
peer [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" to "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Peer -> [Char]
forall a. Show a => a -> [Char]
show Peer
me
			[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++TCPPacketIn -> [Char]
forall a. Show a => a -> [Char]
show TCPPacketIn
ipPacket
	 Maybe (TCPPacketIn -> m ())
optcon <- (State m -> Maybe (TCPPacketIn -> m ()))
-> t m (Maybe (TCPPacketIn -> m ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Port, Peer)
-> Map (Port, Peer) (TCPPacketIn -> m ())
-> Maybe (TCPPacketIn -> m ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Port
port, Peer
peer)(Map (Port, Peer) (TCPPacketIn -> m ())
 -> Maybe (TCPPacketIn -> m ()))
-> (State m -> Map (Port, Peer) (TCPPacketIn -> m ()))
-> State m
-> Maybe (TCPPacketIn -> m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
.State m -> Map (Port, Peer) (TCPPacketIn -> m ())
forall (m :: * -> *). State m -> Connections m
connections)
	 case Maybe (TCPPacketIn -> m ())
optcon of
	   Just TCPPacketIn -> m ()
toConnection -> do --debug $ "Forwarding "++show c
				   m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ TCPPacketIn -> m ()
toConnection TCPPacketIn
ipPacket
	   Maybe (TCPPacketIn -> m ())
_ -> do Maybe (Listening m)
optlistener <- (State m -> Maybe (Listening m)) -> t m (Maybe (Listening m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Port -> Map Port (Listening m) -> Maybe (Listening m)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Port
port (Map Port (Listening m) -> Maybe (Listening m))
-> (State m -> Map Port (Listening m))
-> State m
-> Maybe (Listening m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State m -> Map Port (Listening m)
forall (m :: * -> *). State m -> Listeners m
listeners)
		   case Maybe (Listening m)
optlistener of
		     Just Listening m
listener | Bool
s Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
a ->
		       (Peer, Peer)
-> ((Peer, Peer)
    -> ([Char] -> m ())
    -> (InPacket -> m ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m ())
-> t m ()
forall {m :: * -> *} {m :: * -> *} {t :: (* -> *) -> * -> *} {a}
       {v :: * -> *} {m :: * -> *} {io :: * -> *} {a}.
(DelayIO m, ForkIO m, MonadState (State m) (t m), MonadTrans t,
 Show a, MVarIO v m, MVarIO v m, ChannelIO c m, ChannelIO c io,
 ChannelIO c m, ChannelIO c m) =>
((a, Port), Peer)
-> (((a, Port), Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> t m ()
activate' (Peer, Peer)
c (TCPPacketIn
-> Listening m
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m ()
forall {f :: * -> *} {m :: * -> *} {v :: * -> *} {content} {b} {a}.
(Container f, DelayIO m, MVarIO v m) =>
f (Packet content)
-> ((Peer, b) -> m a)
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> b
-> m ()
synReceived TCPPacketIn
ipPacket Listening m
listener)
		     Maybe (Listening m)
_ | Bool
a -> (Peer, Peer) -> Word32 -> t m ()
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t m)) =>
(Peer, Peer) -> Word32 -> t m ()
reset (Peer, Peer)
c Word32
acknr -- Half-open connection detected
		     Maybe (Listening m)
_ -> t m ()
dropit

    reset :: (Peer, Peer) -> Word32 -> t m ()
reset (Peer, Peer)
c Word32
acknr =
        do let rst :: ControlBits
rst = ControlBits
forall a. Bounded a => a
minBound{rst=True}
	   [Char] -> t m ()
forall {t :: (* -> *) -> * -> *}. MonadTrans t => [Char] -> t m ()
debug ([Char] -> t m ()) -> [Char] -> t m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"RST "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Peer, Peer) -> [Char]
forall a. Show a => a -> [Char]
show (Peer, Peer)
c
	   m () -> t m ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> t m ()) -> m () -> t m ()
forall a b. (a -> b) -> a -> b
$ Interface m i (Packet (Packet OutPacket))
-> Packet (Packet OutPacket) -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m i (Packet (Packet OutPacket))
iface (Packet (Packet OutPacket) -> Packet (Packet OutPacket)
forall {content}.
Unparse content =>
Packet (Packet content) -> Packet (Packet content)
setTCPchksum (()
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
forall {a}.
Unparse a =>
a
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
tcpPacket () ControlBits
rst (Peer, Peer)
c Word32
acknr Word32
0))

    pickPort :: StateT (State m) m Port
pickPort = do T{listeners :: forall (m :: * -> *). State m -> Listeners m
listeners=Map Port (Listening m)
l,connections :: forall (m :: * -> *). State m -> Connections m
connections=Map (Port, Peer) (TCPPacketIn -> m ())
c} <- StateT (State m) m (State m)
forall s (m :: * -> *). MonadState s m => m s
get
		  let inuse :: [Port]
inuse = Map Port (Listening m) -> [Port]
forall k a. Map k a -> [k]
Map.keys Map Port (Listening m)
l[Port] -> [Port] -> [Port]
forall a. [a] -> [a] -> [a]
++((Port, Peer) -> Port) -> [(Port, Peer)] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map (Port, Peer) -> Port
forall a b. (a, b) -> a
fst (Map (Port, Peer) (TCPPacketIn -> m ()) -> [(Port, Peer)]
forall k a. Map k a -> [k]
Map.keys Map (Port, Peer) (TCPPacketIn -> m ())
c) -- duplicates, slow?
		  Port -> StateT (State m) m Port
forall a. a -> StateT (State m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Port -> StateT (State m) m Port)
-> Port -> StateT (State m) m Port
forall a b. (a -> b) -> a -> b
$ [Port] -> Port
forall a. HasCallStack => [a] -> a
head ((Word16 -> Port) -> [Word16] -> [Port]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> Port
Port [Word16
32768..Word16
65535][Port] -> [Port] -> [Port]
forall a. Eq a => [a] -> [a] -> [a]
\\[Port]
inuse)

    activate :: Peer
-> ((Peer, Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> StateT (State m) m ()
activate Peer
peer (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> io ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m a
handler =
	do Port
port <- StateT (State m) m Port
pickPort -- find an unused port
	   let me :: Peer
me = (Addr
myIP,Port
port)
	   (Peer, Peer)
-> ((Peer, Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> StateT (State m) m ()
forall {m :: * -> *} {m :: * -> *} {t :: (* -> *) -> * -> *} {a}
       {v :: * -> *} {m :: * -> *} {io :: * -> *} {a}.
(DelayIO m, ForkIO m, MonadState (State m) (t m), MonadTrans t,
 Show a, MVarIO v m, MVarIO v m, ChannelIO c m, ChannelIO c io,
 ChannelIO c m, ChannelIO c m) =>
((a, Port), Peer)
-> (((a, Port), Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> t m ()
activate' (Peer
me,Peer
peer) (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> io ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m a
handler

    activate' :: ((a, Port), Peer)
-> (((a, Port), Peer)
    -> ([Char] -> m ())
    -> (InPacket -> io ())
    -> Interface m ConReq (Packet (Packet OutPacket))
    -> v ()
    -> Active m
    -> m a)
-> t m ()
activate' c :: ((a, Port), Peer)
c@(me :: (a, Port)
me@(a
_,Port
port),Peer
peer) ((a, Port), Peer)
-> ([Char] -> m ())
-> (InPacket -> io ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m a
handler =
        do c ConReq
outCh <- m (c ConReq) -> t m (c ConReq)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (c ConReq)
forall a. m (c a)
forall (c :: * -> *) (io :: * -> *) a. ChannelIO c io => io (c a)
newChan -- packets from client to connection
	   c InPacket
inCh <- m (c InPacket) -> t m (c InPacket)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (c InPacket)
forall a. m (c a)
forall (c :: * -> *) (io :: * -> *) a. ChannelIO c io => io (c a)
newChan -- packets from connection to client
	   v ()
flowctl <- m (v ()) -> t m (v ())
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (v ()) -> t m (v ())) -> m (v ()) -> t m (v ())
forall a b. (a -> b) -> a -> b
$ () -> m (v ())
forall a. a -> m (v a)
forall (v :: * -> *) (io :: * -> *) a. MVarIO v io => a -> io (v a)
newMVar () -- for client output flow control
           let cdebug :: [Char] -> m ()
cdebug [Char]
msg = [Char] -> m ()
debugIO ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ (a, Port) -> [Char]
forall a. Show a => a -> [Char]
show (a, Port)
me[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"<->"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Peer -> [Char]
forall a. Show a => a -> [Char]
show Peer
peer[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n    "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
msg
	       forward :: TCPPacketIn -> m ()
forward = c ConReq -> ConReq -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c ConReq
outCh (ConReq -> m ()) -> (TCPPacketIn -> ConReq) -> TCPPacketIn -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCPPacketIn -> ConReq
ConFromNetwork
	   (State m -> State m) -> t m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State m -> State m) -> t m ()) -> (State m -> State m) -> t m ()
forall a b. (a -> b) -> a -> b
$ (Port, Peer) -> (TCPPacketIn -> m ()) -> State m -> State m
forall {m :: * -> *}.
(Port, Peer) -> (TCPPacketIn -> m ()) -> State m -> State m
connect (Port
port,Peer
peer) TCPPacketIn -> m ()
forward
           let io :: Interface m ConReq (Packet (Packet OutPacket))
io = Net.Interface { rx :: m ConReq
Net.rx=c ConReq -> m ConReq
forall a. c a -> m a
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> io a
readChan c ConReq
outCh,
				    tx :: Packet (Packet OutPacket) -> m ()
Net.tx=Interface m i (Packet (Packet OutPacket))
-> Packet (Packet OutPacket) -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m i (Packet (Packet OutPacket))
iface (Packet (Packet OutPacket) -> m ())
-> (Packet (Packet OutPacket) -> Packet (Packet OutPacket))
-> Packet (Packet OutPacket)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Packet (Packet OutPacket) -> Packet (Packet OutPacket)
forall {content}.
Unparse content =>
Packet (Packet content) -> Packet (Packet content)
setTCPchksum }
	       active :: Active m
active = Active { close :: m ()
close=c ConReq -> ConReq -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c ConReq
outCh ConReq
Close,
				 io :: Interface m InPacket OutPacket
io=Net.Interface {
				      rx :: m InPacket
Net.rx=c InPacket -> m InPacket
forall a. c a -> m a
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> io a
readChan c InPacket
inCh,
				      tx :: OutPacket -> m ()
Net.tx=OutPacket -> m ()
forall {m :: * -> *}.
(MVarIO v m, ChannelIO c m) =>
OutPacket -> m ()
tx}}
                 where tx :: OutPacket -> m ()
tx OutPacket
p = do --debugIO $ "takeMVar flowctl "++show (outLen p)
                                 v () -> m ()
forall a. v a -> m a
forall (v :: * -> *) (io :: * -> *) a. MVarIO v io => v a -> io a
takeMVar v ()
flowctl
				 c ConReq -> ConReq -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c ConReq
outCh (OutPacket -> ConReq
ConTx OutPacket
p)
				 --debugIO $ "tookMvar flowctl"
	   m ThreadId -> t m ThreadId
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m ThreadId -> t m ThreadId) -> m ThreadId -> t m ThreadId
forall a b. (a -> b) -> a -> b
$ m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$
             do ThreadId
t <- m () -> m ThreadId
forall (io :: * -> *). ForkIO io => io () -> io ThreadId
fork (m () -> m ThreadId) -> m () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ (Int -> m ()) -> m ()
forall {m :: * -> *} {t} {a} {b}.
(DelayIO m, Num t) =>
(t -> m a) -> m b
timer (c ConReq -> ConReq -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c ConReq
outCh (ConReq -> m ()) -> (Int -> ConReq) -> Int -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ConReq
Tick)
                ((a, Port), Peer)
-> ([Char] -> m ())
-> (InPacket -> io ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> Active m
-> m a
handler ((a, Port), Peer)
c [Char] -> m ()
cdebug (c InPacket -> InPacket -> io ()
forall a. c a -> a -> io ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c InPacket
inCh)  Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl Active m
active
		ThreadId -> m ()
forall (io :: * -> *). ForkIO io => ThreadId -> io ()
kill ThreadId
t
                c (Req m) -> Req m -> m ()
forall a. c a -> a -> m ()
forall (c :: * -> *) (io :: * -> *) a.
ChannelIO c io =>
c a -> a -> io ()
writeChan c (Req m)
reqChan (Port -> Peer -> Req m
forall (m :: * -> *). Port -> Peer -> Req m
Disconnect Port
port Peer
peer)
           () -> t m ()
forall a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

--------------------------------------------------------------------------------
synReceived :: f (Packet content)
-> ((Peer, b) -> m a)
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> b
-> m ()
synReceived f (Packet content)
ipPacket (Peer, b) -> m a
reply c :: (Peer, Peer)
c@(Peer
_,Peer
peer) [Char] -> m ()
debug InPacket -> m ()
deliver Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl b
active =
    do --debug $ "SYN received " ++show rxSeqNr
       let synackP :: Packet (Packet OutPacket)
synackP = (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
synackPacket (Peer, Peer)
c Word32
txSeqNr (Word32
rxSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1)
       --debug $ "Sending SYN ACK " ++show txSeqNr++" "++show (rxSeqNr+1)
       m () -> (TCPPacketIn -> m ()) -> Maybe TCPPacketIn -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
forall (m :: * -> *). Monad m => m ()
done TCPPacketIn -> m ()
forall {f :: * -> *} {f :: * -> *}.
(Container f, Container f) =>
f (f InPacket) -> m ()
gotAck (Maybe TCPPacketIn -> m ()) -> m (Maybe TCPPacketIn) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Packet (Packet OutPacket) -> m (Maybe TCPPacketIn)
waitForAck Packet (Packet OutPacket)
synackP
  where
    gotAck :: f (f InPacket) -> m ()
gotAck f (f InPacket)
ip =
      do --debug $ "Got ACK, connection is established"
	 (Peer, b) -> m a
reply (Peer
peer,b
active) -- not until connection is established
	 let tcp :: f InPacket
tcp = f (f InPacket) -> f InPacket
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (f InPacket)
ip
	     dat :: InPacket
dat = f InPacket -> InPacket
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f InPacket
tcp
	     l :: Word32
l = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (InPacket -> Int
len InPacket
dat)
	 Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
lWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>Word32
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do [Char] -> m ()
debug ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ACK and delever initial bytes "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
l
			 Interface m ConReq (Packet (Packet OutPacket))
-> Packet (Packet OutPacket) -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m ConReq (Packet (Packet OutPacket))
io ((Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
ackPacket (Peer, Peer)
c (Word32
txSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1) (Word32
rxSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
l))
			 InPacket -> m ()
deliver InPacket
dat
	 (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> (Word32, Word32, Word16)
-> m ()
forall {a} {m :: * -> *} {v :: * -> *}.
(Show a, DelayIO m, MVarIO v m, Integral a) =>
(Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> (Word32, Word32, a)
-> m ()
established (Peer, Peer)
c [Char] -> m ()
debug InPacket -> m ()
deliver Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl (Word32
rxSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
l,Word32
txSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1,Word16
txWindow)

    tcp :: Packet content
tcp = f (Packet content) -> Packet content
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (Packet content)
ipPacket
    rxSeqNr :: Word32
rxSeqNr = Packet content -> Word32
forall content. Packet content -> Word32
seqNr Packet content
tcp
    txWindow :: Word16
txWindow = Packet content -> Word16
forall content. Packet content -> Word16
window Packet content
tcp
    txSeqNr :: Word32
txSeqNr = Word32
10000000 -- should be chosen randomly!!!

    waitForAck :: Packet (Packet OutPacket) -> m (Maybe TCPPacketIn)
waitForAck Packet (Packet OutPacket)
synackP = ([Char] -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> Packet (Packet OutPacket)
-> (TCPPacketIn -> Maybe TCPPacketIn)
-> m (Maybe TCPPacketIn)
forall {m :: * -> *} {a} {o} {a}.
Monad m =>
([Char] -> m a)
-> Interface m ConReq o
-> o
-> (TCPPacketIn -> Maybe a)
-> m (Maybe a)
solicitPacket [Char] -> m ()
debug Interface m ConReq (Packet (Packet OutPacket))
io Packet (Packet OutPacket)
synackP TCPPacketIn -> Maybe TCPPacketIn
forall {f :: * -> *} {content}.
Container f =>
f (Packet content) -> Maybe (f (Packet content))
expected
      where
        expected :: f (Packet content) -> Maybe (f (Packet content))
expected f (Packet content)
p = if ControlBits
cbControlBits -> ControlBits -> Bool
forall a. Eq a => a -> a -> Bool
==ControlBits
forall a. Bounded a => a
minBound{ack=True} Bool -> Bool -> Bool
&&
		        Packet content -> Word32
forall content. Packet content -> Word32
ackNr Packet content
tcpWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
txSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1 Bool -> Bool -> Bool
&& Packet content -> Word32
forall content. Packet content -> Word32
seqNr Packet content
tcpWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
rxSeqNrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1
		     then f (Packet content) -> Maybe (f (Packet content))
forall a. a -> Maybe a
Just f (Packet content)
p
		     else Maybe (f (Packet content))
forall a. Maybe a
Nothing
	  where tcp :: Packet content
tcp = f (Packet content) -> Packet content
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (Packet content)
p
		cb :: ControlBits
cb = Packet content -> ControlBits
forall content. Packet content -> ControlBits
controlBits Packet content
tcp
--------------------------------------------------------------------------------

solicitPacket :: ([Char] -> m a)
-> Interface m ConReq o
-> o
-> (TCPPacketIn -> Maybe a)
-> m (Maybe a)
solicitPacket [Char] -> m a
debug Interface m ConReq o
io o
request TCPPacketIn -> Maybe a
expected = Integer -> Int -> m (Maybe a)
forall {t}. (Eq t, Num t) => t -> Int -> m (Maybe a)
loop Integer
3 Int
0
  where
    loop :: t -> Int -> m (Maybe a)
loop t
0 Int
_ = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    loop t
retries Int
0 =
      do [Char] -> m a
debug [Char]
"Retrying"
         Interface m ConReq o -> o -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m ConReq o
io o
request
	 t -> Int -> m (Maybe a)
loop (t
retriest -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
ticksPerSecond)
    loop t
retries Int
t =
      do ConReq
r <- Interface m ConReq o -> m ConReq
forall (m :: * -> *) i o. Interface m i o -> m i
Net.rx Interface m ConReq o
io
	 case ConReq
r of
	   Tick Int
_ -> t -> Int -> m (Maybe a)
loop t
retries (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
	   ConFromNetwork TCPPacketIn
p -> case TCPPacketIn -> Maybe a
expected TCPPacketIn
p of
			         Just a
r -> Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
r)
				 Maybe a
_ -> t -> Int -> m (Maybe a)
loop t
retries Int
t
	   ConReq
_ -> t -> Int -> m (Maybe a)
loop t
retries Int
t

--------------------------------------------------------------------------------
sendSyn :: (Maybe a -> m ())
-> (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> a
-> m ()
sendSyn Maybe a -> m ()
reply (Peer, Peer)
c [Char] -> m ()
debug InPacket -> m ()
deliver Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl a
active =
    do let synP :: Packet (Packet OutPacket)
synP = (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
synPacket (Peer, Peer)
c Word32
iss Word32
0
       --debug "Sent SYN, waiting for SYN ACK"
       m ()
-> ((Word32, Word16) -> m ()) -> Maybe (Word32, Word16) -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
noreply (Word32, Word16) -> m ()
forall {a}. (Show a, Integral a) => (Word32, a) -> m ()
gotAck (Maybe (Word32, Word16) -> m ())
-> m (Maybe (Word32, Word16)) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Packet (Packet OutPacket) -> m (Maybe (Word32, Word16))
waitForAck Packet (Packet OutPacket)
synP
  where
    iss :: Word32
iss = Word32
20000000 -- Initial Send Sequence number, should be chosen randomly!!!

    noreply :: m ()
noreply = Maybe a -> m ()
reply Maybe a
forall a. Maybe a
Nothing

    gotAck :: (Word32, a) -> m ()
gotAck (Word32
irs,a
txWindow) =
      do --debug $ "Got SYN ACK, sending ACK, IRS="++show irs
         Interface m ConReq (Packet (Packet OutPacket))
-> Packet (Packet OutPacket) -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m ConReq (Packet (Packet OutPacket))
io ((Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
ackPacket (Peer, Peer)
c (Word32
issWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1) (Word32
irsWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1))
         Maybe a -> m ()
reply (a -> Maybe a
forall a. a -> Maybe a
Just a
active)
         (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> (Word32, Word32, a)
-> m ()
forall {a} {m :: * -> *} {v :: * -> *}.
(Show a, DelayIO m, MVarIO v m, Integral a) =>
(Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> (Word32, Word32, a)
-> m ()
established (Peer, Peer)
c [Char] -> m ()
debug InPacket -> m ()
deliver Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl (Word32
irsWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1,Word32
issWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1,a
txWindow)

    waitForAck :: Packet (Packet OutPacket) -> m (Maybe (Word32, Word16))
waitForAck Packet (Packet OutPacket)
synP = ([Char] -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> Packet (Packet OutPacket)
-> (TCPPacketIn -> Maybe (Word32, Word16))
-> m (Maybe (Word32, Word16))
forall {m :: * -> *} {a} {o} {a}.
Monad m =>
([Char] -> m a)
-> Interface m ConReq o
-> o
-> (TCPPacketIn -> Maybe a)
-> m (Maybe a)
solicitPacket [Char] -> m ()
debug Interface m ConReq (Packet (Packet OutPacket))
io Packet (Packet OutPacket)
synP TCPPacketIn -> Maybe (Word32, Word16)
forall {f :: * -> *} {content}.
Container f =>
f (Packet content) -> Maybe (Word32, Word16)
expected
      where
        expected :: f (Packet content) -> Maybe (Word32, Word16)
expected f (Packet content)
p =
	  let tcp :: Packet content
tcp = f (Packet content) -> Packet content
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (Packet content)
p
	      cb :: ControlBits
cb = Packet content -> ControlBits
forall content. Packet content -> ControlBits
controlBits Packet content
tcp
	  in if ControlBits
cbControlBits -> ControlBits -> Bool
forall a. Eq a => a -> a -> Bool
==ControlBits
forall a. Bounded a => a
minBound{ack=True,syn=True} Bool -> Bool -> Bool
&& Packet content -> Word32
forall content. Packet content -> Word32
ackNr Packet content
tcpWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
issWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1
	     then (Word32, Word16) -> Maybe (Word32, Word16)
forall a. a -> Maybe a
Just (Packet content -> Word32
forall content. Packet content -> Word32
seqNr Packet content
tcp,Packet content -> Word16
forall content. Packet content -> Word16
window Packet content
tcp)
	     else Maybe (Word32, Word16)
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
dataPacket :: a -> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
dataPacket a
dat = a
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
forall {a}.
Unparse a =>
a
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
tcpPacket a
dat ControlBits
forall a. Bounded a => a
minBound{ack=True}
ackPacket :: (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
ackPacket      = () -> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
forall {a}.
Unparse a =>
a -> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
dataPacket ()
finPacket :: (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
finPacket      = ControlBits
-> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
emptyPacket ControlBits
forall a. Bounded a => a
minBound{ack=True,fin=True}
synPacket :: (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
synPacket   = ControlBits
-> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
emptyPacket ControlBits
forall a. Bounded a => a
minBound{syn=True}
synackPacket :: (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
synackPacket   = ControlBits
-> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
emptyPacket ControlBits
forall a. Bounded a => a
minBound{syn=True,ack=True}
emptyPacket :: ControlBits
-> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
emptyPacket    = ()
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
forall {a}.
Unparse a =>
a
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
tcpPacket ()

tcpPacket :: a
-> ControlBits
-> (Peer, Peer)
-> Word32
-> Word32
-> Packet (Packet OutPacket)
tcpPacket a
dat ControlBits
cb ((Addr
myIP,Port
myPort),(Addr
peerIP,Port
peerPort)) Word32
seqnr Word32
acknr =
    Packet OutPacket -> Packet (Packet OutPacket)
forall {content}. content -> Packet content
iptemplate Packet ()
tcp{content=doUnparse dat}
  where
    tcp :: Packet ()
tcp = Packet ()
template{sourcePort=myPort,destPort=peerPort,
		   ackNr=acknr,seqNr=seqnr,controlBits=cb}

    iptemplate :: content -> Packet content
iptemplate = Protocol -> Addr -> Addr -> content -> Packet content
forall {content}.
Protocol -> Addr -> Addr -> content -> Packet content
IPv4.template Protocol
IPv4.TCP Addr
myIP Addr
peerIP

--------------------------------------------------------------------------------

-- Requests to connection handling thread:
data ConReq = Close
	    | ConTx OutPacket
	    | ConFromNetwork TCPPacketIn
            | Tick Int

data ConState = S { ConState -> Phase
phase::Phase,
		    ConState -> Int
now,ConState -> Int
roundTripTime::Int,
		    ConState -> [(Word32, Int, OutPacket)]
unackedData::[(Word32,Int,OutPacket)],
		    ConState -> OutPacket
unsentData::OutPacket,
		    ConState -> Word32
txUnacked,ConState -> Word32
txSeq,ConState -> Word32
txWindow,ConState -> Word32
rxSeq,ConState -> Word32
rxWindow::Word32 }
data Phase = Established | CloseWait
	   | Closing | FinWait1 | FinWait2 | LastAck
	   | TimeWait | Closed
	   deriving (Phase -> Phase -> Bool
(Phase -> Phase -> Bool) -> (Phase -> Phase -> Bool) -> Eq Phase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Phase -> Phase -> Bool
== :: Phase -> Phase -> Bool
$c/= :: Phase -> Phase -> Bool
/= :: Phase -> Phase -> Bool
Eq,Eq Phase
Eq Phase =>
(Phase -> Phase -> Ordering)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Bool)
-> (Phase -> Phase -> Phase)
-> (Phase -> Phase -> Phase)
-> Ord Phase
Phase -> Phase -> Bool
Phase -> Phase -> Ordering
Phase -> Phase -> Phase
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Phase -> Phase -> Ordering
compare :: Phase -> Phase -> Ordering
$c< :: Phase -> Phase -> Bool
< :: Phase -> Phase -> Bool
$c<= :: Phase -> Phase -> Bool
<= :: Phase -> Phase -> Bool
$c> :: Phase -> Phase -> Bool
> :: Phase -> Phase -> Bool
$c>= :: Phase -> Phase -> Bool
>= :: Phase -> Phase -> Bool
$cmax :: Phase -> Phase -> Phase
max :: Phase -> Phase -> Phase
$cmin :: Phase -> Phase -> Phase
min :: Phase -> Phase -> Phase
Ord,Int -> Phase -> [Char] -> [Char]
[Phase] -> [Char] -> [Char]
Phase -> [Char]
(Int -> Phase -> [Char] -> [Char])
-> (Phase -> [Char]) -> ([Phase] -> [Char] -> [Char]) -> Show Phase
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Phase -> [Char] -> [Char]
showsPrec :: Int -> Phase -> [Char] -> [Char]
$cshow :: Phase -> [Char]
show :: Phase -> [Char]
$cshowList :: [Phase] -> [Char] -> [Char]
showList :: [Phase] -> [Char] -> [Char]
Show)

conReq :: p
-> (OutPacket -> p)
-> (TCPPacketIn -> p)
-> (Int -> p)
-> ConReq
-> p
conReq p
disc OutPacket -> p
tx TCPPacketIn -> p
rx Int -> p
tick ConReq
req =
  case ConReq
req of
    ConReq
Close -> p
disc
    ConTx OutPacket
p -> OutPacket -> p
tx OutPacket
p
    ConFromNetwork TCPPacketIn
p -> TCPPacketIn -> p
rx TCPPacketIn
p
    Tick Int
t -> Int -> p
tick Int
t

ticksPerSecond :: Int
ticksPerSecond=Int
10

timer :: (t -> m a) -> m b
timer t -> m a
m = t -> m b
forall {b}. t -> m b
loop t
0
  where
    loop :: t -> m b
loop t
t = do Int -> m ()
forall (io :: * -> *). DelayIO io => Int -> io ()
delay Int
us
		t -> m a
m t
t
		t -> m b
loop (t
tt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
    us :: Int
us = Int
1000000 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
ticksPerSecond

established :: (Peer, Peer)
-> ([Char] -> m ())
-> (InPacket -> m ())
-> Interface m ConReq (Packet (Packet OutPacket))
-> v ()
-> (Word32, Word32, a)
-> m ()
established (Peer, Peer)
c [Char] -> m ()
debugIO InPacket -> m ()
deliver Interface m ConReq (Packet (Packet OutPacket))
io v ()
flowctl (Word32
rxseq,Word32
txseq,a
txwin) =
    (StateT ConState m () -> ConState -> m ())
-> ConState -> StateT ConState m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ConState m () -> ConState -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ConState
state0 (StateT ConState m () -> m ()) -> StateT ConState m () -> m ()
forall a b. (a -> b) -> a -> b
$
       do [Char] -> StateT ConState m ()
debug ([Char] -> StateT ConState m ()) -> [Char] -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Transmit window = "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++a -> [Char]
forall a. Show a => a -> [Char]
show a
txwin
          StateT ConState m Bool
-> StateT ConState m () -> StateT ConState m ()
forall {m :: * -> *} {a}. Monad m => m Bool -> m a -> m ()
whileM ((Phase -> Phase -> Bool
forall a. Ord a => a -> a -> Bool
<Phase
TimeWait) (Phase -> Bool)
-> StateT ConState m Phase -> StateT ConState m Bool
forall {f :: * -> *} {a} {b}. Functor f => (a -> b) -> f a -> f b
# (ConState -> Phase) -> StateT ConState m Phase
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Phase
phase) (ConReq -> StateT ConState m ()
handle(ConReq -> StateT ConState m ())
-> StateT ConState m ConReq -> StateT ConState m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<StateT ConState m ConReq
rx)
	  Phase
p <- (ConState -> Phase) -> StateT ConState m Phase
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Phase
phase
	  --when (p==TimeWait) $ do debug "Waiting"
	  Int -> StateT ConState m ()
forall (io :: * -> *). DelayIO io => Int -> io ()
delay Int
30000000 -- wait 30 seconds before reusing the same port number
	  --debug "Closed"
  where
    handle :: ConReq -> StateT ConState m ()
handle = StateT ConState m ()
-> (OutPacket -> StateT ConState m ())
-> (TCPPacketIn -> StateT ConState m ())
-> (Int -> StateT ConState m ())
-> ConReq
-> StateT ConState m ()
forall {p}.
p
-> (OutPacket -> p)
-> (TCPPacketIn -> p)
-> (Int -> p)
-> ConReq
-> p
conReq StateT ConState m ()
close OutPacket -> StateT ConState m ()
conTx TCPPacketIn -> StateT ConState m ()
forall {f :: * -> *}.
Container f =>
f (Packet InPacket) -> StateT ConState m ()
conRx Int -> StateT ConState m ()
tick

    state0 :: ConState
state0 = S {phase :: Phase
phase=Phase
Established,
		now :: Int
now=Int
0,
		roundTripTime :: Int
roundTripTime=Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
ticksPerSecond, -- Use 3s as the intitial RTT
		unackedData :: [(Word32, Int, OutPacket)]
unackedData=[],
		unsentData :: OutPacket
unsentData=OutPacket
emptyOutPack,
		txUnacked :: Word32
txUnacked=Word32
txseq,
		txSeq :: Word32
txSeq=Word32
txseq,
		txWindow :: Word32
txWindow=a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
txwin,
		rxSeq :: Word32
rxSeq=Word32
rxseq,
		rxWindow :: Word32
rxWindow=Word32
1400}

    fakeMSS :: Int
fakeMSS = Int
512 -- !!! maximum segment size

    debug :: [Char] -> StateT ConState m ()
debug = m () -> StateT ConState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT ConState m ())
-> ([Char] -> m ()) -> [Char] -> StateT ConState m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> m ()
debugIO
    rx :: StateT ConState m ConReq
rx = m ConReq -> StateT ConState m ConReq
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Interface m ConReq (Packet (Packet OutPacket)) -> m ConReq
forall (m :: * -> *) i o. Interface m i o -> m i
Net.rx Interface m ConReq (Packet (Packet OutPacket))
io)
    tx :: Packet (Packet OutPacket) -> StateT ConState m ()
tx = m () -> StateT ConState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT ConState m ())
-> (Packet (Packet OutPacket) -> m ())
-> Packet (Packet OutPacket)
-> StateT ConState m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface m ConReq (Packet (Packet OutPacket))
-> Packet (Packet OutPacket) -> m ()
forall (m :: * -> *) i o. Interface m i o -> o -> m ()
Net.tx Interface m ConReq (Packet (Packet OutPacket))
io

    acknowledge :: Word32 -> StateT ConState m ()
acknowledge Word32
acknr =
	do s :: ConState
s@S{txSeq :: ConState -> Word32
txSeq=Word32
seq} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	   Packet (Packet OutPacket) -> StateT ConState m ()
tx ((Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
ackPacket (Peer, Peer)
c Word32
seq Word32
acknr)
	   ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{rxSeq=acknr}

    sendData :: OutPacket -> StateT ConState m ()
sendData OutPacket
dat =
        do s :: ConState
s@S{txSeq :: ConState -> Word32
txSeq=Word32
seq,now :: ConState -> Int
now=Int
t,unackedData :: ConState -> [(Word32, Int, OutPacket)]
unackedData=[(Word32, Int, OutPacket)]
ps} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	   let l :: Word32
l=Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutPacket -> Int
outLen OutPacket
dat)
	   Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
lWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>Word32
0) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$
	       do OutPacket -> Word32 -> StateT ConState m ()
forall {a}. Unparse a => a -> Word32 -> StateT ConState m ()
sendData' OutPacket
dat Word32
seq
                  ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{txSeq=seq+l,unackedData=ps++[(seq,t,dat)]}
	          --debug $ "Sent "++show l++" bytes upto "++show (seq+l)
    sendData' :: a -> Word32 -> StateT ConState m ()
sendData' a
dat Word32
seq = Packet (Packet OutPacket) -> StateT ConState m ()
tx (Packet (Packet OutPacket) -> StateT ConState m ())
-> (Word32 -> Packet (Packet OutPacket))
-> Word32
-> StateT ConState m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
forall {a}.
Unparse a =>
a -> (Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
dataPacket a
dat (Peer, Peer)
c Word32
seq (Word32 -> StateT ConState m ())
-> StateT ConState m Word32 -> StateT ConState m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ConState -> Word32) -> StateT ConState m Word32
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Word32
rxSeq

    trySendData :: StateT ConState m ()
trySendData =
        do S{txSeq :: ConState -> Word32
txSeq=Word32
seq,txUnacked :: ConState -> Word32
txUnacked=Word32
unacked,txWindow :: ConState -> Word32
txWindow=Word32
win} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	   Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
seqWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
unackedWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<Word32
win) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$
             do let n :: Int
n=Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
unackedWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
winWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
seq)
		OutPacket -> StateT ConState m ()
sendData (OutPacket -> StateT ConState m ())
-> StateT ConState m OutPacket -> StateT ConState m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> StateT ConState m OutPacket
unqueueData Int
n

    queueData :: OutPacket -> StateT ConState m ()
queueData OutPacket
p =
	do --debug $ "Adding "++show (outLen p)++" bytes to transmit queue"
	   s :: ConState
s@S{unsentData :: ConState -> OutPacket
unsentData=OutPacket
old,txWindow :: ConState -> Word32
txWindow=Word32
win} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	   let new :: OutPacket
new=OutPacket -> OutPacket -> OutPacket
appendOutPack OutPacket
old OutPacket
p
           ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{unsentData=new}
	   -- Allow client to queue more output?
	   if OutPacket -> Word32
outLen' OutPacket
newWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<Word32
win
	      then do --debug "Unblocking client..."
		      v () -> () -> StateT ConState m ()
forall a. v a -> a -> StateT ConState m ()
forall (v :: * -> *) (io :: * -> *) a.
MVarIO v io =>
v a -> a -> io ()
putMVar v ()
flowctl ()
		      --debug "Unblocked client"
	      else [Char] -> StateT ConState m ()
debug [Char]
"Leaving client blocked"

    outLen' :: OutPacket -> Word32
outLen' = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (OutPacket -> Int) -> OutPacket -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutPacket -> Int
outLen

    unqueueData :: Int -> StateT ConState m OutPacket
unqueueData Int
n =
	do s :: ConState
s@S{unsentData :: ConState -> OutPacket
unsentData=OutPacket
old,txWindow :: ConState -> Word32
txWindow=Word32
win} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
           let (OutPacket
p1,OutPacket
p2) = Int -> OutPacket -> (OutPacket, OutPacket)
splitOutPack (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
fakeMSS Int
n) OutPacket
old
           ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{unsentData=p2}
	   let l :: Word32
l = OutPacket -> Word32
outLen' OutPacket
p1
               q :: Word32
q = OutPacket -> Word32
outLen' OutPacket
p2
           -- Allow client to queue more output:
           --{-
	   Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutPacket -> Word32
outLen' OutPacket
oldWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>=Word32
win Bool -> Bool -> Bool
&& Word32
qWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<Word32
win) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$
		do [Char] -> StateT ConState m ()
debug [Char]
"(Delayed) unblocking client..."
		   v () -> () -> StateT ConState m ()
forall a. v a -> a -> StateT ConState m ()
forall (v :: * -> *) (io :: * -> *) a.
MVarIO v io =>
v a -> a -> io ()
putMVar v ()
flowctl ()
		   [Char] -> StateT ConState m ()
debug [Char]
"(Delayed) unblocked client"

           --}
           {-
	   when (l>0 || q>0) $
		debug $ "Sending "++show l++" bytes, "
			  ++show q++ " bytes left in transmit queue"
           --}
	   OutPacket -> StateT ConState m OutPacket
forall a. a -> StateT ConState m a
forall (m :: * -> *) a. Monad m => a -> m a
return OutPacket
p1

    sendFin :: StateT ConState m ()
sendFin =
	do s :: ConState
s@S{txSeq :: ConState -> Word32
txSeq=Word32
seq,rxSeq :: ConState -> Word32
rxSeq=Word32
ack} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	   Packet (Packet OutPacket) -> StateT ConState m ()
tx ((Peer, Peer) -> Word32 -> Word32 -> Packet (Packet OutPacket)
finPacket (Peer, Peer)
c Word32
seq Word32
ack)
	   ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{txSeq=seq+1}

    goto :: Phase -> m ()
goto Phase
p = do (ConState -> ConState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConState -> ConState) -> m ()) -> (ConState -> ConState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ ConState
s -> ConState
s{phase=p}
		--debug $ "Go to state "++show p

    -- Some time has passed:
    tick :: Int -> StateT ConState m ()
tick Int
now =
      do Int
rtt <- (ConState -> Int) -> StateT ConState m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Int
roundTripTime
         ([(Word32, Int, OutPacket)]
ps',Bool
timeout) <-
            (StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)]
 -> Bool -> StateT ConState m ([(Word32, Int, OutPacket)], Bool))
-> Bool
-> StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)]
-> StateT ConState m ([(Word32, Int, OutPacket)], Bool)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)]
-> Bool -> StateT ConState m ([(Word32, Int, OutPacket)], Bool)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT Bool
False (StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)]
 -> StateT ConState m ([(Word32, Int, OutPacket)], Bool))
-> ([(Word32, Int, OutPacket)]
    -> StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)])
-> [(Word32, Int, OutPacket)]
-> StateT ConState m ([(Word32, Int, OutPacket)], Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word32, Int, OutPacket)
 -> StateT Bool (StateT ConState m) (Word32, Int, OutPacket))
-> [(Word32, Int, OutPacket)]
-> StateT Bool (StateT ConState m) [(Word32, Int, OutPacket)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int
-> (Word32, Int, OutPacket)
-> StateT Bool (StateT ConState m) (Word32, Int, OutPacket)
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, MonadState Bool (t (StateT ConState m))) =>
Int
-> (Word32, Int, OutPacket)
-> t (StateT ConState m) (Word32, Int, OutPacket)
retransmit Int
rtt) ([(Word32, Int, OutPacket)]
 -> StateT ConState m ([(Word32, Int, OutPacket)], Bool))
-> StateT ConState m [(Word32, Int, OutPacket)]
-> StateT ConState m ([(Word32, Int, OutPacket)], Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (ConState -> [(Word32, Int, OutPacket)])
-> StateT ConState m [(Word32, Int, OutPacket)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> [(Word32, Int, OutPacket)]
unackedData
	 Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
timeout (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ (ConState -> ConState) -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConState -> ConState) -> StateT ConState m ())
-> (ConState -> ConState) -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ \ ConState
s -> ConState
s{roundTripTime=backoff rtt}
	 (ConState -> ConState) -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConState -> ConState) -> StateT ConState m ())
-> (ConState -> ConState) -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ \ ConState
s -> ConState
s{now=now,unackedData=ps'}
      where
         backoff :: Int -> Int
backoff Int
rtt = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
5Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
ticksPerSecond) (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*(Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 Int
rtt))

         retransmit :: Int
-> (Word32, Int, OutPacket)
-> t (StateT ConState m) (Word32, Int, OutPacket)
retransmit Int
rtt p :: (Word32, Int, OutPacket)
p@(Word32
seq,Int
t,OutPacket
buf) =
	     if Int
nowInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
rtt
	     then do StateT ConState m () -> t (StateT ConState m) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ConState m () -> t (StateT ConState m) ())
-> StateT ConState m () -> t (StateT ConState m) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StateT ConState m ()
debug ([Char] -> StateT ConState m ()) -> [Char] -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Retransmitting seqNr "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
seq
                                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" len "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show (OutPacket -> Int
outLen OutPacket
buf)
                                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" after "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Int -> [Char]
forall a. Show a => a -> [Char]
show(Int
nowInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t)[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" ticks"
                     StateT ConState m () -> t (StateT ConState m) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ConState m () -> t (StateT ConState m) ())
-> StateT ConState m () -> t (StateT ConState m) ()
forall a b. (a -> b) -> a -> b
$ OutPacket -> Word32 -> StateT ConState m ()
forall {a}. Unparse a => a -> Word32 -> StateT ConState m ()
sendData' OutPacket
buf Word32
seq
		     Bool -> t (StateT ConState m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Bool
True
		     (Word32, Int, OutPacket)
-> t (StateT ConState m) (Word32, Int, OutPacket)
forall a. a -> t (StateT ConState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32
seq,Int
now,OutPacket
buf)
	     else (Word32, Int, OutPacket)
-> t (StateT ConState m) (Word32, Int, OutPacket)
forall a. a -> t (StateT ConState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32, Int, OutPacket)
p

    -- Local request to close the connection:
    close :: StateT ConState m ()
close =
      do Phase
p <- (ConState -> Phase) -> StateT ConState m Phase
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Phase
phase
	 case Phase
p of
	   Phase
Established -> do StateT ConState m ()
sendFin ; Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
FinWait1
	   Phase
CloseWait   -> do StateT ConState m ()
sendFin ; Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
LastAck
	   Phase
_ -> [Char] -> StateT ConState m ()
debug [Char]
"Buggy local client closing more than once"

    -- Local request to send some data:
    conTx :: OutPacket -> StateT ConState m ()
conTx OutPacket
dat =
      do Phase
p <- (ConState -> Phase) -> StateT ConState m Phase
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Phase
phase
	 --let l=fromIntegral (outLen dat)
	 --when (l>0) $
	 if Phase
pPhase -> Phase -> Bool
forall a. Ord a => a -> a -> Bool
>Phase
CloseWait
	   then [Char] -> StateT ConState m ()
debug [Char]
"Buggy local client sending after closing"
	   else do OutPacket -> StateT ConState m ()
queueData OutPacket
dat
	           StateT ConState m ()
trySendData

    -- Receiver a packet from the network:
    conRx :: f (Packet InPacket) -> StateT ConState m ()
conRx f (Packet InPacket)
ip | ControlBits -> Bool
rst (Packet InPacket -> ControlBits
forall content. Packet content -> ControlBits
controlBits (f (Packet InPacket) -> Packet InPacket
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (Packet InPacket)
ip)) = -- also check seqNr
      -- Should probably notify client that the connection was reset
      -- and not just closed the normal way...
      do Phase
p <- (ConState -> Phase) -> StateT ConState m Phase
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Phase
phase
	 Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Phase
pPhase -> Phase -> Bool
forall a. Eq a => a -> a -> Bool
==Phase
Established) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ m () -> StateT ConState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InPacket -> m ()
deliver InPacket
emptyInPack) -- EOS
	 Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
TimeWait -- or Closed?
    conRx f (Packet InPacket)
ip =
      do let tcp :: Packet InPacket
tcp   = f (Packet InPacket) -> Packet InPacket
forall a. f a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents f (Packet InPacket)
ip
	     got :: Word32
got   = Packet InPacket -> Word32
forall content. Packet content -> Word32
seqNr Packet InPacket
tcp
	     dat :: InPacket
dat   = Packet InPacket -> InPacket
forall a. Packet a -> a
forall (f :: * -> *) a. Container f => f a -> a
contents Packet InPacket
tcp
	     l :: Word32
l=Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (InPacket -> Int
len InPacket
dat)
	     cb :: ControlBits
cb=Packet InPacket -> ControlBits
forall content. Packet content -> ControlBits
controlBits Packet InPacket
tcp
	 --debug $ "Got packet with "++show cb++" and "++show l++" bytes of data"
	 Word32
expecting <- (ConState -> Word32) -> StateT ConState m Word32
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Word32
rxSeq
	 -- also check RST flag!
	 Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
lWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>Word32
0) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$
	     do let new :: Word32
new=Word32
gotWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
lWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
expecting
                Word32
rxwin <- (ConState -> Word32) -> StateT ConState m Word32
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Word32
rxWindow
		if Word32
newWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>Word32
0 Bool -> Bool -> Bool
&& Word32
newWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word32
rxwin
		   then
		     do --debug $ "ACK upto "++show ack
			    --    ++" and deliver "++show new++" bytes"
			let ack :: Word32
ack=Word32
gotWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
l
			    dup :: Int
dup=Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
lWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
new)
			(ConState -> ConState) -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConState -> ConState) -> StateT ConState m ())
-> (ConState -> ConState) -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ \ ConState
s->ConState
s{rxSeq=ack}
			m () -> StateT ConState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT ConState m ()) -> m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ InPacket -> m ()
deliver (Int -> InPacket -> InPacket
skipIn Int
dup InPacket
dat)
		   else do Word32 -> StateT ConState m ()
acknowledge Word32
expecting
			   [Char] -> StateT ConState m ()
debug ([Char] -> StateT ConState m ()) -> [Char] -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"got duplicate input "
			           [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++(Word32, Word32, Word32) -> [Char]
forall a. Show a => a -> [Char]
show (Word32
got,Word32
l,Word32
expecting)
	 S{phase :: ConState -> Phase
phase=Phase
p,rxSeq :: ConState -> Word32
rxSeq=Word32
expecting} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	 if ControlBits -> Bool
fin ControlBits
cb
	   then let finseq :: Word32
finseq=Word32
gotWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
l
                    ack :: Word32
ack=Word32
finseqWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1
		    ackgoto :: Phase -> StateT ConState m ()
ackgoto Phase
p = do Word32 -> StateT ConState m ()
acknowledge Word32
ack;Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
p
	        in if Word32
finseqWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word32
expecting
		   then [Char] -> StateT ConState m ()
debug [Char]
"FIN with unexpected sequence number"
		   else case Phase
p of
			  Phase
Established -> do m () -> StateT ConState m ()
forall (m :: * -> *) a. Monad m => m a -> StateT ConState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InPacket -> m ()
deliver InPacket
emptyInPack) -- EOS
					    Phase -> StateT ConState m ()
ackgoto Phase
CloseWait
			  Phase
FinWait1    -> do Phase -> StateT ConState m ()
ackgoto Phase
Closing
			  Phase
FinWait2    -> do Phase -> StateT ConState m ()
ackgoto Phase
TimeWait
			  Phase
_ -> [Char] -> StateT ConState m ()
debug [Char]
"Unexpected FIN"
           else Word32 -> StateT ConState m ()
acknowledge Word32
expecting
	 S{txUnacked :: ConState -> Word32
txUnacked=Word32
unacked,txSeq :: ConState -> Word32
txSeq=Word32
seq} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
	 let acknr :: Word32
acknr = Packet InPacket -> Word32
forall content. Packet content -> Word32
ackNr Packet InPacket
tcp
	 Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ControlBits -> Bool
ack ControlBits
cb Bool -> Bool -> Bool
&& Word32
acknrWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word32
unacked Bool -> Bool -> Bool
&&
	       Word32
acknrWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
unackedWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<=Word32
seqWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
unacked) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ -- !! modulo arithmetic
	      do s :: ConState
s@S{now :: ConState -> Int
now=Int
now,roundTripTime :: ConState -> Int
roundTripTime=Int
oldrtt,unackedData :: ConState -> [(Word32, Int, OutPacket)]
unackedData=[(Word32, Int, OutPacket)]
ps} <- StateT ConState m ConState
forall s (m :: * -> *). MonadState s m => m s
get
		 let ([(Word32, Int, OutPacket)]
ps1,[(Word32, Int, OutPacket)]
ps2) =((Word32, Int, OutPacket) -> Bool)
-> [(Word32, Int, OutPacket)]
-> ([(Word32, Int, OutPacket)], [(Word32, Int, OutPacket)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Word32 -> (Word32, Int, OutPacket) -> Bool
forall {a} {b}. (Ord a, Num a) => a -> (a, b, OutPacket) -> Bool
isAcked Word32
acknr) [(Word32, Int, OutPacket)]
ps
		     newrtt :: Int
newrtt=if [(Word32, Int, OutPacket)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Word32, Int, OutPacket)]
ps1
			     then Int
oldrtt
			     else [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ Int
nowInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
t | (Word32
_,Int
t,OutPacket
_)<-[(Word32, Int, OutPacket)]
ps1]
		     rtt :: Int
rtt=(Int
oldrttInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
newrtt) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
		 ConState -> StateT ConState m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ConState
s{txUnacked=acknr,unackedData=ps2,roundTripTime=rtt}
		 {-
		 debug $ "Update ACKed output to "++show acknr
                         ++", "++show (length ps2)++" unacked packets"
			 ++", new roundtrip time="++show rtt++" ticks"
		 -}
		 StateT ConState m ()
trySendData
		 Word32
seq <- (ConState -> Word32) -> StateT ConState m Word32
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConState -> Word32
txSeq
		 Bool -> StateT ConState m () -> StateT ConState m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
acknrWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
seq) (StateT ConState m () -> StateT ConState m ())
-> StateT ConState m () -> StateT ConState m ()
forall a b. (a -> b) -> a -> b
$ -- when everything sent has been acked
		   case ConState -> Phase
phase ConState
s of
		     Phase
FinWait1 -> Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
FinWait2
		     Phase
Closing  -> Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
TimeWait
		     Phase
LastAck  -> Phase -> StateT ConState m ()
forall {m :: * -> *}. MonadState ConState m => Phase -> m ()
goto Phase
Closed
		     Phase
_ -> () -> StateT ConState m ()
forall a. a -> StateT ConState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

isAcked :: a -> (a, b, OutPacket) -> Bool
isAcked a
acknr (a
seq,b
t,OutPacket
buf) = a
seqa -> a -> a
forall a. Num a => a -> a -> a
+Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutPacket -> Int
outLen OutPacket
buf)a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
acknr

--------------------------------------------------------------------------------
okTCPchksum :: Packet a -> Bool
okTCPchksum Packet a
ip = Packet a -> Word16
forall {a}. Unparse a => Packet a -> Word16
tcp_chksum Packet a
ip Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0

setTCPchksum :: Packet (Packet content) -> Packet (Packet content)
setTCPchksum Packet (Packet content)
ip = Packet (Packet content)
ip{IPv4.content=tcp'}
  where
    tcp' :: Packet content
tcp' = Packet content
tcp{TCP.checksum=tcp_chksum ip}
    tcp :: Packet content
tcp = Packet (Packet content) -> Packet content
forall content. Packet content -> content
forall (f :: * -> *) a. Container f => f a -> a
contents Packet (Packet content)
ip

tcp_chksum :: Packet a -> Word16
tcp_chksum Packet a
ip = OutPacket -> Word16
outPacketChecksum OutPacket
pseudoTCP
  where
    tcp :: a
tcp = Packet a -> a
forall content. Packet content -> content
forall (f :: * -> *) a. Container f => f a -> a
contents Packet a
ip
    pseudoHeader :: (Addr, Addr, Word8, Protocol, Word16)
pseudoHeader = (Packet a -> Addr
forall content. Packet content -> Addr
IPv4.source Packet a
ip,Packet a -> Addr
forall content. Packet content -> Addr
IPv4.dest Packet a
ip,Word8
0::Word8,Protocol
IPv4.TCP,Word16
tcpLength)
    tcpLength :: Word16
tcpLength = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (OutPacket -> Int
outLen OutPacket
utcp)::Word16
    pseudoTCP :: OutPacket
pseudoTCP = ((Addr, Addr, Word8, Protocol, Word16), OutPacket) -> OutPacket
forall {a}. Unparse a => a -> OutPacket
doUnparse ((Addr, Addr, Word8, Protocol, Word16)
pseudoHeader,OutPacket
utcp)
    utcp :: OutPacket
utcp = a -> OutPacket
forall {a}. Unparse a => a -> OutPacket
doUnparse a
tcp -- TCP packet will be serialized twice!!
    outPacketChecksum :: OutPacket -> Word16
outPacketChecksum = [Word16] -> Word16
Util.checksum ([Word16] -> Word16)
-> (OutPacket -> [Word16]) -> OutPacket -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word16]
bytes_to_words_big ([Word8] -> [Word16])
-> (OutPacket -> [Word8]) -> OutPacket -> [Word16]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutPacket -> [Word8]
outBytes

--pre: n<=len p
skipIn :: Int -> InPacket -> InPacket
skipIn Int
n InPacket
p = Int -> InPacket -> InPacket
dropInPack Int
n InPacket
p