hans 2.4.0.0 → 2.4.0.1

raw patch · 23 files changed

+563/−328 lines, 23 filesdep +networkdep +stmdep ~basedep ~bytestringdep ~containersnew-component:exe:echo-clientnew-component:exe:tcp-test-clientPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network, stm

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

API changes (from Hackage documentation)

Files

• echo-client/Main.hs +73/−0
• hans.cabal +33/−4
• src/Hans/DhcpClient.hs +65/−18
• src/Hans/Layer.hs +12/−12
• src/Hans/Layer/Arp.hs +6/−6
• src/Hans/Layer/Arp/Table.hs +7/−7
• src/Hans/Layer/Dns.hs +7/−7
• src/Hans/Layer/Ethernet.hs +4/−4
• src/Hans/Layer/IP4.hs +19/−19
• src/Hans/Layer/IP4/Fragmentation.hs +6/−6
• src/Hans/Layer/Icmp4.hs +4/−3
• src/Hans/Layer/Tcp.hs +14/−12
• src/Hans/Layer/Tcp/Handlers.hs +39/−39
• src/Hans/Layer/Tcp/Monad.hs +91/−40
• src/Hans/Layer/Tcp/Socket.hs +33/−11
• src/Hans/Layer/Tcp/Timers.hs +20/−43
• src/Hans/Layer/Tcp/Types.hs +35/−35
• src/Hans/Layer/Tcp/WaitBuffer.hs +4/−11
• src/Hans/Layer/Tcp/Window.hs +8/−8
• src/Hans/Layer/Udp.hs +4/−4
• tcp-test-client/Main.hs +36/−0
• tcp-test/Main.hs +19/−17
• web-server/Main.hs +24/−22

@@ -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.4.0.0+version:        2.4.0.1 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,7 @@ executable tcp-test         main-is:        Main.hs         hs-source-dirs: tcp-test-        ghc-options:    -Wall -threaded+        ghc-options:    -Wall -rtsopts -threaded         build-depends:  base       >= 4.0.0.0 && < 5,                         cereal     >= 0.3.5.2,                         bytestring >= 0.9.1.0,@@ -180,6 +182,33 @@         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,+                        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 tcp-test-client+        main-is:        Main.hs+        hs-source-dirs: tcp-test-client+        if os(HaLVM)+                buildable:          False+        else+                build-depends:      base,+                                    bytestring,+                                    network+  executable test-suite         hs-source-dirs: tests

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

