diff --git a/echo-client/Main.hs b/echo-client/Main.hs deleted file mode 100644 --- a/echo-client/Main.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Main where - -import Control.Concurrent (threadDelay) -import Hans.Address.Mac -import Hans.DhcpClient -import Hans.NetworkStack -import System.Environment (getArgs) - -#ifdef HaLVM_HOST_OS -import Hans.Device.Xen -import Hypervisor.Console -import Hypervisor.XenStore -import XenDevice.NIC -#else -import Hans.Device.Tap -#endif - -main :: IO () -main = do - - [ip] <- getArgs - let addr = read ip - - ns <- newNetworkStack - mac <- initEthernetDevice ns - - deviceUp ns mac - putStrLn "Network stack running..." - - putStrLn "Discovering address" - - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just self -> do - putStrLn ("Bound to address: " ++ show self) - - sock <- connect ns addr 9001 Nothing - putStrLn ("Connected to: " ++ show addr) - - putStrLn "Sending bytes..." - sent <- sendBytes sock "Hello" - - putStrLn ("Sent " ++ show sent ++ " bytes") - print =<< recvBytes sock 512 - - threadDelay 1000000 - - close sock - -#ifdef HaLVM_HOST_OS -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = - do xs <- initXenStore - _ <- initXenConsole -- should set up putStrLn - nics <- listNICs xs - case nics of - [] -> fail "No NICs found to use!" - (macstr:_) -> - do let mac = read macstr - nic <- openNIC xs macstr - addDevice ns mac (xenSend nic) (xenReceiveLoop nic) - return mac -#else -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = do - let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x57 - Just dev <- openTapDevice "tap7" - addDevice ns mac (tapSend dev) (tapReceiveLoop dev) - return mac -#endif diff --git a/hans.cabal b/hans.cabal --- a/hans.cabal +++ b/hans.cabal @@ -1,5 +1,5 @@ name: hans -version: 2.4.0.1 +version: 2.5.0.0 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -60,8 +60,7 @@ containers >= 0.3.0.0, monadLib >= 3.6.0, time >= 1.1.0.0, - fingertree >= 0.0.1.0, - stm >= 2.4 + fingertree >= 0.0.1.0 if flag(word32-in-random) build-depends: random >= 1.0.1.0 @@ -145,8 +144,7 @@ executable web-server main-is: Main.hs hs-source-dirs: web-server - ghc-options: -Wall -threaded -rtsopts -fno-warn-unused-do-bind - -fno-warn-orphans + ghc-options: -Wall -threaded -rtsopts if os(HaLVM) buildable: False @@ -170,23 +168,7 @@ executable tcp-test main-is: Main.hs hs-source-dirs: tcp-test - ghc-options: -Wall -rtsopts -threaded - build-depends: base >= 4.0.0.0 && < 5, - cereal >= 0.3.5.2, - bytestring >= 0.9.1.0, - containers >= 0.3.0.0, - monadLib >= 3.6.0, - time >= 1.1.0.0, - old-locale >= 1.0.0.0, - hans - if os(HaLVM) - build-depends: XenDevice >= 2.0.0 && < 3.0.0, - HALVMCore >= 2.0.0 && < 3.0.0 - -executable echo-client - main-is: Main.hs - hs-source-dirs: echo-client - ghc-options: -Wall -rtsopts -threaded + ghc-options: -Wall -threaded -rtsopts build-depends: base >= 4.0.0.0 && < 5, cereal >= 0.3.5.2, bytestring >= 0.9.1.0, diff --git a/src/Hans/DhcpClient.hs b/src/Hans/DhcpClient.hs --- a/src/Hans/DhcpClient.hs +++ b/src/Hans/DhcpClient.hs @@ -16,8 +16,7 @@ import Hans.NetworkStack import Hans.Timers (delay_) -import Control.Monad (guard,unless) -import Control.Concurrent.STM +import Control.Monad (guard) import Data.Maybe (fromMaybe,mapMaybe) import System.Random (randomIO) import qualified Data.ByteString as S @@ -46,65 +45,21 @@ -- DHCP ------------------------------------------------------------------------ +type AckHandler = IP4 -> IO () + -- | Discover a dhcp server, and request an address. dhcpDiscover :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) - => stack -> Mac -> IO (Maybe IP4) -dhcpDiscover ns mac = do - addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) - - offerTMV <- newEmptyTMVarIO - addUdpHandler ns bootpc (handleOffer ns offerTMV) - + => stack -> Mac -> AckHandler -> IO () +dhcpDiscover ns mac h = do w32 <- randomIO let xid = Xid (fromIntegral (w32 :: Int)) - disc = discoverToMessage (mkDiscover xid mac) - -- waitResult sends our DHCP discover and waits for an offer. - mbOffer <- waitResult retries disc offerTMV - case mbOffer of - - -- We exceeded our retries, give up. - Nothing -> return Nothing - - -- We got an offer - -- - Install an DHCP Ack handler. - -- - Send a DHCP Request via waitResult, and wait for an IP to appear in resp. - Just offer -> do - resp <- newEmptyTMVarIO - addUdpHandler ns bootpc (handleAck ns offer (Just (atomically . putTMVar resp))) - let req = requestToMessage (offerToRequest offer) - waitResult retries req resp - - where - -- RFC 2131 says to do exponential backoff starting at 4s and going to 64s. - -- It also says to add random noise between -1s and +1s, but we're skipping that for now. - initialTimeout :: Int - initialTimeout = 4000000 -- 4 seconds in µs - - retries :: Int - retries = 6 + addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) + addUdpHandler ns bootpc (handleOffer ns (Just h)) - -- Sends a message and waits for a response (indicated by a value appearing the TMVar) - -- until timeout. Retries a given number of times doubling the backoff each time. - waitResult :: Int -> Dhcp4Message -> TMVar a -> IO (Maybe a) - waitResult n msg result = go n initialTimeout - where - go 0 _to = return Nothing - go i to = - do sendMessage ns msg currentNetwork broadcastIP4 broadcastMac - timeout <- registerDelay to - -- If there is a result, return Just it. - -- If not, and we aren't timed out, retry. - -- If we are timed out, return Nothing. - mb <- atomically $ orElse (fmap Just (takeTMVar result)) - (do isTimedOut <- readTVar timeout - unless isTimedOut retry - return Nothing) - -- Exponential backoff on timeout, return result on success. - case mb of - Just _ -> return mb - Nothing -> go (i-1) (to * 2) + let disc = discoverToMessage (mkDiscover xid mac) + sendMessage ns disc currentNetwork broadcastIP4 broadcastMac -- | Restore the connection between the Ethernet and IP4 layers. restoreIp4 :: (HasEthernet stack, HasIP4 stack) => stack -> IO () @@ -128,18 +83,21 @@ -- | Handle a DHCP Offer message. -- -- * Remove the current UDP handler --- * Write offer to TMV for retrieval. +-- * Install an DHCP Ack handler +-- * Send a DHCP Request handleOffer :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) - => stack -> TMVar Offer -> IP4 -> UdpPort + => stack -> Maybe AckHandler -> IP4 -> UdpPort -> S.ByteString -> IO () -handleOffer ns tmv _src _srcPort bytes = +handleOffer ns mbh _src _srcPort bytes = case getDhcp4Message bytes of Right msg -> case parseDhcpMessage msg of Just (Right (OfferMessage offer)) -> do removeUdpHandler ns bootpc - atomically $ putTMVar tmv offer + let req = requestToMessage (offerToRequest offer) + addUdpHandler ns bootpc (handleAck ns offer mbh) + sendMessage ns req currentNetwork broadcastIP4 broadcastMac msg1 -> do putStrLn (show msg) @@ -149,11 +107,6 @@ -- | Handle a DHCP Ack message. -- --- The optional handler (mbh) is present only the first time handleAck is --- installed, so we can update the main thread on our IP assignment. After --- that (when dhcpRenew installs handleAck) it is Nothing, because we just --- have to update the network stack. --- -- * Remove the custom IP4 handler -- * Restore the connection between the Ethernet and IP4 layers -- * Remove the bootpc UDP listener @@ -162,7 +115,7 @@ -- has passed handleAck :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) - => stack -> Offer -> Maybe (IP4 -> IO ()) -> IP4 -> UdpPort + => stack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort -> S.ByteString -> IO () handleAck ns offer mbh _src _srcPort bytes = case getDhcp4Message bytes of @@ -189,7 +142,7 @@ -- -- * Re-install the DHCP IP4 handler -- * Add a UDP handler for an Ack message --- * Re-send a request message, generated from the offer given. +-- * Re-send a renquest message, generated from the offer given. dhcpRenew :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) => stack -> Offer -> IO () diff --git a/src/Hans/Layer/IP4.hs b/src/Hans/Layer/IP4.hs --- a/src/Hans/Layer/IP4.hs +++ b/src/Hans/Layer/IP4.hs @@ -33,7 +33,7 @@ import Hans.Utils.Checksum import Control.Concurrent (forkIO) -import Control.Monad (guard, (<=<)) +import Control.Monad (guard,mplus,(<=<)) import MonadLib (get,set) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S @@ -124,10 +124,10 @@ state <- get just (route addr (ip4Routes state)) --- Route a packet that is forwardable. --- XXX Hide this facility behind configuration -_forward :: IP4Header -> L.ByteString -> IP () -_forward hdr body = do + +-- | Route a packet that is forwardable +forward :: IP4Header -> L.ByteString -> IP () +forward hdr body = do rule@(src,_,_) <- findRoute (ip4DestAddr hdr) guard (src /= ip4SourceAddr hdr) sendPacket' hdr body rule @@ -138,21 +138,23 @@ state <- get guard (ip `elem` localAddrs (ip4Routes state)) -_findSourceMask :: IP4 -> IP IP4Mask -_findSourceMask ip = do + +findSourceMask :: IP4 -> IP IP4Mask +findSourceMask ip = do state <- get just (sourceMask ip (ip4Routes state)) -_broadcastDestination :: IP4 -> IP () -_broadcastDestination ip = do - mask <- _findSourceMask ip + +broadcastDestination :: IP4 -> IP () +broadcastDestination ip = do + mask <- findSourceMask ip guard (isBroadcast mask ip) -- | Route a message to a local handler routeLocal :: IP4Header -> S.ByteString -> IP () routeLocal hdr body = do let dest = ip4DestAddr hdr - localAddress dest + localAddress dest `mplus` broadcastDestination dest h <- getHandler (ip4Protocol hdr) mb <- handleFragments hdr body case mb of @@ -192,9 +194,7 @@ -- forward? let payload = S.take (plen - hlen) rest - routeLocal hdr payload - -- XXX Hide this old router functionality behind a setting - -- `mplus` forward hdr (chunk payload) + routeLocal hdr payload `mplus` forward hdr (chunk payload) handleAddRule :: Rule IP4Mask IP4 -> IP () diff --git a/src/Hans/Layer/Tcp/Handlers.hs b/src/Hans/Layer/Tcp/Handlers.hs --- a/src/Hans/Layer/Tcp/Handlers.hs +++ b/src/Hans/Layer/Tcp/Handlers.hs @@ -20,7 +20,7 @@ import Control.Monad (guard,when,unless,join) import Data.Bits (bit) import Data.Int (Int64) -import Data.Maybe (fromMaybe,isJust) +import Data.Maybe (fromMaybe,isJust,isNothing) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F @@ -142,7 +142,8 @@ -- check SYN when (tcpSyn hdr) $ - do modifyTcpSocket_ $ \ sock -> sock + do advanceRcvNxt 1 + modifyTcpSocket_ $ \ sock -> sock { tcpOutMSS = fromMaybe (tcpInMSS sock) (getMSS hdr) -- clear out, and configure the retransmit buffer @@ -151,25 +152,20 @@ $ clearRetransmit $ tcpOut sock - -- this corresponds to setting IRS to SEQ.SEG, and advancing - -- RCV.NXT by one - , tcpIn = emptyLocalWindow (tcpSeqNum hdr + 1) 14600 0 + -- this corresponds to setting IRS to SEQ.SEG + , tcpIn = emptyLocalWindow (tcpSeqNum hdr) 14600 0 , tcpSack = sackSupported hdr , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr) } when (tcpAck hdr) $ - do -- advance SND.UNA - modifyTcpSocket_ $ \ sock -> sock - { tcpSndUna = tcpAckNum hdr } - + do handleAck hdr -- update SND.UNA TcpSocket { .. } <- getTcpSocket if tcpSndUna > tcpIss then do ack + establishConnection notify True - setState Established - -- continue at step 6 when (tcpUrg hdr) (proceedFromStep6 hdr body) @@ -180,8 +176,6 @@ done - when (not (tcpSyn hdr || tcpRst hdr)) discardAndReturn - -- make sure that the sequence numbers are valid checkSequenceNumber hdr body checkResetBit hdr @@ -225,14 +219,22 @@ -- | Process the presence of the RST bit checkResetBit :: TcpHeader -> Sock () checkResetBit hdr - | tcpRst hdr = do - TcpSocket { .. } <- getTcpSocket - whenStates [ SynReceived, Established, FinWait1, FinWait2 - , CloseWait, Closing, LastAck] $ - do notify False - closeSocket - done + | tcpRst hdr = + do TcpSocket { .. } <- getTcpSocket + whenState SynReceived $ + -- from an active open + do when (isNothing tcpParent) closeSocket + done + + whenStates [Established,FinWait1,FinWait2,CloseWait] $ + do closeSocket + done + + whenStates [Closing,LastAck] $ + do closeSocket + done + | otherwise = return () checkSynBit :: TcpHeader -> Sock () @@ -291,7 +293,7 @@ processSegmentText hdr body = whenStates [Established,FinWait1,FinWait2] $ do if S.null body - -- make sure that the delayed ack flag gets set + -- make sure that the the delayed ack flag gets set then when (tcpSyn hdr || tcpFin hdr) $ modifyTcpTimers_ $ \ tt -> tt { ttDelayedAck = True } diff --git a/src/Hans/Layer/Tcp/Monad.hs b/src/Hans/Layer/Tcp/Monad.hs --- a/src/Hans/Layer/Tcp/Monad.hs +++ b/src/Hans/Layer/Tcp/Monad.hs @@ -468,6 +468,3 @@ closeSocket = do shutdown setState Closed - -userClose :: Sock () -userClose = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True }) diff --git a/src/Hans/Layer/Tcp/Socket.hs b/src/Hans/Layer/Tcp/Socket.hs --- a/src/Hans/Layer/Tcp/Socket.hs +++ b/src/Hans/Layer/Tcp/Socket.hs @@ -100,9 +100,8 @@ } else socketError ConnectionRefused , tcpState = Listen - , tcpSndNxt = isn + 1 + , tcpSndNxt = isn , tcpSndUna = isn - , tcpIss = isn , tcpTimestamp = Just (emptyTimestamp now) } -- XXX how should the retry/backoff be implemented @@ -216,6 +215,8 @@ -- closing a connection that doesn't exist causes a CloseError connected `mplus` unblock (socketError CloseError) +userClose :: Sock () +userClose = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True }) -- Writing --------------------------------------------------------------------- diff --git a/src/Hans/Layer/Tcp/Timers.hs b/src/Hans/Layer/Tcp/Timers.hs --- a/src/Hans/Layer/Tcp/Timers.hs +++ b/src/Hans/Layer/Tcp/Timers.hs @@ -49,11 +49,15 @@ -- the slow timer is valid for all states but TimeWait; the check is done -- here because the socket may have only just transitioned to TimeWait, -- and hasn't been moved to hostTimeWaits yet. - TcpSocket { .. } <- getTcpSocket - unless (tcpState == TimeWait) handleRTO - handle2MSL - updateTimers + do TcpSocket { .. } <- getTcpSocket + unless (tcpState == TimeWait) $ + do handleRTO + handleFinWait2 + handle2MSL + + updateTimers + -- second, decrement the 2MSL timer for sockets in the TimeWait state modifyHost_ $ \ host -> host { hostTimeWaits = stepTimeWaitConnections (hostTimeWaits host) } @@ -121,6 +125,23 @@ if tcpState /= TimeWait && ttIdle <= ttMaxIdle then set2MSL tcpKeepIntVal else closeSocket + +-- FIN_WAIT_2 ------------------------------------------------------------------ + +-- | The FinWait2 10m timeout. +finWait2Idle :: SlowTicks +finWait2Idle = 1200 + +-- | GC the connection if it's been open for a long time, in FIN_WAIT_2. +-- +-- XXX not sure if this is the correct way to do this. should this set a flag +-- to indicate that if the 2MSL timer goes off, the connection should be cleaned +-- up? +handleFinWait2 :: Sock () +handleFinWait2 = whenState FinWait2 + $ whenIdleFor finWait2Idle + $ set2MSL tcpKeepIntVal + -- RTO ------------------------------------------------------------------------- diff --git a/tcp-test/Main.hs b/tcp-test/Main.hs --- a/tcp-test/Main.hs +++ b/tcp-test/Main.hs @@ -18,13 +18,16 @@ import Hans.Device.Tap #endif -import Control.Concurrent (threadDelay,forkIO) - -import Control.Monad (forever) +import Control.Concurrent (newEmptyMVar,putMVar,takeMVar,threadDelay,forkIO + ,killThread,myThreadId) +import Control.Monad (forever,when) import System.Environment (getArgs) import qualified Data.ByteString.Lazy as L import qualified Control.Exception as X +import System.Exit (exitSuccess) + + localAddr :: IP4 localAddr = IP4 192 168 90 2 @@ -39,15 +42,14 @@ args <- getArgs if args == ["dhcp"] then do putStrLn "Discovering address" - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just ip -> do - putStrLn ("Bound to address: " ++ show ip) + res <- newEmptyMVar + dhcpDiscover ns mac (putMVar res) + ip <- takeMVar res + putStrLn ("Bound to address: " ++ show ip) - -- putStrLn "Looking up galois.com..." - -- HostEntry { .. } <- getHostByName ns "galois.com" - -- print hostAddresses + -- putStrLn "Looking up galois.com..." + -- HostEntry { .. } <- getHostByName ns "galois.com" + -- print hostAddresses else do setAddress mac ns @@ -98,7 +100,7 @@ [] -> fail "No NICs found to use!" (macstr:_) -> do let mac = read macstr - nic <- openNIC xs macstr + nic <- openNIC xs macstr addDevice ns mac (xenSend nic) (xenReceiveLoop nic) return mac #else diff --git a/web-server/Main.hs b/web-server/Main.hs --- a/web-server/Main.hs +++ b/web-server/Main.hs @@ -15,6 +15,7 @@ import Data.Time import Data.Version import Data.Word +import GHC.Stats import Hans.Address.Mac import Hans.Address.IP4 import Hans.Device.Tap @@ -25,11 +26,13 @@ import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Stream +import Network.Stream import System.Exit import System.Info -import Text.Blaze.Html5 as H hiding (map, main) +import Text.Blaze.Html5 as H hiding (map) import Text.Blaze.Html5.Attributes(href) import Text.Blaze.Html.Renderer.String +import Text.Blaze.Internal(string) #if !MIN_VERSION_base(4,8,0) import System.Locale @@ -43,7 +46,7 @@ | BS.head bstr == 10 -> return (Right (acc ++ "\n")) | otherwise -> loop (acc ++ BSC.unpack bstr) - readBlock s y = loop (fromIntegral y) BS.empty + readBlock s x = loop (fromIntegral x) BS.empty where loop 0 acc = return (Right (BSC.unpack acc)) loop x acc = do bstr <- recvBytes s x @@ -89,19 +92,18 @@ deviceUp ns mac putStrLn ("Starting server on device " ++ show mac) - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just ipaddr -> do - putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr) + ipMV <- newEmptyMVar + dhcpDiscover ns mac (putMVar ipMV) + ipaddr <- takeMVar ipMV + putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr) - lsock <- listen ns undefined 80 `catch` handler - forever $ do - sock <- accept lsock - putStrLn "Accepted socket." - _ <- forkIO (handleClient sock state) - _ <- forkIO (addHost ns (sockRemoteHost sock) (lastHosts state)) - return () + lsock <- listen ns undefined 80 `catch` handler + forever $ do + sock <- accept lsock + putStrLn "Accepted socket." + forkIO (handleClient sock state) + forkIO (addHost ns (sockRemoteHost sock) (lastHosts state)) + return () where handler ListenError{} = @@ -115,9 +117,9 @@ case mreq of Left err -> putStrLn ("ReqERROR: " ++ show err) Right req -> - do bod <- buildBody req state + do body <- buildBody req state putStrLn "Built response" - let lenstr = show (length bod) + let lenstr = show (length body) keepAlive = [ mkHeader HdrConnection "keep-alive" | hdr <- retrieveHeaders HdrConnection req , map toLower (hdrValue hdr) == "keep-alive" ] @@ -129,7 +131,7 @@ , rspHeaders = mkHeader HdrContentLength lenstr : mkHeader HdrContentType "text/html" : conn - , rspBody = bod + , rspBody = body } respondHTTP sock resp if null keepAlive @@ -137,7 +139,7 @@ else handleClient sock state buildBody :: Request String -> ServerState -> IO String -buildBody _req state = +buildBody req state = do numReqs <- modifyMVar (responseCount state) (\ x -> return (x + 1, x)) prevHosts <- readMVar (lastHosts state) putStrLn ("prevHosts: " ++ show prevHosts ++ "\n") @@ -158,7 +160,7 @@ li $ hans >> " to talk to you over TCP." li $ do http >> " (modified to use the " >> network_hans " shim) to understand your request and respond to it." - li $ do blaze >> " (which built out of the box) to generate this " + li $ do blaze >> " (which built out of the box) to generate this " "pretty HTML." li $ do "... and a host of other libraries to do other, more " "standard, things."