{-# 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)