Output.hs

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

module Hans.IP4.Output (
    sendIP4, queueIP4,
    prepareIP4,
    primSendIP4,
    responder,

    -- * ICMP4 Messages
    queueIcmp4,
    portUnreachable,
  ) where

import Hans.Checksum (computeChecksum)
import Hans.Config (config,Config(..))
import Hans.Device
           (Device(..),DeviceConfig(..),DeviceStats(..),updateError,statTX
           ,ChecksumOffload(..),txOffload,deviceConfig)
import Hans.Ethernet
           ( Mac,sendEthernet,pattern ETYPE_IPV4, pattern ETYPE_ARP
           , pattern BroadcastMac)
import Hans.IP4.ArpTable
           (lookupEntry,resolveAddr,QueryResult(..),markUnreachable
           ,writeChanStrategy)
import Hans.IP4.Icmp4
           (Icmp4Packet(..),DestinationUnreachableCode(..),renderIcmp4Packet)
import Hans.IP4.Packet
import Hans.IP4.RoutingTable (Route(..),routeSource,routeNextHop)
import Hans.Lens
import Hans.Network.Types
import Hans.Serialize (runPutPacket)
import Hans.Threads (forkNamed)
import Hans.Types

import           Control.Concurrent (threadDelay)
import qualified Control.Concurrent.BoundedChan as BC
import           Control.Monad (when,forever,unless)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import           Data.Serialize.Put (putWord16be)



responder :: NetworkStack -> IO ()
responder ns = forever $
  do req <- BC.readChan (ip4ResponderQueue (view ip4State ns))
     case req of

       Send mbSrc dst df prot payload ->
         do _ <- sendIP4 ns mbSrc dst df prot payload
            return ()

       Finish dev mac frames ->
            sendIP4Frames dev mac frames


-- | Queue a message on the responder queue instead of attempting to send it
-- directly.
queueIP4 :: NetworkStack -> DeviceStats
         -> SendSource -> IP4 -> Bool -> NetworkProtocol -> L.ByteString
         -> IO ()
queueIP4 ns stats mbSrc dst df prot payload =
  do written <- BC.tryWriteChan (ip4ResponderQueue (view ip4State ns))
                    (Send mbSrc dst df prot payload)
     unless written (updateError statTX stats)


-- | Send an IP4 packet to the given destination. If it's not possible to find a
-- route to the destination, return False.
sendIP4 :: NetworkStack -> SendSource -> IP4
        -> Bool -> NetworkProtocol -> L.ByteString
        -> IO Bool

