Output.hs

{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}

module Hans.Tcp.Output (
    -- * Output
    routeTcp,
    sendTcp,

    -- ** With a TCB
    sendWithTcb,
    sendAck,
    sendFin,
    sendData,
    canSend,

    -- ** From the fast-path
    queueTcp,
    queueWithTcb,
    queueAck,
    responder,

    -- $notes
  ) where

import           Hans.Addr.Types (Addr)
import           Hans.Config (config)
import           Hans.Checksum (finalizeChecksum,extendChecksum)
import           Hans.Device.Types (Device(..),ChecksumOffload(..),txOffload)
import           Hans.Lens (view,set)
import           Hans.Network
import           Hans.Serialize (runPutPacket)
import           Hans.Tcp.Packet
                     (TcpHeader(..),putTcpHeader,emptyTcpHeader,tcpAck,tcpFin
                     ,tcpPsh,TcpOption(..),setTcpOption)
import qualified Hans.Tcp.RecvWindow as Recv
import qualified Hans.Tcp.SendWindow as Send
import           Hans.Tcp.Tcb
import           Hans.Types

import qualified Control.Concurrent.BoundedChan as BC
import           Control.Monad (when,forever)
import qualified Data.ByteString.Lazy as L
import           Data.IORef (readIORef,atomicModifyIORef',atomicWriteIORef)
import           Data.Int (Int64)
import           Data.Serialize.Put (putWord16be)
import           Data.Time.Clock (getCurrentTime)
import           Data.Word (Word32)


-- Sending with a TCB ----------------------------------------------------------

-- | Send a single ACK immediately.
sendAck :: NetworkStack -> Tcb -> IO ()
sendAck ns tcb =
  do _ <- sendWithTcb ns tcb (set tcpAck True emptyTcpHeader) L.empty
     return ()

-- | Send a single FIN packet.
sendFin :: NetworkStack -> Tcb -> IO ()
sendFin ns tcb =
  do let hdr = set tcpFin True
             $ set tcpAck True emptyTcpHeader
     _ <- sendWithTcb ns tcb hdr L.empty
     return ()

-- | Send a data segment, potentially sending multiple packets if the send
-- window allows, and the payload is larger than MSS. When the remote window is
-- full, this returns 0.
sendData :: NetworkStack -> Tcb -> L.ByteString -> IO Int64
sendData ns tcb = go 0
  where
  -- technically the MSS could change between sends, so this ensures that we
  -- would pick up that change.
  go acc bytes
    | L.null bytes =
      return acc

    | otherwise =
      do mss <- fromIntegral `fmap` readIORef (tcbMss tcb)
         mb  <- sendWithTcb ns tcb hdr (L.take mss bytes)
         case mb of

           -- when the amount sent was less than mss, we've filled the send
           -- window, and won't be able to send any more.
           Just len | len < mss -> return $! acc + len
                    | otherwise -> let acc' = acc + len
                                    in acc' `seq` go acc' (L.drop len bytes)

           -- the send window is full, return the accumulator
           Nothing -> return acc

  hdr = set tcpAck True
      $ set tcpPsh True
        emptyTcpHeader


-- | Determine if there is any room in the remote window for us to send
-- data.
canSend :: Tcb -> IO Bool
canSend Tcb { .. } =
  (not . Send.fullWindow) `fmap` readIORef tcbSendWindow

-- | Send a segment and queue it in the remote window. The number of bytes that
-- were sent is returned.
sendWithTcb :: NetworkStack -> Tcb -> TcpHeader -> L.ByteString -> IO (Maybe Int64)
sendWithTcb ns Tcb { .. } hdr body =
  do TcbConfig { .. } <- readIORef tcbConfig

     recvWindow <- readIORef tcbRecvWindow

     mbTSecr <- if tcUseTimestamp
                   then Just `fmap` readIORef tcbTSRecent
                   else return Nothing

     let mkHdr tsVal seqNum =
           addTimestamp tsVal mbTSecr
             hdr { tcpSeqNum     = seqNum
                 , tcpAckNum     = if view tcpAck hdr
                                      then view Recv.rcvNxt recvWindow
                                      else 0
                 , tcpDestPort   = tcbRemotePort
                 , tcpSourcePort = tcbLocalPort
                 , tcpWindow     = view Recv.rcvWnd recvWindow
                 }

     -- only enter the retransmit queue if the segment contains data
     now   <- getCurrentTime
     mbRes <- atomicModifyIORef' tcbSendWindow
                  (Send.queueSegment (view config ns) now mkHdr body)
     case mbRes of

       Just (startRT,hdr',body') ->
         do -- clear the delayed ack flag and update Last.ACK.sent, when an ack
            -- is present
            when (view tcpAck hdr') $
              do atomicWriteIORef tcbNeedsDelayedAck False
                 atomicWriteIORef tcbLastAckSent (tcpAckNum hdr')

            -- reset the retransmit timer, if the retransmit queue is now
            -- non-empty
            when startRT (atomicModifyIORef' tcbTimers resetRetransmit)

            -- send the frame
            _ <- sendTcp ns tcbRouteInfo tcbRemote hdr' body'

            -- return how much of the segment was actually delivered
            return (Just (L.length body'))

       Nothing ->
            return Nothing


-- | The presence of a tracked TSecr value controls whether or not we send the
-- timestamp option.
addTimestamp :: Word32 -> Maybe Word32 -> TcpHeader -> TcpHeader
addTimestamp tsVal (Just tsEcr) hdr = setTcpOption (OptTimestamp tsVal tsEcr) hdr
addTimestamp _     _            hdr = hdr


-- Fast-path Sending -----------------------------------------------------------

-- | Responder thread for messages generated in the fast-path.
responder :: NetworkStack -> IO ()
responder ns = forever $
  do msg <- BC.readChan chan
     case msg of
       SendSegment ri dst hdr body ->
         do _ <- sendTcp ns ri dst hdr body
            return ()

       SendWithTcb tcb hdr body ->
         do _ <- sendWithTcb ns tcb hdr body
            return ()

  where
  chan = view tcpQueue ns


-- | Queue an outgoing TCP segment from the fast-path.
--
-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue").
queueTcp :: NetworkStack
         -> RouteInfo Addr -> Addr -> TcpHeader -> L.ByteString -> IO Bool
queueTcp ns ri dst hdr body =
  BC.tryWriteChan (view tcpQueue ns) $! SendSegment ri dst hdr body


-- | Queue an outgoing TCP segment from the fast-path.
queueWithTcb :: NetworkStack -> Tcb -> TcpHeader -> L.ByteString -> IO Bool
queueWithTcb ns tcb hdr body =
  BC.tryWriteChan (view tcpQueue ns) $! SendWithTcb tcb hdr body


-- | Queue an ACK from the fast-path.
queueAck :: NetworkStack -> Tcb -> IO Bool
queueAck ns tcb = queueWithTcb ns tcb (set tcpAck True emptyTcpHeader) L.empty


-- Primitive Send --------------------------------------------------------------

-- | Send outgoing tcp segments, with a route calculation.
--
-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue").
routeTcp :: Network addr
         => NetworkStack -> Device
         -> addr -> addr -> TcpHeader -> L.ByteString -> IO Bool
routeTcp ns dev src dst hdr payload
  | L.length payload > fromIntegral (maxBound :: Word32) =
    return False

  | otherwise =
    do mbRoute <- findNextHop ns (Just dev) (Just src) dst
       case mbRoute of

         Just ri ->
           do let bytes = renderTcpPacket (view txOffload dev) src dst hdr payload
              sendDatagram ns ri dst False PROT_TCP bytes
              return True

         Nothing ->
              return False


-- | Lowest-level output function for TCP.
--
-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue").
sendTcp :: Network addr
        => NetworkStack
        -> RouteInfo addr -> addr -> TcpHeader -> L.ByteString -> IO Bool
sendTcp ns ri dst hdr payload
  | L.length payload >= fromIntegral (maxBound :: Word32) =
    return False

  | otherwise =
    do let bytes = renderTcpPacket (view txOffload ri) (riSource ri) dst hdr payload
       sendDatagram ns ri dst False PROT_TCP bytes

       return True


-- | Render out a tcp packet, calculating the checksum when the device requires
-- it.
renderTcpPacket :: Network addr
                => ChecksumOffload -> addr -> addr -> TcpHeader -> L.ByteString
                -> L.ByteString
renderTcpPacket ChecksumOffload { .. } src dst hdr body
  | coTcp     = bytes
  | otherwise = beforeCS `L.append` csBytes
  where
  bytes  = runPutPacket 20 40 body (putTcpHeader hdr)

  cs     = finalizeChecksum
         $ extendChecksum bytes
         $ pseudoHeader src dst PROT_TCP (fromIntegral (L.length bytes))

  beforeCS = L.take 16 bytes
  csBytes  = runPutPacket 2 0 (L.drop 18 bytes) (putWord16be cs)


-- $notes
-- #no-retransmit-queue#
--
-- = No Retransmit Queue
-- This function will not record entries in the retransmit queue, and is
-- responsible only for output to a lower layer.