diff --git a/echo-client/Main.hs b/echo-client/Main.hs new file mode 100644 --- /dev/null +++ b/echo-client/Main.hs @@ -0,0 +1,73 @@ +{-# 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.5.0.0 +version: 2.6.0.0 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -60,7 +60,8 @@ containers >= 0.3.0.0, monadLib >= 3.6.0, time >= 1.1.0.0, - fingertree >= 0.0.1.0 + fingertree >= 0.0.1.0, + stm >= 2.4 if flag(word32-in-random) build-depends: random >= 1.0.1.0 @@ -144,7 +145,8 @@ executable web-server main-is: Main.hs hs-source-dirs: web-server - ghc-options: -Wall -threaded -rtsopts + ghc-options: -Wall -threaded -rtsopts -fno-warn-unused-do-bind + -fno-warn-orphans if os(HaLVM) buildable: False @@ -168,7 +170,23 @@ executable tcp-test main-is: Main.hs hs-source-dirs: tcp-test - ghc-options: -Wall -threaded -rtsopts + 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 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,7 +16,8 @@ import Hans.NetworkStack import Hans.Timers (delay_) -import Control.Monad (guard) +import Control.Monad (guard,unless) +import Control.Concurrent.STM import Data.Maybe (fromMaybe,mapMaybe) import System.Random (randomIO) import qualified Data.ByteString as S @@ -45,22 +46,66 @@ -- 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 -> AckHandler -> IO () -dhcpDiscover ns mac h = do + => stack -> Mac -> IO (Maybe IP4) +dhcpDiscover ns mac = do + addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) + + offerTMV <- newEmptyTMVarIO + addUdpHandler ns bootpc (handleOffer ns offerTMV) + w32 <- randomIO let xid = Xid (fromIntegral (w32 :: Int)) + disc = discoverToMessage (mkDiscover xid mac) - addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) - addUdpHandler ns bootpc (handleOffer ns (Just h)) + -- waitResult sends our DHCP discover and waits for an offer. + mbOffer <- waitResult retries disc offerTMV + case mbOffer of - let disc = discoverToMessage (mkDiscover xid mac) - sendMessage ns disc currentNetwork broadcastIP4 broadcastMac + -- 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 + + -- 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) + -- | Restore the connection between the Ethernet and IP4 layers. restoreIp4 :: (HasEthernet stack, HasIP4 stack) => stack -> IO () restoreIp4 ns = connectEthernet (ip4Handle ns) (ethernetHandle ns) @@ -83,21 +128,18 @@ -- | Handle a DHCP Offer message. -- -- * Remove the current UDP handler --- * Install an DHCP Ack handler --- * Send a DHCP Request +-- * Write offer to TMV for retrieval. handleOffer :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) - => stack -> Maybe AckHandler -> IP4 -> UdpPort + => stack -> TMVar Offer -> IP4 -> UdpPort -> S.ByteString -> IO () -handleOffer ns mbh _src _srcPort bytes = +handleOffer ns tmv _src _srcPort bytes = case getDhcp4Message bytes of Right msg -> case parseDhcpMessage msg of Just (Right (OfferMessage offer)) -> do removeUdpHandler ns bootpc - let req = requestToMessage (offerToRequest offer) - addUdpHandler ns bootpc (handleAck ns offer mbh) - sendMessage ns req currentNetwork broadcastIP4 broadcastMac + atomically $ putTMVar tmv offer msg1 -> do putStrLn (show msg) @@ -107,6 +149,11 @@ -- | 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 @@ -115,7 +162,7 @@ -- has passed handleAck :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack , HasDns stack ) - => stack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort + => stack -> Offer -> Maybe (IP4 -> IO ()) -> IP4 -> UdpPort -> S.ByteString -> IO () handleAck ns offer mbh _src _srcPort bytes = case getDhcp4Message bytes of @@ -142,7 +189,7 @@ -- -- * Re-install the DHCP IP4 handler -- * Add a UDP handler for an Ack message --- * Re-send a renquest message, generated from the offer given. +-- * Re-send a request 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,mplus,(<=<)) +import Control.Monad (guard, (<=<)) 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 -forward :: IP4Header -> L.ByteString -> IP () -forward hdr body = do +-- Route a packet that is forwardable. +-- XXX Hide this facility behind configuration +_forward :: IP4Header -> L.ByteString -> IP () +_forward hdr body = do rule@(src,_,_) <- findRoute (ip4DestAddr hdr) guard (src /= ip4SourceAddr hdr) sendPacket' hdr body rule @@ -138,23 +138,21 @@ 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 `mplus` broadcastDestination dest + localAddress dest h <- getHandler (ip4Protocol hdr) mb <- handleFragments hdr body case mb of @@ -194,7 +192,9 @@ -- forward? let payload = S.take (plen - hlen) rest - routeLocal hdr payload `mplus` forward hdr (chunk payload) + routeLocal hdr payload + -- XXX Hide this old router functionality behind a setting + -- `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,isNothing) +import Data.Maybe (fromMaybe,isJust) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Foldable as F @@ -142,8 +142,7 @@ -- check SYN when (tcpSyn hdr) $ - do advanceRcvNxt 1 - modifyTcpSocket_ $ \ sock -> sock + do modifyTcpSocket_ $ \ sock -> sock { tcpOutMSS = fromMaybe (tcpInMSS sock) (getMSS hdr) -- clear out, and configure the retransmit buffer @@ -152,20 +151,25 @@ $ clearRetransmit $ tcpOut sock - -- this corresponds to setting IRS to SEQ.SEG - , tcpIn = emptyLocalWindow (tcpSeqNum hdr) 14600 0 + -- this corresponds to setting IRS to SEQ.SEG, and advancing + -- RCV.NXT by one + , tcpIn = emptyLocalWindow (tcpSeqNum hdr + 1) 14600 0 , tcpSack = sackSupported hdr , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr) } when (tcpAck hdr) $ - do handleAck hdr -- update SND.UNA + do -- advance SND.UNA + modifyTcpSocket_ $ \ sock -> sock + { tcpSndUna = tcpAckNum hdr } + TcpSocket { .. } <- getTcpSocket if tcpSndUna > tcpIss then do ack - establishConnection notify True + setState Established + -- continue at step 6 when (tcpUrg hdr) (proceedFromStep6 hdr body) @@ -176,6 +180,8 @@ done + when (not (tcpSyn hdr || tcpRst hdr)) discardAndReturn + -- make sure that the sequence numbers are valid checkSequenceNumber hdr body checkResetBit hdr @@ -219,21 +225,13 @@ -- | Process the presence of the RST bit checkResetBit :: TcpHeader -> Sock () checkResetBit hdr - | 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 + | tcpRst hdr = do + TcpSocket { .. } <- getTcpSocket + whenStates [ SynReceived, Established, FinWait1, FinWait2 + , CloseWait, Closing, LastAck] $ + do notify False + closeSocket + done | otherwise = return () @@ -293,7 +291,7 @@ processSegmentText hdr body = whenStates [Established,FinWait1,FinWait2] $ do if S.null body - -- make sure that the the delayed ack flag gets set + -- make sure that 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,3 +468,6 @@ 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,8 +100,9 @@ } else socketError ConnectionRefused , tcpState = Listen - , tcpSndNxt = isn + , tcpSndNxt = isn + 1 , tcpSndUna = isn + , tcpIss = isn , tcpTimestamp = Just (emptyTimestamp now) } -- XXX how should the retry/backoff be implemented @@ -215,8 +216,6 @@ -- 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,14 +49,10 @@ -- 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. - do TcpSocket { .. } <- getTcpSocket - unless (tcpState == TimeWait) $ - do handleRTO - handleFinWait2 - - handle2MSL - - updateTimers + TcpSocket { .. } <- getTcpSocket + unless (tcpState == TimeWait) handleRTO + handle2MSL + updateTimers -- second, decrement the 2MSL timer for sockets in the TimeWait state modifyHost_ $ \ host -> @@ -125,23 +121,6 @@ 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,16 +18,13 @@ import Hans.Device.Tap #endif -import Control.Concurrent (newEmptyMVar,putMVar,takeMVar,threadDelay,forkIO - ,killThread,myThreadId) -import Control.Monad (forever,when) +import Control.Concurrent (threadDelay,forkIO) + +import Control.Monad (forever) 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 @@ -42,14 +39,15 @@ args <- getArgs if args == ["dhcp"] then do putStrLn "Discovering address" - res <- newEmptyMVar - dhcpDiscover ns mac (putMVar res) - ip <- takeMVar res - putStrLn ("Bound to address: " ++ show ip) + mbIP <- dhcpDiscover ns mac + case mbIP of + Nothing -> putStrLn "Couldn't get an IP address." + Just ip -> do + 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 @@ -100,7 +98,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,7 +15,6 @@ import Data.Time import Data.Version import Data.Word -import GHC.Stats import Hans.Address.Mac import Hans.Address.IP4 import Hans.Device.Tap @@ -26,13 +25,11 @@ 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) +import Text.Blaze.Html5 as H hiding (map, main) 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 @@ -46,7 +43,7 @@ | BS.head bstr == 10 -> return (Right (acc ++ "\n")) | otherwise -> loop (acc ++ BSC.unpack bstr) - readBlock s x = loop (fromIntegral x) BS.empty + readBlock s y = loop (fromIntegral y) BS.empty where loop 0 acc = return (Right (BSC.unpack acc)) loop x acc = do bstr <- recvBytes s x @@ -92,18 +89,19 @@ deviceUp ns mac putStrLn ("Starting server on device " ++ show mac) - ipMV <- newEmptyMVar - dhcpDiscover ns mac (putMVar ipMV) - ipaddr <- takeMVar ipMV - putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr) + 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) - 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{} = @@ -117,9 +115,9 @@ case mreq of Left err -> putStrLn ("ReqERROR: " ++ show err) Right req -> - do body <- buildBody req state + do bod <- buildBody req state putStrLn "Built response" - let lenstr = show (length body) + let lenstr = show (length bod) keepAlive = [ mkHeader HdrConnection "keep-alive" | hdr <- retrieveHeaders HdrConnection req , map toLower (hdrValue hdr) == "keep-alive" ] @@ -131,7 +129,7 @@ , rspHeaders = mkHeader HdrContentLength lenstr : mkHeader HdrContentType "text/html" : conn - , rspBody = body + , rspBody = bod } respondHTTP sock resp if null keepAlive @@ -139,7 +137,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") @@ -160,7 +158,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."