hans 2.5.0.0 → 2.6.0.0

raw patch · 10 files changed

+235/−122 lines, 10 filesdep +stmdep ~basedep ~bytestringdep ~containersnew-component:exe:echo-clientPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

Dependency ranges changed: base, bytestring, containers, old-locale

API changes (from Hackage documentation)

Files

• echo-client/Main.hs +73/−0
• hans.cabal +22/−4
• src/Hans/DhcpClient.hs +65/−18
• src/Hans/Layer/IP4.hs +14/−14
• src/Hans/Layer/Tcp/Handlers.hs +21/−23
• src/Hans/Layer/Tcp/Monad.hs +3/−0
• src/Hans/Layer/Tcp/Socket.hs +2/−3
• src/Hans/Layer/Tcp/Timers.hs +4/−25
• tcp-test/Main.hs +12/−14
• web-server/Main.hs +19/−21

@@ -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

@@ -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,

@@ -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 ()

@@ -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 ()

@@ -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 } 

@@ -468,3 +468,6 @@ closeSocket  = do   shutdown   setState Closed++userClose :: Sock ()+userClose  = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True })

@@ -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 ---------------------------------------------------------------------

@@ -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 ------------------------------------------------------------------------- 

@@ -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

@@ -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."