diff --git a/hans.cabal b/hans.cabal --- a/hans.cabal +++ b/hans.cabal @@ -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 diff --git a/src/Hans/Device/Xen.hs b/src/Hans/Device/Xen.hs --- a/src/Hans/Device/Xen.hs +++ b/src/Hans/Device/Xen.hs @@ -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 -> diff --git a/src/Hans/HashTable.hs b/src/Hans/HashTable.hs --- a/src/Hans/HashTable.hs +++ b/src/Hans/HashTable.hs @@ -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) diff --git a/src/Hans/IP4/ArpTable.hs b/src/Hans/IP4/ArpTable.hs --- a/src/Hans/IP4/ArpTable.hs +++ b/src/Hans/IP4/ArpTable.hs @@ -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 } diff --git a/src/Hans/IP4/Dhcp/Client.hs b/src/Hans/IP4/Dhcp/Client.hs --- a/src/Hans/IP4/Dhcp/Client.hs +++ b/src/Hans/IP4/Dhcp/Client.hs @@ -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 () diff --git a/src/Hans/Monad.hs b/src/Hans/Monad.hs --- a/src/Hans/Monad.hs +++ b/src/Hans/Monad.hs @@ -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 diff --git a/src/Hans/Tcp/Input.hs b/src/Hans/Tcp/Input.hs --- a/src/Hans/Tcp/Input.hs +++ b/src/Hans/Tcp/Input.hs @@ -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 diff --git a/src/Hans/Tcp/RecvWindow.hs b/src/Hans/Tcp/RecvWindow.hs --- a/src/Hans/Tcp/RecvWindow.hs +++ b/src/Hans/Tcp/RecvWindow.hs @@ -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 diff --git a/src/Hans/Tcp/State.hs b/src/Hans/Tcp/State.hs --- a/src/Hans/Tcp/State.hs +++ b/src/Hans/Tcp/State.hs @@ -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)) diff --git a/src/Hans/Tcp/Tcb.hs b/src/Hans/Tcp/Tcb.hs --- a/src/Hans/Tcp/Tcb.hs +++ b/src/Hans/Tcp/Tcb.hs @@ -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. diff --git a/src/Hans/Tcp/Timers.hs b/src/Hans/Tcp/Timers.hs --- a/src/Hans/Tcp/Timers.hs +++ b/src/Hans/Tcp/Timers.hs @@ -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