hans 3.0.1 → 3.0.2

raw patch · 11 files changed

+129/−104 lines, 11 filesdep +SHAdep −cryptonitedep −memorydep ~heapsPVP ok

version bump matches the API change (PVP)

Dependencies added: SHA

Dependencies removed: cryptonite, memory

Dependency ranges changed: heaps

API changes (from Hackage documentation)

Files

• hans.cabal +3/−4
• src/Hans/Device/Xen.hs +10/−6
• src/Hans/HashTable.hs +21/−6
• src/Hans/IP4/ArpTable.hs +1/−1
• src/Hans/IP4/Dhcp/Client.hs +1/−1
• src/Hans/Monad.hs +7/−0
• src/Hans/Tcp/Input.hs +70/−71
• src/Hans/Tcp/RecvWindow.hs +4/−3
• src/Hans/Tcp/State.hs +4/−11
• src/Hans/Tcp/Tcb.hs +7/−0
• src/Hans/Tcp/Timers.hs +1/−1

@@ -1,5 +1,5 @@ name:           hans-version:        3.0.1+version:        3.0.2 cabal-version:  >= 1.18 license:        BSD3 license-file:   LICENSE@@ -43,7 +43,7 @@         hs-source-dirs:         src         build-depends:          base       >= 4.0.0.0 && < 5,                                 cereal     >= 0.5.0.0,-                                heaps,+                                heaps      <= 0.3.3,                                 psqueues,                                 bytestring,                                 containers,@@ -54,8 +54,7 @@                                 BoundedChan,                                 random,                                 monadLib,-                                cryptonite,-                                memory+                                SHA          -- XXX: which of these should be exposed?         exposed-modules:        Hans

@@ -10,14 +10,15 @@ import           Control.Concurrent (newMVar,modifyMVar_,killThread) import           Control.Concurrent.BoundedChan                      (BoundedChan,newBoundedChan,tryWriteChan,readChan)+import           Control.Exception(try) import           Control.Monad (forever) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L+import           Hypervisor.ErrorCodes(ErrorCode) import           Hypervisor.XenStore (XenStore) import           XenDevice.NIC (NIC,listNICs,openNIC,setReceiveHandler,sendPacket) - listDevices :: XenStore -> IO [DeviceName] listDevices xs =   do nics <- listNICs xs@@ -73,12 +74,15 @@ -- NOTE: No way to update stats here, as we can't tell if sendPacket failed. xenSendLoop :: DeviceStats -> NIC -> BoundedChan L.ByteString -> IO () xenSendLoop stats nic chan = forever $-  do bs <- readChan chan-     sendPacket nic bs+  do bs  <- readChan chan+     res <- try $ sendPacket nic bs -     -- NOTE: sendPacket always succeeds-     updateBytes   statTX stats (fromIntegral (L.length bs))-     updatePackets statTX stats+     case res :: Either ErrorCode () of+       Right () ->+         do updateBytes   statTX stats (fromIntegral (L.length bs))+            updatePackets statTX stats+       Left _ ->+            updateError   statTX stats  xenRecv :: NetworkStack -> Device -> L.ByteString -> IO () xenRecv ns dev @ Device { .. } = \ bytes ->