@@ -14,14 +14,14 @@ import Data.Time.Clock.POSIX import MonadLib (StateM(get,set),BaseM(inBase)) import qualified Control.Exception as X-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map  data LayerState i = LayerState-  { lsNow     :: POSIXTime-  , lsState   :: i+  { lsNow     :: !POSIXTime+  , lsState   :: !i   } -data Action = Nop | Action (IO ())+data Action = Nop | Action !(IO ())  instance Monoid Action where   mempty = Nop@@ -35,9 +35,9 @@ runAction (Action m) = m `X.catch` \ se -> print (se :: X.SomeException)  data Result i a-  = Error Action-  | Exit (LayerState i) Action-  | Result (LayerState i) a Action+  = Error !Action+  | Exit !(LayerState i) !Action+  | Result !(LayerState i) !a !Action  -- | Early exit continuation type Exit i r = LayerState i -> Action -> Result i r@@ -67,7 +67,7 @@   loop i = do     a   <- msg     now <- getPOSIXTime-    let res = runLayer (i {lsNow = now }) (k a)+    let res = (runLayer $! i {lsNow = now }) (k a)     _ <- X.evaluate res `X.catch` \ se -> do            putStrLn (name ++ show (se :: X.SomeException))            return res@@ -98,8 +98,8 @@   mplus = (<|>)  instance StateM (Layer i) i where-  get   = Layer (\i0 o0 _ _ k -> k (lsState i0) i0 o0)-  set i = Layer (\i0 o0 _ _ k -> k () (i0 { lsState = i }) o0)+  get   = Layer (\i0 o0 _ _ k -> (k $! lsState i0) i0 o0)+  set i = Layer (\i0 o0 _ _ k -> (k () $! i0 { lsState = i }) o0)  instance BaseM (Layer i) (Layer i) where   inBase = id@@ -118,10 +118,10 @@  {-# INLINE time #-} time :: Layer i POSIXTime-time  = Layer (\i o _ _ k -> k (lsNow i) i o)+time  = Layer (\i o _ _ k -> (k $! lsNow i) i o)  output :: IO () -> Layer i ()-output m = Layer $ \i0 o0 _ _ k -> k () i0 (o0 `mappend` Action m)+output m = Layer $ \i0 o0 _ _ k -> k () i0 $! o0 `mappend` Action m  liftRight :: Either String b -> Layer i b liftRight (Right b)  = return b

@@ -27,7 +27,7 @@ import Control.Monad (forM_,mplus,guard,unless,when) import MonadLib (BaseM(inBase),set,get) import qualified Data.ByteString.Lazy as L-import qualified Data.Map             as Map+import qualified Data.Map.Strict      as Map import qualified Data.ByteString      as S  @@ -69,11 +69,11 @@ type Arp = Layer ArpState  data ArpState = ArpState-  { arpTable    :: ArpTable-  , arpAddrs    :: Map.Map IP4 Mac -- this layer's addresses-  , arpWaiting  :: Map.Map IP4 [Maybe Mac -> IO ()]-  , arpEthernet :: EthernetHandle-  , arpSelf     :: ArpHandle+  { arpTable    :: !ArpTable+  , arpAddrs    :: !(Map.Map IP4 Mac) -- this layer's addresses+  , arpWaiting  :: !(Map.Map IP4 [Maybe Mac -> IO ()])+  , arpEthernet :: {-# UNPACK #-} !EthernetHandle+  , arpSelf     :: {-# UNPACK #-} !ArpHandle   }  emptyArpState :: ArpHandle -> EthernetHandle -> ArpState

@@ -5,7 +5,7 @@  import Control.Arrow (second) import Data.Time.Clock.POSIX (POSIXTime)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map   -- Arp Table -------------------------------------------------------------------@@ -14,15 +14,15 @@ arpEntryTimeout = 60  data ArpEntry-  = ArpEntry    { arpMac     :: Mac-                , arpTimeout :: POSIXTime+  = ArpEntry    { arpMac     :: {-# UNPACK #-} !Mac+                , arpTimeout :: !POSIXTime                 }-  | ArpPending  { arpTimeout :: POSIXTime+  | ArpPending  { arpTimeout :: !POSIXTime                 }  deriving Show  data ArpResult-  = KnownAddress Mac+  = KnownAddress {-# UNPACK #-} !Mac   | Pending   | Unknown @@ -43,8 +43,8 @@ -- | Assumption: there is not already a pending ARP query recorded in the -- ARP table for the given IP address. addPending :: POSIXTime -> IP4 -> ArpTable -> ArpTable-addPending now ip = Map.insert ip ent where-  ent = ArpPending+addPending now ip =+  Map.insert ip ArpPending     { arpTimeout = now + arpEntryTimeout -- FIXME: should queries stay longer?     } 

@@ -38,7 +38,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as L-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map   -- External Interface ----------------------------------------------------------@@ -103,12 +103,12 @@  type Dns = Layer DnsState -data DnsState = DnsState { dnsSelf        :: DnsHandle-                         , dnsUdpHandle   :: UdpHandle-                         , dnsNameServers :: [IP4]-                         , dnsReqId       :: !Word16-                         , dnsQueries     :: Map.Map Word16 DnsQuery-                         , dnsTimeout     :: Milliseconds+data DnsState = DnsState { dnsSelf        :: {-# UNPACK #-} !DnsHandle+                         , dnsUdpHandle   :: {-# UNPACK #-} !UdpHandle+                         , dnsNameServers :: ![IP4]+                         , dnsReqId       :: {-# UNPACK #-} !Word16+                         , dnsQueries     :: !(Map.Map Word16 DnsQuery)+                         , dnsTimeout     :: {-# UNPACK #-} !Milliseconds                          }  emptyDnsState :: DnsHandle -> UdpHandle -> DnsState

@@ -31,7 +31,7 @@ import Control.Monad (mplus) import MonadLib (get,set) import qualified Data.ByteString.Lazy as L-import qualified Data.Map             as Map+import qualified Data.Map.Strict      as Map import qualified Data.ByteString      as S  @@ -96,9 +96,9 @@ type Eth = Layer EthernetState  data EthernetState = EthernetState-  { ethHandlers :: Handlers EtherType Handler-  , ethDevices  :: Map.Map Mac EthernetDevice-  , ethHandle   :: EthernetHandle+  { ethHandlers :: !(Handlers EtherType Handler)+  , ethDevices  :: !(Map.Map Mac EthernetDevice)+  , ethHandle   :: {-# UNPACK #-} !EthernetHandle   }  instance ProvidesHandlers EthernetState EtherType Handler where

@@ -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@@ -72,11 +72,11 @@ type IP = Layer IP4State  data IP4State = IP4State-  { ip4Fragments :: FragmentationTable IP4-  , ip4Routes    :: RoutingTable IP4-  , ip4Handlers  :: Handlers IP4Protocol Handler-  , ip4NextIdent :: Ident-  , ip4ArpHandle :: ArpHandle+  { ip4Fragments :: !(FragmentationTable IP4)+  , ip4Routes    :: !(RoutingTable IP4)+  , ip4Handlers  :: !(Handlers IP4Protocol Handler)+  , ip4NextIdent :: {-# UNPACK #-} !Ident+  , ip4ArpHandle :: {-# UNPACK #-} !ArpHandle   }  instance ProvidesHandlers IP4State IP4Protocol Handler where@@ -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 ()

@@ -9,7 +9,7 @@ import Data.Ord (comparing) import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.ByteString.Lazy as L-import qualified Data.Map             as Map+import qualified Data.Map.Strict      as Map import qualified Data.ByteString      as S  @@ -21,14 +21,14 @@  data Fragments = Fragments   { startTime :: !POSIXTime-  , totalSize :: !Int-  , fragments :: [Fragment]+  , totalSize :: {-# UNPACK #-} !Int+  , fragments :: ![Fragment]   } deriving Show  data Fragment = Fragment-  { fragmentOffset  :: !Int-  , fragmentLength  :: !Int-  , fragmentPayload :: L.ByteString+  { fragmentOffset  :: {-# UNPACK #-} !Int+  , fragmentLength  :: {-# UNPACK #-} !Int+  , fragmentPayload :: !L.ByteString   } deriving (Eq,Show)  instance Ord Fragment where

@@ -18,6 +18,7 @@ import qualified Hans.Layer.IP4 as IP4  import Control.Concurrent (forkIO)+import Control.Monad (unless) import Data.Serialize (runPut,putByteString) import MonadLib (get,set) import qualified Data.ByteString as S@@ -37,8 +38,8 @@   void (forkIO (loopLayer "icmp4" handles (receive h) id))  data Icmp4Handles = Icmp4Handles-  { icmpIp4      :: IP4.IP4Handle-  , icmpHandlers :: [Handler]+  { icmpIp4      :: {-# UNPACK #-} !IP4.IP4Handle+  , icmpHandlers :: ![Handler]   }  type Icmp4 = Layer Icmp4Handles@@ -106,4 +107,4 @@ matchHandlers :: Icmp4Packet -> Icmp4 () matchHandlers pkt = do   s <- get-  output (mapM_ ($ pkt) (icmpHandlers s))+  unless (null (icmpHandlers s)) (output (mapM_ ($ pkt) (icmpHandlers s)))

@@ -18,6 +18,7 @@ import Hans.Utils  import Control.Concurrent (forkIO)+import Control.Monad (when) import Data.Time.Clock.POSIX (getPOSIXTime,POSIXTime) import qualified Data.ByteString as S @@ -30,7 +31,7 @@   addIP4Handler ip4 tcpProtocol (queueTcp tcp)    -- initialize the timers-  send tcp initTimers+  initTimers tcp  -- | Queue a tcp packet. queueTcp :: TcpHandle -> IP4Header -> S.ByteString -> IO ()@@ -43,15 +44,16 @@ -- | Run the tcp action, after updating any internal state. stepTcp :: Tcp () -> Tcp () stepTcp body = do-  now <- time-  modifyHost $ \ host ->-    let diff = now - hostLastUpdate host-        -- increment the ISN at 128KHz-        inc  = round (isnRate * diff)-     in if inc > 0-           then host-             { hostLastUpdate    = now-             , hostInitialSeqNum = hostInitialSeqNum host + inc-             }-           else host+  now        <- time+  lastUpdate <- getLastUpdate+  let diff = now - lastUpdate+      -- increment the ISN at 128KHz+      inc  = round (isnRate * diff)++  when (inc > 0) $+    modifyHost_ $ \ host ->+      host { hostLastUpdate    = now+           , hostInitialSeqNum = hostInitialSeqNum host + inc+           }+   body

@@ -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@@ -44,8 +44,7 @@  noConnection :: IP4 -> TcpHeader -> S.ByteString -> Tcp () noConnection src hdr @ TcpHeader { .. } body =-  do output (putStrLn "no connection")-     if | tcpRst    -> return ()+  do if | tcpRst    -> return ()         | tcpAck    -> sendSegment src (mkRst hdr)                    L.empty         | otherwise -> sendSegment src (mkRstAck hdr (S.length body)) L.empty      finish@@ -100,10 +99,7 @@  segmentArrives :: IP4 -> TcpHeader -> S.ByteString -> Sock () segmentArrives src hdr body =-  do shouldDrop <- modifyTcpSocket (updateTimestamp hdr)-     when shouldDrop discardAndReturn--     whenState Closed (inTcp (noConnection src hdr body))+  do whenState Closed (inTcp (noConnection src hdr body))       whenState Listen $        do when (tcpAck hdr) (rst hdr)@@ -116,6 +112,9 @@           -- wasn't covered by the above two cases.           done +     shouldDrop <- modifyTcpSocket (updateTimestamp hdr)+     when shouldDrop discardAndReturn+      whenState SynSent $        do tcp <- getTcpSocket @@ -143,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@@ -153,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) @@ -177,6 +180,8 @@                      done +          when (not (tcpSyn hdr || tcpRst hdr)) discardAndReturn+      -- make sure that the sequence numbers are valid      checkSequenceNumber hdr body      checkResetBit hdr@@ -220,23 +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) $ do flushQueues-                                            closeSocket-            done--       whenStates [Established,FinWait1,FinWait2,CloseWait] $-         do flushQueues-            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 () @@ -247,8 +242,7 @@     do tcp <- getTcpSocket         when (tcpSeqNum hdr `inRcvWnd` tcp) $-         do flushQueues-            closeSocket+         do closeSocket             done    | otherwise  = return ()@@ -286,7 +280,8 @@                  when (nothingOutstanding tcp) enterTimeWait         whenState LastAck $-         do tcp <- getTcpSocket+         do handleAck hdr+            tcp <- getTcpSocket             when (nothingOutstanding tcp) $ do closeSocket                                                done @@ -296,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 } @@ -356,14 +351,18 @@   do finalizers <- modifyTcpSocket flush      outputS finalizers   where-  flush tcp = (fins,tcp')+  flush tcp = (inFins >> outFins,tcp')     where      -- empty the outgoing buffer, notifying all waiting processes that the send     -- won't happen-    (fins,out') = flushWaiting (tcpOutBuffer tcp)+    (outFins,out') = flushWaiting (tcpOutBuffer tcp) +    -- empty the input buffer+    (inFins, in')  = flushWaiting (tcpInBuffer tcp)+     tcp' = tcp { tcpOutBuffer = out'+               , tcpInBuffer  = in'                }  @@ -372,13 +371,14 @@ -- -- RFC 1323 updateTimestamp :: TcpHeader -> TcpSocket -> (Bool,TcpSocket)-updateTimestamp hdr tcp = (shouldDrop,tcp { tcpTimestamp = ts' })+updateTimestamp hdr tcp +  | shouldDrop = (True, tcp)+  | otherwise  = (False,tcp { tcpTimestamp = ts' })   where   -- when the timestamp check fails from an ack, that's not a syn,ack, mark this   -- packet as one to be dropped.   shouldDrop = not (tcpSyn hdr || tcpRst hdr)-            && isJust (tcpTimestamp tcp)-            && isNothing ts'+            && isJust (tcpTimestamp tcp) /= isJust ts'   ts' = do     ts                     <- tcpTimestamp tcp     OptTimestamp them echo <- findTcpOption OptTagTimestamp hdr

@@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE MultiWayIf #-}  module Hans.Layer.Tcp.Monad where @@ -20,7 +21,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq-import qualified Data.Traversable as T   -- TCP Monad -------------------------------------------------------------------@@ -30,9 +30,9 @@ type Tcp = Layer TcpState  data TcpState = TcpState-  { tcpSelf  :: TcpHandle-  , tcpIP4   :: IP4Handle-  , tcpHost  :: Host+  { tcpSelf  :: {-# UNPACK #-} !TcpHandle+  , tcpIP4   :: {-# UNPACK #-} !IP4Handle+  , tcpHost  :: !Host   }  emptyTcpState :: TcpHandle -> IP4Handle -> POSIXTime -> TcpState@@ -56,19 +56,29 @@ getHost :: Tcp Host getHost  = tcpHost `fmap` get +getLastUpdate :: Tcp POSIXTime+getLastUpdate  = hostLastUpdate `fmap` getHost+ setHost :: Host -> Tcp () setHost host = do   rw <- get-  set $! rw { tcpHost = host }+  host `seq` set rw { tcpHost = host } -modifyHost :: (Host -> Host) -> Tcp ()+modifyHost_ :: (Host -> Host) -> Tcp ()+modifyHost_ f = do+  host <- getHost+  setHost (f host)++modifyHost :: (Host -> (a,Host)) -> Tcp a modifyHost f = do   host <- getHost-  setHost $! f host+  let (a,host') = f host+  setHost host'+  return a  -- | Reset the 2MSL timer on the socket in TimeWait. resetTimeWait2MSL :: SocketId -> Tcp ()-resetTimeWait2MSL sid = modifyHost $ \ host ->+resetTimeWait2MSL sid = modifyHost_ $ \ host ->   host { hostTimeWaits = Map.adjust twReset2MSL sid (hostTimeWaits host) }  getTimeWait :: IP4 -> TcpHeader -> Tcp (Maybe (SocketId,TimeWaitSock))@@ -80,14 +90,19 @@  removeTimeWait :: SocketId -> Tcp () removeTimeWait sid =-  modifyHost $ \ host ->+  modifyHost_ $ \ host ->     host { hostTimeWaits = Map.delete sid (hostTimeWaits host) }  getConnections :: Tcp Connections getConnections  = hostConnections `fmap` getHost +takeConnections :: Tcp Connections+takeConnections  =+  modifyHost $ \ Host { .. } ->+    (hostConnections, Host { hostConnections = Map.empty, .. })+ setConnections :: Connections -> Tcp ()-setConnections cons = modifyHost (\host -> host { hostConnections = cons })+setConnections cons = modifyHost_ (\host -> host { hostConnections = cons })  -- | Lookup a connection, returning @Nothing@ if the connection doesn't exist. lookupConnection :: SocketId -> Tcp (Maybe TcpSocket)@@ -117,7 +132,7 @@ setConnection :: SocketId -> TcpSocket -> Tcp () setConnection ident con   | tcpState con == TimeWait =-    modifyHost $ \ host ->+    modifyHost_ $ \ host ->       host { hostTimeWaits   = addTimeWait con (hostTimeWaits host)            , hostConnections = Map.delete ident (hostConnections host)            }@@ -162,7 +177,7 @@ -- | Increment the initial sequence number by a value. addInitialSeqNum :: TcpSeqNum -> Tcp () addInitialSeqNum sn =-  modifyHost (\host -> host { hostInitialSeqNum = hostInitialSeqNum host + sn })+  modifyHost_ (\host -> host { hostInitialSeqNum = hostInitialSeqNum host + sn })  -- | Allocate a new port for use. allocatePort :: Tcp TcpPort@@ -176,7 +191,7 @@  -- | Release a used port. closePort :: TcpPort -> Tcp ()-closePort port = modifyHost (releasePort port)+closePort port = modifyHost_ (releasePort port)   -- Socket Monad ----------------------------------------------------------------@@ -190,17 +205,16 @@ -- locally.  This gives the ability to simulate `finished`, with the benefit of -- only yielding from the Sock context, not the whole Tcp context. newtype Sock a = Sock-  { unSock :: forall r. TcpSocket -> Escape r -> Next a r-           -> Tcp (TcpSocket,Maybe r)+  { unSock :: forall r. TcpSocket -> Escape r -> Next a r -> Tcp r   } -type Escape r = TcpSocket -> Tcp (TcpSocket,Maybe r)--type Next a r = TcpSocket -> a -> Tcp (TcpSocket, Maybe r)+type Escape r = TcpSocket      -> Tcp r+type Next a r = TcpSocket -> a -> Tcp r  instance Functor Sock where   fmap f m = Sock $ \s  x k -> unSock m s x                   $ \s' a   -> k s' (f a)+  {-# INLINE fmap #-}  instance Applicative Sock where   {-# INLINE pure #-}@@ -217,10 +231,16 @@    m >>= f = Sock $ \ s  x k -> unSock m s x                  $ \ s' a   -> unSock (f a) s' x k+  {-# INLINE (>>=) #-} +  m >> n = Sock $ \ s  x k -> unSock m s  x+                $ \ s' _   -> unSock n s' x k+  {-# INLINE (>>) #-}+ inTcp :: Tcp a -> Sock a inTcp m = Sock $ \ s _ k -> do a <- m                                k s a+{-# INLINE inTcp #-}   -- | Finish early, with no result.@@ -232,19 +252,27 @@   do _ <- runSock tcp sm      return () -runSock' :: TcpSocket -> Sock a -> Tcp TcpSocket-runSock' tcp sm =-  do (tcp',_) <- runSock tcp sm-     return tcp'+runSock :: TcpSocket -> Sock a -> Tcp (Maybe a)+runSock tcp sm =+  do (tcp',mb) <- runSock' tcp sm+     setConnection (tcpSocketId tcp') $! tcp'+     return mb --- | Run the socket action, and increment its internal timestamp value.-runSock :: TcpSocket -> Sock a -> Tcp (TcpSocket,Maybe a)-runSock tcp sm = do+seqMaybe :: Maybe a -> ()+seqMaybe (Just a) = a `seq` ()+seqMaybe Nothing  = ()++-- | Run the socket action, and increment its internal timestamp value.  Do not+-- add it back to the connections map.+runSock' :: TcpSocket -> Sock a -> Tcp (TcpSocket,Maybe a)+runSock' tcp sm = do   now      <- time-  let steppedTcp = tcp { tcpTimestamp = stepTimestamp now `fmap` tcpTimestamp tcp }-  r@(tcp',_) <- unSock sm steppedTcp escapeK nextK-  addConnection (tcpSocketId tcp') tcp'-  return r+  let steppedTcp = tcp { tcpTimestamp =+                           let ts' = stepTimestamp now `fmap` tcpTimestamp tcp+                            in seqMaybe ts' `seq` ts'+                       }+  res@(tcp',_) <- (unSock sm $! steppedTcp) escapeK nextK+  tcp' `seq` return res   where   escapeK s = return (s,Nothing)   nextK s a = return (s,Just a)@@ -253,13 +281,31 @@ -- computation fails. eachConnection :: Sock () -> Tcp () eachConnection m =-  setConnections . removeClosed =<< T.mapM sandbox =<< getConnections+  do cs       <- takeConnections+     (cs',ws) <- sandbox [] [] (Map.elems cs)++     modifyHost_ $ \ Host { .. } ->+       Host { hostConnections = cs'+            , hostTimeWaits   = Map.union ws hostTimeWaits+            , ..+            }+   where    -- Prevent failure in the socket action from leaking out of this scope.  When   -- failure is detected, just return the old TCB-  sandbox tcp = runSock' tcp m `mplus` return tcp+  sandbox active timeWait (tcp:rest) =+    do tcp' <- fmap fst (runSock' tcp m) `mplus` return tcp +       if | tcpState tcp' == TimeWait -> sandbox       active (tcp':timeWait) rest+          | tcpState tcp' == Closed+            && tcpUserClosed tcp'     -> sandbox       active       timeWait  rest+          | otherwise                 -> sandbox (tcp':active)      timeWait  rest++  sandbox active timeWait [] =+    return ( Map.fromList [ (tcpSocketId tcp, tcp)            | tcp <- active ]+           , Map.fromList [ (tcpSocketId tcp, mkTimeWait tcp) | tcp <- timeWait ])+ withConnection :: IP4 -> TcpHeader -> Sock a -> Tcp () withConnection remote hdr m = withConnection' remote hdr m mzero @@ -277,7 +323,7 @@ listeningConnection sid m = do   tcp <- getConnection sid   guard (tcpState tcp == Listen && isAccepting tcp)-  (_,mb) <- runSock tcp m+  mb <- runSock tcp m   return mb  -- | Run a socket operation in the context of the socket identified by the@@ -300,27 +346,29 @@ inParent m = do   mbPid <- getParent   case mbPid of-    Just pid -> inTcp $ do p      <- getConnection pid-                           (_,mb) <- runSock p m+    Just pid -> inTcp $ do p  <- getConnection pid+                           mb <- runSock p m                            return mb     Nothing  -> return Nothing  withChild :: TcpSocket -> Sock a -> Sock (Maybe a)-withChild tcp m = inTcp $ do (_,mb) <- runSock tcp m+withChild tcp m = inTcp $ do mb <- runSock tcp m                              return mb  getTcpSocket :: Sock TcpSocket-getTcpSocket  = Sock (\s _ k -> k s s)+getTcpSocket  = Sock (\s _ k -> k s $! s)+{-# INLINE getTcpSocket #-}  setTcpSocket :: TcpSocket -> Sock ()-setTcpSocket tcp = Sock (\ _ _ k -> k tcp ())+setTcpSocket tcp = Sock (\ _ _ k -> (k $! tcp) ())+{-# INLINE setTcpSocket #-}  getTcpTimers :: Sock TcpTimers getTcpTimers  = tcpTimers `fmap` getTcpSocket  modifyTcpSocket :: (TcpSocket -> (a,TcpSocket)) -> Sock a modifyTcpSocket f = Sock $ \ s _ k -> let (a,s') = f s-                                       in k s' a+                                       in (k $! s') a  modifyTcpSocket_ :: (TcpSocket -> TcpSocket) -> Sock () modifyTcpSocket_ k = modifyTcpSocket (\tcp -> ((), k tcp))@@ -407,8 +455,8 @@ shutdown :: Sock () shutdown  = do   finalize <- modifyTcpSocket $ \ tcp -> -      let (wOut,bufOut) = shutdownWaiting (tcpOutBuffer tcp)-          (wIn,bufIn)   = shutdownWaiting (tcpInBuffer tcp)+      let (wOut,bufOut) = flushWaiting (tcpOutBuffer tcp)+          (wIn,bufIn)   = flushWaiting (tcpInBuffer tcp)        in (wOut >> wIn,tcp { tcpOut       = clearRetransmit (tcpOut tcp)                            , tcpOutBuffer = bufOut                            , tcpInBuffer  = bufIn@@ -420,3 +468,6 @@ closeSocket  = do   shutdown   setState Closed++userClose :: Sock ()+userClose  = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True })

@@ -27,7 +27,7 @@ import Control.Exception (Exception,throwIO) import Control.Monad (mplus) import Data.Int (Int64)-import Data.Maybe (fromMaybe)+import Data.Maybe (isJust) import Data.Typeable (Typeable) import qualified Data.ByteString.Lazy as L @@ -35,7 +35,7 @@ -- Socket Interface ------------------------------------------------------------  data Socket = Socket-  { sockHandle :: TcpHandle+  { sockHandle :: !TcpHandle   , sockId     :: !SocketId   } @@ -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@@ -187,7 +188,7 @@            CloseWait ->             do finAck-               setState TimeWait+               setState LastAck                ok            SynSent ->@@ -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 ---------------------------------------------------------------------@@ -247,14 +246,24 @@  outputBytes :: L.ByteString -> Wakeup -> TcpSocket -> (Maybe Int64, TcpSocket) outputBytes bytes wakeup tcp-  | tcpState tcp == Established = (mbWritten,    tcp { tcpOutBuffer = bufOut })-  | otherwise                   = (Just written, tcp { tcpOutBuffer = flushed })+  | tcpState tcp == Established              = ok+  | tcpState tcp == CloseWait                = ok+  | tcpState tcp `elem` [ Closing, LastAck+                        , FinWait1, FinWait2+                        , TimeWait ]         = bad+  | otherwise                                = bad   where   (mbWritten,bufOut) = writeBytes bytes wakeup (tcpOutBuffer tcp)-  (fin,flushed)      = flushWaiting bufOut-  written            = fromMaybe 0 mbWritten +  -- normal response (add the data to the output buffer, or queue if there's no+  -- space available)+  ok = (mbWritten, tcp { tcpOutBuffer = bufOut }) +  -- the connection is closed, so return that no data was written, and don't+  -- queue a wakeup action+  bad = (Just 0, tcp)++ -- Reading ---------------------------------------------------------------------  -- | True when there are bytes queued to receive.@@ -282,6 +291,19 @@    in performRecv  inputBytes :: Int64 -> Wakeup -> TcpSocket -> (Maybe L.ByteString, TcpSocket)-inputBytes len wakeup tcp = (mbRead, tcp { tcpInBuffer = bufIn })+inputBytes len wakeup tcp+  | tcpState tcp == Established                        = ok+  | tcpState tcp == CloseWait                          = if isJust mbRead+                                                            then ok+                                                            else bad+  | tcpState tcp `elem` [ Closing, LastAck, TimeWait ] = bad+  | otherwise                                          = ok+   where   (mbRead,bufIn) = readBytes len wakeup (tcpInBuffer tcp)++  -- normal behavior (read buffered data, or queue)+  ok = (mbRead, tcp { tcpInBuffer = bufIn })++  -- return that there's no data to read, and don't queue a wakeup action+  bad = (Just L.empty, tcp)

@@ -12,12 +12,10 @@   ) where  import Hans.Channel-import Hans.Layer import Hans.Layer.Tcp.Messages import Hans.Layer.Tcp.Monad import Hans.Layer.Tcp.Types import Hans.Layer.Tcp.Window-import Hans.Timers (Milliseconds)  import Control.Concurrent (forkIO,threadDelay) import Control.Monad (when,unless,forever,void)@@ -27,41 +25,37 @@  -- Timer Handlers -------------------------------------------------------------- --- | Schedule a @Tcp@ action to run every n milliseconds.------ XXX we should investigate timing the time that body takes to run, and making--- the decision about how long to delay based on that.-every :: Milliseconds -> Tcp () -> Tcp ()-every len body = do-  tcp <- self-  let timeout = len * 1000-  output $ void $ forkIO $ forever $-    do threadDelay timeout-       send tcp body- -- | Schedule the timers to run on the fast and slow intervals.-initTimers :: Tcp ()-initTimers  = do+initTimers :: TcpHandle -> IO ()+initTimers tcp = do   every 500 slowTimer   every 200 fastTimer +  where++  -- XXX we should investigate timing the time that body takes to run, and+  -- making the decision about how long to delay based on that.+  every n body = void $ forkIO $ forever $+    do threadDelay timeout+       send tcp body+    where+    timeout = n * 1000+ -- | Fires every 500ms. slowTimer :: Tcp () slowTimer  =   do -- first, handle active connections      eachConnection $ do-       -- the slow timer is valid for all states but TimeWait-       do TcpSocket { .. } <- getTcpSocket-          unless (tcpState == TimeWait) $-            do handleRTO-               handleFinWait2--          handle2MSL--          updateTimers+       -- 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       -- second, decrement the 2MSL timer for sockets in the TimeWait state-     modifyHost $ \ host ->+     modifyHost_ $ \ host ->        host { hostTimeWaits = stepTimeWaitConnections (hostTimeWaits host) }  resetIdle :: Sock ()@@ -127,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 ------------------------------------------------------------------------- 

@@ -21,11 +21,11 @@ -- Hosts Information -----------------------------------------------------------  data Host = Host-  { hostConnections   :: Connections-  , hostTimeWaits     :: TimeWaitConnections-  , hostInitialSeqNum :: !TcpSeqNum+  { hostConnections   :: !Connections+  , hostTimeWaits     :: !TimeWaitConnections+  , hostInitialSeqNum :: {-# UNPACK #-} !TcpSeqNum   , hostPorts         :: !(PortManager TcpPort)-  , hostLastUpdate    :: POSIXTime+  , hostLastUpdate    :: !POSIXTime   }  emptyHost :: POSIXTime -> Host@@ -58,9 +58,9 @@   Map.filter (\tcp -> tcpState tcp /= Closed || not (tcpUserClosed tcp))  data SocketId = SocketId-  { sidLocalPort  :: !TcpPort-  , sidRemotePort :: !TcpPort-  , sidRemoteHost :: !IP4+  { sidLocalPort  :: {-# UNPACK #-} !TcpPort+  , sidRemotePort :: {-# UNPACK #-} !TcpPort+  , sidRemoteHost :: {-# UNPACK #-} !IP4   } deriving (Eq,Show,Ord)  emptySocketId :: SocketId@@ -94,14 +94,14 @@ -- | The socket that's in TimeWait, plus its current 2MSL value. type TimeWaitConnections = Map.Map SocketId TimeWaitSock -data TimeWaitSock = TimeWaitSock { tw2MSL      :: !SlowTicks+data TimeWaitSock = TimeWaitSock { tw2MSL      :: {-# UNPACK #-} !SlowTicks                                    -- ^ The current 2MSL value-                                 , twInit2MSL  :: !SlowTicks+                                 , twInit2MSL  :: {-# UNPACK #-} !SlowTicks                                    -- ^ The initial 2MSL value-                                 , twSeqNum    :: !TcpSeqNum+                                 , twSeqNum    :: {-# UNPACK #-} !TcpSeqNum                                    -- ^ The sequence number to use when                                    -- responding to messages-                                 , twTimestamp :: Maybe Timestamp+                                 , twTimestamp :: !(Maybe Timestamp)                                    -- ^ The last timestamp used                                  } deriving (Show) @@ -143,16 +143,16 @@   { ttDelayedAck :: !Bool      -- 2MSL-  , tt2MSL       :: !SlowTicks+  , tt2MSL       :: {-# UNPACK #-} !SlowTicks      -- retransmit timer-  , ttRTO        :: !SlowTicks+  , ttRTO        :: {-# UNPACK #-} !SlowTicks   , ttSRTT       :: !POSIXTime   , ttRTTVar     :: !POSIXTime      -- idle timer-  , ttMaxIdle    :: !SlowTicks-  , ttIdle       :: !SlowTicks+  , ttMaxIdle    :: {-# UNPACK #-} !SlowTicks+  , ttIdle       :: {-# UNPACK #-} !SlowTicks   }  emptyTcpTimers :: TcpTimers@@ -171,8 +171,8 @@  -- | Manage the timestamp values that are in flight between two hosts. data Timestamp = Timestamp-  { tsTimestamp     :: !Word32-  , tsLastTimestamp :: !Word32+  { tsTimestamp     :: {-# UNPACK #-} !Word32+  , tsLastTimestamp :: {-# UNPACK #-} !Word32   , tsGranularity   :: !POSIXTime -- ^ Hz   , tsLastUpdate    :: !POSIXTime   } deriving (Show)@@ -211,28 +211,28 @@ type Close = IO ()  data TcpSocket = TcpSocket-  { tcpParent      :: Maybe SocketId-  , tcpSocketId    :: !SocketId+  { tcpParent      :: !(Maybe SocketId)+  , tcpSocketId    :: {-# UNPACK #-} !SocketId   , tcpState       :: !ConnState-  , tcpAcceptors   :: Seq.Seq Acceptor-  , tcpNotify      :: Maybe Notify-  , tcpIss         :: !TcpSeqNum-  , tcpSndNxt      :: !TcpSeqNum-  , tcpSndUna      :: !TcpSeqNum+  , tcpAcceptors   :: !(Seq.Seq Acceptor)+  , tcpNotify      :: !(Maybe Notify)+  , tcpIss         :: {-# UNPACK #-} !TcpSeqNum+  , tcpSndNxt      :: {-# UNPACK #-} !TcpSeqNum+  , tcpSndUna      :: {-# UNPACK #-} !TcpSeqNum -  , tcpUserClosed  :: Bool-  , tcpOut         :: RemoteWindow-  , tcpOutBuffer   :: Buffer Outgoing-  , tcpOutMSS      :: !Int64-  , tcpIn          :: LocalWindow-  , tcpInBuffer    :: Buffer Incoming-  , tcpInMSS       :: !Int64+  , tcpUserClosed  :: !Bool+  , tcpOut         :: !RemoteWindow+  , tcpOutBuffer   :: !(Buffer Outgoing)+  , tcpOutMSS      :: {-# UNPACK #-} !Int64+  , tcpIn          :: !LocalWindow+  , tcpInBuffer    :: !(Buffer Incoming)+  , tcpInMSS       :: {-# UNPACK #-} !Int64 -  , tcpTimers      :: !TcpTimers-  , tcpTimestamp   :: Maybe Timestamp+  , tcpTimers      :: {-# UNPACK #-} !TcpTimers+  , tcpTimestamp   :: !(Maybe Timestamp) -  , tcpSack        :: Bool-  , tcpWindowScale :: Bool+  , tcpSack        :: !Bool+  , tcpWindowScale :: !Bool   }  emptyTcpSocket :: Word16 -> Int -> TcpSocket

@@ -12,7 +12,6 @@     -- * Directed Buffers   , Buffer   , emptyBuffer-  , shutdownWaiting   , isFull   , isEmpty   , flushWaiting@@ -56,10 +55,10 @@  -- | Data Buffers, in a direction. data Buffer d = Buffer-  { bufBytes     :: L.ByteString-  , bufWaiting   :: Seq.Seq Wakeup-  , bufSize      :: !Int64-  , bufAvailable :: !Int64+  { bufBytes     :: !L.ByteString+  , bufWaiting   :: !(Seq.Seq Wakeup)+  , bufSize      :: {-# UNPACK #-} !Int64+  , bufAvailable :: {-# UNPACK #-} !Int64   }  -- | An empty buffer, with a limit.@@ -115,12 +114,6 @@         , bufAvailable = bufAvailable buf + L.length bytes         }   return (bytes,buf')---- | Run all waiting continuations with a parameter of False, -shutdownWaiting :: Buffer d -> (IO (), Buffer d)-shutdownWaiting buf = (m,buf { bufWaiting = Seq.empty })-  where-  m = F.mapM_ abort (bufWaiting buf)   -- Sending Buffer --------------------------------------------------------------

@@ -23,11 +23,11 @@  -- | Remote window management. data RemoteWindow = RemoteWindow-  { rwSegments     :: OutSegments-  , rwAvailable    :: !Word32-  , rwSize         :: !Word32-  , rwSndWind      :: !Word16-  , rwSndWindScale :: !Int+  { rwSegments     :: !OutSegments+  , rwAvailable    :: {-# UNPACK #-} !Word32+  , rwSize         :: {-# UNPACK #-} !Word32+  , rwSndWind      :: {-# UNPACK #-} !Word16+  , rwSndWindScale :: {-# UNPACK #-} !Int   } deriving (Show)  -- | The empty window, seeded with an initial size.@@ -122,10 +122,10 @@  -- | A delivered segment. data OutSegment = OutSegment-  { outAckNum :: !TcpSeqNum+  { outAckNum :: {-# UNPACK #-} !TcpSeqNum   , outTime   :: !POSIXTime-  , outFresh  :: Bool       -- ^ Whether or not this is a retransmission-  , outRTO    :: !Int       -- ^ Retransmit timer for this segment+  , outFresh  :: !Bool               -- ^ Whether or not this is a retransmission+  , outRTO    :: {-# UNPACK #-} !Int -- ^ Retransmit timer for this segment   , outHeader :: !TcpHeader   , outBody   :: !L.ByteString   } deriving (Show)

@@ -123,10 +123,10 @@ type Udp = Layer UdpState  data UdpState = UdpState-  { udpPorts       :: PortManager UdpPort-  , udpHandlers    :: Handlers UdpPort Handler-  , udpIp4Handle   :: IP4.IP4Handle-  , udpIcmp4Handle :: Icmp4.Icmp4Handle+  { udpPorts       :: !(PortManager UdpPort)+  , udpHandlers    :: !(Handlers UdpPort Handler)+  , udpIp4Handle   :: {-# UNPACK #-} !IP4.IP4Handle+  , udpIcmp4Handle :: {-# UNPACK #-} !Icmp4.Icmp4Handle   }  emptyUdp4State :: IP4.IP4Handle -> Icmp4.Icmp4Handle -> UdpState

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import           Control.Concurrent (forkIO,killThread,threadDelay)+import qualified Control.Exception as X+import           Control.Monad (replicateM,when)+import qualified Data.ByteString.Char8 as S+import qualified Data.Foldable as F+import           Network (withSocketsDo,connectTo,PortID(..))+import           System.Environment (getArgs)+import           System.IO (hPutStrLn,hGetLine,hClose)++main = withSocketsDo $+  do [addr]  <- getArgs++     X.bracket (replicateM 100 (forkClient addr))+               (mapM_ killThread) $ \ _ ->++       do _ <- getLine+          return ()++forkClient addr =+  do tid <- forkIO (createClient addr)+     threadDelay (100 * 1000)+     return tid++createClient addr =+  X.bracket (connectTo addr (PortNumber 9001)) hClose $ \ conn ->+    F.forM_ (cycle ["foo", "bar", "baz", "ASDF"]) $ \ str ->+      do S.hPutStrLn conn str+         str' <- S.hGetLine conn+         when (str /= str') $+           do putStrLn "Invalid echo server response:"+              putStr   "  expected: " >> S.putStrLn str+              putStr   "  received: " >> S.putStrLn str'

@@ -18,18 +18,19 @@ 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  localAddr :: IP4 localAddr  = IP4 192 168 90 2  main :: IO () main  = do+   ns  <- newNetworkStack   mac <- initEthernetDevice ns   deviceUp ns mac@@ -38,20 +39,21 @@   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 -             server ns       else do setAddress mac ns-             server ns +  server ns+ server :: NetworkStack -> IO () server ns = do   sock <- listen ns localAddr 9001@@ -65,13 +67,13 @@ handleClient :: Socket -> IO () handleClient conn =   do putStrLn ("Got one: " ++ show (sockRemoteHost conn))-     loop+     loop `X.catch` \se -> do print (se :: X.SomeException)+                              close conn   where   loop =     do buf <- recvBytes conn 512        if L.null buf-          then do putStrLn "Client closed connection"-                  close conn+          then    putStrLn "Client closed connection"           else do _ <- sendBytes conn buf                   loop @@ -96,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

@@ -1,6 +1,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-} -- Copyright 2014 Galois, Inc. -- This software is distributed under a standard, three-clause BSD license. -- Please see the file LICENSE, distributed with this software, for specific@@ -14,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@@ -25,15 +25,16 @@ import Network.HTTP.Base import Network.HTTP.Headers import Network.HTTP.Stream-import Network.Stream import System.Exit import System.Info-import System.Locale-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+#endif+ instance Stream Socket where   readLine s = loop ""    where loop acc =@@ -42,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@@ -88,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{} =@@ -113,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" ]@@ -127,7 +129,7 @@                            , rspHeaders = mkHeader HdrContentLength lenstr                                         : mkHeader HdrContentType   "text/html"                                         : conn-                           , rspBody = body+                           , rspBody = bod                            }             respondHTTP sock resp             if null keepAlive@@ -135,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")@@ -156,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."