hans 2.4.0.1 → 2.5.0.0

raw patch · 10 files changed

+122/−235 lines, 10 filesdep −stmdep ~basedep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: stm

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

API changes (from Hackage documentation)

Files

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

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

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

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

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

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

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

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

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

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

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