@@ -31,8 +31,19 @@  type Bucket k a = IORef [(k,a)] +cons' :: a -> [a] -> [a]+cons' h tl = h `seq` tl `seq` (h:tl)+{-# INLINE cons' #-} +nfList :: [a] -> ()+nfList []       = ()+nfList (a:rest) = a `seq` nfList rest+{-# INLINE nfList #-} +nfListId :: [a] -> [a]+nfListId xs = nfList xs `seq` xs+{-# INLINE nfListId #-}+ -- | Create a new hash table with the given size. newHashTable :: (Eq k, Hashable k) => Int -> IO (HashTable k a) newHashTable htSize =@@ -50,10 +61,13 @@         | otherwise   = return () {-# INLINE mapBuckets #-} - filterHashTable :: (Eq k, Hashable k)                 => (k -> a -> Bool) -> HashTable k a -> IO ()-filterHashTable p = mapBuckets (filter (uncurry p))+filterHashTable p = mapBuckets go+  where+  go []                         = []+  go (x@(k,a):rest) | p k a     = cons' x (go rest)+                    | otherwise = go rest {-# INLINE filterHashTable #-}  -- | Monadic mapping over the values of a hash table.@@ -69,9 +83,10 @@ {-# INLINE mapHashTableM_ #-}  mapHashTable :: (Eq k, Hashable k) => (k -> a -> a) -> HashTable k a -> IO ()-mapHashTable f = mapBuckets (map f')+mapHashTable f = mapBuckets go   where-  f' (k,a) = (k, f k a)+  go []           = []+  go ((k,a):rest) = cons' ((,) k $! f k a) (go rest) {-# INLINE mapHashTable #-}  getBucket :: Hashable k => HashTable k a -> k -> Bucket k a@@ -92,7 +107,7 @@ {-# INLINE lookup #-}  delete :: (Eq k, Hashable k) => k -> HashTable k a -> IO ()-delete k ht = modifyBucket ht k (\ bucket -> (removeEntry bucket, ()))+delete k ht = modifyBucket ht k (\ bucket -> (nfListId (removeEntry bucket), ()))    where @@ -138,7 +153,7 @@ -- behaviors all perform slightly better. alter :: (Eq k, Hashable k)        => (Maybe a -> (Maybe a, b)) -> k -> HashTable k a -> IO b-alter f k ht = modifyBucket ht k (update id)+alter f k ht = modifyBucket ht k (update nfListId)   where    update mkBucket (e@(k',a):rest)

@@ -41,7 +41,7 @@ -- -- INVARIANT: there should never be entries in the map that aren't also in the -- heap.-data ArpTable = ArpTable { atMacs        :: HT.HashTable IP4 Entry+data ArpTable = ArpTable { atMacs        :: !(HT.HashTable IP4 Entry)                          , atLifetime    :: !NominalDiffTime                          , atPurgeThread :: !ThreadId                          }

@@ -171,7 +171,7 @@ -- | Perform a DHCP Renew. renew :: NetworkStack -> DhcpConfig -> Device -> Offer -> IO () renew ns cfg dev offer =-  do sock <- newUdpSocket ns defaultSocketConfig (Just dev) WildcardIP4 (Just bootps)+  do sock <- newUdpSocket ns defaultSocketConfig (Just dev) WildcardIP4 (Just bootpc)      _    <- dhcpRequest cfg dev sock offer       return ()

@@ -4,6 +4,7 @@     Hans()   , runHans, runHansOnce   , setEscape, escape, dropPacket+  , callCC   , io   , decode, decode'   ) where@@ -72,6 +73,12 @@ escape :: Hans a escape  = Hans (\ e _ -> e) {-# INLINE escape #-}++-- | Call-cc. NOTE: the continuation will inherit the escape point of the+-- calling context.+callCC :: ((b -> Hans a) -> Hans b) -> Hans b+callCC f = Hans (\e k -> unHans (f (\b -> Hans (\_ _ -> k b))) e k)+{-# INLINE callCC #-}  -- | Synonym for 'escape' that also updates device statistics. dropPacket :: DeviceStats -> Hans a

@@ -158,9 +158,7 @@   where   go []                   = return ()   go ((hdr,payload):segs) =-    do let continue = go segs--       -- page 70 and page 71+    do -- page 70 and page 71        -- check RST/check SYN        when (view tcpRst hdr || view tcpSyn hdr) $          do io $ do when (view tcpSyn hdr) $@@ -181,94 +179,94 @@         -- page 72        -- check ACK-       unless (view tcpAck hdr) continue--       -- update the send window-       mbAck <- io $-         do mbAck <- atomicModifyIORef' (tcbSendWindow tcb)-                         (ackSegment (view config ns) now (tcpAckNum hdr))-            handleRTTMeasurement tcb mbAck+       -- NOTE: processing ends here if ack is not present, which is why the+       -- remainder of packet processing is underneath this `when`.+       when (view tcpAck hdr) $ +         do -- Reset idle timeout+            io $ atomicModifyIORef' (tcbTimers tcb) resetIdleTimer -       state <- io (getState tcb)-       case state of+            -- update the send window+            mbAck <- io $+              do mbAck <- atomicModifyIORef' (tcbSendWindow tcb)+                              (ackSegment (view config ns) now (tcpAckNum hdr))+                 handleRTTMeasurement tcb mbAck -         SynReceived ->-           case mbAck of-             Just True  -> io (setState tcb Established)-             Just False -> return ()-             Nothing    -> do let rst = set tcpRst True emptyTcpHeader-                              _ <- io (queueWithTcb ns tcb rst L.empty)-                              continue+            state <- io (getState tcb)+            case state of -         FinWait1 ->-           case mbAck of-             Just True ->-               do io (setState tcb FinWait2)-                  io (processFinWait2 ns tcb)-                  continue+              SynReceived ->+                case mbAck of+                  Just True  -> io (setState tcb Established)+                  Just False -> return ()+                  Nothing    -> do let rst = set tcpRst True emptyTcpHeader+                                   _ <- io (queueWithTcb ns tcb rst L.empty)+                                   return () -             _ -> continue+              FinWait1 ->+                case mbAck of+                  Just True ->+                    do io (setState tcb FinWait2)+                       io (processFinWait2 ns tcb) -         FinWait2 ->-           case mbAck of-             Just True ->-               do io (processFinWait2 ns tcb)-                  continue+                  _ -> return () -             _ -> continue+              FinWait2 ->+                case mbAck of+                  Just True -> io (processFinWait2 ns tcb)+                  _         -> return () -         Closing ->-           case mbAck of-             Just True -> enterTimeWait ns tcb-             _         -> continue+              Closing ->+                case mbAck of+                  Just True -> enterTimeWait ns tcb+                  _         -> return () -         LastAck ->-           case mbAck of-             Just True ->-               do io (setState tcb Closed)-                  io (closeActive ns tcb)-                  escape+              LastAck ->+                case mbAck of+                  Just True ->+                    do io (setState tcb Closed)+                       io (closeActive ns tcb)+                       escape -             _ -> continue+                  _ -> return () -         -- TimeWait processing is done in handleTimeWait+              -- TimeWait processing is done in handleTimeWait -         -- CloseWait | Established-         _ -> return ()+              -- CloseWait | Established+              _ -> return () -       -- page 73-       -- check URG+            -- page 73+            -- check URG -       -- page 74-       -- process the segment text-       -- XXX: we're ignoring PSH for now, just making the data immediately-       -- available-       unless (S.null payload) $ io $-         do signalDelayedAck tcb-            queueBytes payload tcb+            -- page 74+            -- process the segment text+            -- XXX: we're ignoring PSH for now, just making the data immediately+            -- available+            unless (S.null payload) $ io $+              do signalDelayedAck tcb+                 queueBytes payload tcb -       -- page 75-       -- check FIN-       when (view tcpFin hdr) $-         do -- send an ACK to the FIN-            _ <- io (queueAck ns tcb)+            -- page 75+            -- check FIN+            when (view tcpFin hdr) $+              do -- send an ACK to the FIN+                 _ <- io (queueAck ns tcb) -            state' <- io (getState tcb)-            case state' of+                 state' <- io (getState tcb)+                 case state' of -              SynReceived -> io (setState tcb CloseWait)-              Established -> io (setState tcb CloseWait)+                   SynReceived -> io (setState tcb CloseWait)+                   Established -> io (setState tcb CloseWait) -              FinWait1 ->-                case mbAck of-                  Just True -> enterTimeWait ns tcb-                  _         -> io (setState tcb Closing)+                   FinWait1 ->+                     case mbAck of+                       Just True -> enterTimeWait ns tcb+                       _         -> io (setState tcb Closing) -              FinWait2 -> enterTimeWait ns tcb+                   FinWait2 -> enterTimeWait ns tcb -              _ -> continue+                   _ -> return () -       continue+       go segs   -- | Processing for the FinWait2 state, when the retransmit queue is known to be@@ -287,6 +285,7 @@ enterTimeWait :: NetworkStack -> Tcb -> Hans () enterTimeWait ns tcb =   do tw <- io (mkTimeWaitTcb tcb)+     io (closeActive ns tcb)      io (registerTimeWait ns tw)      escape 

@@ -71,11 +71,12 @@   len' = len - flag tcpSyn - flag tcpFin  -- | Resolve overlap between two segments. It's assumed that the two segments do--- actually overlap.+-- actually overlap. Overlap is resolved by trimming the front of the later+-- packet. resolveOverlap :: Segment -> Segment -> [Segment] resolveOverlap a b =-  case trimSeg (fromTcpSeqNum (segEnd x - segStart y)) x of-    Just x' -> [x',y]+  case trimSeg (fromTcpSeqNum (segEnd x - segStart y)) y of+    Just y' -> [x,y']     Nothing -> error "resolveOverlap: invariant violated"   where   (x,y) | segStart a < segStart b = (a,b) -- a overlaps b