-- A special case for when the sender knows that this is the right device and
-- source address. The routing table is still queried to find the next hop, and
-- if the route found doesn't use the device provided, the packets aren't sent.
sendIP4 ns (SourceDev dev src) dst df prot payload =
  do mbRoute <- lookupRoute4 ns dst
     case mbRoute of
       Just (_,next,dev') | devName dev == devName dev' ->
         do primSendIP4 ns dev src dst next df prot payload
            return True

       _ ->
         do updateError statTX (devStats dev)
            return False

-- sending from a specific device
sendIP4 ns (SourceIP4 src) dst df prot payload =
  do mbRoute <- isLocalAddr ns src
     case mbRoute of
       Just route ->
         do primSendIP4 ns (routeDevice route) (routeSource route)
                dst (routeNextHop dst route) df prot payload
            return True

       Nothing ->
            return False

-- find the right path out
sendIP4 ns SourceAny dst df prot payload =
  do mbRoute <- lookupRoute4 ns dst
     case mbRoute of
       Just (src,next,dev) -> do primSendIP4 ns dev src dst next df prot payload
                                 return True
       Nothing             -> return False


prepareHeader :: NetworkStack -> IP4 -> IP4 -> Bool -> NetworkProtocol -> IO IP4Header
prepareHeader ns src dst df prot =
  do ident <- nextIdent ns
     return $! set ip4DontFragment df
               emptyIP4Header { ip4Ident      = ident
                              , ip4SourceAddr = src
                              , ip4DestAddr   = dst
                              , ip4Protocol   = prot
                              , ip4TimeToLive = cfgIP4InitialTTL (view config ns)
                              }


-- | Prepare IP4 fragments to be sent.
prepareIP4 :: NetworkStack -> Device -> IP4 -> IP4 -> Bool -> NetworkProtocol
           -> L.ByteString
           -> IO [L.ByteString]
prepareIP4 ns dev src dst df prot payload =
  do hdr <- prepareHeader ns src dst df prot

     let DeviceConfig { .. } = devConfig dev

     return $ [ renderIP4Packet (view txOffload dev) h p
              | (h,p) <- splitPacket (fromIntegral dcMtu) hdr payload ]


-- | Send an IP4 packet to the given destination. This assumes that routing has
-- already taken place, and that the source and destination addresses are
-- correct.
primSendIP4 :: NetworkStack -> Device -> IP4 -> IP4 -> IP4 -> Bool -> NetworkProtocol
             -> L.ByteString -> IO ()
primSendIP4 ns dev src dst next df prot payload
    -- when the source and next hop are the same, re-queue in the network stack
    -- after fragment reassembly
  | src == next =
    do hdr <- prepareHeader ns src dst df prot
       _   <- BC.tryWriteChan (nsInput ns) $! FromIP4 dev hdr (L.toStrict payload)
       -- don't write any stats for packets that skip the device layer
       return ()

    -- the packet is leaving the network stack so encode it and send
  | otherwise =
    do packets <- prepareIP4 ns dev src dst df prot payload
       arpOutgoing ns dev src next packets


-- | Retrieve the outgoing address for this IP4 packet, and send along all
-- fragments.
arpOutgoing :: NetworkStack -> Device -> IP4 -> IP4 -> [L.ByteString] -> IO ()
arpOutgoing _ dev _ BroadcastIP4 packets =
    sendIP4Frames dev BroadcastMac packets

arpOutgoing ns dev src next packets =
  do res <- resolveAddr (ip4ArpTable (view ip4State ns)) next queueSend
     case res of
       Known dstMac ->
         sendIP4Frames dev dstMac packets

       -- The mac wasn't present in the table. If this was the first request for
       -- this address, start a request thread.
       Unknown newRequest () ->
         when newRequest $ do _ <- forkNamed "arpRequestThread"
                                       (arpRequestThread ns dev src next)
                              return ()

  where

  queueSend =
    writeChanStrategy (Just (devStats dev)) mkFinish
        (ip4ResponderQueue (view ip4State ns))

  mkFinish mbMac =
    do dstMac <- mbMac
       return $! Finish dev dstMac packets


sendIP4Frames :: Device -> Mac -> [L.ByteString] -> IO ()
sendIP4Frames dev dstMac packets =
  mapM_ (sendEthernet dev dstMac ETYPE_IPV4) packets


-- | Make an Arp request for the given IP address, until the maximum retries
-- have been exhausted, or the entry made it into the table.
arpRequestThread :: NetworkStack -> Device -> IP4 -> IP4 -> IO ()
arpRequestThread ns dev src dst = loop 0
  where
  IP4State { ..} = view ip4State ns

  request = renderArpPacket ArpPacket { arpOper   = ArpRequest
                                      , arpSHA    = devMac dev
                                      , arpSPA    = src
                                      , arpTHA    = BroadcastMac
                                      , arpTPA    = dst
                                      }

  loop n =
    do sendEthernet dev BroadcastMac ETYPE_ARP request
       threadDelay ip4ArpRetryDelay

       mb <- lookupEntry ip4ArpTable dst
       case mb of
         Just{}                    -> return ()
         Nothing | n < ip4ArpRetry -> loop (n + 1)
                 | otherwise       -> markUnreachable ip4ArpTable dst


-- | The final step to render an IP header and its payload out as a lazy
-- 'ByteString'. Compute the checksum over the packet with its checksum zeroed,
-- then reconstruct a new lazy 'ByteString' that contains chunks from the old
-- header, and the new checksum.
renderIP4Packet :: ChecksumOffload -> IP4Header -> L.ByteString -> L.ByteString
renderIP4Packet ChecksumOffload { .. } hdr pkt
  | coIP4     = bytes `L.append` pkt
  | otherwise = withChecksum
  where

  pktlen    = L.length pkt

  bytes     = runPutPacket 20 40 pkt (putIP4Header hdr (fromIntegral pktlen))
  cs        = computeChecksum (L.take (L.length bytes - pktlen) bytes)

  beforeCS  = L.take 10 bytes
  afterCS   = L.drop 12 bytes
  csBytes   = runPutPacket 2 100 afterCS (putWord16be cs)

  withChecksum = beforeCS `L.append` csBytes


-- ICMP Messages ---------------------------------------------------------------

queueIcmp4 :: NetworkStack -> Device -> SendSource -> IP4 -> Icmp4Packet
           -> IO ()
queueIcmp4 ns dev src dst pkt =
  let msg = renderIcmp4Packet (view txOffload dev) pkt
      df  = fromIntegral (L.length msg) < dcMtu (view deviceConfig dev) - 20
   in queueIP4 ns (devStats dev) src dst df PROT_ICMP4 msg

-- | Emit a destination unreachable ICMP message. This will always be queued via
-- the responder queue, as it is most likely coming from the fast path. The
-- bytestring argument is assumed to be the original IP4 datagram, trimmed to
-- IP4 header + 8 bytes of data.
portUnreachable :: NetworkStack -> Device -> SendSource -> IP4 -> S.ByteString
                -> IO ()
portUnreachable ns dev src dst chunk =
  queueIcmp4 ns dev src dst (DestinationUnreachable PortUnreachable chunk)