@@ -54,18 +54,16 @@ import           Control.Concurrent (threadDelay,MVar,newMVar,modifyMVar) import qualified Control.Concurrent.BoundedChan as BC import           Control.Monad (guard)-import           Crypto.Hash (hash,Digest,MD5)-import           Data.ByteArray (withByteArray) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import           Data.Digest.Pure.SHA(sha1,integerDigest) import qualified Data.Foldable as F import           Data.Hashable (Hashable) import qualified Data.Heap as H import           Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef)-import           Data.Serialize (runPut,putByteString)+import           Data.Serialize (runPutLazy,putByteString) import           Data.Time.Clock (UTCTime,getCurrentTime,addUTCTime,diffUTCTime) import           Data.Word (Word32)-import           Foreign.Storable (peek) import           GHC.Generics (Generic) import           System.Random (newStdGen,random,randoms) @@ -395,8 +393,7 @@                                  , tcpLastUpdate = now                                  , .. } -           digest :: Digest MD5-           digest  = hash $ runPut $+           digest  = integerDigest $ sha1 $ runPutLazy $              do putAddr src                 putTcpPort srcPort                 putAddr dst@@ -405,8 +402,4 @@          in (timers', (ticks, digest)) -     -- NOTE: MD5 digests are always 128 bytes, so peeking the first 4 bytes off-     -- of the front should never fail.-     withByteArray f_digest $ \ ptr ->-       do w32 <- peek ptr-          return (fromIntegral (m + w32))+     return (fromIntegral (m + fromIntegral f_digest))

@@ -46,6 +46,7 @@     setRcvNxt,     finalizeTcb,     getSndUna,+    resetIdleTimer,      -- ** Active Config     TcbConfig(..),@@ -171,6 +172,12 @@            , ttIdle       = ttIdle tt + 1            } +-- | Reset idle timer in the presence of packets, for use with+-- 'atomicModifyIORef\''.+resetIdleTimer :: TcpTimers -> (TcpTimers, ())+resetIdleTimer t = (idleReset, ())+  where+   idleReset = t { ttIdle = 0 }  -- | Calibrate the RTO timer, given a round-trip measurement, as specified by -- RFC-6298.

@@ -31,7 +31,7 @@        let delay = 0.250 - diffUTCTime end start        when (delay > 0) (threadDelay (toUSeconds delay)) -       loop (not runSlow)+       loop $! not runSlow   -- | The body of the fast and slow tick handlers. The boolean indicates whether