diff --git a/cbits/tapdevice.c b/cbits/tapdevice.c --- a/cbits/tapdevice.c +++ b/cbits/tapdevice.c @@ -1,8 +1,8 @@ - #include #include #include +#if defined(__linux) #include #include #include @@ -10,27 +10,93 @@ #include int init_tap_device(char *name) { - int fd, ret; - struct ifreq ifr; + int fd, ret; + struct ifreq ifr; - if(name == NULL) { - return -1; - } + if(name == NULL) { + return -1; + } - fd = open("/dev/net/tun", O_RDWR); - if(fd < 0) { - return -2; - } + fd = open("/dev/net/tun", O_RDWR); + if(fd < 0) { + return -2; + } - memset(&ifr, 0x0, sizeof(struct ifreq)); - ifr.ifr_flags = IFF_TAP | IFF_NO_PI; - strncpy(ifr.ifr_name, name, IFNAMSIZ); + memset(&ifr, 0x0, sizeof(struct ifreq)); + ifr.ifr_flags = IFF_TAP | IFF_NO_PI; + strncpy(ifr.ifr_name, name, IFNAMSIZ); - ret = ioctl(fd, TUNSETIFF, (void*) &ifr); - if(ret != 0) { - close(fd); - return -3; - } + ret = ioctl(fd, TUNSETIFF, (void*) &ifr); + if(ret != 0) { + close(fd); + return -3; + } - return fd; + return fd; } + +#define TAP_IMPL_DEFINED +#endif + +#if defined(__APPLE__) +#include +#include +#include +#include +#include +#include + +int init_tap_device(char *name) +{ + char *pathname = alloca(32); + struct ifreq ifr; + int fd, sock, flags; + + snprintf(pathname, 32, "/dev/%s", name); + fd = open(pathname, O_RDWR); + if(fd < 0) { + printf("Open failed (%s)\n", pathname); + return -2; + } + printf("fd = %d\n", fd); + + sock = socket(AF_INET, SOCK_DGRAM, 0); + if(sock < 0) { + printf("Socket open failed\n"); + } + + memset(&ifr, 0, sizeof(ifr)); + strncpy(ifr.ifr_name, name, sizeof(ifr.ifr_name)); + if( ioctl(sock, SIOCGIFFLAGS, &ifr) < 0 ) { + printf("Get failed: %d\n", errno); + return -errno; + } + printf("Flags: %x\n", ifr.ifr_flags); + + ifr.ifr_flags |= IFF_UP | IFF_RUNNING; + if( ioctl(sock, SIOCSIFFLAGS, &ifr) < 0 ) { + printf("Set failed: %d (%s)\n", errno, strerror(errno)); + return -errno; + } + + flags = fcntl(fd, F_GETFL, 0); + if(flags == -1) { + printf("fcntl get failed\n"); + return -errno; + } + + if( fcntl(fd, F_SETFL, flags & ~O_NONBLOCK) == -1 ) { + printf("fcntl set failed\n"); + return -errno; + } + + printf("Everything's good! (fd = %d)\n", fd); + return fd; +} +#define TAP_IMPL_DEFINED +#endif + +#ifndef TAP_IMPL_DEFINED +#error "No TAP interface for building host!" +#endif + diff --git a/example/WebServer.hs b/example/WebServer.hs --- a/example/WebServer.hs +++ b/example/WebServer.hs @@ -5,11 +5,10 @@ import Data.Time.Clock (UTCTime(..),addUTCTime) import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime,posixSecondsToUTCTime) import Data.Time.Format (formatTime) -import Hans.Layer.Tcp.Socket - (Socket,readLine,sendSocket,acceptSocket,listenPort,closeSocket - ,SocketError(..)) import Hans.Message.Tcp (TcpPort) -import Hans.Setup (NetworkStack(nsTcp)) +import Hans.NetworkStack + (NetworkStack,tcpHandle,Socket,readLine,sendSocket,acceptSocket,listenPort + ,closeSocket,SocketError(..)) import System.Exit (exitFailure) import System.Locale (defaultTimeLocale) import qualified Control.Exception as X @@ -41,7 +40,7 @@ loop initServer :: NetworkStack -> TcpPort -> IO Socket -initServer ns port = listenPort (nsTcp ns) port `X.catch` h +initServer ns port = listenPort (tcpHandle ns) port `X.catch` h where h ListenError{} = do putStrLn ("Unable to listen on port: " ++ show port) diff --git a/example/test.hs b/example/test.hs --- a/example/test.hs +++ b/example/test.hs @@ -8,9 +8,8 @@ import Hans.Address.IP4 import Hans.Address.Mac import Hans.DhcpClient (dhcpDiscover) -import Hans.Layer.Ethernet import Hans.Message.Tcp (TcpPort(..)) -import Hans.Setup +import Hans.NetworkStack import System.Exit (exitFailure) import qualified Data.ByteString as S @@ -56,7 +55,7 @@ Just nic <- openXenDevice "" let mac = read (getNICName nic) print mac - addEthernetDevice (nsEthernet ns) mac (xenSend nic) (xenReceiveLoop nic) + addDevice mac (xenSend nic) (xenReceiveLoop nic) ns --let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56 --putStrLn "Waiting for input channel..." --input <- buildInput @@ -68,7 +67,7 @@ initEthernetDevice ns = do let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56 Just dev <- openTapDevice "tap0" - addEthernetDevice (nsEthernet ns) mac (tapSend dev) (tapReceiveLoop dev) + addDevice ns mac (tapSend dev) (tapReceiveLoop dev) return mac #endif @@ -79,9 +78,9 @@ main = do args <- getArgs #endif - ns <- setup + ns <- newNetworkStack mac <- initEthernetDevice ns - startEthernetDevice (nsEthernet ns) mac + deviceUp ns mac setAddress args mac ns webserver ns (TcpPort 8000) @@ -89,19 +88,10 @@ setAddress args mac ns = case args of ["dhcp"] -> dhcpDiscover ns mac print - [ip,gw] -> apply (addrOptions ip gw mac) ns + [ip,gw] -> do + addIP4Addr ns (read ip `withMask` 24) mac 1500 + routeVia ns (IP4 0 0 0 0 `withMask` 0) (read gw) _ -> do putStrLn "Usage: dhcp" putStrLn " " exitFailure - -addrOptions :: String -> String -> Mac -> [SomeOption] -addrOptions ip gw mac = - [ SomeOption (LocalEthernet (ip4 `withMask` 24) mac) - , SomeOption (Route (IP4 0 0 0 0 `withMask` 0) gw4) - ] - where - ip4 :: IP4 - ip4 = read ip - gw4 :: IP4 - gw4 = read gw diff --git a/hans.cabal b/hans.cabal --- a/hans.cabal +++ b/hans.cabal @@ -1,5 +1,5 @@ name: hans -version: 2.1.0.0 +version: 2.4.0.0 cabal-version: >= 1.8 license: BSD3 license-file: LICENSE @@ -15,23 +15,31 @@ source-repository head type: git - location: git://src.galois.com/srv/git/HaNS.git + location: git://github.com/GaloisInc/HaNS.git flag bounded-channels default: False description: Use bounded channels for message passing +flag enable-tests + default: False + description: Enable building the test suite + flag example default: False description: Build the example program -flag halvm +flag web-server + description: Build a simple web-server example + +flag word32-in-random default: False - description: Build for the HaLVM + description: Word32 in Random library - if(flag(halvm)) - build-depends: XenDevice, communication + if(os(HaLVM)) + build-depends: XenDevice >= 2.0.0 && < 3.0.0, + HALVMCore >= 2.0.0 && < 3.0.0 exposed-modules: Hans.Device.Xen, Hans.Device.Ivc else @@ -46,66 +54,64 @@ ghc-options: -Wall hs-source-dirs: src - build-depends: base == 4.*, - cereal == 0.3.*, - bytestring == 0.9.1.*, - containers >= 0.4.0.0 && < 0.5.0.0, - monadLib == 3.6.*, - time >= 1.2.0.0 && < 1.3.0.0, - fingertree == 0.0.1.*, - random == 1.0.0.* + 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, + fingertree >= 0.0.1.0 + + if flag(word32-in-random) + build-depends: random >= 1.0.1.0 + cpp-options: -DWORD32_IN_RANDOM + else + build-depends: random >= 1.0.0.0 + exposed-modules: Data.PrefixTree, Hans.Address, - Hans.Utils.Checksum, - Hans.Layer, - Hans.Ports, - Hans.Setup, - Hans.Utils, + Hans.Address.IP4, + Hans.Address.Mac, Hans.Channel, Hans.DhcpClient, - Hans.Simple, - Hans.Layer.Tcp, + Hans.Layer, + Hans.Layer.Arp, Hans.Layer.Arp.Table, + Hans.Layer.Ethernet, + Hans.Layer.Dns, + Hans.Layer.IP4, + Hans.Layer.IP4.Fragmentation, + Hans.Layer.IP4.Routing, + Hans.Layer.Icmp4, + Hans.Layer.Tcp, Hans.Layer.Tcp.Handlers, + Hans.Layer.Tcp.Messages, Hans.Layer.Tcp.Monad, Hans.Layer.Tcp.Socket, - Hans.Layer.IP4, + Hans.Layer.Tcp.Timers, + Hans.Layer.Tcp.Types, + Hans.Layer.Tcp.WaitBuffer, + Hans.Layer.Tcp.Window, Hans.Layer.Udp, - Hans.Layer.Arp, - Hans.Layer.IP4.Routing, - Hans.Layer.IP4.Fragmentation, - Hans.Layer.Timer, - Hans.Layer.Ethernet, - Hans.Layer.Icmp4, - Hans.Message.Tcp, - Hans.Message.Types, - Hans.Message.Udp, - Hans.Message.Ip4, - Hans.Message.EthernetFrame, Hans.Message.Arp, - Hans.Message.Dhcp4Codec, Hans.Message.Dhcp4, + Hans.Message.Dhcp4Codec, Hans.Message.Dhcp4Options, + Hans.Message.Dns, + Hans.Message.EthernetFrame, Hans.Message.Icmp4, - Hans.Address.Mac, - Hans.Address.IP4, - Network.TCP.Aux.SockMonad, - Network.TCP.Aux.Param, - Network.TCP.Aux.Misc, - Network.TCP.Aux.Output, - Network.TCP.LTS.User, - Network.TCP.LTS.Out, - Network.TCP.LTS.InPassive, - Network.TCP.LTS.InActive, - Network.TCP.LTS.InMisc, - Network.TCP.LTS.In, - Network.TCP.LTS.InData, - Network.TCP.Type.Socket, - Network.TCP.Type.Syscall, - Network.TCP.Type.Datagram, - Network.TCP.Type.Base, - Network.TCP.Type.Timer + Hans.Message.Ip4, + Hans.Message.Tcp, + Hans.Message.Types, + Hans.Message.Udp, + Hans.NetworkStack, + Hans.Ports, + Hans.Simple, + Hans.Timers, + Hans.Utils, + Hans.Utils.Checksum + executable test if flag(example) buildable: True @@ -120,19 +126,89 @@ other-modules: WebServer ghc-options: -Wall hs-source-dirs: example - build-depends: base == 4.*, - cereal == 0.3.0.*, - bytestring == 0.9.1.*, - containers >= 0.4.0.0 && < 0.5.0.0, - monadLib == 3.6.*, - time >= 1.2.0.0 && < 1.3.0.0, - old-locale == 1.0.0.*, + 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 flag(halvm) - build-depends: XenDevice == 1.0.0, - RendezvousLib == 1.0.0, - HALVMCore == 1.0.0, - communication == 1.0.0 + if os(HaLVM) + build-depends: XenDevice >= 2.0.0 && < 3.0.0, + HALVMCore >= 2.0.0 && < 3.0.0 else ghc-options: -threaded + +executable web-server + main-is: Main.hs + hs-source-dirs: web-server + ghc-options: -Wall -threaded -rtsopts + + if os(HaLVM) + buildable: False + else + if flag(web-server) + 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, + HTTP >= 4000.2.17, + blaze-html >= 0.7.0.2, + blaze-markup, + hans + + else + buildable: False + +executable tcp-test + main-is: Main.hs + hs-source-dirs: tcp-test + ghc-options: -Wall -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 test-suite + hs-source-dirs: tests + main-is: Main.hs + + if flag(enable-tests) + buildable: True + other-modules: Icmp4, + Icmp4.Packet, + IP4, + IP4.Addr, + IP4.Packet, + Tcp, + Tcp.Packet, + Tcp.Window, + Udp, + Udp.Packet, + Utils + + build-depends: base >= 4 && < 5, + containers >= 0.3, + bytestring >= 0.9.1, + old-locale >= 1, + test-framework-quickcheck2 >= 0.2.12.2, + test-framework >= 0.6, + QuickCheck >= 2.4.2, + random >= 1.0.1.1, + cereal >= 0.3.5.2, + hans + + else + buildable: False diff --git a/src/Hans/Address/IP4.hs b/src/Hans/Address/IP4.hs --- a/src/Hans/Address/IP4.hs +++ b/src/Hans/Address/IP4.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} module Hans.Address.IP4 where @@ -8,13 +9,14 @@ import Control.Monad (guard,liftM2) import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (getWord32be) -import Data.Serialize.Put (putWord32be) +import Data.Serialize.Get (Get,getWord32be) +import Data.Serialize.Put (Putter,putWord32be) import Data.Bits (Bits((.&.),(.|.),shiftL,shiftR)) import Data.Data (Data) import Data.List (intersperse) import Data.Typeable (Typeable) import Data.Word (Word8,Word32) +import GHC.Generics (Generic) import Numeric (readDec) @@ -23,8 +25,11 @@ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - deriving (Ord,Eq,Typeable,Data) + deriving (Ord,Eq,Typeable,Data,Generic) +broadcastIP4 :: IP4 +broadcastIP4 = IP4 255 255 255 255 + instance Address IP4 where addrSize _ = 4 @@ -33,11 +38,15 @@ f 0 _ xs = xs f m i xs = (i .&. m == 0) : f (m `shiftR` 1) i xs +parseIP4 :: Get IP4 +parseIP4 = convertFromWord32 `fmap` getWord32be + +renderIP4 :: Putter IP4 +renderIP4 = putWord32be . convertToWord32 + instance Serialize IP4 where - get = do - n <- getWord32be - return $! convertFromWord32 n - put ip = putWord32be (convertToWord32 ip) + get = parseIP4 + put = renderIP4 instance Show IP4 where showsPrec _ (IP4 a b c d) = foldl (.) id diff --git a/src/Hans/Address/Mac.hs b/src/Hans/Address/Mac.hs --- a/src/Hans/Address/Mac.hs +++ b/src/Hans/Address/Mac.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE DeriveGeneric #-} module Hans.Address.Mac ( Mac(..) + , parseMac + , renderMac + , broadcastMac , showsMac , macMask ) where @@ -8,12 +12,14 @@ import Hans.Address import Hans.Utils (showPaddedHex) +import Control.Applicative ((<*>),(<$>)) import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (getWord16be,getWord32be) -import Data.Serialize.Put (putByteString) -import Data.Bits (Bits(shiftR,testBit,complement)) +import Data.Serialize.Get (Get,getWord8) +import Data.Serialize.Put (Putter,putByteString) +import Data.Bits (Bits(testBit,complement)) import Data.List (intersperse) import Data.Word (Word8) +import GHC.Generics ( Generic ) import Numeric (readHex) import qualified Data.ByteString as S @@ -26,7 +32,7 @@ {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 - deriving ( Eq, Ord ) + deriving ( Eq, Ord, Generic ) -- | Show a Mac address. @@ -45,6 +51,10 @@ (complement e) (complement f) +-- | The broadcast mac address. +broadcastMac :: Mac +broadcastMac = Mac 0xff 0xff 0xff 0xff 0xff 0xff + instance Show Mac where showsPrec _ = showsMac @@ -66,12 +76,18 @@ toBits (Mac a b c d e f) = concatMap k [a,b,c,d,e,f] where k i = map (testBit i) [0 .. 7] -instance Serialize Mac where - get = do - n <- getWord32be - m <- getWord16be - let f x d = fromIntegral (x `shiftR` d) - return $! Mac (f n 24) (f n 16) (f n 8) (fromIntegral n) - (f m 8) (fromIntegral m) +parseMac :: Get Mac +parseMac = Mac + <$> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 - put (Mac a b c d e f) = putByteString (S.pack [a,b,c,d,e,f]) +renderMac :: Putter Mac +renderMac (Mac a b c d e f) = putByteString (S.pack [a,b,c,d,e,f]) + +instance Serialize Mac where + get = parseMac + put = renderMac diff --git a/src/Hans/Device/Ivc.hs b/src/Hans/Device/Ivc.hs --- a/src/Hans/Device/Ivc.hs +++ b/src/Hans/Device/Ivc.hs @@ -1,30 +1,19 @@ {-# LANGUAGE MultiParamTypeClasses #-} - +{-# LANGUAGE FlexibleContexts #-} module Hans.Device.Ivc ( ivcSend , ivcReceiveLoop - , Bytes(getBytes) ) where import Hans.Layer.Ethernet (EthernetHandle,queueEthernet) - -import Communication.IVC as IVC (put,OutChannelEx,get,InChannelEx,Bin) +import Communication.IVC as IVC import Control.Monad (forever,when) -import Data.Serialize (Serialize(get,put),getByteString,putByteString,remaining) import qualified Data.ByteString as S -newtype Bytes = Bytes - { getBytes :: S.ByteString - } deriving Show - -instance Serialize Bytes where - get = Bytes `fmap` (getByteString =<< remaining) - put = putByteString . getBytes - -ivcSend :: OutChannelEx Bin Bytes -> S.ByteString -> IO () -ivcSend chan = IVC.put chan . Bytes +ivcSend :: IVC.WriteableChan c S.ByteString => c -> S.ByteString -> IO () +ivcSend chan = IVC.put chan -ivcReceiveLoop :: InChannelEx Bin Bytes -> EthernetHandle -> IO () -ivcReceiveLoop chan eth = forever $ do - Bytes bs <- IVC.get chan - when (S.length bs > 14) (queueEthernet eth bs) +ivcReceiveLoop :: IVC.ReadableChan c S.ByteString => c -> EthernetHandle -> IO () +ivcReceiveLoop chan eth = forever $ + do bs <- IVC.get chan + when (S.length bs > 14) (queueEthernet eth bs) diff --git a/src/Hans/Device/Tap.hs b/src/Hans/Device/Tap.hs --- a/src/Hans/Device/Tap.hs +++ b/src/Hans/Device/Tap.hs @@ -3,19 +3,19 @@ module Hans.Device.Tap where import Hans.Layer.Ethernet -import Hans.Utils +import Hans.Utils (strict,DeviceName) import Control.Concurrent (threadWaitRead) import Control.Monad (forever) import Data.Word (Word8) import Foreign.C.String (CString,withCString) -import Foreign.C.Types (CLong,CSize) +import Foreign.C.Types (CLong(..),CSize(..),CInt(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr) -import System.Posix.Types (Fd) +import System.Posix.Types (Fd(..)) import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S - +import qualified Data.ByteString.Lazy as L -- | Open a device by name. @@ -27,9 +27,11 @@ -- | Send an ethernet frame via a tap device. -tapSend :: Fd -> Packet -> IO () +-- +-- TODO: make more use of the lazy bytestring +tapSend :: Fd -> L.ByteString -> IO () tapSend fd packet = do - let (fptr, 0, len) = S.toForeignPtr packet + let (fptr, 0, len) = S.toForeignPtr (strict packet) _res <- withForeignPtr fptr $ \ptr -> c_write fd ptr (fromIntegral len) -- XXX: make sure to continue sending if res < len return () @@ -40,17 +42,21 @@ tapReceiveLoop fd eh = forever (k =<< tapReceive fd) where k pkt = queueEthernet eh pkt - -- | Recieve an ethernet frame from a tap device. -tapReceive :: Fd -> IO Packet +tapReceive :: Fd -> IO S.ByteString tapReceive fd = do threadWaitRead fd - let packet ptr = fromIntegral `fmap` c_read fd ptr 1514 + let packet ptr = fromIntegral `fmap` c_read' fd ptr 1514 bs <- S.createAndTrim 1514 packet if S.length bs <= 14 then tapReceive fd else return bs +c_read' :: Fd -> Ptr Word8 -> CSize -> IO CLong +c_read' fd buf size = do + res <- c_read fd buf size +-- Errno eno <- getErrno + return res foreign import ccall unsafe "init_tap_device" c_init_tap_device :: CString -> IO Fd @@ -58,5 +64,6 @@ foreign import ccall unsafe "write" c_write :: Fd -> Ptr Word8 -> CSize -> IO CLong -foreign import ccall unsafe "read" +foreign import ccall safe "read" c_read :: Fd -> Ptr Word8 -> CSize -> IO CLong + 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 @@ -1,40 +1,15 @@ module Hans.Device.Xen where import Hans.Layer.Ethernet -import Hans.Utils -import Data.Maybe (listToMaybe) import XenDevice.NIC as Xen import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L - --- Utilities ------------------------------------------------------------------- - -infixl 1 >>=? -(>>=?) :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) -m >>=? f = do - mb <- m - case mb of - Nothing -> return Nothing - Just a -> f a - -returnJust :: Monad m => a -> m (Maybe a) -returnJust = return . Just - - -- Xen NIC --------------------------------------------------------------------- - -openXenDevice :: String -> IO (Maybe NIC) -openXenDevice _ = - listToMaybe `fmap` Xen.potentialNICs >>=? \ dev -> - initializeNIC dev Nothing - - -xenSend :: NIC -> S.ByteString -> IO () -xenSend nic bs = void (Xen.transmitPacket nic (L.fromChunks [bs])) - +xenSend :: NIC -> L.ByteString -> IO () +xenSend = Xen.sendPacket xenReceiveLoop :: NIC -> EthernetHandle -> IO () xenReceiveLoop nic eh = Xen.setReceiveHandler nic k diff --git a/src/Hans/DhcpClient.hs b/src/Hans/DhcpClient.hs --- a/src/Hans/DhcpClient.hs +++ b/src/Hans/DhcpClient.hs @@ -3,25 +3,24 @@ ) where import Hans.Address -import Hans.Address.IP4 -import Hans.Address.Mac +import Hans.Address.IP4 (IP4(..),broadcastIP4,IP4Mask(..)) +import Hans.Address.Mac (Mac(..),broadcastMac) import Hans.Layer.Ethernet (sendEthernet,addEthernetHandler) import Hans.Layer.IP4 (connectEthernet) -import Hans.Layer.Timer (delay) -import Hans.Layer.Udp (addUdpHandler,removeUdpHandler,queueUdp) import Hans.Message.Dhcp4 import Hans.Message.Dhcp4Codec import Hans.Message.Dhcp4Options import Hans.Message.EthernetFrame import Hans.Message.Ip4 import Hans.Message.Udp -import Hans.Setup +import Hans.NetworkStack +import Hans.Timers (delay_) import Control.Monad (guard) -import Data.Serialize (runGet,runPut) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe,mapMaybe) import System.Random (randomIO) import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L -- Protocol Constants ---------------------------------------------------------- @@ -37,15 +36,6 @@ currentNetwork :: IP4 currentNetwork = IP4 0 0 0 0 -broadcastIP4 :: IP4 -broadcastIP4 = IP4 255 255 255 255 - -broadcastMac :: Mac -broadcastMac = Mac 0xff 0xff 0xff 0xff 0xff 0xff - -udpProtocol :: IP4Protocol -udpProtocol = IP4Protocol 0x11 - ethernetIp4 :: EtherType ethernetIp4 = EtherType 0x0800 @@ -58,32 +48,35 @@ type AckHandler = IP4 -> IO () -- | Discover a dhcp server, and request an address. -dhcpDiscover :: NetworkStack -> Mac -> AckHandler -> IO () +dhcpDiscover :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack + , HasDns stack ) + => stack -> Mac -> AckHandler -> IO () dhcpDiscover ns mac h = do w32 <- randomIO let xid = Xid (fromIntegral (w32 :: Int)) - addEthernetHandler (nsEthernet ns) ethernetIp4 (dhcpIP4Handler ns) - addUdpHandler (nsUdp ns) bootpc (handleOffer ns (Just h)) + addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) + addUdpHandler ns bootpc (handleOffer ns (Just h)) let disc = discoverToMessage (mkDiscover xid mac) sendMessage ns disc currentNetwork broadcastIP4 broadcastMac -- | Restore the connection between the Ethernet and IP4 layers. -restoreIp4 :: NetworkStack -> IO () -restoreIp4 ns = connectEthernet (nsIp4 ns) (nsEthernet ns) +restoreIp4 :: (HasEthernet stack, HasIP4 stack) => stack -> IO () +restoreIp4 ns = connectEthernet (ip4Handle ns) (ethernetHandle ns) -- | Handle IP4 messages from the Ethernet layer, passing all relevant DHCP -- messages to the UDP layer. -dhcpIP4Handler :: NetworkStack -> S.ByteString -> IO () +dhcpIP4Handler :: (HasUdp stack) + => stack -> S.ByteString -> IO () dhcpIP4Handler ns bytes = - case runGet parseIP4Packet bytes of + case parseIP4Packet bytes of Left err -> putStrLn err >> return () Right (hdr,ihl,len) | ip4Protocol hdr == udpProtocol -> queue | otherwise -> return () where - queue = queueUdp (nsUdp ns) (ip4SourceAddr hdr) (ip4DestAddr hdr) + queue = queueUdp ns hdr $ S.take (len - ihl) $ S.drop ihl bytes @@ -92,16 +85,18 @@ -- * Remove the current UDP handler -- * Install an DHCP Ack handler -- * Send a DHCP Request -handleOffer :: NetworkStack -> Maybe AckHandler -> IP4 -> UdpPort +handleOffer :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack + , HasDns stack ) + => stack -> Maybe AckHandler -> IP4 -> UdpPort -> S.ByteString -> IO () handleOffer ns mbh _src _srcPort bytes = - case runGet (getDhcp4Message) bytes of + case getDhcp4Message bytes of Right msg -> case parseDhcpMessage msg of Just (Right (OfferMessage offer)) -> do - removeUdpHandler (nsUdp ns) bootpc + removeUdpHandler ns bootpc let req = requestToMessage (offerToRequest offer) - addUdpHandler (nsUdp ns) bootpc (handleAck ns offer mbh) + addUdpHandler ns bootpc (handleAck ns offer mbh) sendMessage ns req currentNetwork broadcastIP4 broadcastMac msg1 -> do @@ -118,19 +113,20 @@ -- * Configure the network stack with options from the Ack -- * Install a timer that renews the address after 50% of the lease time -- has passed -handleAck :: NetworkStack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort +handleAck :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack + , HasDns stack ) + => stack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort -> S.ByteString -> IO () handleAck ns offer mbh _src _srcPort bytes = - case runGet (getDhcp4Message) bytes of + case getDhcp4Message bytes of Right msg -> case parseDhcpMessage msg of Just (Right (AckMessage ack)) -> do - removeUdpHandler (nsUdp ns) bootpc + removeUdpHandler ns bootpc restoreIp4 ns - apply (ackNsOptions ack) ns + ackNsOptions ack ns let ms = fromIntegral (ackLeaseTime ack) * 500 - delay (nsTimers ns) ms (dhcpRenew ns offer) - putStrLn ("Bound to: " ++ show (ackYourAddr ack)) + delay_ ms (dhcpRenew ns offer) case mbh of Nothing -> return () @@ -147,12 +143,14 @@ -- * Re-install the DHCP IP4 handler -- * Add a UDP handler for an Ack message -- * Re-send a renquest message, generated from the offer given. -dhcpRenew :: NetworkStack -> Offer -> IO () +dhcpRenew :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack + , HasDns stack ) + => stack -> Offer -> IO () dhcpRenew ns offer = do - addEthernetHandler (nsEthernet ns) ethernetIp4 (dhcpIP4Handler ns) + addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) let req = requestToMessage (offerToRequest offer) - addUdpHandler (nsUdp ns) bootpc (handleAck ns offer Nothing) + addUdpHandler ns bootpc (handleAck ns offer Nothing) sendMessage ns req currentNetwork broadcastIP4 broadcastMac @@ -171,47 +169,52 @@ p _ a = a -- | Produce options for the network stack from a DHCP Ack. -ackNsOptions :: Ack -> [SomeOption] -ackNsOptions ack = - [ toOption (LocalEthernet (addr `withMask` mask) mac) - , toOption (Route defaultRoute gateway) - ] - where - mac = ackClientHardwareAddr ack - addr = ackYourAddr ack - opts = ackOptions ack - mask = fromMaybe 24 (lookupSubnet opts) - gateway = fromMaybe (ackRelayAddr ack) (lookupGateway opts) +ackNsOptions :: (HasIP4 stack, HasArp stack, HasDns stack) + => Ack -> stack -> IO () +ackNsOptions ack ns = do + let mac = ackClientHardwareAddr ack + addr = ackYourAddr ack + opts = ackOptions ack + mask = fromMaybe 24 (lookupSubnet opts) + gateway = fromMaybe (ackRelayAddr ack) (lookupGateway opts) + addIP4Addr ns (addr `withMask` mask) mac 1500 + routeVia ns defaultRoute gateway + let nameServers = concat (mapMaybe getNameServers (ackOptions ack)) + mapM_ (addNameServer ns) nameServers +getNameServers :: Dhcp4Option -> Maybe [IP4] +getNameServers (OptNameServers addrs) = Just addrs +getNameServers _ = Nothing + + -- Packet Helpers -------------------------------------------------------------- -sendMessage :: NetworkStack -> Dhcp4Message -> IP4 -> IP4 -> Mac -> IO () +sendMessage :: HasEthernet stack + => stack -> Dhcp4Message -> IP4 -> IP4 -> Mac -> IO () sendMessage ns resp src dst hwdst = do - ipBytes <- mkIpBytes src dst bootpc bootps - (runPut (putDhcp4Message resp)) + ipBytes <- mkIpBytes src dst bootpc bootps (putDhcp4Message resp) let mac = dhcp4ClientHardwareAddr resp let frame = EthernetFrame { etherDest = hwdst , etherSource = mac , etherType = ethernetIp4 - , etherData = ipBytes } - putStrLn (show mac ++ " -> " ++ show hwdst) - - sendEthernet (nsEthernet ns) frame + sendEthernet (ethernetHandle ns) frame ipBytes -mkIpBytes :: IP4 -> IP4 -> UdpPort -> UdpPort -> S.ByteString -> IO S.ByteString +mkIpBytes :: IP4 -> IP4 -> UdpPort -> UdpPort -> L.ByteString -> IO L.ByteString mkIpBytes srcAddr dstAddr srcPort dstPort payload = do udpBytes <- do let udpHdr = UdpHeader srcPort dstPort 0 - udp = UdpPacket udpHdr payload mk = mkIP4PseudoHeader srcAddr dstAddr udpProtocol - renderUdpPacket udp mk + renderUdpPacket udpHdr payload mk ipBytes <- do - let ipHdr = emptyIP4Header udpProtocol srcAddr dstAddr - ip = IP4Packet ipHdr udpBytes - renderIP4Packet ip + let ipHdr = emptyIP4Header + { ip4SourceAddr = srcAddr + , ip4DestAddr = dstAddr + , ip4Protocol = udpProtocol + } + renderIP4Packet ipHdr udpBytes return ipBytes diff --git a/src/Hans/Layer.hs b/src/Hans/Layer.hs --- a/src/Hans/Layer.hs +++ b/src/Hans/Layer.hs @@ -12,7 +12,7 @@ import Control.Monad (ap,MonadPlus(mzero,mplus)) import Data.Monoid (Monoid(..)) import Data.Time.Clock.POSIX -import MonadLib (StateM(get,set)) +import MonadLib (StateM(get,set),BaseM(inBase)) import qualified Control.Exception as X import qualified Data.Map as Map @@ -36,8 +36,12 @@ data Result i a = Error Action + | Exit (LayerState i) Action | Result (LayerState i) a Action +-- | Early exit continuation +type Exit i r = LayerState i -> Action -> Result i r + -- | Failure continuation type Failure i r = Action -> Result i r @@ -45,67 +49,86 @@ type Success a i r = a -> LayerState i -> Action -> Result i r newtype Layer i a = Layer - { getLayer :: forall r. LayerState i -> Action - -> Failure i r -> Success a i r + { getLayer :: forall r. LayerState i + -> Action + -> Exit i r + -> Failure i r + -> Success a i r -> Result i r } runLayer :: LayerState i -> Layer i a -> Result i a -runLayer i0 m = getLayer m i0 mempty Error success +runLayer i0 m = getLayer m i0 mempty Exit Error success where success a i o = Result i a o -loopLayer :: i -> IO msg -> (msg -> Layer i ()) -> IO () -loopLayer i0 msg k = loop (LayerState 0 i0) +loopLayer :: String -> i -> IO msg -> (msg -> Layer i ()) -> IO () +loopLayer name i0 msg k = + loop (LayerState 0 i0) `X.finally` putStrLn (name ++ " died") where loop i = do a <- msg now <- getPOSIXTime let res = runLayer (i {lsNow = now }) (k a) - X.evaluate res `X.catch` \ se -> print (se :: X.SomeException) >> return res + _ <- X.evaluate res `X.catch` \ se -> do + putStrLn (name ++ show (se :: X.SomeException)) + return res case res of Error m -> runAction m >> loop i + Exit i' m -> runAction m >> loop i' Result i' () m -> runAction m >> loop i' instance Functor (Layer i) where - fmap g m = Layer (\i0 o0 f k -> getLayer m i0 o0 f (\a i o -> k (g a) i o)) + fmap g m = Layer $ \i0 o0 x f k -> + getLayer m i0 o0 x f (\a i o -> k (g a) i o) instance Applicative (Layer i) where pure = return (<*>) = ap instance Alternative (Layer i) where - empty = Layer (\_ o0 f _ -> f o0) - a <|> b = Layer (\i o f k -> getLayer a i o (\_ -> getLayer b i o f k) k) + empty = Layer (\_ o0 _ f _ -> f o0) + a <|> b = Layer (\i o x f k -> getLayer a i o x (\_ -> getLayer b i o x f k) k) instance Monad (Layer i) where - return x = Layer (\i o _ k -> k x i o) - m >>= g = Layer $ \i0 o0 f k -> getLayer m i0 o0 f $ \a i o -> - getLayer (g a) i o f k + return a = Layer (\i o _ _ k -> k a i o) + m >>= g = Layer $ \i0 o0 x f k -> getLayer m i0 o0 x f $ \a i o -> + getLayer (g a) i o x f k instance MonadPlus (Layer i) where mzero = empty 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 + -- Utilities ------------------------------------------------------------------- +-- | Finish early, successfully, with no further processing. +finish :: Layer i a +finish = Layer (\i o x _ _ -> x i o) +{-# INLINE finish #-} + +{-# INLINE dropPacket #-} dropPacket :: Layer i a -dropPacket = empty +dropPacket = finish +{-# INLINE time #-} time :: Layer i POSIXTime -time = Layer $ \i0 o0 _ k -> k (lsNow i0) i0 o0 +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 liftRight (Left err) = do output (putStrLn err) dropPacket + -- Handler Generalization ------------------------------------------------------ diff --git a/src/Hans/Layer/Arp.hs b/src/Hans/Layer/Arp.hs --- a/src/Hans/Layer/Arp.hs +++ b/src/Hans/Layer/Arp.hs @@ -11,35 +11,42 @@ , addLocalAddress ) where -import Hans.Address.IP4 -import Hans.Address.Mac +import Hans.Address.IP4 (IP4,parseIP4,renderIP4) +import Hans.Address.Mac (Mac,parseMac,renderMac,broadcastMac) import Hans.Channel import Hans.Layer import Hans.Layer.Arp.Table import Hans.Layer.Ethernet -import Hans.Layer.Timer import Hans.Message.Arp + (ArpPacket(..),parseArpPacket,renderArpPacket,ArpOper(..)) import Hans.Message.EthernetFrame +import Hans.Timers (delay_) import Hans.Utils import Control.Concurrent (forkIO,takeMVar,putMVar,newEmptyMVar) import Control.Monad (forM_,mplus,guard,unless,when) -import Data.Serialize (decode,encode) import MonadLib (BaseM(inBase),set,get) -import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.ByteString as S + +-- Arp ------------------------------------------------------------------------- + -- | A handle to a running arp layer. type ArpHandle = Channel (Arp ()) -- | Start an arp layer. -runArpLayer :: ArpHandle -> EthernetHandle -> TimerHandle -> IO () -runArpLayer h eth th = do +runArpLayer :: ArpHandle -> EthernetHandle -> IO () +runArpLayer h eth = do addEthernetHandler eth (EtherType 0x0806) (send h . handleIncoming) - let i = emptyArpState h eth th - void (forkIO (loopLayer i (receive h) id)) + let i = emptyArpState h eth + void (forkIO (loopLayer "arp" i (receive h) id)) +-- External Interface ---------------------------------------------------------- + -- | Lookup the hardware address associated with an IP address. arpWhoHas :: BaseM m IO => ArpHandle -> IP4 -> m (Maybe Mac) arpWhoHas h !ip = inBase $ do @@ -47,13 +54,12 @@ send h (whoHas ip (putMVar var)) takeMVar var - -- | Send an IP packet via the arp layer, to resolve the underlying hardware -- addresses. -arpIP4Packet :: ArpHandle -> IP4 -> IP4 -> Packet -> IO () +arpIP4Packet :: ArpHandle -> IP4 -> IP4 -> L.ByteString -> IO () arpIP4Packet h !src !dst !pkt = send h (handleOutgoing src dst pkt) - +-- | Associate an address with a mac in the Arp layer. addLocalAddress :: ArpHandle -> IP4 -> Mac -> IO () addLocalAddress h !ip !mac = send h (handleAddAddress ip mac) @@ -67,26 +73,21 @@ , arpAddrs :: Map.Map IP4 Mac -- this layer's addresses , arpWaiting :: Map.Map IP4 [Maybe Mac -> IO ()] , arpEthernet :: EthernetHandle - , arpTimers :: TimerHandle , arpSelf :: ArpHandle } -emptyArpState :: ArpHandle -> EthernetHandle -> TimerHandle -> ArpState -emptyArpState h eth ts = ArpState +emptyArpState :: ArpHandle -> EthernetHandle -> ArpState +emptyArpState h eth = ArpState { arpTable = Map.empty , arpAddrs = Map.empty , arpWaiting = Map.empty , arpEthernet = eth - , arpTimers = ts , arpSelf = h } ethernetHandle :: Arp EthernetHandle ethernetHandle = arpEthernet `fmap` get -timerHandle :: Arp TimerHandle -timerHandle = arpTimers `fmap` get - addEntry :: IP4 -> Mac -> Arp () addEntry spa sha = do state <- get @@ -134,9 +135,9 @@ { etherSource = arpSHA msg , etherDest = arpTHA msg , etherType = 0x0806 - , etherData = encode msg } - output (sendEthernet eth frame) + body = renderArpPacket renderMac renderIP4 msg + output (sendEthernet eth frame body) advanceArpTable :: Arp () advanceArpTable = do @@ -165,7 +166,7 @@ , arpPType = 0x0800 , arpSHA = sha , arpSPA = spa - , arpTHA = Mac 0xff 0xff 0xff 0xff 0xff 0xff + , arpTHA = broadcastMac , arpTPA = ip , arpOper = ArpRequest } @@ -174,15 +175,12 @@ set state { arpTable = table' } addWaiter ip k mapM_ (sendArpPacket . msg) addrs - th <- timerHandle - output (delay th 10000 (send (arpSelf state) advanceArpTable)) - --- Message Handling ------------------------------------------------------------ + output (delay_ 10000 (send (arpSelf state) advanceArpTable)) -- | Process an incoming arp packet -handleIncoming :: Packet -> Arp () +handleIncoming :: S.ByteString -> Arp () handleIncoming bs = do - msg <- liftRight (decode bs) + msg <- liftRight (parseArpPacket parseMac parseIP4 bs) -- ?Do I have the hardware type in ar$hrd -- Yes: (This check is enforced by the type system) -- [optionally check the hardware length ar$hln] @@ -228,16 +226,15 @@ -- | Output a packet to the ethernet layer. -handleOutgoing :: IP4 -> IP4 -> Packet -> Arp () -handleOutgoing src dst bs = do +handleOutgoing :: IP4 -> IP4 -> L.ByteString -> Arp () +handleOutgoing src dst body = do eth <- ethernetHandle lha <- localHwAddress src let frame dha = EthernetFrame { etherDest = dha , etherSource = lha , etherType = 0x0800 - , etherData = bs } whoHas dst $ \ res -> case res of Nothing -> return () - Just dha -> sendEthernet eth (frame dha) + Just dha -> sendEthernet eth (frame dha) body diff --git a/src/Hans/Layer/Dns.hs b/src/Hans/Layer/Dns.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Dns.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hans.Layer.Dns ( + DnsHandle + , runDnsLayer + , DnsException + + , addNameServer + , removeNameServer + + , HostName + , HostEntry(..) + , getHostByName + , getHostByAddr + ) where + +import Hans.Address.IP4 +import Hans.Channel +import Hans.Layer +import Hans.Layer.Udp as Udp +import Hans.Message.Dns +import Hans.Message.Udp +import Hans.Timers + +import Control.Concurrent ( forkIO, MVar, newEmptyMVar, takeMVar, putMVar ) +import Control.Monad ( mzero, guard, when ) +import Data.Bits ( shiftR, (.&.), (.|.) ) +import Data.Foldable ( foldl' ) +import Data.List ( intercalate ) +import Data.String ( fromString ) +import Data.Typeable ( Typeable ) +import Data.Word ( Word16 ) +import MonadLib ( get, set ) +import qualified Control.Exception as X +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 + + +-- External Interface ---------------------------------------------------------- + +type DnsHandle = Channel (Dns ()) + +runDnsLayer :: DnsHandle -> UdpHandle -> IO () +runDnsLayer h udp = + do _ <- forkIO (loopLayer "dns" (emptyDnsState h udp) (receive h) id) + return () + +data DnsException = NoNameServers + -- ^ No name servers have been configured + | OutOfServers + -- ^ Ran out of name servers to try + | DoesNotExist + -- ^ Unable to find any information about the host + | DnsRequestFailed + deriving (Show,Typeable) + +instance X.Exception DnsException + +addNameServer :: DnsHandle -> IP4 -> IO () +addNameServer h addr = + send h $ do state <- get + set $! state { dnsNameServers = addr : dnsNameServers state } + +removeNameServer :: DnsHandle -> IP4 -> IO () +removeNameServer h addr = + send h $ do state <- get + set $! state + { dnsNameServers = filter (/= addr) (dnsNameServers state) } + +type HostName = String + +data HostEntry = HostEntry { hostName :: HostName + , hostAliases :: [HostName] + , hostAddresses :: [IP4] + } deriving (Show) + +getHostByName :: DnsHandle -> HostName -> IO HostEntry +getHostByName h host = + do res <- newEmptyMVar + send h (getHostEntry res (FromHost host)) + e <- takeMVar res + case e of + Right he -> return he + Left err -> X.throwIO err + + +getHostByAddr :: DnsHandle -> IP4 -> IO HostEntry +getHostByAddr h addr = + do res <- newEmptyMVar + send h (getHostEntry res (FromIP4 addr)) + e <- takeMVar res + case e of + Right he -> return he + Left err -> X.throwIO err + + +-- Handlers -------------------------------------------------------------------- + +type Dns = Layer DnsState + +data DnsState = DnsState { dnsSelf :: DnsHandle + , dnsUdpHandle :: UdpHandle + , dnsNameServers :: [IP4] + , dnsReqId :: !Word16 + , dnsQueries :: Map.Map Word16 DnsQuery + , dnsTimeout :: Milliseconds + } + +emptyDnsState :: DnsHandle -> UdpHandle -> DnsState +emptyDnsState h udp = DnsState { dnsSelf = h + , dnsUdpHandle = udp + , dnsNameServers = [] + , dnsReqId = 1 + , dnsQueries = Map.empty + , dnsTimeout = 180000 -- 3 minutes + } + +-- LFSR: x^16 + x^14 + x^13 + x^11 + 1 +-- +-- 0xB400 ~ bit 15 .|. bit 13 .|. bit 12 .|. bit 10 +stepReqId :: Word16 -> Word16 +stepReqId w = (w `shiftR` 1) .|. (negate (w .&. 0x1) .&. 0xB400) + +-- | Register a fresh request, along with a timer to reap the request after +-- 'dnsTimeout'. +registerRequest :: (Word16 -> DnsQuery) -> Dns Word16 +registerRequest mk = + do state <- get + let reqId = dnsReqId state + set state { dnsReqId = stepReqId reqId + , dnsQueries = Map.insert reqId (mk reqId) (dnsQueries state) + } + return reqId + +registerTimeout :: Word16 -> Timer -> Dns () +registerTimeout reqId timer = + do DnsState { .. } <- get + case Map.lookup reqId dnsQueries of + Just query -> updateRequest reqId query { qTimeout = Just timer } + Nothing -> output (cancel timer) + +updateRequest :: Word16 -> DnsQuery -> Dns () +updateRequest reqId query = + do state <- get + set state { dnsQueries = Map.insert reqId query (dnsQueries state) } + +lookupRequest :: Word16 -> Dns DnsQuery +lookupRequest reqId = + do DnsState { .. } <- get + case Map.lookup reqId dnsQueries of + Just query -> return query + Nothing -> mzero + +removeRequest :: Word16 -> Dns () +removeRequest reqId = + do state <- get + set state { dnsQueries = Map.delete reqId (dnsQueries state) } + + +data Source = FromHost HostName + | FromIP4 IP4 + deriving (Show) + +sourceQType :: Source -> [QType] +sourceQType FromHost{} = [QType A] +sourceQType FromIP4{} = [QType PTR] + +sourceHost :: Source -> Name +sourceHost (FromHost h) = toLabels h +sourceHost (FromIP4 (IP4 a b c d)) = let byte w = fromString (show w) + in map byte [d,c,b,a] ++ ["in-addr","arpa"] + +toLabels :: String -> Name +toLabels str = case break (== '.') str of + (as,_:bs) -> fromString as : toLabels bs + (as,_) -> [fromString as] + +getHostEntry :: DnsResult -> Source -> Dns () +getHostEntry res src = + do DnsState { .. } <- get + + -- make sure that there are name servers to work with + when (null dnsNameServers) $ + do output (putError res NoNameServers) + mzero + + -- register a upd handler on a fresh port, and query the name servers in + -- order + output $ + do port <- addUdpHandlerAnyPort dnsUdpHandle (serverResponse dnsSelf src) + send dnsSelf (createRequest res dnsNameServers src port) + + +-- | Create the query packet, and register the request with the DNS layer. +-- Then, send a request to the first name server. +createRequest :: DnsResult -> [IP4] -> Source -> UdpPort -> Dns () +createRequest res nss src port = + do DnsState { .. } <- get + reqId <- registerRequest (mkDnsQuery res nss port src) + sendRequest reqId + + +-- | Send a request to the next name server in the queue. +sendRequest :: Word16 -> Dns () +sendRequest reqId = + do query <- lookupRequest reqId + + case qServers query of + + n:rest -> do updateRequest reqId query { qServers = rest + , qLastServer = Just n + } + sendQuery n (qUdpPort query) reqId (qRequest query) + + -- out of servers to try + [] -> do removeRequest reqId + output (putError (qResult query) OutOfServers) + +expireRequest :: Word16 -> Dns () +expireRequest reqId = + do DnsQuery { .. } <- lookupRequest reqId + removeRequest reqId + output (putError qResult OutOfServers) + +-- | Handle the response from the server. +handleResponse :: Source -> IP4 -> UdpPort -> S.ByteString -> Dns () +handleResponse src srcIp srcPort bytes = + do guard (srcPort == 53) + + DNSPacket { .. } <- liftRight (parseDNSPacket bytes) + let DNSHeader { .. } = dnsHeader + DnsQuery { .. } <- lookupRequest dnsId + + -- require that the last name server we sent to was the one that responded, + -- and that it responded with a response, not a request. + guard (Just srcIp == qLastServer && not dnsQuery) + + if dnsRC == RespNoError + then output (putResult qResult (parseHostEntry src dnsAnswers)) + else output (putError qResult DnsRequestFailed) + + removeRequest dnsId + DnsState { .. } <- get + output $ do removeUdpHandler dnsUdpHandle qUdpPort + case qTimeout of + Just timeout -> cancel timeout + Nothing -> return () + +parseHostEntry :: Source -> [RR] -> HostEntry +parseHostEntry (FromHost host) = parseAddr host +parseHostEntry (FromIP4 addr) = parsePtr addr + +-- | Parse the A and CNAME parts out of a response. +parseAddr :: HostName -> [RR] -> HostEntry +parseAddr host = foldl' processAnswer emptyHostEntry + where + + emptyHostEntry = HostEntry { hostName = host + , hostAliases = [] + , hostAddresses = [] } + + processAnswer he RR { .. } = case rrRData of + RDA ip -> he { hostAddresses = ip : hostAddresses he } + RDCNAME ns -> he { hostName = intercalate "." (map C8.unpack ns) + , hostAliases = hostName he : hostAliases he } + _ -> he + +parsePtr :: IP4 -> [RR] -> HostEntry +parsePtr addr = foldl' processAnswer emptyHostEntry + where + emptyHostEntry = HostEntry { hostName = "" + , hostAliases = [] + , hostAddresses = [addr] } + + processAnswer he RR { .. } = case rrRData of + RDPTR name -> he { hostName = intercalate "." (map C8.unpack name) } + _ -> he + + +-- Query Management ------------------------------------------------------------ + +type DnsResult = MVar (Either DnsException HostEntry) + +putResult :: DnsResult -> HostEntry -> IO () +putResult var he = putMVar var (Right he) + +putError :: DnsResult -> DnsException -> IO () +putError var err = putMVar var (Left err) + +data DnsQuery = DnsQuery { qResult :: DnsResult + -- ^ The handle back to the thread waiting fo the + -- HostEntry + , qUdpPort :: !UdpPort + -- ^ The port this request is receiving on + , qRequest :: L.ByteString + -- ^ The packet to send + , qServers :: [IP4] + -- ^ Name servers left to try + , qLastServer :: Maybe IP4 + -- ^ The last server queried + , qTimeout :: Maybe Timer + -- ^ The timer for the current request + } + +mkDnsQuery :: DnsResult -> [IP4] -> UdpPort -> Source -> Word16 -> DnsQuery +mkDnsQuery res nss port src reqId = + DnsQuery { qResult = res + , qUdpPort = port + , qRequest = renderDNSPacket (mkDNSPacket host qs reqId) + , qServers = nss + , qLastServer = Nothing + , qTimeout = Nothing + } + where + host = sourceHost src + qs = sourceQType src + + +mkDNSPacket :: Name -> [QType] -> Word16 -> DNSPacket +mkDNSPacket name qs reqId = + DNSPacket { dnsHeader = hdr + , dnsQuestions = [ mkQuery q | q <- qs ] + , dnsAnswers = [] + , dnsAuthorityRecords = [] + , dnsAdditionalRecords = [] + } + where + hdr = DNSHeader { dnsId = reqId + , dnsQuery = True + , dnsOpCode = OpQuery + , dnsAA = False + , dnsTC = False + , dnsRD = True + , dnsRA = False + , dnsRC = RespNoError + } + + mkQuery qty = Query { qName = name + , qType = qty + , qClass = QClass IN + } + + +-- UDP Interaction ------------------------------------------------------------- + +-- | Send a UDP query to the server given +sendQuery :: IP4 -> UdpPort -> Word16 -> L.ByteString -> Dns () +sendQuery nameServer sp reqId bytes = + do DnsState { .. } <- get + output $ do sendUdp dnsUdpHandle nameServer (Just sp) 53 bytes + expire <- delay dnsTimeout (send dnsSelf (expireRequest reqId) `X.finally` putStrLn "KILLED") + send dnsSelf (registerTimeout reqId expire) + +-- | Queue the packet into the DNS layer for processing. +serverResponse :: DnsHandle -> Source -> UdpPort -> Udp.Handler +serverResponse dns src _ srcIp srcPort bytes = + send dns (handleResponse src srcIp srcPort bytes) diff --git a/src/Hans/Layer/Ethernet.hs b/src/Hans/Layer/Ethernet.hs --- a/src/Hans/Layer/Ethernet.hs +++ b/src/Hans/Layer/Ethernet.hs @@ -25,20 +25,21 @@ import Hans.Channel import Hans.Layer import Hans.Message.EthernetFrame -import Hans.Utils (Packet,void,just) +import Hans.Utils (void,just) import Control.Concurrent (forkIO,ThreadId,killThread) import Control.Monad (mplus) -import Data.Serialize (decode,encode) import MonadLib (get,set) -import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.ByteString as S --- Messages -------------------------------------------------------------------- +-- Ethernet Layer -------------------------------------------------------------- -type Handler = Packet -> IO () +type Handler = S.ByteString -> IO () -type Tx = Packet -> IO () +type Tx = L.ByteString -> IO () type Rx = EthernetHandle -> IO () type EthernetHandle = Channel (Eth ()) @@ -46,12 +47,15 @@ -- | Run the ethernet layer. runEthernetLayer :: EthernetHandle -> IO () runEthernetLayer h = - void (forkIO (loopLayer (emptyEthernetState h) (receive h) id)) + void (forkIO (loopLayer "ethernet" (emptyEthernetState h) (receive h) id)) -sendEthernet :: EthernetHandle -> EthernetFrame -> IO () -sendEthernet h !frame = send h (handleOutgoing frame) -queueEthernet :: EthernetHandle -> Packet -> IO () +-- External Interface ---------------------------------------------------------- + +sendEthernet :: EthernetHandle -> EthernetFrame -> L.ByteString -> IO () +sendEthernet h !frame body = send h (handleOutgoing frame body) + +queueEthernet :: EthernetHandle -> S.ByteString -> IO () queueEthernet h !pkt = send h (handleIncoming pkt) startEthernetDevice :: EthernetHandle -> Mac -> IO () @@ -111,14 +115,15 @@ self :: Eth EthernetHandle self = ethHandle `fmap` get + -- Message Handling ------------------------------------------------------------ -- | Handle an incoming packet, from a device. -handleIncoming :: Packet -> Eth () +handleIncoming :: S.ByteString -> Eth () handleIncoming pkt = do - frame <- liftRight (decode pkt) - h <- getHandler (etherType frame) - output (h (etherData frame)) + (hdr,body) <- liftRight (parseEthernetFrame pkt) + h <- getHandler (etherType hdr) + output (h body) -- | Get the device associated with a mac address. @@ -137,10 +142,10 @@ -- | Send an outgoing ethernet frame via the device that it's associated with. -handleOutgoing :: EthernetFrame -> Eth () -handleOutgoing frame = do +handleOutgoing :: EthernetFrame -> L.ByteString -> Eth () +handleOutgoing frame body = do dev <- getDevice (etherSource frame) - output (devTx dev (encode frame)) + output (devTx dev (renderEthernetFrame frame body)) -- | Add an ethernet device to the state. diff --git a/src/Hans/Layer/IP4.hs b/src/Hans/Layer/IP4.hs --- a/src/Hans/Layer/IP4.hs +++ b/src/Hans/Layer/IP4.hs @@ -13,8 +13,10 @@ , withIP4Source , sendIP4Packet , addIP4RoutingRule - , addIP4Handler + , addIP4Handler, Handler , removeIP4Handler + + , Mtu ) where import Hans.Address @@ -32,18 +34,18 @@ import Control.Concurrent (forkIO) import Control.Monad (guard,mplus,(<=<)) -import Data.Serialize.Get (runGet) import MonadLib (get,set) -import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S -type Handler = IP4 -> IP4 -> Packet -> IO () +type Handler = IP4Header -> S.ByteString -> IO () type IP4Handle = Channel (IP ()) runIP4Layer :: IP4Handle -> ArpHandle -> EthernetHandle -> IO () runIP4Layer h arp eth = do - void (forkIO (loopLayer (emptyIP4State arp) (receive h) id)) + void (forkIO (loopLayer "ip4" (emptyIP4State arp) (receive h) id)) connectEthernet h eth connectEthernet :: IP4Handle -> EthernetHandle -> IO () @@ -56,8 +58,8 @@ addIP4RoutingRule :: IP4Handle -> Rule IP4Mask IP4 -> IO () addIP4RoutingRule h !rule = send h (handleAddRule rule) -sendIP4Packet :: IP4Handle -> IP4Protocol -> IP4 -> Packet -> IO () -sendIP4Packet h !prot !dst !pkt = send h (handleOutgoing prot dst pkt) +sendIP4Packet :: IP4Handle -> IP4Header -> L.ByteString -> IO () +sendIP4Packet h !hdr !pkt = send h (sendBytes hdr pkt) addIP4Handler :: IP4Handle -> IP4Protocol -> Handler -> IO () addIP4Handler h !prot k = send h (addHandler prot k) @@ -97,30 +99,23 @@ arpHandle :: IP ArpHandle arpHandle = ip4ArpHandle `fmap` get -sendBytes :: IP4Protocol -> IP4 -> Packet -> IP () -sendBytes prot dst bs = do - rule@(src,_,mtu) <- findRoute dst - let hdr = emptyIP4Header prot src dst - hdr' <- if fromIntegral (S.length bs) + 20 < mtu - then return hdr - else do - i <- nextIdent - return (setIdent i hdr) - sendPacket' (IP4Packet hdr' bs) rule - -sendPacket :: IP4Packet -> IP () -sendPacket pkt = do - rule@(src,_,_) <- findRoute (ip4DestAddr (ip4Header pkt)) - guard (src /= ip4SourceAddr (ip4Header pkt)) - sendPacket' pkt rule +sendBytes :: IP4Header -> L.ByteString -> IP () +sendBytes hdr0 bs = do + rule@(src,_,_) <- findRoute (ip4DestAddr hdr0) + ident <- nextIdent + let hdr = hdr0 + { ip4SourceAddr = src + , ip4Ident = ident + } + sendPacket' hdr bs rule -- | Send a packet using a given routing rule -sendPacket' :: IP4Packet -> (IP4,IP4,Mtu) -> IP () -sendPacket' pkt (src,dst,mtu) = do +sendPacket' :: IP4Header -> L.ByteString -> (IP4,IP4,Mtu) -> IP () +sendPacket' hdr body (src,dst,mtu) = do arp <- arpHandle output $ do - let frags = splitPacket mtu pkt - mapM_ (arpIP4Packet arp src dst <=< renderIP4Packet) frags + let frags = splitPacket mtu hdr body + mapM_ (arpIP4Packet arp src dst <=< uncurry renderIP4Packet) frags -- | Find a route to an address @@ -131,9 +126,11 @@ -- | Route a packet that is forwardable -forward :: IP4Packet -> IP () -forward pkt = sendPacket pkt - +forward :: IP4Header -> L.ByteString -> IP () +forward hdr body = do + rule@(src,_,_) <- findRoute (ip4DestAddr hdr) + guard (src /= ip4SourceAddr hdr) + sendPacket' hdr body rule -- | Require that an address is local. localAddress :: IP4 -> IP () @@ -154,22 +151,22 @@ guard (isBroadcast mask ip) -- | Route a message to a local handler -routeLocal :: IP4Packet -> IP () -routeLocal pkt@(IP4Packet hdr _) = do +routeLocal :: IP4Header -> S.ByteString -> IP () +routeLocal hdr body = do let dest = ip4DestAddr hdr localAddress dest `mplus` broadcastDestination dest h <- getHandler (ip4Protocol hdr) - mb <- handleFragments pkt + mb <- handleFragments hdr body case mb of + Just bs -> output (h hdr (strict bs)) Nothing -> return () - Just bs -> output (h (ip4SourceAddr hdr) (ip4DestAddr hdr) bs) -handleFragments :: IP4Packet -> IP (Maybe Packet) -handleFragments pkt = do +handleFragments :: IP4Header -> S.ByteString -> IP (Maybe L.ByteString) +handleFragments hdr body = do state <- get now <- time - let (table',mb) = processIP4Packet now (ip4Fragments state) pkt + let (table',mb) = processIP4Packet now (ip4Fragments state) hdr body table' `seq` set state { ip4Fragments = table' } return mb @@ -183,13 +180,11 @@ -- Message Handling ------------------------------------------------------------ -- | Incoming packet from the network -handleIncoming :: Packet -> IP () +handleIncoming :: S.ByteString -> IP () handleIncoming bs = do - (hdr,hlen,plen) <- liftRight (runGet parseIP4Packet bs) + (hdr,hlen,plen) <- liftRight (parseIP4Packet bs) let (header,rest) = S.splitAt hlen bs - let payload = S.take plen rest let checksum = computeChecksum 0 header - let pkt = IP4Packet hdr payload guard $ and [ S.length bs >= 20 , hlen >= 20 @@ -198,13 +193,8 @@ ] -- forward? - routeLocal pkt `mplus` forward pkt - - --- | Outgoing packet -handleOutgoing :: IP4Protocol -> IP4 -> Packet -> IP () -handleOutgoing prot dst bs = do - sendBytes prot dst bs + let payload = S.take (plen - hlen) rest + routeLocal hdr payload `mplus` forward hdr (chunk payload) handleAddRule :: Rule IP4Mask IP4 -> IP () diff --git a/src/Hans/Layer/IP4/Fragmentation.hs b/src/Hans/Layer/IP4/Fragmentation.hs --- a/src/Hans/Layer/IP4/Fragmentation.hs +++ b/src/Hans/Layer/IP4/Fragmentation.hs @@ -4,12 +4,13 @@ import Hans.Address import Hans.Address.IP4 import Hans.Message.Ip4 -import Hans.Utils +import Hans.Utils (chunk) import Data.Ord (comparing) import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.ByteString as S -import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.ByteString as S type FragmentationTable addr = Map.Map (Ident,addr,addr) Fragments @@ -27,7 +28,7 @@ data Fragment = Fragment { fragmentOffset :: !Int , fragmentLength :: !Int - , fragmentPayload :: !Packet + , fragmentPayload :: L.ByteString } deriving (Eq,Show) instance Ord Fragment where @@ -54,7 +55,7 @@ combineFragments f g = Fragment (fragmentOffset f) len pay where len = fragmentLength f + fragmentLength g - pay = fragmentPayload f `S.append` fragmentPayload g + pay = fragmentPayload f `L.append` fragmentPayload g -- | Given a group of fragments, a new fragment, and a possible total size, @@ -81,27 +82,30 @@ -- is itself a fully-complete packet. processFragment :: Address addr => POSIXTime -> FragmentationTable addr -> Bool -> Int - -> addr -> addr -> Ident -> Packet - -> (FragmentationTable addr, Maybe Packet) -processFragment _ table False 0 _ _ _ bs = (table, Just bs) -processFragment now table areMore off src dest ident bs = case group of - Fragments _ x [Fragment 0 y bs'] - | x == y -> (Map.delete entry table, Just bs') - _ -> (Map.insert entry group table, Nothing) + -> addr -> addr -> Ident -> S.ByteString + -> (FragmentationTable addr, Maybe L.ByteString) +processFragment _ table False 0 _ _ _ bs = + (table, Just (chunk bs)) +processFragment now table areMore off src dest ident bs = + case group of + Fragments _ x [Fragment 0 y bs'] + | x == y -> (Map.delete entry table, Just bs') + _ -> (Map.insert entry group table, Nothing) where entry = (ident,src,dest) group = case Map.lookup (ident,src,dest) table of Nothing -> Fragments now newTotalLen [cur] Just g -> expandGroup g cur newTotalLen - curlen = fromIntegral (S.length bs) - cur = Fragment off curlen bs + curlen = S.length bs + cur = Fragment off curlen (chunk bs) newTotalLen | areMore = -1 | otherwise = off + curlen -processIP4Packet :: POSIXTime -> FragmentationTable IP4 -> IP4Packet - -> (FragmentationTable IP4, Maybe Packet) -processIP4Packet now table (IP4Packet hdr bs) = +processIP4Packet :: POSIXTime -> FragmentationTable IP4 + -> IP4Header -> S.ByteString + -> (FragmentationTable IP4, Maybe L.ByteString) +processIP4Packet now table hdr bs = processFragment now table areMore off src dest ident bs where off = fromIntegral (ip4FragmentOffset hdr) diff --git a/src/Hans/Layer/Icmp4.hs b/src/Hans/Layer/Icmp4.hs --- a/src/Hans/Layer/Icmp4.hs +++ b/src/Hans/Layer/Icmp4.hs @@ -6,19 +6,21 @@ Icmp4Handle , runIcmp4Layer , addIcmp4Handler + , destUnreachable ) where -import Hans.Address.IP4 +import Hans.Address.IP4 (IP4,broadcastIP4) import Hans.Channel import Hans.Layer -import Hans.Layer.IP4 import Hans.Message.Icmp4 import Hans.Message.Ip4 import Hans.Utils +import qualified Hans.Layer.IP4 as IP4 import Control.Concurrent (forkIO) -import Data.Serialize (decode,encode) +import Data.Serialize (runPut,putByteString) import MonadLib (get,set) +import qualified Data.ByteString as S type Handler = Icmp4Packet -> IO () @@ -27,45 +29,62 @@ icmpProtocol :: IP4Protocol icmpProtocol = IP4Protocol 0x1 -runIcmp4Layer :: Icmp4Handle -> IP4Handle -> IO () +runIcmp4Layer :: Icmp4Handle -> IP4.IP4Handle -> IO () runIcmp4Layer h ip4 = do let handles = Icmp4Handles ip4 [] - addIP4Handler ip4 icmpProtocol - $ \src dst bs -> send h (handleIncoming src dst bs) - void (forkIO (loopLayer handles (receive h) id)) + IP4.addIP4Handler ip4 icmpProtocol + $ \ hdr bs -> send h (handleIncoming hdr bs) + void (forkIO (loopLayer "icmp4" handles (receive h) id)) data Icmp4Handles = Icmp4Handles - { icmpIp4 :: IP4Handle + { icmpIp4 :: IP4.IP4Handle , icmpHandlers :: [Handler] } type Icmp4 = Layer Icmp4Handles -ip4Handle :: Icmp4 IP4Handle +ip4Handle :: Icmp4 IP4.IP4Handle ip4Handle = icmpIp4 `fmap` get -sendPacket :: IP4 -> Icmp4Packet -> Icmp4 () -sendPacket dst pkt = do - ip4 <- ip4Handle - output $ sendIP4Packet ip4 icmpProtocol dst (encode pkt) - -- | Add a handler for Icmp4 messages that match the provided predicate. addIcmp4Handler :: Icmp4Handle -> Handler -> IO () addIcmp4Handler h k = send h (handleAdd k) +-- | Send a destination unreachable message to a host, with the given bytes as +-- its body. Don't send the message, if the message was broadcast. +destUnreachable :: Icmp4Handle -> DestinationUnreachableCode + -> IP4Header -> Int -> S.ByteString -> IO () +destUnreachable h code hdr len body + | ip4DestAddr hdr == broadcastIP4 = return () + | otherwise = send h $ do + let bytes = runPut $ do + putIP4Header hdr len + putByteString (S.take 8 body) + sendPacket True (ip4SourceAddr hdr) (DestinationUnreachable code bytes) + -- Message Handling ------------------------------------------------------------ +-- | Deliver an ICMP message via the IP4 layer. +sendPacket :: Bool -> IP4 -> Icmp4Packet -> Icmp4 () +sendPacket df dst pkt = do + ip4 <- ip4Handle + let hdr = emptyIP4Header + { ip4DestAddr = dst + , ip4Protocol = icmpProtocol + , ip4DontFragment = df + } + output $ IP4.sendIP4Packet ip4 hdr + $ renderIcmp4Packet pkt + -- | Handle incoming ICMP packets -handleIncoming :: IP4 -> IP4 -> Packet -> Icmp4 () -handleIncoming src _dst bs = do - pkt <- liftRight (decode bs) +handleIncoming :: IP4Header -> S.ByteString -> Icmp4 () +handleIncoming hdr bs = do + pkt <- liftRight (parseIcmp4Packet bs) matchHandlers pkt case pkt of -- XXX: Only echo-request is handled at the moment - Echo ident seqNum dat -> handleEchoRequest src ident seqNum dat - _ty -> do - --output (putStrLn ("Unhandled ICMP message type: " ++ show ty)) - dropPacket + Echo ident seqNum dat -> handleEchoRequest hdr ident seqNum dat + _ty -> dropPacket -- | Add an icmp packet handler. @@ -76,9 +95,11 @@ -- | Respond to an echo request -handleEchoRequest :: IP4 -> Identifier -> SequenceNumber -> Packet -> Icmp4 () -handleEchoRequest src ident seqNum dat = do - sendPacket src (EchoReply ident seqNum dat) +handleEchoRequest :: IP4Header -> Identifier -> SequenceNumber -> S.ByteString + -> Icmp4 () +handleEchoRequest hdr ident seqNum dat = + sendPacket (ip4DontFragment hdr) (ip4SourceAddr hdr) + (EchoReply ident seqNum dat) -- | Output the IO actions for each handler that's registered. diff --git a/src/Hans/Layer/Tcp.hs b/src/Hans/Layer/Tcp.hs --- a/src/Hans/Layer/Tcp.hs +++ b/src/Hans/Layer/Tcp.hs @@ -1,49 +1,57 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} module Hans.Layer.Tcp ( TcpHandle , runTcpLayer , queueTcp - - , module Exports ) where -import Hans.Address.IP4 import Hans.Channel import Hans.Layer import Hans.Layer.IP4 -import Hans.Layer.Tcp.Monad (Tcp,TcpHandle,TcpState(..),emptyTcpState) -import Hans.Layer.Tcp.Socket as Exports -import Hans.Layer.Timer (TimerHandle,udelay) -import Hans.Message.Tcp (tcpProtocol) -import Hans.Layer.Tcp.Handlers (handleIncomingTcp,handleOutgoing) -import Hans.Utils (void) - -import Network.TCP.Type.Base (posixtime_to_time) -import Network.TCP.Type.Socket (update_host_time) +import Hans.Layer.Tcp.Handlers +import Hans.Layer.Tcp.Monad +import Hans.Layer.Tcp.Timers +import Hans.Layer.Tcp.Types +import Hans.Message.Ip4 +import Hans.Message.Tcp +import Hans.Utils import Control.Concurrent (forkIO) -import MonadLib (get,set) +import Data.Time.Clock.POSIX (getPOSIXTime,POSIXTime) import qualified Data.ByteString as S -runTcpLayer :: TcpHandle -> IP4Handle -> TimerHandle -> IO () -runTcpLayer tcp ip4 t = do - let s0 = emptyTcpState tcp ip4 t - void (forkIO (loopLayer s0 (receive tcp) updateTimeAndRun)) +runTcpLayer :: TcpHandle -> IP4Handle -> IO () +runTcpLayer tcp ip4 = do + start <- getPOSIXTime + let s0 = emptyTcpState tcp ip4 start + void (forkIO (loopLayer "tcp" s0 (receive tcp) stepTcp)) addIP4Handler ip4 tcpProtocol (queueTcp tcp) + -- initialize the timers + send tcp initTimers + -- | Queue a tcp packet. -queueTcp :: TcpHandle -> IP4 -> IP4 -> S.ByteString -> IO () -queueTcp tcp !src !dst !bs = send tcp (handleIncomingTcp src dst bs) +queueTcp :: TcpHandle -> IP4Header -> S.ByteString -> IO () +queueTcp tcp !hdr !bs = send tcp (handleIncomingTcp hdr bs) --- | Pull the time out of the Layer monad, and convert it to a value that can be --- used with the TCP layer. -updateTimeAndRun :: Tcp () -> Tcp () -updateTimeAndRun body = do +-- | Rate of ISN increase, in Hz. +isnRate :: POSIXTime +isnRate = 128000 + +-- | Run the tcp action, after updating any internal state. +stepTcp :: Tcp () -> Tcp () +stepTcp body = do now <- time - s <- get - set $! s { tcpHost = update_host_time (posixtime_to_time now) (tcpHost s) } + 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 body - handleOutgoing diff --git a/src/Hans/Layer/Tcp/Handlers.hs b/src/Hans/Layer/Tcp/Handlers.hs --- a/src/Hans/Layer/Tcp/Handlers.hs +++ b/src/Hans/Layer/Tcp/Handlers.hs @@ -1,74 +1,506 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} + module Hans.Layer.Tcp.Handlers ( handleIncomingTcp - , handleOutgoing + , outputSegments ) where -import Hans.Address.IP4 (IP4,convertFromWord32) -import Hans.Channel (send) -import Hans.Layer (output,liftRight) -import Hans.Layer.IP4 (sendIP4Packet,withIP4Source) +import Hans.Address.IP4 +import Hans.Layer +import Hans.Layer.Tcp.Messages import Hans.Layer.Tcp.Monad - (Tcp,TcpState(..),ip4Handle,ip4Handle,ip4Handle,ip4Handle) -import Hans.Layer.Timer (udelay) +import Hans.Layer.Tcp.Timers +import Hans.Layer.Tcp.Types +import Hans.Layer.Tcp.Window +import Hans.Message.Ip4 import Hans.Message.Tcp - (tcpProtocol,renderWithTcpChecksumIP4,TcpPacket(..),getTcpPacket - ,recreateTcpChecksumIP4,TcpHeader(..)) -import Network.TCP.LTS.In (tcp_deliver_in_packet) -import Network.TCP.Type.Base (get_ip,bufferchain_collapse,IPAddr(..)) -import Network.TCP.Type.Datagram - (ICMPDatagram(..),UDPDatagram(..),TCPSegment(..),IPMessage(..) - ,mkTCPSegment) -import Network.TCP.Type.Socket (Host(..)) - -import Control.Monad (unless,guard) -import Data.Serialize (runGet) -import MonadLib (get,set) +import Control.Monad (guard,when,unless,join) +import Data.Bits (bit) +import Data.Int (Int64) +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 --- | Handle a TCP message from the IP4 layer. -handleIncomingTcp :: IP4 -> IP4 -> S.ByteString -> Tcp () -handleIncomingTcp src dst bytes = do - let cs = recreateTcpChecksumIP4 src dst bytes - pkt@(TcpPacket hdr _body) <- liftRight (runGet getTcpPacket bytes) - guard (tcpChecksum hdr == cs) - tcp_deliver_in_packet (mkTCPSegment src dst pkt) +-- Incoming Packets ------------------------------------------------------------ --- | Force packets out of the pure layer. -handleOutgoing :: Tcp () -handleOutgoing = do - s <- get - let h = tcpHost s - set (s { tcpHost = h { output_queue = [], ready_list = [] } }) - let msgs = output_queue h - unless (null msgs) (mapM_ deliverIPMessage msgs) - let ready = ready_list h - unless (null ready) (mapM_ output ready) +-- | Process a single incoming tcp packet. +handleIncomingTcp :: IP4Header -> S.ByteString -> Tcp () +handleIncomingTcp ip4 bytes = do -deliverIPMessage :: IPMessage -> Tcp () -deliverIPMessage msg = - case msg of - TCPMessage seg -> deliverTCPSegment seg - ICMPMessage icmp -> deliverICMPDatagram icmp - UDPMessage udp -> deliverUDPDatagram udp + let src = ip4SourceAddr ip4 + dst = ip4DestAddr ip4 -deliverTCPSegment :: TCPSegment -> Tcp () -deliverTCPSegment seg = do - let hdr = tcp_header seg - IPAddr dst = get_ip (tcp_dst seg) - dstAddr = convertFromWord32 dst - ip4 <- ip4Handle - output $ withIP4Source ip4 dstAddr $ \ srcAddr -> do - body <- bufferchain_collapse (tcp_data seg) - let pkt = renderWithTcpChecksumIP4 srcAddr dstAddr (TcpPacket hdr body) - sendIP4Packet ip4 tcpProtocol dstAddr pkt + guard (validateTcpChecksumIP4 src dst bytes) + (hdr,body) <- liftRight (parseTcpPacket bytes) -deliverICMPDatagram :: ICMPDatagram -> Tcp () -deliverICMPDatagram _icmp = do - output (putStrLn "Ignoring TCP icmp packet") + withConnection' src hdr (segmentArrives src hdr body) + $ timeWaitConnection src hdr + $ noConnection src hdr body -deliverUDPDatagram :: UDPDatagram -> Tcp () -deliverUDPDatagram _udp = do - output (putStrLn "Ignoring TCP udp packet") +noConnection :: IP4 -> TcpHeader -> S.ByteString -> Tcp () +noConnection src hdr @ TcpHeader { .. } body = + do output (putStrLn "no connection") + if | tcpRst -> return () + | tcpAck -> sendSegment src (mkRst hdr) L.empty + | otherwise -> sendSegment src (mkRstAck hdr (S.length body)) L.empty + finish + +-- Arrival to a TIME_WAIT socket------------------------------------------------ + +-- | Handle an incoming packet in the TimeWait state +timeWaitConnection :: IP4 -> TcpHeader -> Tcp () -> Tcp () +timeWaitConnection src hdr noTimeWait = + do mb <- getTimeWait src hdr + case mb of + Just (sid,tcp) -> handleTimeWait sid tcp hdr + Nothing -> noTimeWait + + +handleTimeWait :: SocketId -> TimeWaitSock -> TcpHeader -> Tcp () +handleTimeWait sid TimeWaitSock { .. } TcpHeader { .. } + | tcpRst || tcpSyn = removeTimeWait sid + | tcpAck = do resetTimeWait2MSL sid + + let addTimestamp + | Just ts <- twTimestamp = setTcpOption (mkTimestamp ts) + | otherwise = id + + hdr = addTimestamp emptyTcpHeader + { tcpDestPort = tcpSourcePort + , tcpSourcePort = tcpDestPort + , tcpSeqNum = twSeqNum + -- advance RCV.NXT over the FIN + , tcpAckNum = tcpSeqNum + 1 + , tcpAck = True + } + + -- ACK the retransmitted FIN,ACK + when tcpFin (sendSegment (sidRemoteHost sid) hdr L.empty) + | otherwise = return () + + + +-- Segment Arrival ------------------------------------------------------------- + +{-# INLINE discardAndReturn #-} +discardAndReturn :: Sock a +discardAndReturn = do outputSegments + escape + +{-# INLINE done #-} +done :: Sock a +done = do outputSegments + escape + +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)) + + whenState Listen $ + do when (tcpAck hdr) (rst hdr) + + when (tcpSyn hdr) $ do child <- createConnection src hdr + _ <- withChild child synAck + return () + + -- RST will be dropped at this point, as will anything else that + -- wasn't covered by the above two cases. + done + + whenState SynSent $ + do tcp <- getTcpSocket + + -- check the ACK + when (tcpAck hdr) $ + do when (tcpAckNum hdr <= tcpIss tcp || + tcpAckNum hdr > tcpSndNxt tcp) $ + do unless (tcpRst hdr) (rst hdr) + discardAndReturn + + -- one of these has to be set to continue processing in this state. + unless (tcpSyn hdr || tcpRst hdr) discardAndReturn + + -- check RST + let accAcceptable = tcpSndUna tcp <= tcpAckNum hdr && + tcpAckNum hdr <= tcpSndNxt tcp + + when (tcpRst hdr) $ + do when accAcceptable $ do notify False + closeSocket + discardAndReturn + + -- this is where a security/compartment check would be done + + -- check SYN + + when (tcpSyn hdr) $ + do advanceRcvNxt 1 + modifyTcpSocket_ $ \ sock -> sock + { tcpOutMSS = fromMaybe (tcpInMSS sock) (getMSS hdr) + + -- clear out, and configure the retransmit buffer + , tcpOut = setSndWind (tcpWindow hdr) + $ setSndWindScale (windowScale hdr) + $ clearRetransmit + $ tcpOut sock + + -- 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 handleAck hdr -- update SND.UNA + TcpSocket { .. } <- getTcpSocket + if tcpSndUna > tcpIss + then do ack + establishConnection + notify True + + -- continue at step 6 + when (tcpUrg hdr) (proceedFromStep6 hdr body) + + else do setState SynReceived + synAck + -- XXX queue any additional data for processing + -- once Established has been reached + + done + + -- make sure that the sequence numbers are valid + checkSequenceNumber hdr body + checkResetBit hdr + -- skip security/precidence check + checkSynBit hdr + checkAckBit hdr + proceedFromStep6 hdr body + +proceedFromStep6 :: TcpHeader -> S.ByteString -> Sock () +proceedFromStep6 hdr body = + do -- XXX skipping URG processing + processSegmentText hdr body + checkFinBit hdr + + +-- | Make sure that there is space for the incoming segment +checkSequenceNumber :: TcpHeader -> S.ByteString -> Sock () +checkSequenceNumber hdr body = + do TcpSocket { .. } <- getTcpSocket + + -- RCV.NXT <= SEG.SEQ + off < RCV.NXT + RCV.WND + let canReceive off = + lwRcvNxt tcpIn <= segSeq && + segSeq < lwRcvNxt tcpIn + fromIntegral (lwRcvWind tcpIn) + where + segSeq = tcpSeqNum hdr + off + + len = fromIntegral (S.length body) + + shouldDiscard + | len == 0 = if lwRcvWind tcpIn == 0 + -- SEQ.SEG = RCV.NXT + then tcpSeqNum hdr == lwRcvNxt tcpIn + else canReceive 0 + | otherwise = canReceive 0 || canReceive (len - 1) + + when (shouldDiscard && all not [tcpAck hdr, tcpUrg hdr, tcpRst hdr]) $ + do unless (tcpRst hdr) ack + discardAndReturn + +-- | 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 + + | otherwise = return () + +checkSynBit :: TcpHeader -> Sock () +checkSynBit hdr + | tcpSyn hdr = whenStates [SynReceived,Established,FinWait1,FinWait2 + ,CloseWait,Closing,LastAck] $ + do tcp <- getTcpSocket + + when (tcpSeqNum hdr `inRcvWnd` tcp) $ + do flushQueues + closeSocket + done + + | otherwise = return () + +checkAckBit :: TcpHeader -> Sock () +checkAckBit hdr + | tcpAck hdr = + do whenState SynReceived $ + do tcp <- getTcpSocket + if tcpSndUna tcp <= tcpAckNum hdr && tcpAckNum hdr <= tcpSndNxt tcp + then establishConnection + else rst hdr + + whenStates [Established,FinWait1,FinWait2,CloseWait,Closing] $ + do let TcpHeader { .. } = hdr + TcpSocket { .. } <- getTcpSocket + + -- if the ack was to something that is outstanding, update SND.UNA, + -- and filter things out of the retransmit queue + when (tcpSndUna < tcpAckNum && tcpAckNum <= tcpSndNxt) (handleAck hdr) + + -- if the ack is to something that hasn't been sent yet, drop the + -- segment + when (tcpSndNxt < tcpAckNum) discardAndReturn + + whenState FinWait1 $ + do tcp <- getTcpSocket + when (nothingOutstanding tcp) (setState FinWait2) + + -- XXX no way to acknowledge the user's close request from FinWait2 + -- whenState FinWait2 $ ... + + whenState Closing $ + do tcp <- getTcpSocket + when (nothingOutstanding tcp) enterTimeWait + + whenState LastAck $ + do tcp <- getTcpSocket + when (nothingOutstanding tcp) $ do closeSocket + done + + | otherwise = discardAndReturn + +processSegmentText :: TcpHeader -> S.ByteString -> Sock () +processSegmentText hdr body = + whenStates [Established,FinWait1,FinWait2] $ + do if S.null body + -- make sure that the the delayed ack flag gets set + then when (tcpSyn hdr || tcpFin hdr) $ modifyTcpTimers_ + $ \ tt -> tt { ttDelayedAck = True } + + -- push the segment through the local window, if it was the next thing + -- expected, a wakeup action will be returned, notifying a waiting + -- thread that there's something to read in the input buffer. + else do mb <- modifyTcpSocket (handleData hdr body) + + -- notify any waiting threads that there is stuff to read + case mb of + Just wakeup -> outputS (tryAgain wakeup) + Nothing -> return () + + + -- otherwise, ignore the segment text + +checkFinBit :: TcpHeader -> Sock () +checkFinBit hdr + | tcpFin hdr = + do -- do not process the FIN + whenStates [Closed,Listen,SynSent] + discardAndReturn + + -- advance RCV.NXT over the FIN + advanceRcvNxt 1 + + flushQueues + ack + + -- don't emit a FIN here, as that should be done by the user with an + -- explicit call to `close` + + whenStates [SynReceived,Established] (setState CloseWait) + + -- XXX this needs to check that the FIN was ACKed, instead of just + -- entering TimeWait + whenState FinWait1 $ do TcpSocket { .. } <- getTcpSocket + if tcpSndNxt <= tcpSndUna + then enterTimeWait + else setState Closing + + whenState FinWait2 enterTimeWait + + -- don't do anything else for the remaining states + done + + | otherwise = return () + + +-- | Flush all pending outgoing state. +-- +-- TODO: +-- * Push all data out of the incoming queue to the incoming buffer +-- * Mark the socket as not accepting any more user data +flushQueues :: Sock () +flushQueues = + do finalizers <- modifyTcpSocket flush + outputS finalizers + where + flush tcp = (fins,tcp') + where + + -- empty the outgoing buffer, notifying all waiting processes that the send + -- won't happen + (fins,out') = flushWaiting (tcpOutBuffer tcp) + + tcp' = tcp { tcpOutBuffer = out' + } + + +-- | Update the currently held timestamp for both sides, and return a boolean +-- that indicates whether or not the packet should be dropped. +-- +-- RFC 1323 +updateTimestamp :: TcpHeader -> TcpSocket -> (Bool,TcpSocket) +updateTimestamp hdr tcp = (shouldDrop,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' + ts' = do + ts <- tcpTimestamp tcp + OptTimestamp them echo <- findTcpOption OptTagTimestamp hdr + -- when this is an ack, the echo value should not be greater than the + -- current timestamp. this doesn't currently account for overflow, so + -- connections lasting >27 days will probably fail. + let rel = tsTimestamp ts - echo + isGreater = 0 < rel && rel < bit 31 + when (tcpAck hdr) (guard (tsTimestamp ts == echo || isGreater)) + return ts { tsLastTimestamp = them } + +-- | Enqueue a new packet in the local window, attempting to place the bytes +-- received in the user buffer as they complete a part of the stream. Bytes are +-- ack'd as they complete the stream, and bytes that would cause the local +-- buffer to overflow are dropped. +handleData :: TcpHeader -> S.ByteString -> TcpSocket + -> (Maybe Wakeup, TcpSocket) +handleData hdr body tcp0 = fromMaybe (Nothing,tcp) $ do + (wakeup,buf') <- putBytes bytes (tcpInBuffer tcp) + let tcp' = tcp + { tcpInBuffer = buf' + , tcpTimers = (tcpTimers tcp) + { ttDelayedAck = or [ not (L.null bytes) + , tcpSyn hdr + , tcpFin hdr ] + } + } + return (wakeup, tcp') + where + (segs,win') = incomingPacket hdr body (tcpIn tcp0) + tcp = tcp0 { tcpIn = win' } + bytes = L.fromChunks (map inBody (F.toList segs)) + + +-- | Handle an ACK to a sent data segment. +handleAck :: TcpHeader -> Sock () +handleAck hdr = do + now <- inTcp time + modifyTcpSocket_ (updateAck now) + where + -- using Karns algorithm, only calibrate the RTO if the packet that was ack'd + -- has not yet been retransmitted. + updateAck now tcp = case receiveAck hdr (tcpOut tcp) of + Just (seg,out') -> + let calibrate | outFresh seg = calibrateRTO now (outTime seg) + | otherwise = id + in tcp { tcpOut = out' + , tcpSndUna = tcpAckNum hdr + , tcpTimers = calibrate (tcpTimers tcp) + } + Nothing -> tcp + +-- | Setup the 2MSL timer, and enter the TIME_WAIT state. We only enter +-- TimeWait if all of our sent data has been ACKed, so it's safe to clear out +-- the retransmit queue here. +enterTimeWait :: Sock () +enterTimeWait = do + modifyTcpSocket_ $ \ tcp -> tcp { tcpOut = clearRetransmit (tcpOut tcp) } + set2MSL mslTimeout + setState TimeWait + +createConnection :: IP4 -> TcpHeader -> Sock TcpSocket +createConnection ip4 hdr = + do let parent = listenSocketId (tcpDestPort hdr) + isn <- inTcp initialSeqNum + tcp <- getTcpSocket + return (emptyTcpSocket (tcpWindow hdr) (windowScale hdr)) + { tcpParent = Just parent + , tcpSocketId = incomingSocketId ip4 hdr + , tcpState = SynReceived + , tcpIss = isn + , tcpSndNxt = isn + , tcpSndUna = isn + , tcpIn = emptyLocalWindow (tcpSeqNum hdr) 14600 0 + , tcpOutMSS = fromMaybe defaultMSS (getMSS hdr) + , tcpTimestamp = do + -- require that the parent had a timestamp + ts <- tcpTimestamp tcp + -- require that they have sent us a timestamp, before using them + OptTimestamp val _ <- findTcpOption OptTagTimestamp hdr + return ts { tsLastTimestamp = val } + , tcpSack = sackSupported hdr + , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr) + } + +establishConnection :: Sock () +establishConnection = + do mb <- inParent popAcceptor + case join mb of + Just k -> do sid <- tcpSocketId `fmap` getTcpSocket + outputS (k sid) + setState Established + + -- no one available to accept the connection, close it + Nothing -> do finAck + setState FinWait1 + done + + +-- Buffer Delivery ------------------------------------------------------------- + +-- | Fill up the remote window with segments. +outputSegments :: Sock () +outputSegments = do + now <- inTcp time + (ws,segs) <- modifyTcpSocket (genSegments now) + F.mapM_ outputSegment segs + unless (null ws) (outputS (F.traverse_ tryAgain ws)) + + +-- Utilities ------------------------------------------------------------------- + +-- | Extract the maximum segment size from a header, if the option is present. +getMSS :: TcpHeader -> Maybe Int64 +getMSS hdr = do + OptMaxSegmentSize n <- findTcpOption OptTagMaxSegmentSize hdr + return (fromIntegral n) + +windowScale :: TcpHeader -> Int +windowScale hdr = fromMaybe 0 $ do + OptWindowScaling n <- findTcpOption OptTagWindowScaling hdr + return (fromIntegral n) + +sackSupported :: TcpHeader -> Bool +sackSupported = isJust . findTcpOption OptTagSackPermitted diff --git a/src/Hans/Layer/Tcp/Messages.hs b/src/Hans/Layer/Tcp/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Messages.hs @@ -0,0 +1,264 @@ +module Hans.Layer.Tcp.Messages where + +import Hans.Layer ( time ) +import Hans.Layer.Tcp.Monad +import Hans.Layer.Tcp.Types +import Hans.Layer.Tcp.Window +import Hans.Message.Tcp + +import Data.Maybe ( fromMaybe ) +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq + + +-- Generic Packets ------------------------------------------------------------- + +mkSegment :: TcpSocket -> TcpHeader +mkSegment tcp = case tcpTimestamp tcp of + Just ts -> setTcpOption (mkTimestamp ts) hdr + Nothing -> hdr + where + hdr = emptyTcpHeader + { tcpDestPort = sidRemotePort (tcpSocketId tcp) + , tcpSourcePort = sidLocalPort (tcpSocketId tcp) + , tcpSeqNum = tcpSndNxt tcp + , tcpAckNum = tcpRcvNxt tcp + -- XXX this doesn't really reflect the right number + , tcpWindow = lwRcvWind (tcpIn tcp) + } + +mkAck :: TcpSocket -> TcpHeader +mkAck tcp = addSackOption tcp + $ (mkSegment tcp) + { tcpAck = True + } + + +-- Options --------------------------------------------------------------------- + +-- | Add the Sack option to a tcp packet. +addSackOption :: TcpSocket -> TcpHeader -> TcpHeader +addSackOption sock + | tcpSack sock && not (null bs) = setTcpOption (OptSack bs) + | otherwise = id + where + bs = F.toList (localWindowSackBlocks (tcpIn sock)) + +-- | Add the sack permitted tcp option. +addSackPermitted :: TcpSocket -> TcpHeader -> TcpHeader +addSackPermitted sock + | tcpSack sock = setTcpOption OptSackPermitted + | otherwise = id + +-- | Add the window scale option on the outgoing header. +addWindowScale :: TcpSocket -> TcpHeader -> TcpHeader +addWindowScale sock + | tcpWindowScale sock = setTcpOption + $ OptWindowScaling + $ fromIntegral + $ lwRcvWindScale + $ tcpIn sock + | otherwise = id + + +-- Connection Refusal ---------------------------------------------------------- + +-- | Given a tcp header, generate the next header in the sequence that +-- corresponds to the RST ACK response. As this should only be used in +-- situations in which an ACK was not received, this adds one plus the body +-- length to the ack number. +mkRstAck :: TcpHeader -> Int -> TcpHeader +mkRstAck hdr len = emptyTcpHeader + { tcpSeqNum = 0 + , tcpAckNum = tcpSeqNum hdr + fromIntegral len + 1 -- to ack their message + , tcpRst = True + , tcpAck = True + , tcpDestPort = tcpSourcePort hdr + , tcpSourcePort = tcpDestPort hdr + } + +mkRst :: TcpHeader -> TcpHeader +mkRst hdr = emptyTcpHeader + { tcpSeqNum = tcpAckNum hdr + , tcpRst = True + , tcpDestPort = tcpSourcePort hdr + , tcpSourcePort = tcpDestPort hdr + } + + +-- Connection Establishment ---------------------------------------------------- + +mkSyn :: TcpSocket -> TcpHeader +mkSyn tcp = addSackPermitted tcp + $ addWindowScale tcp + $ setTcpOption (mkMSS tcp) + $ (mkSegment tcp) + { tcpSyn = True + , tcpAckNum = 0 + } + +-- | Construct a SYN ACK packet, in response to a SYN. +mkSynAck :: TcpSocket -> TcpHeader +mkSynAck tcp = addSackPermitted tcp + $ addWindowScale tcp + $ setTcpOption (mkMSS tcp) + $ (mkSegment tcp) + { tcpSyn = True + , tcpAck = True + } + + +-- Connection Closing ---------------------------------------------------------- + +-- | Construct a FIN packet. +-- +-- XXX should this include a sack option? +mkFinAck :: TcpSocket -> TcpHeader +mkFinAck tcp = (mkSegment tcp) + { tcpFin = True + , tcpAck = True + } + + +-- Data Packets ---------------------------------------------------------------- + +mkData :: TcpSocket -> TcpHeader +mkData tcp = addSackOption tcp + $ (mkSegment tcp) + { tcpAck = True + , tcpPsh = True + } + + +-- Socket Actions -------------------------------------------------------------- + +syn :: Sock () +syn = do + tcp <- getTcpSocket + tcpOutput (mkSyn tcp) L.empty + advanceSndNxt 1 + +-- | Respond to a SYN message with a SYN ACK message. +synAck :: Sock () +synAck = do + advanceRcvNxt 1 + tcp <- getTcpSocket + tcpOutput (mkSynAck tcp) L.empty + advanceSndNxt 1 + +-- | Send an ACK packet. +ack :: Sock () +ack = do + clearDelayedAck + tcp <- getTcpSocket + tcpOutput (mkAck tcp) L.empty + +-- | Schedule a delayed ACK packet. +delayedAck :: Sock () +delayedAck = modifyTcpTimers_ (\tt -> tt { ttDelayedAck = True }) + +-- | Unschedule a delayed ACK packet. +clearDelayedAck :: Sock () +clearDelayedAck = modifyTcpTimers_ (\tt -> tt { ttDelayedAck = False }) + +-- | Queue an outgoing fin packet in the outgoing window, and send it. +-- +-- NOTE: This uses genSegments, which will pull data out of the waiti +finAck :: Sock () +finAck = do + now <- inTcp time + + seg <- modifyTcpSocket $ \ tcp -> + + let -- construct the outgoing FIN,ACK segment + hdr = mkFinAck tcp + finAckOutSeg = mkOutSegment now (ttRTO (tcpTimers tcp)) hdr L.empty + + -- push the FIN,ACK into the outgoing window + tcp' = tcp { tcpOut = addSegment finAckOutSeg (tcpOut tcp) + + -- advance SND.NXT over the FIN + , tcpSndNxt = tcpSndNxt tcp + 1 + } + + in (finAckOutSeg, tcp') + + outputSegment seg + clearDelayedAck + +rstAck :: TcpHeader -> Int -> Sock () +rstAck hdr len = tcpOutput (mkRstAck hdr len) L.empty + +rst :: TcpHeader -> Sock () +rst hdr = tcpOutput (mkRst hdr) L.empty + +-- | Send a segment. +outputSegment :: OutSegment -> Sock () +outputSegment seg = do + clearDelayedAck + tcpOutput (outHeader seg) (outBody seg) + + +-- Flag Tests ------------------------------------------------------------------ + +type SetFlag = TcpHeader -> Bool +type UnsetFlag = TcpHeader -> Bool + +testFlags :: [SetFlag] -> [UnsetFlag] -> TcpHeader -> Bool +testFlags sfs ufs hdr = all test sfs && all (not . test) ufs + where + test prj = prj hdr + +isSyn :: TcpHeader -> Bool +isSyn = testFlags [ tcpSyn ] + [ tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpFin ] + +isSynAck :: TcpHeader -> Bool +isSynAck = testFlags [ tcpSyn, tcpAck ] + [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpFin ] + +isRstAck :: TcpHeader -> Bool +isRstAck = testFlags [ tcpRst, tcpAck ] + [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpSyn, tcpFin ] + +isAck :: TcpHeader -> Bool +isAck = testFlags [ tcpAck ] + [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpSyn, tcpFin ] + +isFin :: TcpHeader -> Bool +isFin = testFlags [ tcpFin ] + [ tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpSyn ] + +isFinAck :: TcpHeader -> Bool +isFinAck = testFlags [ tcpFin, tcpAck ] + [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpSyn ] + + +-- Packet Output --------------------------------------------------------------- + +-- | Take data from the output buffer, and turn it into segments. When data was +-- freed from the output buffer, the wakeup actions for any threads currently +-- blocked on writing to the output buffer will be returned. +genSegments :: POSIXTime -> TcpSocket -> (([Wakeup],OutSegments),TcpSocket) +genSegments now tcp0 = loop [] Seq.empty tcp0 + where + loop ws segs tcp + | rwAvailable (tcpOut tcp) <= 0 = result + | otherwise = fromMaybe result $ do + let len = nextSegSize tcp + (mbWakeup,body,bufOut) <- takeBytes len (tcpOutBuffer tcp) + let seg = mkOutSegment now (ttRTO (tcpTimers tcp)) (mkData tcp) body + tcp' = tcp { tcpSndNxt = outAckNum seg + , tcpOut = addSegment seg (tcpOut tcp) + , tcpOutBuffer = bufOut + } + + return (loop (addWakeup mbWakeup) (segs Seq.|> seg) tcp') + where + + addWakeup Nothing = ws + addWakeup (Just w) = w:ws + + result = ((ws,segs),tcp) diff --git a/src/Hans/Layer/Tcp/Monad.hs b/src/Hans/Layer/Tcp/Monad.hs --- a/src/Hans/Layer/Tcp/Monad.hs +++ b/src/Hans/Layer/Tcp/Monad.hs @@ -1,36 +1,45 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} + module Hans.Layer.Tcp.Monad where +import Hans.Address.IP4 import Hans.Channel import Hans.Layer import Hans.Layer.IP4 -import Hans.Layer.Timer +import Hans.Layer.Tcp.Types +import Hans.Layer.Tcp.Window +import Hans.Message.Ip4 +import Hans.Message.Tcp -import MonadLib -import Network.TCP.Type.Datagram (IPMessage) -import Network.TCP.Type.Socket (Host(..),empty_host,TCPSocket) -import Network.TCP.Type.Syscall (SocketID) -import qualified Data.Map as Map +import Control.Applicative(Applicative(..)) +import Control.Monad (MonadPlus(..),guard,when) +import Data.Time.Clock.POSIX (POSIXTime) +import MonadLib (get,set) +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 ------------------------------------------------------------------- type TcpHandle = Channel (Tcp ()) -type Tcp = Layer (TcpState (IO ())) +type Tcp = Layer TcpState -data TcpState t = TcpState - { tcpSelf :: TcpHandle - , tcpIP4 :: IP4Handle - , tcpTimers :: TimerHandle - , tcpHost :: Host t +data TcpState = TcpState + { tcpSelf :: TcpHandle + , tcpIP4 :: IP4Handle + , tcpHost :: Host } -emptyTcpState :: TcpHandle -> IP4Handle -> TimerHandle -> TcpState t -emptyTcpState tcp ip4 timer = TcpState - { tcpSelf = tcp - , tcpIP4 = ip4 - , tcpTimers = timer - , tcpHost = empty_host +emptyTcpState :: TcpHandle -> IP4Handle -> POSIXTime -> TcpState +emptyTcpState tcp ip4 start = TcpState + { tcpSelf = tcp + , tcpIP4 = ip4 + , tcpHost = emptyHost start } -- | The handle to this layer. @@ -41,52 +50,373 @@ ip4Handle :: Tcp IP4Handle ip4Handle = tcpIP4 `fmap` get --- | Get the handle to the Timer layer. -timerHandle :: Tcp TimerHandle -timerHandle = tcpTimers `fmap` get +-- Host Operations ------------------------------------------------------------- --- Compatibility Layer --------------------------------------------------------- +getHost :: Tcp Host +getHost = tcpHost `fmap` get -type HMonad t = Layer (TcpState t) +setHost :: Host -> Tcp () +setHost host = do + rw <- get + set $! rw { tcpHost = host } -get_host :: HMonad t (Host t) -get_host = tcpHost `fmap` get +modifyHost :: (Host -> Host) -> Tcp () +modifyHost f = do + host <- getHost + setHost $! f host -put_host :: Host t -> HMonad t () -put_host h = do - s <- get - set $! s { tcpHost = h } +-- | Reset the 2MSL timer on the socket in TimeWait. +resetTimeWait2MSL :: SocketId -> Tcp () +resetTimeWait2MSL sid = modifyHost $ \ host -> + host { hostTimeWaits = Map.adjust twReset2MSL sid (hostTimeWaits host) } -modify_host :: (Host t -> Host t) -> HMonad t () -modify_host f = do - h <- get_host - put_host $! f h +getTimeWait :: IP4 -> TcpHeader -> Tcp (Maybe (SocketId,TimeWaitSock)) +getTimeWait remote hdr = + do host <- getHost + let sid = incomingSocketId remote hdr + return $ do tw <- Map.lookup sid (hostTimeWaits host) + return (sid,tw) -emit_segs :: [IPMessage] -> HMonad t () -emit_segs segs = modify_host (\h -> h { output_queue = output_queue h ++ segs }) +removeTimeWait :: SocketId -> Tcp () +removeTimeWait sid = + modifyHost $ \ host -> + host { hostTimeWaits = Map.delete sid (hostTimeWaits host) } -emit_ready :: [t] -> HMonad t () -emit_ready ts = modify_host (\h -> h { ready_list = ready_list h ++ ts }) +getConnections :: Tcp Connections +getConnections = hostConnections `fmap` getHost -has_sock :: SocketID -> HMonad t Bool -has_sock sid = (Map.member sid . sock_map) `fmap` get_host +setConnections :: Connections -> Tcp () +setConnections cons = modifyHost (\host -> host { hostConnections = cons }) -lookup_sock :: SocketID -> HMonad t (TCPSocket t) -lookup_sock sid = do - h <- get_host - case Map.lookup sid (sock_map h) of - Nothing -> fail "lookup_sock: sid not found" - Just res -> return res +-- | Lookup a connection, returning @Nothing@ if the connection doesn't exist. +lookupConnection :: SocketId -> Tcp (Maybe TcpSocket) +lookupConnection sid = do + cons <- getConnections + return (Map.lookup sid cons) -delete_sock :: SocketID -> HMonad t () -delete_sock sid = - modify_host (\h -> h { sock_map = Map.delete sid (sock_map h) } ) +-- | Retrieve a connection from the host. The computation fails if the +-- connection doesn't exist. +getConnection :: SocketId -> Tcp TcpSocket +getConnection sid = do + cs <- getConnections + case Map.lookup sid cs of + Just tcp -> return tcp + Nothing -> mzero -update_sock :: SocketID -> (TCPSocket t -> TCPSocket t) -> HMonad t () -update_sock sid f = - modify_host (\h -> h { sock_map = Map.adjust f sid (sock_map h) }) +-- | Assign a connection to a socket id. If the TcpSocket is in TimeWait, this +-- will do two things: +-- +-- 1. Remove the corresponding key from the connections map +-- 2. Add the socket to the TimeWait map, using the current value of its 2MSL +-- timer (which should be set when the TimeWait state is entered) +-- +-- The purpose of this is to clean up the memory associated with the connection +-- as soon as possible, and once it's in TimeWait, no data will flow on the +-- socket. +setConnection :: SocketId -> TcpSocket -> Tcp () +setConnection ident con + | tcpState con == TimeWait = + modifyHost $ \ host -> + host { hostTimeWaits = addTimeWait con (hostTimeWaits host) + , hostConnections = Map.delete ident (hostConnections host) + } -insert_sock :: SocketID -> TCPSocket t -> HMonad t () -insert_sock sid sock = do - modify_host (\h -> h { sock_map = Map.insert sid sock (sock_map h) }) + | otherwise = + do cons <- getConnections + setConnections (Map.insert ident con cons) + +-- | Add a new connection to the host. +addConnection :: SocketId -> TcpSocket -> Tcp () +addConnection = setConnection + +-- | Modify an existing connection in the host. +modifyConnection :: SocketId -> (TcpSocket -> TcpSocket) -> Tcp () +modifyConnection sid k = do + cons <- getConnections + setConnections (Map.adjust k sid cons) + +-- | Remove a connection from the host. +remConnection :: SocketId -> Tcp () +remConnection sid = do + cons <- getConnections + setConnections (Map.delete sid cons) + +-- | Send out a tcp segment via the IP layer. +sendSegment :: IP4 -> TcpHeader -> L.ByteString -> Tcp () +sendSegment dst hdr body = do + ip4 <- ip4Handle + output $ withIP4Source ip4 dst $ \ src -> do + let ip4Hdr = emptyIP4Header + { ip4DestAddr = dst + , ip4Protocol = tcpProtocol + , ip4DontFragment = False + } + pkt = renderWithTcpChecksumIP4 src dst hdr body + sendIP4Packet ip4 ip4Hdr pkt + +-- | Get the initial sequence number. +initialSeqNum :: Tcp TcpSeqNum +initialSeqNum = hostInitialSeqNum `fmap` getHost + +-- | Increment the initial sequence number by a value. +addInitialSeqNum :: TcpSeqNum -> Tcp () +addInitialSeqNum sn = + modifyHost (\host -> host { hostInitialSeqNum = hostInitialSeqNum host + sn }) + +-- | Allocate a new port for use. +allocatePort :: Tcp TcpPort +allocatePort = do + host <- getHost + case takePort host of + Just (p,host') -> do + setHost host' + return p + Nothing -> mzero + +-- | Release a used port. +closePort :: TcpPort -> Tcp () +closePort port = modifyHost (releasePort port) + + +-- Socket Monad ---------------------------------------------------------------- + +-- | Tcp operations in the context of a socket. +-- +-- This implementation is a bit ridiculous, and when the eventual rewrite comes +-- this should be one of the first things to be reconsidered. The basic problem +-- is that if you rely on the `finished` implementation for the Layer monad, you +-- exit from the socket context as well, losing any changes that have been made +-- 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) + } + +type Escape r = TcpSocket -> Tcp (TcpSocket,Maybe r) + +type Next a r = TcpSocket -> a -> Tcp (TcpSocket, Maybe r) + +instance Functor Sock where + fmap f m = Sock $ \s x k -> unSock m s x + $ \s' a -> k s' (f a) + +instance Applicative Sock where + {-# INLINE pure #-} + pure x = Sock $ \ s _ k -> k s x + + {-# INLINE (<*>) #-} + f <*> a = Sock $ \ s x k -> unSock f s x + $ \ s' g -> unSock a s' x + $ \ s'' b -> k s'' (g b) + +instance Monad Sock where + {-# INLINE return #-} + return = pure + + m >>= f = Sock $ \ s x k -> unSock m s x + $ \ s' a -> unSock (f a) s' x k + +inTcp :: Tcp a -> Sock a +inTcp m = Sock $ \ s _ k -> do a <- m + k s a + + +-- | Finish early, with no result. +escape :: Sock a +escape = Sock $ \ s x _ -> x s + +runSock_ :: TcpSocket -> Sock a -> Tcp () +runSock_ tcp sm = + do _ <- runSock tcp sm + return () + +runSock' :: TcpSocket -> Sock a -> Tcp TcpSocket +runSock' tcp sm = + do (tcp',_) <- runSock tcp sm + return tcp' + +-- | Run the socket action, and increment its internal timestamp value. +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 + where + escapeK s = return (s,Nothing) + nextK s a = return (s,Just a) + +-- | Iterate for each connection, rolling back to its previous state if the +-- computation fails. +eachConnection :: Sock () -> Tcp () +eachConnection m = + setConnections . removeClosed =<< T.mapM sandbox =<< getConnections + 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 + +withConnection :: IP4 -> TcpHeader -> Sock a -> Tcp () +withConnection remote hdr m = withConnection' remote hdr m mzero + +withConnection' :: IP4 -> TcpHeader -> Sock a -> Tcp () -> Tcp () +withConnection' remote hdr m noConn = do + cs <- getConnections + case Map.lookup estId cs `mplus` Map.lookup listenId cs of + Just con -> runSock_ con m + Nothing -> noConn + where + estId = incomingSocketId remote hdr + listenId = listenSocketId (tcpDestPort hdr) + +listeningConnection :: SocketId -> Sock a -> Tcp (Maybe a) +listeningConnection sid m = do + tcp <- getConnection sid + guard (tcpState tcp == Listen && isAccepting tcp) + (_,mb) <- runSock tcp m + return mb + +-- | Run a socket operation in the context of the socket identified by the +-- socket id. +-- +-- XXX this should really be renamed, as it's not guarding on the state of the +-- socket +establishedConnection :: SocketId -> Sock a -> Tcp () +establishedConnection sid m = do + tcp <- getConnection sid + runSock_ tcp m + +-- | Get the parent id of the current socket, and fail if it doesn't exist. +getParent :: Sock (Maybe SocketId) +getParent = tcpParent `fmap` getTcpSocket + +-- | Run an action in the context of the socket's parent. Returns `Nothing` if +-- the connection has no parent. +inParent :: Sock a -> Sock (Maybe a) +inParent m = do + mbPid <- getParent + case mbPid of + 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 + return mb + +getTcpSocket :: Sock TcpSocket +getTcpSocket = Sock (\s _ k -> k s s) + +setTcpSocket :: TcpSocket -> Sock () +setTcpSocket tcp = Sock (\ _ _ k -> k tcp ()) + +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 + +modifyTcpSocket_ :: (TcpSocket -> TcpSocket) -> Sock () +modifyTcpSocket_ k = modifyTcpSocket (\tcp -> ((), k tcp)) + +modifyTcpTimers :: (TcpTimers -> (a,TcpTimers)) -> Sock a +modifyTcpTimers k = modifyTcpSocket $ \ tcp -> + let (a,t') = k (tcpTimers tcp) + in (a,tcp { tcpTimers = t' }) + +modifyTcpTimers_ :: (TcpTimers -> TcpTimers) -> Sock () +modifyTcpTimers_ k = modifyTcpTimers (\t -> ((), k t)) + +-- | Set the state of the current connection. +setState :: ConnState -> Sock () +setState state = modifyTcpSocket_ (\tcp -> tcp { tcpState = state }) + +-- | Get the state of the current connection. +getState :: Sock ConnState +getState = tcpState `fmap` getTcpSocket + +whenState :: ConnState -> Sock () -> Sock () +whenState state body = do + curState <- getState + when (state == curState) body + +whenStates :: [ConnState] -> Sock () -> Sock () +whenStates states body = do + curState <- getState + when (curState `elem` states) body + +pushAcceptor :: Acceptor -> Sock () +pushAcceptor k = modifyTcpSocket_ $ \ tcp -> tcp + { tcpAcceptors = tcpAcceptors tcp Seq.|> k + } + +-- | Pop off an acceptor. +popAcceptor :: Sock (Maybe Acceptor) +popAcceptor = do + tcp <- getTcpSocket + case Seq.viewl (tcpAcceptors tcp) of + a Seq.:< as -> do setTcpSocket $! tcp { tcpAcceptors = as } + return (Just a) + Seq.EmptyL -> return Nothing + +-- | Send a notification back to a waiting process that the socket has been +-- established, or that it has failed. It's assumed that this will only be +-- called from the context of a user socket, so when the parameter is @False@, +-- the user close field will be set to true. +notify :: Bool -> Sock () +notify success = do + mbNotify <- modifyTcpSocket $ \ tcp -> + let tcp' = tcp { tcpNotify = Nothing } + in if success + then (tcpNotify tcp, tcp') + else (tcpNotify tcp, tcp' { tcpUserClosed = True }) + + case mbNotify of + Just f -> outputS (f success) + Nothing -> return () + +-- | Output some IO to the Tcp layer. +outputS :: IO () -> Sock () +outputS = inTcp . output + +advanceRcvNxt :: TcpSeqNum -> Sock () +advanceRcvNxt n = + modifyTcpSocket_ (\tcp -> tcp { tcpIn = addRcvNxt n (tcpIn tcp) }) + +advanceSndNxt :: TcpSeqNum -> Sock () +advanceSndNxt n = + modifyTcpSocket_ (\tcp -> tcp { tcpSndNxt = tcpSndNxt tcp + n }) + +remoteHost :: Sock IP4 +remoteHost = (sidRemoteHost . tcpSocketId) `fmap` getTcpSocket + +-- | Send a TCP segment in the context of a socket. +tcpOutput :: TcpHeader -> L.ByteString -> Sock () +tcpOutput hdr body = do + dst <- remoteHost + inTcp (sendSegment dst hdr body) + + +-- | Unblock any waiting processes, in preparation to close. +shutdown :: Sock () +shutdown = do + finalize <- modifyTcpSocket $ \ tcp -> + let (wOut,bufOut) = shutdownWaiting (tcpOutBuffer tcp) + (wIn,bufIn) = shutdownWaiting (tcpInBuffer tcp) + in (wOut >> wIn,tcp { tcpOut = clearRetransmit (tcpOut tcp) + , tcpOutBuffer = bufOut + , tcpInBuffer = bufIn + }) + outputS finalize + +-- | Set the socket state to closed, and unblock any waiting processes. +closeSocket :: Sock () +closeSocket = do + shutdown + setState Closed diff --git a/src/Hans/Layer/Tcp/Socket.hs b/src/Hans/Layer/Tcp/Socket.hs --- a/src/Hans/Layer/Tcp/Socket.hs +++ b/src/Hans/Layer/Tcp/Socket.hs @@ -1,189 +1,287 @@ {-# LANGUAGE DeriveDataTypeable #-} module Hans.Layer.Tcp.Socket ( - -- * Socket Layer Socket() - , SocketError(..) - , listenPort - , acceptSocket - , connect - , sendSocket - , closeSocket - , readBytes - , readLine + , sockRemoteHost + , sockRemotePort + , sockLocalPort + , connect, ConnectError(..) + , listen, ListenError(..) + , accept, AcceptError(..) + , close, CloseError(..) + , sendBytes, canSend + , recvBytes, canRecv ) where import Hans.Address.IP4 import Hans.Channel import Hans.Layer +import Hans.Layer.Tcp.Handlers +import Hans.Layer.Tcp.Messages import Hans.Layer.Tcp.Monad -import Hans.Message.Tcp (TcpPort(..)) - -import Network.TCP.LTS.User (tcp_process_user_request) -import Network.TCP.Type.Base - (IPAddr(..),SocketID,TCPAddr(..)) -import Network.TCP.Type.Syscall (SockReq(..),SockRsp(..)) +import Hans.Layer.Tcp.Types +import Hans.Layer.Tcp.Window +import Hans.Message.Tcp -import Control.Exception (throwIO,Exception) -import Control.Concurrent (MVar,newMVar,newEmptyMVar,takeMVar,putMVar) +import Control.Concurrent (MVar,newEmptyMVar,takeMVar,putMVar) +import Control.Exception (Exception,throwIO) +import Control.Monad (mplus) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) -import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L --- Socket Layer ---------------------------------------------------------------- +-- Socket Interface ------------------------------------------------------------ + data Socket = Socket - { socketTcpHandle :: TcpHandle - , socketId :: !SocketID - , socketBuffer :: MVar L.ByteString + { sockHandle :: TcpHandle + , sockId :: !SocketId } -data SocketResult a - = SocketResult a - | SocketError SocketError +-- | The remote host of a socket. +sockRemoteHost :: Socket -> IP4 +sockRemoteHost = sidRemoteHost . sockId -data SocketError - = ListenError String - | AcceptError String - | ConnectError String - | SendError String - | RecvError String - | CloseError String - deriving (Typeable,Show) +-- | The remote port of a socket. +sockRemotePort :: Socket -> TcpPort +sockRemotePort = sidRemotePort . sockId -instance Exception SocketError +-- | The local port of a socket. +sockLocalPort :: Socket -> TcpPort +sockLocalPort = sidLocalPort . sockId --- | Block on a socket operation, waiting for the TCP layer to finish an action. +data SocketGenericError = SocketGenericError + deriving (Show,Typeable) + +instance Exception SocketGenericError + +-- | Block on the result of a Tcp action, from a different context. +-- +-- XXX closing the socket should also unblock any other threads waiting on +-- socket actions blockResult :: TcpHandle -> (MVar (SocketResult a) -> Tcp ()) -> IO a -blockResult tcp k = do - var <- newEmptyMVar - send tcp (k var) - sr <- takeMVar var - case sr of +blockResult tcp action = do + res <- newEmptyMVar + -- XXX put a more meaningful error here + let unblock = output (putMVar res (socketError SocketGenericError)) + send tcp (action res `mplus` unblock) + sockRes <- takeMVar res + case sockRes of SocketResult a -> return a - SocketError se -> throwIO se + SocketError e -> throwIO e --- | Call @output@ if the @Tcp@ action returns a @Just@. -maybeOutput :: Tcp (Maybe (IO ())) -> Tcp () -maybeOutput body = do - mb <- body + +-- Connect --------------------------------------------------------------------- + +-- | A connect call failed. +data ConnectError = ConnectionRefused + deriving (Show,Typeable) + +instance Exception ConnectError + +-- | Connect to a remote host. +connect :: TcpHandle -> IP4 -> TcpPort -> Maybe TcpPort -> IO Socket +connect tcp remote remotePort mbLocal = blockResult tcp $ \ res -> do + localPort <- maybe allocatePort return mbLocal + isn <- initialSeqNum + now <- time + let sid = SocketId + { sidLocalPort = localPort + , sidRemoteHost = remote + , sidRemotePort = remotePort + } + sock = (emptyTcpSocket 0 0) + { tcpSocketId = sid + , tcpNotify = Just $ \ success -> putMVar res $! if success + then SocketResult Socket + { sockHandle = tcp + , sockId = sid + } + else socketError ConnectionRefused + , tcpState = Listen + , tcpSndNxt = isn + , tcpSndUna = isn + , tcpTimestamp = Just (emptyTimestamp now) + } + -- XXX how should the retry/backoff be implemented + runSock_ sock $ do + syn + setState SynSent + + +-- Listen ---------------------------------------------------------------------- + +data ListenError = ListenError + deriving (Show,Typeable) + +instance Exception ListenError + +-- | Open a new listening socket that can be used to accept new connections. +listen :: TcpHandle -> IP4 -> TcpPort -> IO Socket +listen tcp _src port = blockResult tcp $ \ res -> do + let sid = listenSocketId port + mb <- lookupConnection sid case mb of - Just m -> output m - Nothing -> return () --- | Listen on a port. -listenPort :: TcpHandle -> TcpPort -> IO Socket -listenPort tcp (TcpPort port) = blockResult tcp $ \ res -> do - let mkError = SocketError . ListenError - k rsp = case rsp of - SockNew sid -> do - buf <- newMVar L.empty - putMVar res (SocketResult (Socket tcp sid buf)) - SockError err -> putMVar res (mkError err) - _ -> putMVar res (mkError "Unexpected response") - maybeOutput (tcp_process_user_request (SockListen port,k)) + Nothing -> do + now <- time + let con = (emptyTcpSocket 0 0) + { tcpSocketId = sid + , tcpState = Listen + , tcpTimestamp = Just (emptyTimestamp now) + } + addConnection sid con + output $ putMVar res $ SocketResult Socket + { sockHandle = tcp + , sockId = sid + } --- | Accept a client connection on a @Socket@. -acceptSocket :: Socket -> IO Socket -acceptSocket sock = blockResult (socketTcpHandle sock) $ \ res -> do - let mkError = SocketError . AcceptError - k rsp = case rsp of - SockNew sid -> do - buf <- newMVar L.empty - putMVar res (SocketResult (Socket (socketTcpHandle sock) sid buf)) - SockError err -> putMVar res (mkError err) - _ -> putMVar res (mkError "Unexpected response") - maybeOutput (tcp_process_user_request (SockAccept (socketId sock),k)) + Just _ -> output (putMVar res (socketError ListenError)) --- | Connect to a remote server. -connect :: TcpHandle -> IP4 -> IP4 -> TcpPort -> IO Socket -connect tcp src dst (TcpPort port) = blockResult tcp $ \ res -> do - let us = IPAddr (convertToWord32 src) - them = TCPAddr (IPAddr (convertToWord32 dst), port) - mkError = SocketError . ConnectError - k rsp = case rsp of - SockNew sid -> do - buf <- newMVar L.empty - putMVar res (SocketResult (Socket tcp sid buf)) - SockError err -> putMVar res (mkError err) - _ -> putMVar res (mkError "Unexpected response") - maybeOutput (tcp_process_user_request (SockConnect us them,k)) --- | Send on a @Socket@. -sendSocket :: Socket -> S.ByteString -> IO () -sendSocket sock bytes = blockResult (socketTcpHandle sock) $ \ res -> do - let mkError = SocketError . SendError - k rsp = putMVar res $! case rsp of - SockOK -> SocketResult () - SockError err -> mkError err - _ -> mkError "Unexpected response" - maybeOutput (tcp_process_user_request (SockSend (socketId sock) bytes,k)) +-- Accept ---------------------------------------------------------------------- --- | Receive from a @Socket@. -recvSocket :: Socket -> IO S.ByteString -recvSocket sock = blockResult (socketTcpHandle sock) $ \ res -> do - let mkError = SocketError . RecvError - k rsp = putMVar res $! case rsp of - SockData bs -> SocketResult bs - SockError err -> mkError err - _ -> mkError "Unexpected response" - maybeOutput (tcp_process_user_request (SockRecv (socketId sock),k)) +data AcceptError = AcceptError + deriving (Show,Typeable) --- | Close a socket. -closeSocket :: Socket -> IO () -closeSocket sock = - blockResult (socketTcpHandle sock) $ \ res -> do - let mkError = SocketError . CloseError - k rsp = putMVar res $! case rsp of - SockOK -> SocketResult () - SockError err -> mkError err - _ -> mkError "Unexpected response" - maybeOutput (tcp_process_user_request (SockClose (socketId sock),k)) +instance Exception AcceptError +-- | Accept new incoming connections on a listening socket. +accept :: Socket -> IO Socket +accept sock = blockResult (sockHandle sock) $ \ res -> + establishedConnection (sockId sock) $ do + state <- getState + case state of + Listen -> pushAcceptor $ \ sid -> putMVar res $ SocketResult $ Socket + { sockHandle = sockHandle sock + , sockId = sid + } --- Derived Interaction --------------------------------------------------------- + -- XXX need more descriptive errors + _ -> outputS (putMVar res (socketError AcceptError)) --- | Read n bytes from a @Socket@. -readBytes :: Socket -> Int -> IO S.ByteString -readBytes sock goal = do - buf <- takeMVar (socketBuffer sock) - loop buf (fromIntegral (L.length buf)) - where - loop buf len - | goal <= len = finish buf - | otherwise = do - bytes <- recvSocket sock - if S.null bytes - then finish buf - else loop (buf `L.append` L.fromChunks [bytes]) (len + S.length bytes) - finish buf = do - let (as,bs) = L.splitAt (fromIntegral goal) buf - putMVar (socketBuffer sock) bs - return (S.concat (L.toChunks as)) +-- Close ----------------------------------------------------------------------- --- | Read until a CRLF, LF or CR are read. -readLine :: Socket -> IO S.ByteString -readLine sock = do - buf <- takeMVar (socketBuffer sock) - loop False 0 buf +data CloseError = CloseError + deriving (Show,Typeable) + +instance Exception CloseError + +-- | Close an open socket. +close :: Socket -> IO () +close sock = blockResult (sockHandle sock) $ \ res -> do + let unblock r = output (putMVar res r) + ok = inTcp (unblock (SocketResult ())) + closeError = inTcp (unblock (socketError CloseError)) + connected = establishedConnection (sockId sock) $ do + userClose + state <- getState + case state of + + Established -> + do finAck + setState FinWait1 + ok + + CloseWait -> + do finAck + setState TimeWait + ok + + SynSent -> + do closeSocket + ok + + SynReceived -> + do finAck + setState FinWait1 + ok + + -- XXX how should we close a listening socket? what should happen to + -- connections that are in-progress? + Listen -> + do setState Closed + closeSocket + ok + + FinWait1 -> ok + FinWait2 -> ok + + _ -> closeError + + + -- closing a connection that doesn't exist causes a CloseError + connected `mplus` unblock (socketError CloseError) + +userClose :: Sock () +userClose = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True }) + + +-- Writing --------------------------------------------------------------------- + +canSend :: Socket -> IO Bool +canSend sock = + blockResult (sockHandle sock) $ \ res -> + establishedConnection (sockId sock) $ + do tcp <- getTcpSocket + let avail = tcpState tcp == Established && not (isFull (tcpOutBuffer tcp)) + outputS (putMVar res (SocketResult avail)) + +-- | Send bytes over a socket. The number of bytes delivered will be returned, +-- with 0 representing the other side having closed the connection. +sendBytes :: Socket -> L.ByteString -> IO Int64 +sendBytes sock bytes = blockResult (sockHandle sock) $ \ res -> + let result len = putMVar res (SocketResult len) + performSend = establishedConnection (sockId sock) $ do + let wakeup continue + | continue = send (sockHandle sock) performSend + | otherwise = result 0 + mbWritten <- modifyTcpSocket (outputBytes bytes wakeup) + case mbWritten of + Just len -> outputS (result len) + Nothing -> return () + outputSegments + in performSend + +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 }) where - loop cr ix buf - | L.null buf = fillBuffer cr ix buf - | otherwise = - case L.index buf ix of - 0x0d -> loop True (ix+1) buf - 0x0a -> finish (ix+1) buf - _ | cr -> finish ix buf - | otherwise -> loop False (ix+1) buf + (mbWritten,bufOut) = writeBytes bytes wakeup (tcpOutBuffer tcp) + (fin,flushed) = flushWaiting bufOut + written = fromMaybe 0 mbWritten - fillBuffer cr ix buf = do - bytes <- recvSocket sock - if S.null bytes - then finish ix buf - else loop cr ix (buf `L.append` L.fromChunks [bytes]) - finish ix buf = do - let (as,bs) = L.splitAt ix buf - putMVar (socketBuffer sock) bs - return (S.concat (L.toChunks as)) +-- Reading --------------------------------------------------------------------- + +-- | True when there are bytes queued to receive. +canRecv :: Socket -> IO Bool +canRecv sock = + blockResult (sockHandle sock) $ \ res -> + establishedConnection (sockId sock) $ + do tcp <- getTcpSocket + let avail = tcpState tcp == Established && not (isEmpty (tcpInBuffer tcp)) + outputS (putMVar res (SocketResult avail)) + +-- | Receive bytes from a socket. A null ByteString represents the other end +-- closing the socket. +recvBytes :: Socket -> Int64 -> IO L.ByteString +recvBytes sock len = blockResult (sockHandle sock) $ \ res -> + let result bytes = putMVar res (SocketResult bytes) + performRecv = establishedConnection (sockId sock) $ do + let wakeup continue + | continue = send (sockHandle sock) performRecv + | otherwise = result L.empty + mbRead <- modifyTcpSocket (inputBytes len wakeup) + case mbRead of + Just bytes -> outputS (result bytes) + Nothing -> return () + in performRecv + +inputBytes :: Int64 -> Wakeup -> TcpSocket -> (Maybe L.ByteString, TcpSocket) +inputBytes len wakeup tcp = (mbRead, tcp { tcpInBuffer = bufIn }) + where + (mbRead,bufIn) = readBytes len wakeup (tcpInBuffer tcp) diff --git a/src/Hans/Layer/Tcp/Timers.hs b/src/Hans/Layer/Tcp/Timers.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Timers.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Layer.Tcp.Timers ( + initTimers + + , resetIdle + , whenIdleFor + + , set2MSL + + , calibrateRTO + ) 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) +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Foldable as F + + +-- 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 + every 500 slowTimer + every 200 fastTimer + +-- | 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 + + -- second, decrement the 2MSL timer for sockets in the TimeWait state + modifyHost $ \ host -> + host { hostTimeWaits = stepTimeWaitConnections (hostTimeWaits host) } + +resetIdle :: Sock () +resetIdle = modifyTcpTimers_ (\tt -> tt { ttIdle = 0 }) + +-- | Handle only the delayed ack timer, fires ever 200ms. +fastTimer :: Tcp () +fastTimer = eachConnection $ do + tcp <- getTcpSocket + when (tcpState tcp /= TimeWait && needsDelayedAck tcp) ack + + +-- Timer Interaction ----------------------------------------------------------- + +-- | Update timers, decrementing to 0 ones that expire, and incrementing the +-- others. +updateTimers :: Sock () +updateTimers = + modifyTcpSocket_ $ \ tcp -> + let tt = tcpTimers tcp + in tcp { tcpTimers = tt + { tt2MSL = decrement (tt2MSL tt) + , ttIdle = increment (ttIdle tt) + } + } + where + decrement 0 = 0 + decrement val = pred val + increment = succ + + +-- | Conditionally run a timer, when this slow-timer tick will decrement it to +-- zero. +whenTimer :: (TcpTimers -> SlowTicks) -> Sock () -> Sock () +whenTimer prj body = do + tt <- getTcpTimers + when (prj tt == 1) body + +-- | Conditionally run an action when the connection has been idle for at least +-- timeout @SlowTick@s. +whenIdleFor :: Int -> Sock () -> Sock () +whenIdleFor timeout body = do + tt <- getTcpTimers + when (ttIdle tt >= timeout) body + + +-- 2MSL ------------------------------------------------------------------------ + +-- | Set the value of the 2MSL timer. +set2MSL :: SlowTicks -> Sock () +set2MSL val = modifyTcpTimers_ (\tt -> tt { tt2MSL = val }) + +-- | 75 second delay. +tcpKeepIntVal :: SlowTicks +tcpKeepIntVal = 150 + +-- | The timer that handles the TIME_WAIT, as well as the idle timeout. +handle2MSL :: Sock () +handle2MSL = + do whenTimer tt2MSL $ + do TcpSocket { .. } <- getTcpSocket + let TcpTimers { .. } = tcpTimers + 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 ------------------------------------------------------------------------- + +-- | Update segments in the outgoing window, decrementing their RTO timers, and +-- retransmitting them if it expires. +handleRTO :: Sock () +handleRTO = do + s <- getState + when (s /= Closed) (F.mapM_ outputSegment =<< modifyTcpSocket update) + where + update tcp = (segs,tcp { tcpOut = win' }) + where + (segs,win') = genRetransmitSegments (tcpOut tcp) + +-- | Calibrate the RTO timer, as specified by RFC-6298. +calibrateRTO :: POSIXTime -> POSIXTime -> TcpTimers -> TcpTimers +calibrateRTO sent ackd tt + | ttSRTT tt == 0 = initial + | otherwise = rolling + where + + -- round trip measurement + r = ackd - sent + + -- no data has been sent before, seed the RTO values. + initial = updateRTO tt + { ttSRTT = r + , ttRTTVar = r / 2 + } + + -- data has been sent, update based on previous values + alpha = 0.125 + beta = 0.25 + rttvar = (1 - beta) * ttRTTVar tt + beta * abs (ttSRTT tt * r) + srtt = (1 - alpha) * ttSRTT tt + alpha * r + rolling = updateRTO tt + { ttRTTVar = rttvar + , ttSRTT = srtt + } + + -- update the RTO timer length, bounding it at 64 seconds (128 ticks) + updateRTO tt' = tt' + { ttRTO = min 128 (ceiling (ttSRTT tt' + max 0.5 (2 * ttRTTVar tt'))) + } diff --git a/src/Hans/Layer/Tcp/Types.hs b/src/Hans/Layer/Tcp/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Types.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.Layer.Tcp.Types where + +import Hans.Address.IP4 +import Hans.Layer.Tcp.Window +import Hans.Message.Tcp +import Hans.Ports + +import Control.Exception (Exception,SomeException,toException) +import Control.Monad ( guard ) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Word (Word16,Word32) +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq + + +-- Hosts Information ----------------------------------------------------------- + +data Host = Host + { hostConnections :: Connections + , hostTimeWaits :: TimeWaitConnections + , hostInitialSeqNum :: !TcpSeqNum + , hostPorts :: !(PortManager TcpPort) + , hostLastUpdate :: POSIXTime + } + +emptyHost :: POSIXTime -> Host +emptyHost start = Host + { hostConnections = Map.empty + , hostTimeWaits = Map.empty + -- XXX what should we seed this with? + , hostInitialSeqNum = 0 + , hostPorts = emptyPortManager [32768 .. 61000] + , hostLastUpdate = start + } + +takePort :: Host -> Maybe (TcpPort,Host) +takePort host = do + (p,ps) <- nextPort (hostPorts host) + return (p, host { hostPorts = ps }) + +releasePort :: TcpPort -> Host -> Host +releasePort p host = fromMaybe host $ do + ps <- unreserve p (hostPorts host) + return host { hostPorts = ps } + + +-- Connections ----------------------------------------------------------------- + +type Connections = Map.Map SocketId TcpSocket + +removeClosed :: Connections -> Connections +removeClosed = + Map.filter (\tcp -> tcpState tcp /= Closed || not (tcpUserClosed tcp)) + +data SocketId = SocketId + { sidLocalPort :: !TcpPort + , sidRemotePort :: !TcpPort + , sidRemoteHost :: !IP4 + } deriving (Eq,Show,Ord) + +emptySocketId :: SocketId +emptySocketId = SocketId + { sidLocalPort = TcpPort 0 + , sidRemotePort = TcpPort 0 + , sidRemoteHost = IP4 0 0 0 0 + } + +listenSocketId :: TcpPort -> SocketId +listenSocketId port = emptySocketId { sidLocalPort = port } + +incomingSocketId :: IP4 -> TcpHeader -> SocketId +incomingSocketId remote hdr = SocketId + { sidLocalPort = tcpDestPort hdr + , sidRemotePort = tcpSourcePort hdr + , sidRemoteHost = remote + } + +data SocketResult a + = SocketResult a + | SocketError SomeException + deriving (Show) + +socketError :: Exception e => e -> SocketResult a +socketError = SocketError . toException + + +-- Connections in TimeWait ----------------------------------------------------- + +-- | The socket that's in TimeWait, plus its current 2MSL value. +type TimeWaitConnections = Map.Map SocketId TimeWaitSock + +data TimeWaitSock = TimeWaitSock { tw2MSL :: !SlowTicks + -- ^ The current 2MSL value + , twInit2MSL :: !SlowTicks + -- ^ The initial 2MSL value + , twSeqNum :: !TcpSeqNum + -- ^ The sequence number to use when + -- responding to messages + , twTimestamp :: Maybe Timestamp + -- ^ The last timestamp used + } deriving (Show) + +twReset2MSL :: TimeWaitSock -> TimeWaitSock +twReset2MSL tw = tw { tw2MSL = twInit2MSL tw } + +mkTimeWait :: TcpSocket -> TimeWaitSock +mkTimeWait TcpSocket { .. } = + TimeWaitSock { tw2MSL = timeout + , twInit2MSL = timeout + , twSeqNum = tcpSndNxt + , twTimestamp = tcpTimestamp + } + where + timeout | tt2MSL tcpTimers <= 0 = 2 * mslTimeout + | otherwise = tt2MSL tcpTimers + +-- | Add a socket to the TimeWait map. +addTimeWait :: TcpSocket -> TimeWaitConnections -> TimeWaitConnections +addTimeWait tcp socks = Map.insert (tcpSocketId tcp) (mkTimeWait tcp) socks + +-- | Take one step, collecting any connections whose 2MSL timer goes to 0. +stepTimeWaitConnections :: TimeWaitConnections -> TimeWaitConnections +stepTimeWaitConnections = Map.mapMaybe $ \ tw -> + do guard (tw2MSL tw > 0) + return tw { tw2MSL = tw2MSL tw - 1 } + + +-- Timers ---------------------------------------------------------------------- + +type SlowTicks = Int + +-- | MSL is 60 seconds, which is slightly more aggressive than the 2 minutes +-- from the original RFC. +mslTimeout :: SlowTicks +mslTimeout = 2 * 60 + +data TcpTimers = TcpTimers + { ttDelayedAck :: !Bool + + -- 2MSL + , tt2MSL :: !SlowTicks + + -- retransmit timer + , ttRTO :: !SlowTicks + , ttSRTT :: !POSIXTime + , ttRTTVar :: !POSIXTime + + -- idle timer + , ttMaxIdle :: !SlowTicks + , ttIdle :: !SlowTicks + } + +emptyTcpTimers :: TcpTimers +emptyTcpTimers = TcpTimers + { ttDelayedAck = False + , tt2MSL = 0 + , ttRTO = 2 -- one second + , ttSRTT = 0 + , ttRTTVar = 0 + , ttMaxIdle = 10 * 60 * 2 + , ttIdle = 0 + } + + +-- Timestamp Management -------------------------------------------------------- + +-- | Manage the timestamp values that are in flight between two hosts. +data Timestamp = Timestamp + { tsTimestamp :: !Word32 + , tsLastTimestamp :: !Word32 + , tsGranularity :: !POSIXTime -- ^ Hz + , tsLastUpdate :: !POSIXTime + } deriving (Show) + +emptyTimestamp :: POSIXTime -> Timestamp +emptyTimestamp start = Timestamp + { tsTimestamp = 0 + , tsLastTimestamp = 0 + , tsGranularity = 200 + , tsLastUpdate = start + } + +-- | Update the timestamp value, advancing based on the timestamp granularity. +-- If the number of ticks to advance is 0, don't advance the timestamp. +stepTimestamp :: POSIXTime -> Timestamp -> Timestamp +stepTimestamp now ts + | diff == 0 = ts + | otherwise = ts + { tsLastUpdate = now + , tsTimestamp = tsTimestamp ts + diff + } + where + diff = ceiling (tsGranularity ts * (now - tsLastUpdate ts)) + +-- | Generate timestamp option for an outgoing packet. +mkTimestamp :: Timestamp -> TcpOption +mkTimestamp ts = OptTimestamp (tsTimestamp ts) (tsLastTimestamp ts) + + +-- Internal Sockets ------------------------------------------------------------ + +type Acceptor = SocketId -> IO () + +type Notify = Bool -> IO () + +type Close = IO () + +data TcpSocket = TcpSocket + { tcpParent :: Maybe SocketId + , tcpSocketId :: !SocketId + , tcpState :: !ConnState + , tcpAcceptors :: Seq.Seq Acceptor + , tcpNotify :: Maybe Notify + , tcpIss :: !TcpSeqNum + , tcpSndNxt :: !TcpSeqNum + , tcpSndUna :: !TcpSeqNum + + , tcpUserClosed :: Bool + , tcpOut :: RemoteWindow + , tcpOutBuffer :: Buffer Outgoing + , tcpOutMSS :: !Int64 + , tcpIn :: LocalWindow + , tcpInBuffer :: Buffer Incoming + , tcpInMSS :: !Int64 + + , tcpTimers :: !TcpTimers + , tcpTimestamp :: Maybe Timestamp + + , tcpSack :: Bool + , tcpWindowScale :: Bool + } + +emptyTcpSocket :: Word16 -> Int -> TcpSocket +emptyTcpSocket sendWindow sendScale = TcpSocket + { tcpParent = Nothing + , tcpSocketId = emptySocketId + , tcpState = Closed + , tcpAcceptors = Seq.empty + , tcpNotify = Nothing + , tcpIss = 0 + , tcpSndNxt = 0 + , tcpSndUna = 0 + + , tcpUserClosed = False + , tcpOut = emptyRemoteWindow sendWindow sendScale + , tcpOutBuffer = emptyBuffer 16384 + , tcpOutMSS = defaultMSS + , tcpIn = emptyLocalWindow 0 14600 0 + , tcpInBuffer = emptyBuffer 16384 + , tcpInMSS = defaultMSS + + , tcpTimers = emptyTcpTimers + , tcpTimestamp = Nothing + + , tcpSack = True + , tcpWindowScale = True + } + +defaultMSS :: Int64 +defaultMSS = 1460 + +nothingOutstanding :: TcpSocket -> Bool +nothingOutstanding TcpSocket { .. } = tcpSndUna == tcpSndNxt + +tcpRcvNxt :: TcpSocket -> TcpSeqNum +tcpRcvNxt = lwRcvNxt . tcpIn + +inRcvWnd :: TcpSeqNum -> TcpSocket -> Bool +inRcvWnd (TcpSeqNum sn) TcpSocket { .. } = + rcvNxt <= sn && sn < rcvNxt + fromIntegral (lwRcvWind tcpIn) + where + TcpSeqNum rcvNxt = lwRcvNxt tcpIn + +nextSegSize :: TcpSocket -> Int64 +nextSegSize tcp = + min (fromIntegral (rwAvailable (tcpOut tcp))) (tcpOutMSS tcp) + +isAccepting :: TcpSocket -> Bool +isAccepting = not . Seq.null . tcpAcceptors + +needsDelayedAck :: TcpSocket -> Bool +needsDelayedAck = ttDelayedAck . tcpTimers + +mkMSS :: TcpSocket -> TcpOption +mkMSS tcp = OptMaxSegmentSize (fromIntegral (tcpInMSS tcp)) + +data ConnState + = Closed + | Listen + | SynSent + | SynReceived + | Established + | CloseWait + | FinWait1 + | FinWait2 + | Closing + | LastAck + | TimeWait + deriving (Show,Eq,Ord) diff --git a/src/Hans/Layer/Tcp/WaitBuffer.hs b/src/Hans/Layer/Tcp/WaitBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/WaitBuffer.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE EmptyDataDecls #-} + +module Hans.Layer.Tcp.WaitBuffer ( + -- * Delayed work + Wakeup + , tryAgain + , abort + + -- * Directions + , Incoming, Outgoing + + -- * Directed Buffers + , Buffer + , emptyBuffer + , shutdownWaiting + , isFull + , isEmpty + , flushWaiting + + -- ** Application Side + , writeBytes + , readBytes + + -- ** Kernel Side + , takeBytes + , putBytes + ) where + +import Control.Monad (guard) +import Data.Int (Int64) +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq + + +-- Chunk Buffering ------------------------------------------------------------- + +-- | The boolean parameter indicates whether or not the wakeup is happening in +-- the event of a shutdown, or if the original request should be re-run, +-- allowing more data to flow. +type Wakeup = Bool -> IO () + +-- | Indicate that the action should be retried. +tryAgain :: Wakeup -> IO () +tryAgain f = f True + +-- | Indicate that the original action will never succeed. +abort :: Wakeup -> IO () +abort f = f False + +-- | Incoming data. +data Incoming + +-- | Outgoing data. +data Outgoing + +-- | Data Buffers, in a direction. +data Buffer d = Buffer + { bufBytes :: L.ByteString + , bufWaiting :: Seq.Seq Wakeup + , bufSize :: !Int64 + , bufAvailable :: !Int64 + } + +-- | An empty buffer, with a limit. +emptyBuffer :: Int64 -> Buffer d +emptyBuffer size = Buffer + { bufBytes = L.empty + , bufWaiting = Seq.empty + , bufSize = size + , bufAvailable = size + } + +-- | A queue is empty when all space is available. +isEmpty :: Buffer d -> Bool +isEmpty buf = bufAvailable buf == bufSize buf + +-- | A queue is full when there is no available space. +isFull :: Buffer d -> Bool +isFull buf = bufAvailable buf == 0 + +-- | Flush the queue of blocked processes, returning an IO action that +-- negatively acks the waiting processes, and a buffer with an empty wait queue. +flushWaiting :: Buffer d -> (IO (), Buffer d) +flushWaiting buf = (F.traverse_ abort (bufWaiting buf), buf { bufWaiting = Seq.empty }) + +-- | Queue a wakeup action into a buffer. +queueWaiting :: Wakeup -> Buffer d -> Buffer d +queueWaiting wakeup buf = buf { bufWaiting = bufWaiting buf Seq.|> wakeup } + +-- | Queue bytes into a buffer that has some available space. The first result +-- is the number of bytes written (0, in the Nothing case), and the second is +-- the new buffer. +queueBytes :: L.ByteString -> Buffer d -> (Maybe Int64, Buffer d) +queueBytes bytes buf + | bufAvailable buf <= 0 = (Nothing,buf) + | otherwise = (Just qlen, buf') + where + queued = L.take (bufAvailable buf) bytes + qlen = L.length queued + buf' = buf + { bufBytes = bufBytes buf `L.append` queued + , bufAvailable = bufAvailable buf - qlen + } + +-- | Take bytes off of a buffer. When the buffer is empty, this returns +-- Nothing, otherwise it returns (<= len) bytes and the buffer with that number +-- of bytes removed. +removeBytes :: Int64 -> Buffer d -> Maybe (L.ByteString, Buffer d) +removeBytes len buf = do + guard (not (L.null (bufBytes buf))) + let (bytes,rest) = L.splitAt len (bufBytes buf) + buf' = buf + { bufBytes = rest + , 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 -------------------------------------------------------------- + +-- | Queue bytes in an outgoing buffer. When there's no space available in the +-- buffer, the wakeup action is queued. +writeBytes :: L.ByteString -> Wakeup -> Buffer Outgoing + -> (Maybe Int64,Buffer Outgoing) +writeBytes bytes wakeup buf = case queueBytes bytes buf of + (Nothing,buf') -> (Nothing,queueWaiting wakeup buf') + res -> res + +-- | Take bytes off of a sending queue, making room new data. +takeBytes :: Int64 -> Buffer Outgoing + -> Maybe (Maybe Wakeup,L.ByteString,Buffer Outgoing) +takeBytes len buf = do + (bytes,buf') <- removeBytes len buf + case Seq.viewl (bufWaiting buf') of + Seq.EmptyL -> return (Nothing, bytes, buf') + w Seq.:< ws -> return (Just w, bytes, buf' { bufWaiting = ws }) + + +-- Receiving Buffer ------------------------------------------------------------ + +-- | Read bytes from an incoming buffer, queueing if there are no bytes to read. +readBytes :: Int64 -> Wakeup -> Buffer Incoming + -> (Maybe L.ByteString, Buffer Incoming) +readBytes len wakeup buf = + case removeBytes len buf of + Just (bytes,buf') -> (Just bytes, buf') + Nothing -> (Nothing, queueWaiting wakeup buf) + +-- | Place bytes on the incoming buffer, provided that there is enough space for +-- all of the bytes. +putBytes :: L.ByteString -> Buffer Incoming + -> Maybe (Maybe Wakeup,Buffer Incoming) +putBytes bytes buf = do + let needed = L.length bytes + L.length (bufBytes buf) + guard (needed < bufSize buf) + let buf' = buf { bufBytes = bufBytes buf `L.append` bytes } + case Seq.viewl (bufWaiting buf') of + Seq.EmptyL -> return (Nothing, buf') + w Seq.:< ws -> return (Just w, buf' { bufWaiting = ws }) diff --git a/src/Hans/Layer/Tcp/Window.hs b/src/Hans/Layer/Tcp/Window.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Window.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Layer.Tcp.Window ( + module Hans.Layer.Tcp.Window + , module Hans.Layer.Tcp.WaitBuffer + ) where + +import Hans.Layer.Tcp.WaitBuffer +import Hans.Message.Tcp + +import Control.Monad (mzero) +import Data.Bits (shiftL) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Word (Word16,Word32) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq +import qualified Data.Traversable as T + + +-- Remote Window --------------------------------------------------------------- + +-- | Remote window management. +data RemoteWindow = RemoteWindow + { rwSegments :: OutSegments + , rwAvailable :: !Word32 + , rwSize :: !Word32 + , rwSndWind :: !Word16 + , rwSndWindScale :: !Int + } deriving (Show) + +-- | The empty window, seeded with an initial size. +emptyRemoteWindow :: Word16 -> Int -> RemoteWindow +emptyRemoteWindow size scale = refreshRemoteWindow $! RemoteWindow + { rwSegments = Seq.empty + , rwAvailable = 0 + , rwSize = 0 + , rwSndWind = fromIntegral size + , rwSndWindScale = scale + } + +-- | Recalculate internal constants of the remote window. +refreshRemoteWindow :: RemoteWindow -> RemoteWindow +refreshRemoteWindow rw = rw + { rwSize = size + , rwAvailable = avail + } + where + size = fromIntegral (rwSndWind rw) `shiftL` rwSndWindScale rw + used = rwSize rw - rwAvailable rw + avail | used > size = 0 + | otherwise = size - used + + +-- | Set the Snd.Wind.Scale variable for the remote window. +setSndWindScale :: Int -> RemoteWindow -> RemoteWindow +setSndWindScale scale rw = refreshRemoteWindow $! rw + { rwSndWindScale = scale + } + +-- | Set the Snd.Wind variable for the remote window. +setSndWind :: Word16 -> RemoteWindow -> RemoteWindow +setSndWind size rw = refreshRemoteWindow $! rw + { rwSndWind = size + } + +-- | Adjust the internal available counter. +releaseSpace :: Word32 -> RemoteWindow -> RemoteWindow +releaseSpace len rw = rw + { rwAvailable = min (rwSize rw) (rwAvailable rw + len) + } + +-- | Add a segment to the window. +addSegment :: OutSegment -> RemoteWindow -> RemoteWindow +addSegment seg win = win + { rwSegments = rwSegments win Seq.|> seg + , rwAvailable = rwAvailable win - outSize seg + } + +-- | Process an incoming ack, returning a finalizer, and a new window if there +-- was a matching set of packets waiting for an ack. +receiveAck :: TcpHeader -> RemoteWindow -> Maybe (OutSegment,RemoteWindow) +receiveAck hdr win = do + + -- XXX this doesn't deal with partial acks + let match seg = tcpSeqNum (outHeader seg) < tcpAckNum hdr + && outAckNum seg <= tcpAckNum hdr + (acks,rest) = Seq.spanl match (rwSegments win) + + -- require that there was something to ack. + case Seq.viewr acks of + _ Seq.:> seg -> do + let len = F.sum (outSize `fmap` acks) + win' = setSndWind (tcpWindow hdr) + $ releaseSpace len + $ win { rwSegments = rest } + return (seg, win') + Seq.EmptyR -> mzero + + +-- | Update the RTO timer on all segments waiting for an ack. When the timer +-- runs out, output the segment for retransmission. +genRetransmitSegments :: RemoteWindow -> (OutSegments,RemoteWindow) +genRetransmitSegments win = (outSegs, win { rwSegments = segs' }) + where + (outSegs,segs') = T.mapAccumL step Seq.empty (rwSegments win) + step rts seg = (rts',seg') + where + seg' = decrementRTO seg + rts' | outRTO seg' <= 0 = rts Seq.|> seg' + | otherwise = rts + +clearRetransmit :: RemoteWindow -> RemoteWindow +clearRetransmit rw = rw { rwSegments = Seq.empty } + +retransmitEmpty :: RemoteWindow -> Bool +retransmitEmpty rw = Seq.null (rwSegments rw) + + +type OutSegments = Seq.Seq OutSegment + +-- | A delivered segment. +data OutSegment = OutSegment + { outAckNum :: !TcpSeqNum + , outTime :: !POSIXTime + , outFresh :: Bool -- ^ Whether or not this is a retransmission + , outRTO :: !Int -- ^ Retransmit timer for this segment + , outHeader :: !TcpHeader + , outBody :: !L.ByteString + } deriving (Show) + +mkOutSegment :: POSIXTime -> Int -> TcpHeader -> L.ByteString -> OutSegment +mkOutSegment created rto hdr body = + OutSegment { outAckNum = tcpSeqNum hdr + outSize' hdr body + , outTime = created + , outFresh = True + , outRTO = rto + , outHeader = hdr + , outBody = body + } + +ctlLength :: Num len => Bool -> len +ctlLength True = 1 +ctlLength False = 0 + +outSize :: Num a => OutSegment -> a +outSize OutSegment { .. } = outSize' outHeader outBody + +-- | The size of a segment body. +outSize' :: Num a => TcpHeader -> L.ByteString -> a +outSize' TcpHeader { .. } body = fromIntegral (L.length body) + + ctlLength tcpSyn + + ctlLength tcpFin + + +-- | Decrement the RTO value on a segment by the timer granularity (500ms). +-- Once the RTO value dips below 1, mark the segment as no longer fresh. +decrementRTO :: OutSegment -> OutSegment +decrementRTO seg + | outRTO seg' <= 0 = seg' { outFresh = False } + | otherwise = seg' + where + seg' = seg { outRTO = outRTO seg - 1 } + + +-- Local Window ---------------------------------------------------------------- + +-- | Local window, containing a buffer of incoming packets, indexed by their +-- sequence number, relative to RCV.NXT. +-- +-- XXX make this respect the values of size and available +data LocalWindow = LocalWindow + { lwBuffer :: Seq.Seq InSegment + , lwRcvNxt :: !TcpSeqNum + , lwAvailable :: !Word32 + , lwSize :: !Word32 + , lwRcvWind :: !Word16 + , lwRcvWindScale :: !Int + } deriving (Show) + +-- | Empty local buffer, with an initial sequence number as the next expected +-- sequence number. +emptyLocalWindow :: TcpSeqNum -> Word16 -> Int -> LocalWindow +emptyLocalWindow sn size scale = refreshLocalWindow $! LocalWindow + { lwBuffer = Seq.empty + , lwRcvNxt = sn + , lwAvailable = 0 + , lwSize = 0 + , lwRcvWind = size + , lwRcvWindScale = scale + } + +-- | Produce a sequence of blocks for the sack option. +localWindowSackBlocks :: LocalWindow -> Seq.Seq SackBlock +localWindowSackBlocks lw = case Seq.viewl (fmap mkSackBlock (lwBuffer lw)) of + b Seq.:< rest -> uncurry (Seq.|>) (F.foldl step (Seq.empty,b) rest) + Seq.EmptyL -> Seq.empty + where + step (bs,b) b' + | sbRight b == sbLeft b' = (bs,b { sbRight = sbRight b' }) + | otherwise = (bs Seq.|> b, b') + +-- | Recalculate internal constants. +refreshLocalWindow :: LocalWindow -> LocalWindow +refreshLocalWindow lw = lw + { lwSize = fromIntegral (lwRcvWind lw) `shiftL` lwRcvWindScale lw + } + +-- | Update the size of the remote window. +setRcvNxt :: TcpSeqNum -> LocalWindow -> LocalWindow +setRcvNxt sn lw = lw { lwRcvNxt = sn } + +-- | Add a sequence number to the value of Rcv.Nxt. +addRcvNxt :: TcpSeqNum -> LocalWindow -> LocalWindow +addRcvNxt sn win = win { lwRcvNxt = lwRcvNxt win + sn } + +-- | Set the Rcv.Wind variable for the local window. +setRcvWind :: Word16 -> LocalWindow -> LocalWindow +setRcvWind size lw = refreshLocalWindow $! lw + { lwRcvWind = size + } + +-- | Set the Rcv.Wind.Scale variable in the local window. +setRcvWindScale :: Int -> LocalWindow -> LocalWindow +setRcvWindScale scale lw = refreshLocalWindow $! lw + { lwRcvWindScale = scale + } + +-- | Process an incoming packet that needs to pass through the incoming queue. +incomingPacket :: TcpHeader -> S.ByteString -> LocalWindow + -> (Seq.Seq InSegment, LocalWindow) +incomingPacket hdr body win = stepWindow (addInSegment hdr body win) + +-- | Queue an incoming packet in the incoming window. +addInSegment :: TcpHeader -> S.ByteString -> LocalWindow -> LocalWindow +addInSegment hdr body win = win { lwBuffer = insert (lwBuffer win) } + where + seg = mkInSegment (lwRcvNxt win) hdr body + insert buf = case Seq.viewl buf of + a Seq.:< rest -> case compare (inRelSeqNum a) (inRelSeqNum seg) of + LT -> a Seq.<| insert rest + EQ -> seg Seq.<| rest + GT -> seg Seq.<| buf + Seq.EmptyL -> Seq.singleton seg + +-- | Advance the window, if there are packets available to be returned. +stepWindow :: LocalWindow -> (Seq.Seq InSegment, LocalWindow) +stepWindow = loop 0 Seq.empty + where + loop expect segs win = case Seq.viewl (lwBuffer win) of + a Seq.:< rest | inRelSeqNum a == expect -> keep a segs rest win + | otherwise -> finalize segs win + Seq.EmptyL -> finalize segs win + + keep seg segs rest win = loop (inRelSeqNum seg + len) (segs Seq.|> seg) win + { lwBuffer = rest + , lwRcvNxt = lwRcvNxt win + len + } + where + len = fromIntegral (S.length (inBody seg)) + + finalize segs win = (segs,win { lwBuffer = update `fmap` lwBuffer win }) + where + len = F.sum (inLength `fmap` segs) + update is = is { inRelSeqNum = inRelSeqNum is - len } + +data InSegment = InSegment + { inRelSeqNum :: !TcpSeqNum + , inHeader :: !TcpHeader + , inBody :: !S.ByteString + } deriving (Show) + +inSeqNum :: InSegment -> TcpSeqNum +inSeqNum = tcpSeqNum . inHeader + +inLength :: Num a => InSegment -> a +inLength = fromIntegral . S.length . inBody + +-- | Generate an incoming segment, relative to the value of RCV.NXT +mkInSegment :: TcpSeqNum -> TcpHeader -> S.ByteString -> InSegment +mkInSegment rcvNxt hdr body = InSegment + { inRelSeqNum = rel + , inHeader = hdr + , inBody = body + } + where + -- calculate the index, relative to RCV.NXT, taking sequence number wrap into + -- account + rel | tcpSeqNum hdr < rcvNxt = maxBound - rcvNxt + tcpSeqNum hdr + 1 + | otherwise = tcpSeqNum hdr - rcvNxt + +mkSackBlock :: InSegment -> SackBlock +mkSackBlock is = SackBlock + { sbLeft = sn + , sbRight = sn + fromIntegral (S.length (inBody is)) + } + where + sn = tcpSeqNum (inHeader is) diff --git a/src/Hans/Layer/Timer.hs b/src/Hans/Layer/Timer.hs deleted file mode 100644 --- a/src/Hans/Layer/Timer.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS -fno-warn-orphans #-} - -module Hans.Layer.Timer ( - TimerHandle - , runTimerLayer - - , Milliseconds - , delay - , Microseconds - , udelay - ) where - -import Hans.Channel - -import Control.Concurrent (forkIO,threadDelay,MVar,newMVar,takeMVar,putMVar) -import Data.FingerTree as FT -import Data.Monoid (Monoid(..)) -import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime) -import MonadLib - - --- The Timers Structure -------------------------------------------------------- - -data Timer a = Timer - { timerAt :: POSIXTime - , timerValue :: a - } - -instance Monoid POSIXTime where - mempty = 0 - mappend a b | a > b = a - | otherwise = b - -instance Measured POSIXTime (Timer a) where - measure t = timerAt t - -type Timers a = FingerTree POSIXTime (Timer a) - - --- | Add an action to happen sometime in the future. -at :: POSIXTime -> a -> Timers a -> Timers a -at fut a ts = as' >< bs - where - (as,bs) = runnable fut ts - as' = as |> Timer fut a - - --- | Partition the actions into runnable and deferred. -runnable :: POSIXTime -> Timers a -> (Timers a, Timers a) -runnable now ts = FT.split (> now) ts - - --- | Step through the timers in a group. -stepTimers :: Timers a -> Maybe (a, Timers a) -stepTimers ts = case viewl ts of - EmptyL -> Nothing - r :< rs -> Just (timerValue r,rs) - - --- | Run all timers, when the action is an IO action. -runTimers :: Timers (IO a) -> IO (Timers (IO a)) -runTimers ts = do - now <- getPOSIXTime - let loop (Just (a,as)) = a >> loop (stepTimers as) - loop Nothing = return () - (rs,rest) = runnable now ts - loop (stepTimers rs) - return rest - - --- The External Message Interface ---------------------------------------------- - -type ActionTimers = Timers (IO ()) - --- | Mesages handled by the timer thread. -data TimerMessage = AddTimer POSIXTime (IO ()) - --- | A channel to the timer thread. -type TimerHandle = Channel TimerMessage - - --- | Start the timer thread. -runTimerLayer :: TimerHandle -> IO () -runTimerLayer h = do - timers <- newMVar FT.empty - _ <- forkIO (actionHandler timers) - _ <- forkIO (messageHandler h timers) - return () - - -type Milliseconds = Int - --- | Add a message to happen after some number of milliseconds. -delay :: TimerHandle -> Milliseconds -> IO () -> IO () -delay h !off = udelay h (off * 1000) - -type Microseconds = Int - --- | Add a message to happen after some number of microseconds. -udelay :: TimerHandle -> Microseconds -> IO () -> IO () -udelay h !micros k = do - now <- getPOSIXTime - -- the granularity for a NominalTimeDiff is 10^-12 - let off = fromIntegral micros / 1000000 - send h (AddTimer (now + off) k) - - --- Internal Loops -------------------------------------------------------------- - --- | The delay granularity of the timer layer. -timerStep :: Microseconds -timerStep = 100 - - --- | Loop, running available timer actions. -actionHandler :: MVar ActionTimers -> IO () -actionHandler timers = forever $ do - threadDelay timerStep - putMVar timers =<< runTimers =<< takeMVar timers - - --- | Loop, processing timer add requests. -messageHandler :: TimerHandle -> MVar ActionTimers -> IO () -messageHandler h timers = forever $ do - AddTimer t k <- receive h - ts <- takeMVar timers - putMVar timers $! at t k ts diff --git a/src/Hans/Layer/Udp.hs b/src/Hans/Layer/Udp.hs --- a/src/Hans/Layer/Udp.hs +++ b/src/Hans/Layer/Udp.hs @@ -2,55 +2,120 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} module Hans.Layer.Udp ( UdpHandle + , UdpException , runUdpLayer , queueUdp , sendUdp + , Handler , addUdpHandler + , addUdpHandlerAnyPort , removeUdpHandler ) where import Hans.Address.IP4 import Hans.Channel import Hans.Layer -import Hans.Layer.IP4 -import Hans.Layer.Icmp4 +import Hans.Message.Icmp4 import Hans.Message.Ip4 import Hans.Message.Udp import Hans.Ports import Hans.Utils +import qualified Hans.Layer.IP4 as IP4 +import qualified Hans.Layer.Icmp4 as Icmp4 -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO,newEmptyMVar,takeMVar,putMVar) +import Control.Monad (guard,mplus,when) +import Data.Maybe (isNothing) import Data.Serialize.Get (runGet) +import Data.Typeable (Typeable) import MonadLib (get,set) +import qualified Control.Exception as X +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S -type Handler = IP4 -> UdpPort -> Packet -> IO () +type Handler = IP4 -> UdpPort -> S.ByteString -> IO () type UdpHandle = Channel (Udp ()) -udpProtocol :: IP4Protocol -udpProtocol = IP4Protocol 0x11 +data UdpException = NoPortsAvailable + | PortInUse UdpPort + deriving (Show,Typeable) -runUdpLayer :: UdpHandle -> IP4Handle -> Icmp4Handle -> IO () +instance X.Exception UdpException + +runUdpLayer :: UdpHandle -> IP4.IP4Handle -> Icmp4.Icmp4Handle -> IO () runUdpLayer h ip4 icmp4 = do - addIP4Handler ip4 udpProtocol (queueUdp h) - void (forkIO (loopLayer (emptyUdp4State ip4 icmp4) (receive h) id)) + IP4.addIP4Handler ip4 udpProtocol (queueUdp h) + void (forkIO (loopLayer "udp" (emptyUdp4State ip4 icmp4) (receive h) id)) -sendUdp :: UdpHandle -> IP4 -> Maybe UdpPort -> UdpPort -> Packet -> IO () -sendUdp h !dst mb !dp !bs = send h (handleOutgoing dst mb dp bs) +-- | Send a UDP datagram. When the source port is given, this will send using +-- that source port. If the source port is not given, a fresh one is used, and +-- immediately recycled. +-- +-- NOTE: this doesn't prevent you from sending messages on a port that another +-- thread is already using. This is a funky design, and we'd be better suited +-- by introducing a UdpSocket type. +sendUdp :: UdpHandle -> IP4 -> Maybe UdpPort -> UdpPort -> L.ByteString -> IO () +sendUdp h !dst (Just sp) !dp !bs = + send h (handleOutgoing dst sp dp bs) +sendUdp h !dst Nothing !dp !bs = do + res <- newEmptyMVar -queueUdp :: UdpHandle -> IP4 -> IP4 -> Packet -> IO () -queueUdp h !src !dst !bs = send h (handleIncoming src dst bs) + send h $ do e <- allocPort + case e of + Right sp -> + do handleOutgoing dst sp dp bs + freePort sp + output (putMVar res Nothing) + Left err -> output (putMVar res (Just err)) + + mbErr <- takeMVar res + case mbErr of + Nothing -> return () + Just err -> X.throwIO err + +-- | Queue an incoming udp message from the IP4 layer. +queueUdp :: UdpHandle -> IP4Header -> S.ByteString -> IO () +queueUdp h !ip4 !bs = send h (handleIncoming ip4 bs) + +-- | Add a handler for incoming udp datagrams on a specific port. addUdpHandler :: UdpHandle -> UdpPort -> Handler -> IO () -addUdpHandler h !sp k = send h (handleAddHandler sp k) +addUdpHandler h sp k = do + res <- newEmptyMVar + send h $ do mb <- reservePort sp + when (isNothing mb) (addHandler sp k) + output (putMVar res mb) + mb <- takeMVar res + case mb of + Nothing -> return () + Just err -> X.throwIO err +-- | Add a handler for incoming udp datagrams on a freshly allocated port. +addUdpHandlerAnyPort :: UdpHandle -> (UdpPort -> Handler) -> IO UdpPort +addUdpHandlerAnyPort h k = do + res <- newEmptyMVar + send h $ do e <- allocPort + case e of + Right sp -> addHandler sp (k sp) + Left _ -> return () + output (putMVar res e) + + e <- takeMVar res + case e of + Right sp -> return sp + Left err -> X.throwIO err + +-- | Remove a handler present on the port given. removeUdpHandler :: UdpHandle -> UdpPort -> IO () -removeUdpHandler h !sp = send h (handleRemoveHandler sp) +removeUdpHandler h !sp = send h $ do freePort sp + removeHandler sp -- Udp State ------------------------------------------------------------------- @@ -60,11 +125,11 @@ data UdpState = UdpState { udpPorts :: PortManager UdpPort , udpHandlers :: Handlers UdpPort Handler - , udpIp4Handle :: IP4Handle - , udpIcmp4Handle :: Icmp4Handle + , udpIp4Handle :: IP4.IP4Handle + , udpIcmp4Handle :: Icmp4.Icmp4Handle } -emptyUdp4State :: IP4Handle -> Icmp4Handle -> UdpState +emptyUdp4State :: IP4.IP4Handle -> Icmp4.Icmp4Handle -> UdpState emptyUdp4State ip4 icmp4 = UdpState { udpPorts = emptyPortManager [maxBound, maxBound - 1 .. 1 ] , udpHandlers = emptyHandlers @@ -79,49 +144,68 @@ -- Utilities ------------------------------------------------------------------- -ip4Handle :: Udp IP4Handle +modifyPortManager :: (PortManager UdpPort -> (a,PortManager UdpPort)) -> Udp a +modifyPortManager f = do + state <- get + let (a,pm') = f (udpPorts state) + pm' `seq` set state { udpPorts = pm' } + return a + +ip4Handle :: Udp IP4.IP4Handle ip4Handle = udpIp4Handle `fmap` get ---icmp4Handle :: Udp Icmp4Handle ---icmp4Handle = udpIcmp4Handle `fmap` get +icmp4Handle :: Udp Icmp4.Icmp4Handle +icmp4Handle = udpIcmp4Handle `fmap` get -maybePort :: Maybe UdpPort -> Udp UdpPort -maybePort (Just p) = return p -maybePort Nothing = do - state <- get - (p,pm') <- nextPort (udpPorts state) - pm' `seq` set state { udpPorts = pm' } - return p +allocPort :: Udp (Either UdpException UdpPort) +allocPort = modifyPortManager $ \pm -> + case nextPort pm of + Just (p,pm') -> (Right p,pm') + Nothing -> (Left NoPortsAvailable,pm) --- Message Handling ------------------------------------------------------------ +reservePort :: UdpPort -> Udp (Maybe UdpException) +reservePort sp = modifyPortManager $ \ pm -> + case reserve sp pm of + Just pm' -> (Nothing,pm') + Nothing -> (Just (PortInUse sp), pm) -handleAddHandler :: UdpPort -> Handler -> Udp () -handleAddHandler sp k = do - state <- get - pm' <- reserve sp (udpPorts state) - pm' `seq` set state { udpPorts = pm' } - addHandler sp k +freePort :: UdpPort -> Udp () +freePort sp = modifyPortManager $ \ pm -> + case unreserve sp pm of + Just pm' -> ((), pm') + Nothing -> ((), pm ) -handleRemoveHandler :: UdpPort -> Udp () -handleRemoveHandler sp = do - state <- get - pm' <- unreserve sp (udpPorts state) - pm' `seq` set state { udpPorts = pm' } - removeHandler sp +-- Message Handling ------------------------------------------------------------ -handleIncoming :: IP4 -> IP4 -> Packet -> Udp () -handleIncoming src _dst bs = do - UdpPacket hdr pkt <- liftRight (runGet parseUdpPacket bs) - h <- getHandler (udpDestPort hdr) - output (h src (udpSourcePort hdr) pkt) +handleIncoming :: IP4Header -> S.ByteString -> Udp () +handleIncoming ip4 bs = do + let src = ip4SourceAddr ip4 + guard (validateUdpChecksum src (ip4DestAddr ip4) bs) + (hdr,bytes) <- liftRight (runGet parseUdpPacket bs) + listening src hdr bytes `mplus` unreachable ip4 bs +listening :: IP4 -> UdpHeader -> S.ByteString -> Udp () +listening src hdr bytes = do + h <- getHandler (udpDestPort hdr) + output $ do _ <- forkIO (h src (udpSourcePort hdr) bytes) + return () -handleOutgoing :: IP4 -> Maybe UdpPort -> UdpPort -> Packet -> Udp () -handleOutgoing dst mb dp bs = do - sp <- maybePort mb +-- | Deliver a destination unreachable mesasge, via the icmp layer. +unreachable :: IP4Header -> S.ByteString -> Udp () +unreachable hdr orig = do + icmp4 <- icmp4Handle + output (Icmp4.destUnreachable icmp4 PortUnreachable hdr (S.length orig) orig) + +handleOutgoing :: IP4 -> UdpPort -> UdpPort -> L.ByteString -> Udp () +handleOutgoing dst sp dp bs = do ip4 <- ip4Handle - let udp = UdpPacket (UdpHeader sp dp 0) bs - output $ withIP4Source ip4 dst $ \ src -> do - pkt <- renderUdpPacket udp (mkIP4PseudoHeader src dst udpProtocol) - sendIP4Packet ip4 udpProtocol dst pkt + let hdr = UdpHeader sp dp 0 + output $ IP4.withIP4Source ip4 dst $ \ src -> do + let ip4Hdr = emptyIP4Header + { ip4DestAddr = dst + , ip4Protocol = udpProtocol + , ip4DontFragment = False + } + pkt <- renderUdpPacket hdr bs (mkIP4PseudoHeader src dst udpProtocol) + IP4.sendIP4Packet ip4 ip4Hdr pkt diff --git a/src/Hans/Message/Arp.hs b/src/Hans/Message/Arp.hs --- a/src/Hans/Message/Arp.hs +++ b/src/Hans/Message/Arp.hs @@ -1,11 +1,14 @@ module Hans.Message.Arp where -import Hans.Address +import Hans.Address (Address(addrSize)) +import Hans.Utils (chunk) -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (getWord8,getWord16be) -import Data.Serialize.Put (putWord16be,putWord8) +import Control.Applicative (Applicative(..),(<$>)) +import Data.Serialize.Get (Get,runGet,getWord8,getWord16be) +import Data.Serialize.Put (Putter,runPut,putWord16be,putWord8) import Data.Word (Word16) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L -- Arp Packets ----------------------------------------------------------------- @@ -18,57 +21,59 @@ , arpSPA :: p , arpTHA :: hw , arpTPA :: p - } + } deriving (Show) --- | Decode an Arp message. -instance (Address hw, Address p) => Serialize (ArpPacket hw p) where - get = do - hty <- getWord16be - pty <- getWord16be - _ <- getWord8 - _ <- getWord8 - oper <- get - sha <- get - spa <- get - tha <- get - tpa <- get - return $! ArpPacket - { arpHwType = hty - , arpPType = pty - , arpOper = oper - , arpSHA = sha - , arpSPA = spa - , arpTHA = tha - , arpTPA = tpa - } +-- | Parse an Arp packet, given a way to parse hardware and protocol addresses. +parseArpPacket :: Get hw -> Get p + -> S.ByteString -> Either String (ArpPacket hw p) +parseArpPacket getHw getP = runGet $ + ArpPacket + <$> getWord16be -- hardware type + <*> getWord16be -- protocol type + <* getWord8 -- hardware address length (ignored) + <* getWord8 -- protocol address length (ignored) + <*> parseArpOper -- operation + <*> getHw -- sender hardware address + <*> getP -- sender protocol address + <*> getHw -- target hardware address + <*> getP -- target protocol address - put msg = do - putWord16be (arpHwType msg) - putWord16be (arpPType msg) - putWord8 (addrSize (arpSHA msg)) - putWord8 (addrSize (arpSPA msg)) - put (arpOper msg) - put (arpSHA msg) - put (arpSPA msg) - put (arpTHA msg) - put (arpTPA msg) +-- | Render an Arp packet, given a way to render hardware and protocol +-- addresses. +renderArpPacket :: (Address hw, Address p) + => Putter hw -> Putter p + -> ArpPacket hw p -> L.ByteString +renderArpPacket putHw putP arp = chunk $ runPut $ do + putWord16be (arpHwType arp) + putWord16be (arpPType arp) + putWord8 (addrSize (arpSHA arp)) + putWord8 (addrSize (arpSPA arp)) + renderArpOper (arpOper arp) + putHw (arpSHA arp) + putP (arpSPA arp) + putHw (arpTHA arp) + putP (arpTPA arp) -- Arp Opcodes ----------------------------------------------------------------- +-- | Arp operations. data ArpOper = ArpRequest -- ^ 0x1 | ArpReply -- ^ 0x2 - deriving (Eq) - + deriving (Show,Eq) -instance Serialize ArpOper where - get = do - b <- getWord16be - case b of - 0x1 -> return ArpRequest - 0x2 -> return ArpReply - _ -> fail "invalid Arp opcode" +-- | Parse an Arp operation. +parseArpOper :: Get ArpOper +parseArpOper = do + b <- getWord16be + case b of + 0x1 -> return ArpRequest + 0x2 -> return ArpReply + _ -> fail "invalid Arp opcode" - put ArpRequest = putWord16be 0x1 - put ArpReply = putWord16be 0x2 +-- | Render an Arp operation. +renderArpOper :: Putter ArpOper +renderArpOper op = case op of + ArpRequest -> putWord16be 0x1 + ArpReply -> putWord16be 0x2 diff --git a/src/Hans/Message/Dhcp4.hs b/src/Hans/Message/Dhcp4.hs --- a/src/Hans/Message/Dhcp4.hs +++ b/src/Hans/Message/Dhcp4.hs @@ -51,17 +51,20 @@ import Hans.Address.Mac (Mac) import Hans.Message.Dhcp4Codec import Hans.Message.Dhcp4Options +import Hans.Utils (chunk) import Control.Applicative ((<*), (<$>)) import Control.Monad (unless) import Data.Bits (testBit,bit) import Data.Maybe (mapMaybe) -import Data.Serialize.Get (Get, getByteString, isolate, remaining, label, skip) -import Data.Serialize.Put (Put, putByteString) +import Data.Serialize.Get (Get, runGet, getByteString, isolate, remaining, label + , skip) +import Data.Serialize.Put (Put, runPut, putByteString) import Data.Word (Word8,Word16,Word32) import Numeric (showHex) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as L -- DHCP Static Server Settings --------------------------------------------- @@ -97,6 +100,7 @@ data Request = Request { requestXid :: Xid -- ^ Transaction ID of offer , requestBroadcast :: Bool -- ^ Set 'True' to instruct server to send to broadcast hardware address + , requestServerAddr :: IP4 , requestClientHardwareAddress :: Mac -- ^ Hardware address of the client , requestParameters :: [Dhcp4OptionTag] -- ^ Used to specify the information that client needs , requestAddress :: Maybe IP4 -- ^ Used to specify the address which was accepted @@ -228,8 +232,8 @@ } deriving (Eq,Show) -- |'getDhcp4Message' is the binary decoder for parsing 'Dhcp4Message' values. -getDhcp4Message :: Get Dhcp4Message -getDhcp4Message = do +getDhcp4Message :: BS.ByteString -> Either String Dhcp4Message +getDhcp4Message = runGet $ do op <- getAtom hwtype <- getAtom len <- getAtom @@ -264,8 +268,8 @@ } -- |'getDhcp4Message' is the binary encoder for rendering 'Dhcp4Message' values. -putDhcp4Message :: Dhcp4Message -> Put -putDhcp4Message dhcp = do +putDhcp4Message :: Dhcp4Message -> L.ByteString +putDhcp4Message dhcp = chunk $ runPut $ do putAtom (dhcp4Op dhcp) let hwType = Ethernet putAtom hwType @@ -391,6 +395,7 @@ return Request { requestXid = dhcp4Xid msg , requestBroadcast = dhcp4Broadcast msg + , requestServerAddr = dhcp4ServerAddr msg , requestClientHardwareAddress = dhcp4ClientHardwareAddr msg , requestParameters = params' , requestAddress = addr @@ -522,6 +527,7 @@ , dhcp4ServerHostname = "" , dhcp4BootFilename = "" , dhcp4Options = [ OptMessageType Dhcp4Request + , OptServerIdentifier (requestServerAddr request) , OptParameterRequestList $ map KnownTag $ requestParameters request @@ -555,6 +561,7 @@ offerToRequest offer = Request { requestXid = offerXid offer , requestBroadcast = False + , requestServerAddr = offerServerAddr offer , requestClientHardwareAddress = offerClientHardwareAddr offer , requestParameters = [ OptTagSubnetMask , OptTagBroadcastAddress diff --git a/src/Hans/Message/Dns.hs b/src/Hans/Message/Dns.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Dns.hs @@ -0,0 +1,601 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} + +module Hans.Message.Dns ( + DNSPacket(..) + , DNSHeader(..) + , OpCode(..) + , RespCode(..) + , Query(..) + , QClass(..) + , QType(..) + , RR(..) + , Type(..) + , Class(..) + , RData(..) + , Name + + , parseDNSPacket, getDNSPacket + , renderDNSPacket, putDNSPacket + ) where + +import Hans.Address.IP4 +import Hans.Utils (chunk) + +import Control.Monad +import Data.Bits +import Data.Foldable ( traverse_, foldMap ) +import Data.Int +import Data.Serialize ( Putter, runPut, putWord8, putWord16be, putWord32be + , putByteString ) +import Data.Word +import MonadLib ( lift, StateT, runStateT, get, set ) +import Numeric ( showHex ) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Map.Strict as Map +import qualified Data.Serialize.Get as C + + +-- DNS Packets ----------------------------------------------------------------- + +data DNSPacket = DNSPacket { dnsHeader :: DNSHeader + , dnsQuestions :: [Query] + , dnsAnswers :: [RR] + , dnsAuthorityRecords :: [RR] + , dnsAdditionalRecords :: [RR] + } deriving (Show) + +data DNSHeader = DNSHeader { dnsId :: !Word16 + , dnsQuery :: Bool + , dnsOpCode :: OpCode + , dnsAA :: Bool + , dnsTC :: Bool + , dnsRD :: Bool + , dnsRA :: Bool + , dnsRC :: RespCode + } deriving (Show) + +data OpCode = OpQuery + | OpIQuery + | OpStatus + | OpReserved !Word16 + deriving (Show) + +data RespCode = RespNoError + | RespFormatError + | RespServerFailure + | RespNameError + | RespNotImplemented + | RespRefused + | RespReserved !Word16 + deriving (Eq,Show) + +type Name = [S.ByteString] + +data Query = Query { qName :: Name + , qType :: QType + , qClass :: QClass + } deriving (Show) + +data RR = RR { rrName :: Name + , rrClass :: Class + , rrTTL :: !Int32 + , rrRData :: RData + } deriving (Show) + +data QType = QType Type + | AFXR + | MAILB + | MAILA + | QTAny + deriving (Show) + +data Type = A + | NS + | MD + | MF + | CNAME + | SOA + | MB + | MG + | MR + | NULL + | PTR + | HINFO + | MINFO + | MX + | AAAA + deriving (Show) + +data QClass = QClass Class + | QAnyClass + deriving (Show) + +data Class = IN | CS | CH | HS + deriving (Show,Eq) + +data RData = RDA IP4 + | RDNS Name + | RDMD Name + | RDMF Name + | RDCNAME Name + | RDSOA Name Name !Word32 !Int32 !Int32 !Int32 !Word32 + | RDMB Name + | RDMG Name + | RDMR Name + | RDPTR Name + | RDHINFO S.ByteString S.ByteString + | RDMINFO Name Name + | RDMX !Word16 Name + | RDNULL S.ByteString + | RDUnknown Type S.ByteString + deriving (Show) + + +-- Cereal With Label Compression ----------------------------------------------- + +data RW = RW { rwOffset :: !Int + , rwLabels :: Map.Map Int Name + } deriving (Show) + +type Get = StateT RW C.Get + +{-# INLINE unGet #-} +unGet :: Get a -> C.Get a +unGet m = + do (a,_) <- runStateT RW { rwOffset = 0, rwLabels = Map.empty } m + return a + +getOffset :: Get Int +getOffset = rwOffset `fmap` get + +addOffset :: Int -> Get () +addOffset off = + do rw <- get + set $! rw { rwOffset = rwOffset rw + off } + +lookupPtr :: Int -> Get Name +lookupPtr off = + do rw <- get + when (off >= rwOffset rw) (fail "Invalid offset in pointer") + case Map.lookup off (rwLabels rw) of + Just ls -> return ls + Nothing -> fail $ "Unknown label for offset: " ++ showHex off "\n" + ++ show (rwLabels rw) + +data Label = Label Int S.ByteString + | Ptr Int Name + deriving (Show) + +labelsToName :: [Label] -> Name +labelsToName = foldMap toName + where + toName (Label _ l) = [l] + toName (Ptr _ n) = n + +addLabels :: [Label] -> Get () +addLabels labels = + do rw <- get + set $! rw { rwLabels = Map.fromList newLabels `Map.union` rwLabels rw } + where + newLabels = go labels (labelsToName labels) + + go (Label off _ : rest) name@(_ : ns) = (off,name) : go rest ns + go (Ptr off _ : _) name = [(off,name)] + go _ _ = [] + + +{-# INLINE liftGet #-} +liftGet :: Int -> C.Get a -> Get a +liftGet n m = do addOffset n + lift m + + +{-# INLINE getWord8 #-} +getWord8 :: Get Word8 +getWord8 = liftGet 1 C.getWord8 + +{-# INLINE getWord16be #-} +getWord16be :: Get Word16 +getWord16be = liftGet 2 C.getWord16be + +{-# INLINE getWord32be #-} +getWord32be :: Get Word32 +getWord32be = liftGet 4 C.getWord32be + +{-# INLINE getInt32be #-} +getInt32be :: Get Int32 +getInt32be = fromIntegral `fmap` liftGet 4 C.getWord32be + +{-# INLINE getBytes #-} +getBytes :: Int -> Get S.ByteString +getBytes n = liftGet n (C.getBytes n) + +isolate :: Int -> Get a -> Get a +isolate n body = + do off <- get + (a,off') <- lift (C.isolate n (runStateT off body)) + set off' + return a + +label :: String -> Get a -> Get a +label str m = + do off <- get + (a,off') <- lift (C.label str (runStateT off m)) + set off' + return a + + +{-# INLINE putInt32be #-} +putInt32be :: Putter Int32 +putInt32be i = putWord32be (fromIntegral i) + +-- Parsing --------------------------------------------------------------------- + +parseDNSPacket :: S.ByteString -> Either String DNSPacket +parseDNSPacket = C.runGet getDNSPacket + +getDNSPacket :: C.Get DNSPacket +getDNSPacket = unGet $ label "DNSPacket" $ + do dnsHeader <- getDNSHeader + qdCount <- getWord16be + anCount <- getWord16be + nsCount <- getWord16be + arCount <- getWord16be + + let blockOf c l m = label l (replicateM (fromIntegral c) m) + dnsQuestions <- blockOf qdCount "Questions" getQuery + dnsAnswers <- blockOf anCount "Answers" getRR + dnsAuthorityRecords <- blockOf nsCount "Authority Records" getRR + dnsAdditionalRecords <- blockOf arCount "Additional Records" getRR + + return DNSPacket { .. } + +-- 1 1 1 1 1 1 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | ID | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- |QR| Opcode |AA|TC|RD|RA| Z | RCODE | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | QDCOUNT | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | ANCOUNT | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | NSCOUNT | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | ARCOUNT | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +getDNSHeader :: Get DNSHeader +getDNSHeader = label "DNS Header" $ + do dnsId <- getWord16be + flags <- getWord16be + let dnsQuery = not (flags `testBit` 15) + dnsOpCode = parseOpCode (flags `shiftR` 11) + dnsAA = flags `testBit` 10 + dnsTC = flags `testBit` 9 + dnsRD = flags `testBit` 8 + dnsRA = flags `testBit` 7 + dnsZ = (flags `shiftR` 4) .&. 0x7 + dnsRC = parseRespCode (flags .&. 0xf) + + unless (dnsZ == 0) (fail ("Z not zero")) + + return DNSHeader { .. } + + +parseOpCode :: Word16 -> OpCode +parseOpCode 0 = OpQuery +parseOpCode 1 = OpIQuery +parseOpCode 2 = OpStatus +parseOpCode c = OpReserved (c .&. 0xf) + +parseRespCode :: Word16 -> RespCode +parseRespCode 0 = RespNoError +parseRespCode 1 = RespFormatError +parseRespCode 2 = RespServerFailure +parseRespCode 3 = RespNameError +parseRespCode 4 = RespNotImplemented +parseRespCode 5 = RespRefused +parseRespCode c = RespReserved (c .&. 0xf) + +getQuery :: Get Query +getQuery = label "Question" $ + do qName <- getName + qType <- label "QTYPE" getQType + qClass <- label "QCLASS" getQClass + return Query { .. } + +-- 1 1 1 1 1 1 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | | +-- / / +-- / NAME / +-- | | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | TYPE | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | CLASS | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | TTL | +-- | | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +-- | RDLENGTH | +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--| +-- / RDATA / +-- / / +-- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ +getRR :: Get RR +getRR = label "RR" $ + do rrName <- getName + ty <- getType + rrClass <- getClass + rrTTL <- getInt32be + rrRData <- getRData ty + return RR { .. } + + +getType :: Get Type +getType = + do qt <- getQType + case qt of + QType ty -> return ty + _ -> fail ("Invalid TYPE: " ++ show qt) + +getQType :: Get QType +getQType = + do tag <- getWord16be + case tag of + 1 -> return (QType A) + 2 -> return (QType NS) + 3 -> return (QType MD) + 4 -> return (QType MF) + 5 -> return (QType CNAME) + 6 -> return (QType SOA) + 7 -> return (QType MB) + 8 -> return (QType MG) + 9 -> return (QType MR) + 10 -> return (QType NULL) + 12 -> return (QType PTR) + 13 -> return (QType HINFO) + 14 -> return (QType MINFO) + 15 -> return (QType MX) + 28 -> return (QType AAAA) + 252 -> return AFXR + 253 -> return MAILB + 254 -> return MAILA + 255 -> return QTAny + _ -> fail ("Invalid TYPE: " ++ show tag) + + +getQClass :: Get QClass +getQClass = + do tag <- getWord16be + case tag of + 1 -> return (QClass IN) + 2 -> return (QClass CS) + 3 -> return (QClass CH) + 4 -> return (QClass HS) + 255 -> return QAnyClass + _ -> fail ("Invalid CLASS: " ++ show tag) + +getName :: Get Name +getName = + do labels <- go + addLabels labels + return (labelsToName labels) + where + go = do off <- getOffset + len <- getWord8 + if | len .&. 0xc0 == 0xc0 -> + do l <- getWord8 + let ptr = fromIntegral ((0x3f .&. len) `shiftL` 8) + + fromIntegral l + ns <- lookupPtr ptr + return [Ptr off ns] + + | len == 0 -> + return [] + + | otherwise -> + do l <- getBytes (fromIntegral len) + ls <- go + return (Label off l:ls) + +getClass :: Get Class +getClass = label "CLASS" $ + do qc <- getQClass + case qc of + QClass c -> return c + QAnyClass -> fail "Invalid CLASS" + +getRData :: Type -> Get RData +getRData ty = label (show ty) $ + do len <- getWord16be + isolate (fromIntegral len) $ case ty of + A -> RDA `fmap` liftGet 4 parseIP4 + NS -> RDNS `fmap` getName + MD -> RDMD `fmap` getName + MF -> RDMF `fmap` getName + CNAME -> RDCNAME `fmap` getName + SOA -> do mname <- getName + rname <- getName + serial <- getWord32be + refresh <- getInt32be + retry <- getInt32be + expire <- getInt32be + minTTL <- getWord32be + return (RDSOA mname rname serial refresh retry expire minTTL) + MB -> RDMB `fmap` getName + MG -> RDMG `fmap` getName + MR -> RDMR `fmap` getName + NULL -> RDNULL `fmap` (getBytes =<< lift C.remaining) + PTR -> RDPTR `fmap` getName + + HINFO -> do cpuLen <- getWord8 + cpu <- getBytes (fromIntegral cpuLen) + osLen <- getWord8 + os <- getBytes (fromIntegral osLen) + return (RDHINFO cpu os) + + MINFO -> do rmailBx <- getName + emailBx <- getName + return (RDMINFO rmailBx emailBx) + + MX -> do pref <- getWord16be + ex <- getName + return (RDMX pref ex) + + _ -> RDUnknown ty `fmap` (getBytes =<< lift C.remaining) + + +-- Rendering ------------------------------------------------------------------- + +renderDNSPacket :: DNSPacket -> L.ByteString +renderDNSPacket pkt = chunk (runPut (putDNSPacket pkt)) + +putDNSPacket :: Putter DNSPacket +putDNSPacket DNSPacket{ .. } = + do putDNSHeader dnsHeader + + putWord16be (fromIntegral (length dnsQuestions)) + putWord16be (fromIntegral (length dnsAnswers)) + putWord16be (fromIntegral (length dnsAuthorityRecords)) + putWord16be (fromIntegral (length dnsAdditionalRecords)) + + traverse_ putQuery dnsQuestions + traverse_ putRR dnsAnswers + traverse_ putRR dnsAuthorityRecords + traverse_ putRR dnsAdditionalRecords + +putDNSHeader :: Putter DNSHeader +putDNSHeader DNSHeader { .. } = + do putWord16be dnsId + let flag i b w | b = setBit w i + | otherwise = clearBit w i + flags = flag 15 (not dnsQuery) + $ flag 10 dnsAA + $ flag 9 dnsTC + $ flag 8 dnsRD + $ flag 7 dnsRA + $ flag 4 False -- dnsZ + $ (renderOpCode dnsOpCode `shiftL` 11) .|. renderRespCode dnsRC + putWord16be flags + +renderOpCode :: OpCode -> Word16 +renderOpCode OpQuery = 0 +renderOpCode OpIQuery = 1 +renderOpCode OpStatus = 2 +renderOpCode (OpReserved c) = c .&. 0xf + +renderRespCode :: RespCode -> Word16 +renderRespCode RespNoError = 0 +renderRespCode RespFormatError = 1 +renderRespCode RespServerFailure = 2 +renderRespCode RespNameError = 3 +renderRespCode RespNotImplemented = 4 +renderRespCode RespRefused = 5 +renderRespCode (RespReserved c) = c .&. 0xf + +putName :: Putter Name +putName = go + where + go (l:ls) + | S.null l = putWord8 0 + | S.length l > 63 = error "Label too big" + | otherwise = do putWord8 (fromIntegral len) + putByteString l + go ls + where + len = S.length l + + go [] = putWord8 0 + +putQuery :: Putter Query +putQuery Query { .. } = + do putName qName + putQType qType + putQClass qClass + +putType :: Putter Type +putType A = putWord16be 1 +putType NS = putWord16be 2 +putType MD = putWord16be 3 +putType MF = putWord16be 4 +putType CNAME = putWord16be 5 +putType SOA = putWord16be 6 +putType MB = putWord16be 7 +putType MG = putWord16be 8 +putType MR = putWord16be 9 +putType NULL = putWord16be 10 +putType PTR = putWord16be 12 +putType HINFO = putWord16be 13 +putType MINFO = putWord16be 14 +putType MX = putWord16be 15 +putType AAAA = putWord16be 28 + +putQType :: Putter QType +putQType (QType ty) = putType ty +putQType AFXR = putWord16be 252 +putQType MAILB = putWord16be 253 +putQType MAILA = putWord16be 254 +putQType QTAny = putWord16be 255 + +putQClass :: Putter QClass +putQClass (QClass c) = putClass c +putQClass QAnyClass = putWord16be 255 + +putRR :: Putter RR +putRR RR { .. } = + do putName rrName + let (ty,rdata) = putRData rrRData + putType ty + putClass rrClass + putWord32be (fromIntegral rrTTL) + putWord16be (fromIntegral (S.length rdata)) + putByteString rdata + +putClass :: Putter Class +putClass IN = putWord16be 1 +putClass CS = putWord16be 2 +putClass CH = putWord16be 3 +putClass HS = putWord16be 4 + +putRData :: RData -> (Type,S.ByteString) +putRData rd = case rd of + RDA addr -> rdata A (renderIP4 addr) + RDNS name -> rdata NS (putName name) + RDMD name -> rdata MD (putName name) + RDMF name -> rdata MF (putName name) + RDCNAME name -> rdata CNAME (putName name) + RDSOA m r s f t ex ttl -> + rdata SOA $ do putName m + putName r + putWord32be s + putInt32be f + putInt32be t + putInt32be ex + putWord32be ttl + + RDMB name -> rdata MB (putName name) + RDMG name -> rdata MG (putName name) + RDMR name -> rdata MR (putName name) + RDNULL bytes -> rdata NULL $ do putWord8 (fromIntegral (S.length bytes)) + putByteString bytes + RDPTR name -> rdata PTR (putName name) + RDHINFO cpu os -> rdata HINFO $ do putWord8 (fromIntegral (S.length cpu)) + putByteString cpu + putWord8 (fromIntegral (S.length os)) + putByteString os + RDMINFO rm em -> rdata MINFO $ do putName rm + putName em + RDMX pref ex -> rdata MX $ do putWord16be pref + putName ex + RDUnknown ty bytes -> (ty,bytes) + where + rdata tag m = (tag,runPut m) diff --git a/src/Hans/Message/EthernetFrame.hs b/src/Hans/Message/EthernetFrame.hs --- a/src/Hans/Message/EthernetFrame.hs +++ b/src/Hans/Message/EthernetFrame.hs @@ -2,43 +2,59 @@ module Hans.Message.EthernetFrame ( EtherType(..) + , parseEtherType, renderEtherType + , EthernetFrame(..) + , parseEthernetFrame, renderEthernetFrame ) where -import Hans.Address.Mac (Mac) +import Hans.Address.Mac (Mac,parseMac,renderMac) +import Hans.Utils (chunk) -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (Get,getBytes,remaining) -import Data.Serialize.Put (Put,putByteString) -import Data.ByteString (ByteString) +import Control.Applicative ((<$>),(<*>)) +import Data.Serialize.Get (Get,remaining,getWord16be,getBytes,runGet) +import Data.Serialize.Put (Putter,putWord16be,runPut) import Data.Word (Word16) import Numeric (showHex) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + +-- Ether Type ------------------------------------------------------------------ + newtype EtherType = EtherType { getEtherType :: Word16 } - deriving (Eq,Num,Ord,Serialize) + deriving (Eq,Num,Ord) instance Show EtherType where showsPrec _ (EtherType et) = showString "EtherType 0x" . showHex et +parseEtherType :: Get EtherType +parseEtherType = EtherType <$> getWord16be + +renderEtherType :: Putter EtherType +renderEtherType = putWord16be . getEtherType + + +-- Ethernet Frames ------------------------------------------------------------- + data EthernetFrame = EthernetFrame { etherDest :: !Mac , etherSource :: !Mac , etherType :: !EtherType - , etherData :: ByteString } deriving (Eq,Show) -instance Serialize EthernetFrame where - get = parseEthernetFrame - put = renderEthernetFrame - -parseEthernetFrame :: Get EthernetFrame -parseEthernetFrame = do - dst <- get - src <- get - ty <- get - body <- getBytes =<< remaining - return $! EthernetFrame dst src ty body +parseEthernetFrame :: S.ByteString -> Either String (EthernetFrame,S.ByteString) +parseEthernetFrame = runGet ((,) <$> header <*> (getBytes =<< remaining)) + where + header = EthernetFrame + <$> parseMac + <*> parseMac + <*> parseEtherType -renderEthernetFrame :: EthernetFrame -> Put -renderEthernetFrame (EthernetFrame s d t da) = - put s >> put d >> put t >> putByteString da +renderEthernetFrame :: EthernetFrame -> L.ByteString -> L.ByteString +renderEthernetFrame frame body = chunk hdr `L.append` body + where + hdr = runPut $ do + renderMac (etherDest frame) + renderMac (etherSource frame) + renderEtherType (etherType frame) diff --git a/src/Hans/Message/Icmp4.hs b/src/Hans/Message/Icmp4.hs --- a/src/Hans/Message/Icmp4.hs +++ b/src/Hans/Message/Icmp4.hs @@ -3,33 +3,35 @@ module Hans.Message.Icmp4 where import Hans.Address.IP4 (IP4) -import Hans.Message.Types (Lifetime) -import Hans.Utils (Packet) +import Hans.Message.Types (Lifetime,parseLifetime,renderLifetime) +import Hans.Utils (chunk) import Hans.Utils.Checksum (pokeChecksum, computeChecksum) import Control.Monad (liftM2, unless, when, replicateM) import Data.Serialize (Serialize(..)) import Data.Serialize.Get (getWord8, getByteString, remaining, skip, Get, label, - lookAhead, getBytes, isEmpty) -import Data.Serialize.Put (putWord8,putByteString, Put, runPut) + lookAhead, getBytes, isEmpty, runGet) +import Data.Serialize.Put (Putter, putWord8,putByteString, Put, runPut) import Data.Int (Int32) import Data.Word (Word8,Word16,Word32) import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L -- General ICMP Packets -------------------------------------------------------- data Icmp4Packet -- RFC 792 - Internet Control Message Protocol - = EchoReply Identifier SequenceNumber Packet - | DestinationUnreachable DestinationUnreachableCode Packet - | SourceQuench Packet - | Redirect RedirectCode IP4 Packet - | Echo Identifier SequenceNumber Packet + = EchoReply Identifier SequenceNumber S.ByteString + | DestinationUnreachable DestinationUnreachableCode S.ByteString + | SourceQuench S.ByteString + | Redirect RedirectCode IP4 S.ByteString + | Echo Identifier SequenceNumber S.ByteString | RouterAdvertisement Lifetime [RouterAddress] | RouterSolicitation - | TimeExceeded TimeExceededCode Packet - | ParameterProblem Word8 Packet + | TimeExceeded TimeExceededCode S.ByteString + | ParameterProblem Word8 S.ByteString | Timestamp Identifier SequenceNumber Word32 Word32 Word32 | TimestampReply Identifier SequenceNumber Word32 Word32 Word32 | Information Identifier SequenceNumber @@ -41,7 +43,7 @@ -- rfc 950 - Internet Standard Subnetting Procedure | AddressMask Identifier SequenceNumber | AddressMaskReply Identifier SequenceNumber Word32 - deriving Show + deriving (Eq,Show) noCode :: String -> Get () noCode str = do @@ -49,238 +51,249 @@ unless (code == 0) (fail (str ++ " expects code 0")) -instance Serialize Icmp4Packet where - get = label "ICMP" $ do - rest <- lookAhead (getBytes =<< remaining) - unless (computeChecksum 0 rest == 0) - (fail "Bad checksum") - ty <- get +{-# INLINE parseIcmp4Packet #-} +parseIcmp4Packet :: S.ByteString -> Either String Icmp4Packet +parseIcmp4Packet = runGet $ do + rest <- lookAhead (getBytes =<< remaining) + unless (computeChecksum 0 rest == 0) + (fail "Bad checksum") + getIcmp4Packet - let firstGet :: Serialize a => String -> (a -> Get b) -> Get b - firstGet labelString f = label labelString $ do - code <- get - skip 2 -- checksum - f code +getIcmp4Packet :: Get Icmp4Packet +getIcmp4Packet = label "ICMP" $ do - case (ty :: Word8) of - 0 -> firstGet "Echo Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - dat <- getByteString =<< remaining - return $! EchoReply ident seqNum dat + ty <- get - 3 -> firstGet "DestinationUnreachable" $ \ code -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! DestinationUnreachable code dat + let firstGet :: Serialize a => String -> (a -> Get b) -> Get b + firstGet labelString f = label labelString $ do + code <- get + skip 2 -- checksum + f code - 4 -> firstGet "Source Quence" $ \ NoCode -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! SourceQuench dat + case (ty :: Word8) of + 0 -> firstGet "Echo Reply" $ \ NoCode -> do + ident <- get + seqNum <- get + dat <- getByteString =<< remaining + return $! EchoReply ident seqNum dat - 5 -> firstGet "Redirect" $ \ code -> do - gateway <- get - dat <- getByteString =<< remaining - return $! Redirect code gateway dat + 3 -> firstGet "DestinationUnreachable" $ \ code -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! DestinationUnreachable code dat - 8 -> firstGet "Echo" $ \ NoCode -> do - ident <- get - seqNum <- get - dat <- getByteString =<< remaining - return $! Echo ident seqNum dat + 4 -> firstGet "Source Quence" $ \ NoCode -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! SourceQuench dat - 9 -> firstGet "Router Advertisement" $ \ NoCode -> do - n <- getWord8 - sz <- getWord8 - unless (sz == 2) - (fail ("Expected size 2, got: " ++ show sz)) - lifetime <- get - addrs <- replicateM (fromIntegral n) get - return $! RouterAdvertisement lifetime addrs + 5 -> firstGet "Redirect" $ \ code -> do + gateway <- get + dat <- getByteString =<< remaining + return $! Redirect code gateway dat - 10 -> firstGet "Router Solicitation" $ \ NoCode -> do - skip 4 -- reserved - return RouterSolicitation + 8 -> firstGet "Echo" $ \ NoCode -> do + ident <- get + seqNum <- get + dat <- getByteString =<< remaining + return $! Echo ident seqNum dat - 11 -> firstGet "Time Exceeded" $ \ code -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! TimeExceeded code dat + 9 -> firstGet "Router Advertisement" $ \ NoCode -> do + n <- getWord8 + sz <- getWord8 + unless (sz == 2) + (fail ("Expected size 2, got: " ++ show sz)) + lifetime <- parseLifetime + addrs <- replicateM (fromIntegral n) get + return $! RouterAdvertisement lifetime addrs - 12 -> firstGet "Parameter Problem" $ \ NoCode -> do - ptr <- getWord8 - skip 3 -- unused - dat <- getByteString =<< remaining - return $! ParameterProblem ptr dat + 10 -> firstGet "Router Solicitation" $ \ NoCode -> do + skip 4 -- reserved + return RouterSolicitation - 13 -> firstGet "Timestamp" $ \ NoCode -> do - ident <- get - seqNum <- get - origTime <- get - recvTime <- get - tranTime <- get - return $! Timestamp ident seqNum origTime recvTime tranTime + 11 -> firstGet "Time Exceeded" $ \ code -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! TimeExceeded code dat - 14 -> firstGet "Timestamp Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - origTime <- get - recvTime <- get - tranTime <- get - return $! TimestampReply ident seqNum origTime recvTime tranTime + 12 -> firstGet "Parameter Problem" $ \ NoCode -> do + ptr <- getWord8 + skip 3 -- unused + dat <- getByteString =<< remaining + return $! ParameterProblem ptr dat - 15 -> firstGet "Information" $ \ NoCode -> do - ident <- get - seqNum <- get - return $! Information ident seqNum + 13 -> firstGet "Timestamp" $ \ NoCode -> do + ident <- get + seqNum <- get + origTime <- get + recvTime <- get + tranTime <- get + return $! Timestamp ident seqNum origTime recvTime tranTime - 16 -> firstGet "Information Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - return $! InformationReply ident seqNum + 14 -> firstGet "Timestamp Reply" $ \ NoCode -> do + ident <- get + seqNum <- get + origTime <- get + recvTime <- get + tranTime <- get + return $! TimestampReply ident seqNum origTime recvTime tranTime - 17 -> firstGet "Address Mask" $ \ NoCode -> do - ident <- get - seqNum <- get - skip 4 -- address mask - return $! AddressMask ident seqNum + 15 -> firstGet "Information" $ \ NoCode -> do + ident <- get + seqNum <- get + return $! Information ident seqNum - 18 -> firstGet "Address Mask Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - mask <- get - return $! AddressMaskReply ident seqNum mask + 16 -> firstGet "Information Reply" $ \ NoCode -> do + ident <- get + seqNum <- get + return $! InformationReply ident seqNum - 30 -> firstGet "Trace Route" $ \ code -> do - ident <- get - skip 2 -- unused - outHop <- get - retHop <- get - speed <- get - mtu <- get - return $! TraceRoute code ident outHop retHop speed mtu + 17 -> firstGet "Address Mask" $ \ NoCode -> do + ident <- get + seqNum <- get + skip 4 -- address mask + return $! AddressMask ident seqNum - _ -> fail ("Unknown type: " ++ show ty) + 18 -> firstGet "Address Mask Reply" $ \ NoCode -> do + ident <- get + seqNum <- get + mask <- get + return $! AddressMaskReply ident seqNum mask + 30 -> firstGet "Trace Route" $ \ code -> do + ident <- get + skip 2 -- unused + outHop <- get + retHop <- get + speed <- get + mtu <- get + return $! TraceRoute code ident outHop retHop speed mtu - put = putByteString . unsafePerformIO . setChecksum . runPut . put' - -- Argument for safety: The bytestring being - -- destructively modified here is only accessible - -- through the composition and will never escape - where - setChecksum pkt = pokeChecksum (computeChecksum 0 pkt) pkt 2 + _ -> fail ("Unknown type: " ++ show ty) - firstPut :: Serialize a => Word8 -> a -> Put - firstPut ty code - = do put ty - put code - put (0 :: Word16) - put' (EchoReply ident seqNum dat) - = do firstPut 0 NoCode - put ident - put seqNum - putByteString dat +renderIcmp4Packet :: Icmp4Packet -> L.ByteString +renderIcmp4Packet icmp = + -- Argument for safety: The bytestring being + -- destructively modified here is only accessible + -- through the composition and will never escape + chunk (unsafePerformIO (setChecksum (runPut (putIcmp4Packet icmp)))) + where + setChecksum pkt = pokeChecksum (computeChecksum 0 pkt) pkt 2 - put' (DestinationUnreachable code dat) - = do firstPut 3 code - put (0 :: Word32) -- unused - putByteString dat +putIcmp4Packet :: Putter Icmp4Packet +putIcmp4Packet = put' + where + firstPut :: Serialize a => Word8 -> a -> Put + firstPut ty code + = do put ty + put code + put (0 :: Word16) - put' (SourceQuench dat) - = do firstPut 4 NoCode - put (0 :: Word32) -- unused - putByteString dat + put' (EchoReply ident seqNum dat) + = do firstPut 0 NoCode + put ident + put seqNum + putByteString dat - put' (Redirect code gateway dat) - = do firstPut 5 code - put gateway - putByteString dat + put' (DestinationUnreachable code dat) + = do firstPut 3 code + put (0 :: Word32) -- unused + putByteString dat - put' (Echo ident seqNum dat) - = do firstPut 8 NoCode - put ident - put seqNum - putByteString dat + put' (SourceQuench dat) + = do firstPut 4 NoCode + put (0 :: Word32) -- unused + putByteString dat - put' (RouterAdvertisement lifetime addrs) - = do let len = length addrs - addrSize :: Word8 - addrSize = 2 + put' (Redirect code gateway dat) + = do firstPut 5 code + put gateway + putByteString dat - when (len > 255) - (fail "Too many routers in Router Advertisement") + put' (Echo ident seqNum dat) + = do firstPut 8 NoCode + put ident + put seqNum + putByteString dat - firstPut 9 NoCode - put (fromIntegral len :: Word8) - put addrSize - put lifetime - mapM_ put addrs + put' (RouterAdvertisement lifetime addrs) + = do let len = length addrs + addrSize :: Word8 + addrSize = 2 - put' RouterSolicitation - = do firstPut 10 NoCode - put (0 :: Word32) -- RESERVED + when (len > 255) + (fail "Too many routers in Router Advertisement") - put' (TimeExceeded code dat) - = do firstPut 11 code - put (0 :: Word32) -- unused - putByteString dat + firstPut 9 NoCode + put (fromIntegral len :: Word8) + put addrSize + renderLifetime lifetime + mapM_ put addrs - put' (ParameterProblem ptr dat) - = do firstPut 12 NoCode - put ptr - put (0 :: Word8) -- unused - put (0 :: Word16) -- unused - putByteString dat + put' RouterSolicitation + = do firstPut 10 NoCode + put (0 :: Word32) -- RESERVED - put' (Timestamp ident seqNum origTime recvTime tranTime) - = do firstPut 13 NoCode - put ident - put seqNum - put origTime - put recvTime - put tranTime + put' (TimeExceeded code dat) + = do firstPut 11 code + put (0 :: Word32) -- unused + putByteString dat - put' (TimestampReply ident seqNum origTime recvTime tranTime) - = do firstPut 14 NoCode - put ident - put seqNum - put origTime - put recvTime - put tranTime + put' (ParameterProblem ptr dat) + = do firstPut 12 NoCode + put ptr + put (0 :: Word8) -- unused + put (0 :: Word16) -- unused + putByteString dat - put' (Information ident seqNum) - = do firstPut 15 NoCode - put ident - put seqNum + put' (Timestamp ident seqNum origTime recvTime tranTime) + = do firstPut 13 NoCode + put ident + put seqNum + put origTime + put recvTime + put tranTime - put' (InformationReply ident seqNum) - = do firstPut 16 NoCode - put ident - put seqNum + put' (TimestampReply ident seqNum origTime recvTime tranTime) + = do firstPut 14 NoCode + put ident + put seqNum + put origTime + put recvTime + put tranTime - put' (AddressMask ident seqNum) - = do firstPut 17 NoCode - put ident - put seqNum - put (0 :: Word32) -- address mask + put' (Information ident seqNum) + = do firstPut 15 NoCode + put ident + put seqNum - put' (AddressMaskReply ident seqNum mask) - = do firstPut 17 NoCode - put ident - put seqNum - put mask + put' (InformationReply ident seqNum) + = do firstPut 16 NoCode + put ident + put seqNum - put' (TraceRoute code ident outHop retHop speed mtu) - = do firstPut 30 code - put ident - put (0 :: Word16) -- unused - put outHop - put retHop - put speed - put mtu + put' (AddressMask ident seqNum) + = do firstPut 17 NoCode + put ident + put seqNum + put (0 :: Word32) -- address mask + put' (AddressMaskReply ident seqNum mask) + = do firstPut 18 NoCode + put ident + put seqNum + put mask + + put' (TraceRoute code ident outHop retHop speed mtu) + = do firstPut 30 code + put ident + put (0 :: Word16) -- unused + put outHop + put retHop + put speed + put mtu + data NoCode = NoCode instance Serialize NoCode where @@ -297,30 +310,61 @@ | PortUnreachable | FragmentationUnreachable | SourceRouteFailed - deriving Show + | DestinationNetworkUnknown + | DestinationHostUnknown + | SourceHostIsolatedError + | AdministrativelyProhibited + | HostAdministrativelyProhibited + | NetworkUnreachableForTOS + | HostUnreachableForTOS + | CommunicationAdministrativelyProhibited + | HostPrecedenceViolation + | PrecedenceCutoffInEffect + deriving (Eq,Show) instance Serialize DestinationUnreachableCode where get = do b <- getWord8 case b of - 0 -> return NetUnreachable - 1 -> return HostUnreachable - 2 -> return ProtocolUnreachable - 3 -> return PortUnreachable - 4 -> return FragmentationUnreachable - 5 -> return SourceRouteFailed - _ -> fail "Invalid code for Destination Unreachable" + 0 -> return NetUnreachable + 1 -> return HostUnreachable + 2 -> return ProtocolUnreachable + 3 -> return PortUnreachable + 4 -> return FragmentationUnreachable + 5 -> return SourceRouteFailed + 6 -> return DestinationNetworkUnknown + 7 -> return DestinationHostUnknown + 8 -> return SourceHostIsolatedError + 9 -> return AdministrativelyProhibited + 10 -> return HostAdministrativelyProhibited + 11 -> return NetworkUnreachableForTOS + 12 -> return HostUnreachableForTOS + 13 -> return CommunicationAdministrativelyProhibited + 14 -> return HostPrecedenceViolation + 15 -> return PrecedenceCutoffInEffect + _ -> fail "Invalid code for Destination Unreachable" - put NetUnreachable = putWord8 0 - put HostUnreachable = putWord8 1 - put ProtocolUnreachable = putWord8 2 - put PortUnreachable = putWord8 3 - put FragmentationUnreachable = putWord8 4 - put SourceRouteFailed = putWord8 5 + put code = case code of + NetUnreachable -> putWord8 0 + HostUnreachable -> putWord8 1 + ProtocolUnreachable -> putWord8 2 + PortUnreachable -> putWord8 3 + FragmentationUnreachable -> putWord8 4 + SourceRouteFailed -> putWord8 5 + DestinationNetworkUnknown -> putWord8 6 + DestinationHostUnknown -> putWord8 7 + SourceHostIsolatedError -> putWord8 8 + AdministrativelyProhibited -> putWord8 9 + HostAdministrativelyProhibited -> putWord8 10 + NetworkUnreachableForTOS -> putWord8 11 + HostUnreachableForTOS -> putWord8 12 + CommunicationAdministrativelyProhibited -> putWord8 13 + HostPrecedenceViolation -> putWord8 14 + PrecedenceCutoffInEffect -> putWord8 15 data TimeExceededCode = TimeToLiveExceededInTransit | FragmentReassemblyTimeExceeded - deriving Show + deriving (Eq,Show) instance Serialize TimeExceededCode where get = do b <- getWord8 @@ -337,7 +381,7 @@ | RedirectForHost | RedirectForTypeOfServiceAndNetwork | RedirectForTypeOfServiceAndHost - deriving Show + deriving (Eq,Show) instance Serialize RedirectCode where get = do b <- getWord8 @@ -356,7 +400,7 @@ data TraceRouteCode = TraceRouteForwarded | TraceRouteDiscarded - deriving Show + deriving (Eq,Show) instance Serialize TraceRouteCode where get = do b <- getWord8 @@ -376,7 +420,7 @@ data RouterAddress = RouterAddress { raAddr :: IP4 , raPreferenceLevel :: PreferenceLevel - } deriving Show + } deriving (Eq,Show) instance Serialize RouterAddress where get = liftM2 RouterAddress get get diff --git a/src/Hans/Message/Ip4.hs b/src/Hans/Message/Ip4.hs --- a/src/Hans/Message/Ip4.hs +++ b/src/Hans/Message/Ip4.hs @@ -2,17 +2,19 @@ module Hans.Message.Ip4 where -import Hans.Address.IP4 (IP4) +import Hans.Address.IP4 (IP4(..)) import Hans.Utils import Hans.Utils.Checksum import Control.Monad (unless) -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (Get,getWord8,getWord16be,getByteString,isolate,label) -import Data.Serialize.Put (runPut,runPutM,putWord8,putWord16be,putByteString) +import Data.Int (Int64) +import Data.Serialize + (Serialize(..),Get,getWord8,getWord16be,isolate,label,getByteString + ,Put,runPut,putWord8,putWord16be,putByteString,runGet) import Data.Bits (Bits((.&.),(.|.),testBit,setBit,shiftR,shiftL,bit)) import Data.Word (Word8,Word16) import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L -- IP4 Pseudo Header ----------------------------------------------------------- @@ -40,16 +42,11 @@ newtype IP4Protocol = IP4Protocol { getIP4Protocol :: Word8 } deriving (Eq,Ord,Num,Show,Serialize) -data IP4Packet = IP4Packet - { ip4Header :: !IP4Header - , ip4Payload :: S.ByteString - } deriving Show - data IP4Header = IP4Header { ip4Version :: !Word8 , ip4TypeOfService :: !Word8 , ip4Ident :: !Ident - , ip4MayFragment :: Bool + , ip4DontFragment :: Bool , ip4MoreFragments :: Bool , ip4FragmentOffset :: !Word16 , ip4TimeToLive :: !Word8 @@ -58,21 +55,21 @@ , ip4SourceAddr :: !IP4 , ip4DestAddr :: !IP4 , ip4Options :: [IP4Option] - } deriving Show + } deriving (Eq,Show) -emptyIP4Header :: IP4Protocol -> IP4 -> IP4 -> IP4Header -emptyIP4Header prot src dst = IP4Header +emptyIP4Header :: IP4Header +emptyIP4Header = IP4Header { ip4Version = 4 , ip4TypeOfService = 0 , ip4Ident = 0 - , ip4MayFragment = False + , ip4DontFragment = False , ip4MoreFragments = False , ip4FragmentOffset = 0 , ip4TimeToLive = 127 - , ip4Protocol = prot + , ip4Protocol = IP4Protocol 0 , ip4Checksum = 0 - , ip4SourceAddr = src - , ip4DestAddr = dst + , ip4SourceAddr = IP4 0 0 0 0 + , ip4DestAddr = IP4 0 0 0 0 , ip4Options = [] } @@ -91,9 +88,9 @@ -- | Calculate the size of an IP4 packet -ip4PacketSize :: IP4Packet -> Int -ip4PacketSize (IP4Packet hdr bs) = - ip4HeaderSize hdr + fromIntegral (S.length bs) +ip4PacketSize :: IP4Header -> L.ByteString -> Int +ip4PacketSize hdr bs = + ip4HeaderSize hdr + fromIntegral (L.length bs) -- | Calculate the size of an IP4 header ip4HeaderSize :: IP4Header -> Int @@ -101,27 +98,27 @@ -- | Fragment a single IP packet into one or more, given an MTU to fit into. -splitPacket :: Int -> IP4Packet -> [IP4Packet] -splitPacket mtu pkt - | ip4PacketSize pkt > mtu = fragmentPacket mtu' pkt - | otherwise = [pkt] - where - mtu' = fromIntegral (mtu - ip4HeaderSize (ip4Header pkt)) +splitPacket :: Int -> IP4Header -> L.ByteString -> [(IP4Header,L.ByteString)] +splitPacket mtu hdr bs + | ip4PacketSize hdr bs <= mtu = [(hdr,bs)] + | otherwise = fragmentPacket (fromIntegral mtu) hdr bs -- | Given a fragment size and a packet, fragment the packet into multiple -- smaller ones. -fragmentPacket :: Int -> IP4Packet -> [IP4Packet] -fragmentPacket mtu pkt@(IP4Packet hdr bs) - | payloadLen <= mtu = [pkt { ip4Header = noMoreFragments hdr }] - | otherwise = frag : fragmentPacket mtu pkt' +fragmentPacket :: Int64 -> IP4Header -> L.ByteString + -> [(IP4Header,L.ByteString)] +fragmentPacket mtu = loop where - payloadLen = S.length bs - (as,rest) = S.splitAt mtu bs - alen = fromIntegral (S.length as) - pkt' = pkt { ip4Header = hdr', ip4Payload = rest } - hdr' = addOffset alen hdr - frag = pkt { ip4Header = moreFragments hdr, ip4Payload = as } + loop hdr bs + | payloadLen <= mtu = [(noMoreFragments hdr, bs)] + | otherwise = frag : loop hdr' rest + where + payloadLen = L.length bs + (as,rest) = L.splitAt mtu bs + alen = fromIntegral (L.length as) + hdr' = addOffset alen hdr + frag = (moreFragments hdr, as) -- 0 1 2 3 @@ -137,8 +134,8 @@ -- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -- | Destination Address | -- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -parseIP4Packet :: Get (IP4Header, Int, Int) -parseIP4Packet = do +getIP4Packet :: Get (IP4Header, Int, Int) +getIP4Packet = do b0 <- getWord8 let ver = b0 `shiftR` 4 let ihl = fromIntegral ((b0 .&. 0xf) * 4) @@ -163,7 +160,7 @@ { ip4Version = ver , ip4TypeOfService = tos , ip4Ident = ident - , ip4MayFragment = flags `testBit` 1 + , ip4DontFragment = flags `testBit` 1 , ip4MoreFragments = flags `testBit` 0 , ip4FragmentOffset = off * 8 , ip4TimeToLive = ttl @@ -175,43 +172,54 @@ } return (hdr, fromIntegral ihl, fromIntegral len) +{-# INLINE parseIP4Packet #-} +parseIP4Packet :: S.ByteString -> Either String (IP4Header, Int, Int) +parseIP4Packet bytes = runGet getIP4Packet bytes --- | The final step to render an IP header and its payload out as a bytestring. -renderIP4Packet :: IP4Packet -> IO Packet -renderIP4Packet (IP4Packet hdr pkt) = do - let (len,bs) = runPutM $ do - let (optbs,optlen) = renderOptions (ip4Options hdr) - let ihl = 20 + optlen - putWord8 (ip4Version hdr `shiftL` 4 .|. (ihl `div` 4)) - putWord8 (ip4TypeOfService hdr) - putWord16be (fromIntegral (S.length pkt) + fromIntegral ihl) +{-# INLINE renderIP4Header #-} +renderIP4Header :: IP4Header -> Int -> S.ByteString +renderIP4Header hdr pktlen = runPut (putIP4Header hdr pktlen) - put (ip4Ident hdr) - let frag | ip4MayFragment hdr = (`setBit` 1) - | otherwise = id - let morefrags | ip4MoreFragments hdr = (`setBit` 0) - | otherwise = id - let flags = frag (morefrags 0) - let off = ip4FragmentOffset hdr `div` 8 - putWord16be (flags `shiftL` 13 .|. off .&. 0x1fff) +putIP4Header :: IP4Header -> Int -> Put +putIP4Header hdr pktlen = do + let (optbs,optlen) = renderOptions (ip4Options hdr) + let ihl = 20 + optlen + putWord8 (ip4Version hdr `shiftL` 4 .|. (ihl `div` 4)) + putWord8 (ip4TypeOfService hdr) + putWord16be (fromIntegral pktlen + fromIntegral ihl) + put (getIdent (ip4Ident hdr)) + let frag | ip4DontFragment hdr = (`setBit` 1) + | otherwise = id + let morefrags | ip4MoreFragments hdr = (`setBit` 0) + | otherwise = id + let flags = frag (morefrags 0) + let off = ip4FragmentOffset hdr `div` 8 + putWord16be (flags `shiftL` 13 .|. off .&. 0x1fff) - putWord8 (ip4TimeToLive hdr) - put (ip4Protocol hdr) - putWord16be 0 -- (ip4Checksum hdr) + putWord8 (ip4TimeToLive hdr) + put (ip4Protocol hdr) + putWord16be 0 -- checksum - put (ip4SourceAddr hdr) + put (ip4SourceAddr hdr) - put (ip4DestAddr hdr) + put (ip4DestAddr hdr) - putByteString optbs + putByteString optbs - putByteString pkt - return ihl - let cs = computeChecksum 0 (S.take (fromIntegral len) bs) - pokeChecksum cs bs 10 +-- | The final step to render an IP header and its payload out as a bytestring. +renderIP4Packet :: IP4Header -> L.ByteString -> IO L.ByteString +renderIP4Packet hdr pkt = do + hdrBytes <- + let pktlen = fromIntegral (L.length pkt) + bytes = renderIP4Header hdr pktlen + cs = computeChecksum 0 bytes + in pokeChecksum cs bytes 10 + return (chunk hdrBytes `L.append` pkt) + + -- IP4 Options ----------------------------------------------------------------- renderOptions :: [IP4Option] -> (S.ByteString,Word8) @@ -238,7 +246,7 @@ , ip4OptionClass :: !Word8 , ip4OptionNum :: !Word8 , ip4OptionData :: S.ByteString - } deriving Show + } deriving (Eq,Show) ip4OptionSize :: IP4Option -> Int diff --git a/src/Hans/Message/Tcp.hs b/src/Hans/Message/Tcp.hs --- a/src/Hans/Message/Tcp.hs +++ b/src/Hans/Message/Tcp.hs @@ -1,20 +1,26 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hans.Message.Tcp where import Hans.Address.IP4 (IP4) import Hans.Message.Ip4 (mkIP4PseudoHeader,IP4Protocol(..)) -import Hans.Utils.Checksum (computePartialChecksum,computeChecksum,pokeChecksum) +import Hans.Utils (chunk) +import Hans.Utils.Checksum -import Control.Monad (when,unless,ap) +import Control.Monad (unless,ap,replicateM_,replicateM) import Data.Bits ((.&.),setBit,testBit,shiftL,shiftR) -import Data.List (foldl',find) +import Data.List (find) +import Data.Monoid (Monoid(..)) import Data.Serialize (Get,Put,Putter,getWord16be,putWord16be,getWord32be,putWord32be,getWord8 - ,putWord8,putByteString,getBytes,remaining,label,isolate,skip,runPut) + ,putWord8,putByteString,getBytes,remaining,label,isolate,skip,runGet,runPut + ,putLazyByteString) import Data.Word (Word8,Word16,Word32) import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +import qualified Data.Foldable as F -- Tcp Support Types ----------------------------------------------------------- @@ -24,7 +30,7 @@ newtype TcpPort = TcpPort { getPort :: Word16 - } deriving Show + } deriving (Eq,Ord,Read,Show,Num,Enum,Bounded) putTcpPort :: Putter TcpPort putTcpPort (TcpPort w16) = putWord16be w16 @@ -35,8 +41,12 @@ newtype TcpSeqNum = TcpSeqNum { getSeqNum :: Word32 - } deriving (Eq,Ord,Show) + } deriving (Eq,Ord,Show,Num,Bounded,Enum,Real,Integral) +instance Monoid TcpSeqNum where + mempty = 0 + mappend = (+) + putTcpSeqNum :: Putter TcpSeqNum putTcpSeqNum (TcpSeqNum w32) = putWord32be w32 @@ -44,15 +54,14 @@ getTcpSeqNum = TcpSeqNum `fmap` getWord32be -newtype TcpAckNum = TcpAckNum - { getAckNum :: Word32 - } deriving (Eq,Ord,Show) +-- | An alias to TcpSeqNum, as these two are used in the same role. +type TcpAckNum = TcpSeqNum putTcpAckNum :: Putter TcpAckNum -putTcpAckNum (TcpAckNum w32) = putWord32be w32 +putTcpAckNum = putTcpSeqNum getTcpAckNum :: Get TcpAckNum -getTcpAckNum = TcpAckNum `fmap` getWord32be +getTcpAckNum = getTcpSeqNum -- Tcp Header ------------------------------------------------------------------ @@ -93,7 +102,7 @@ , tcpChecksum :: !Word16 , tcpUrgentPointer :: !Word16 , tcpOptions :: [TcpOption] - } deriving Show + } deriving (Eq,Show) instance HasTcpOptions TcpHeader where findTcpOption tag hdr = findTcpOption tag (tcpOptions hdr) @@ -103,8 +112,8 @@ emptyTcpHeader = TcpHeader { tcpSourcePort = TcpPort 0 , tcpDestPort = TcpPort 0 - , tcpSeqNum = TcpSeqNum 0 - , tcpAckNum = TcpAckNum 0 + , tcpSeqNum = 0 + , tcpAckNum = 0 , tcpCwr = False , tcpEce = False , tcpUrg = False @@ -123,11 +132,6 @@ tcpFixedHeaderLength :: Int tcpFixedHeaderLength = 5 --- | Calculate the length of a TcpHeader, in 4-byte octets. -tcpHeaderLength :: TcpHeader -> Int -tcpHeaderLength hdr = - tcpFixedHeaderLength + tcpOptionsLength (tcpOptions hdr) - -- | Render a TcpHeader. The checksum value is never rendered, as it is -- expected to be calculated and poked in afterwords. putTcpHeader :: Putter TcpHeader @@ -136,17 +140,19 @@ putTcpPort (tcpDestPort hdr) putTcpSeqNum (tcpSeqNum hdr) putTcpAckNum (tcpAckNum hdr) - putWord8 (fromIntegral (tcpHeaderLength hdr) `shiftL` 4) + let (optLen,padding) = tcpOptionsLength (tcpOptions hdr) + putWord8 (fromIntegral ((tcpFixedHeaderLength + optLen) `shiftL` 4)) putTcpControl hdr putWord16be (tcpWindow hdr) putWord16be 0 putWord16be (tcpUrgentPointer hdr) - putTcpOptions (tcpOptions hdr) + mapM_ putTcpOption (tcpOptions hdr) + replicateM_ padding (putTcpOptionTag OptTagEndOfOptions) -- | Parse out a TcpHeader, and its length. The resulting length is in bytes, -- and is derived from the data offset. getTcpHeader :: Get (TcpHeader,Int) -getTcpHeader = do +getTcpHeader = label "TcpHeader" $ do src <- getTcpPort dst <- getTcpPort seqNum <- getTcpSeqNum @@ -158,7 +164,7 @@ cs <- getWord16be urgent <- getWord16be let optsLen = len - tcpFixedHeaderLength - opts <- getTcpOptions optsLen + opts <- label "options" (isolate (optsLen `shiftL` 2) getTcpOptions) let hdr = setTcpControl cont emptyTcpHeader { tcpSourcePort = src , tcpDestPort = dst @@ -167,7 +173,7 @@ , tcpWindow = win , tcpChecksum = cs , tcpUrgentPointer = urgent - , tcpOptions = opts + , tcpOptions = filter (/= OptEndOfOptions) opts } return (hdr,len * 4) @@ -207,11 +213,16 @@ findTcpOption :: TcpOptionTag -> a -> Maybe TcpOption setTcpOption :: TcpOption -> a -> a +setTcpOptions :: HasTcpOptions a => [TcpOption] -> a -> a +setTcpOptions opts a = foldr setTcpOption a opts + data TcpOptionTag = OptTagEndOfOptions | OptTagNoOption | OptTagMaxSegmentSize | OptTagWindowScaling + | OptTagSackPermitted + | OptTagSack | OptTagTimestamp | OptTagUnknown !Word8 deriving (Eq,Show) @@ -224,6 +235,8 @@ 1 -> OptTagNoOption 2 -> OptTagMaxSegmentSize 3 -> OptTagWindowScaling + 4 -> OptTagSackPermitted + 5 -> OptTagSack 8 -> OptTagTimestamp _ -> OptTagUnknown ty @@ -234,6 +247,8 @@ OptTagNoOption -> 1 OptTagMaxSegmentSize -> 2 OptTagWindowScaling -> 3 + OptTagSackPermitted -> 4 + OptTagSack -> 5 OptTagTimestamp -> 8 OptTagUnknown ty -> ty @@ -256,73 +271,73 @@ | OptNoOption | OptMaxSegmentSize !Word16 | OptWindowScaling !Word8 + | OptSackPermitted + | OptSack [SackBlock] | OptTimestamp !Word32 !Word32 | OptUnknown !Word8 !Word8 !S.ByteString - deriving Show + deriving (Show,Eq) +data SackBlock = SackBlock + { sbLeft :: !TcpSeqNum + , sbRight :: !TcpSeqNum + } deriving (Show,Eq) + tcpOptionTag :: TcpOption -> TcpOptionTag tcpOptionTag opt = case opt of OptEndOfOptions{} -> OptTagEndOfOptions OptNoOption{} -> OptTagNoOption OptMaxSegmentSize{} -> OptTagMaxSegmentSize + OptSackPermitted{} -> OptTagSackPermitted + OptSack{} -> OptTagSack OptWindowScaling{} -> OptTagWindowScaling OptTimestamp{} -> OptTagTimestamp OptUnknown ty _ _ -> OptTagUnknown ty --- | Get the length of a TcpOptions, in 4-byte words. This rounds up to the --- nearest 4-byte word. -tcpOptionsLength :: [TcpOption] -> Int +-- | Get the rendered length of a list of TcpOptions, in 4-byte words, and the +-- number of padding bytes required. This rounds up to the nearest 4-byte word. +tcpOptionsLength :: [TcpOption] -> (Int,Int) tcpOptionsLength opts - | left == 0 = len - | otherwise = len + 1 + | left == 0 = (len,0) + | otherwise = (len + 1,4 - left) where - (len,left) = foldl' step 0 opts `quotRem` 4 - step acc opt = tcpOptionLength opt + acc + (len,left) = F.sum (fmap tcpOptionLength opts) `quotRem` 4 tcpOptionLength :: TcpOption -> Int -tcpOptionLength OptEndOfOptions{} = 1 -tcpOptionLength OptNoOption{} = 1 -tcpOptionLength OptMaxSegmentSize{} = 4 -tcpOptionLength OptWindowScaling{} = 3 -tcpOptionLength OptTimestamp{} = 10 -tcpOptionLength (OptUnknown _ len _) = fromIntegral len +tcpOptionLength opt = case opt of + OptEndOfOptions{} -> 1 + OptNoOption{} -> 1 + OptMaxSegmentSize{} -> 4 + OptWindowScaling{} -> 3 + OptSackPermitted{} -> 2 + OptSack bs -> sackLength bs + OptTimestamp{} -> 10 + OptUnknown _ len _ -> fromIntegral len --- | Render out the tcp options, and pad with zeros if they don't fall on a --- 4-byte boundary. -putTcpOptions :: Putter [TcpOption] -putTcpOptions opts = do - let len = tcpOptionsLength opts - left = len `rem` 4 - padding - | left == 0 = 0 - | otherwise = 4 - left - mapM_ putTcpOption opts - when (padding > 0) (putByteString (S.replicate padding 0)) - putTcpOption :: Putter TcpOption -putTcpOption opt = +putTcpOption opt = do + putTcpOptionTag (tcpOptionTag opt) case opt of - OptEndOfOptions -> putWord8 0 - OptNoOption -> putWord8 1 + OptEndOfOptions -> return () + OptNoOption -> return () OptMaxSegmentSize mss -> putMaxSegmentSize mss OptWindowScaling w -> putWindowScaling w + OptSackPermitted -> putSackPermitted + OptSack bs -> putSack bs OptTimestamp v r -> putTimestamp v r - OptUnknown ty len bs -> putUnknown ty len bs + OptUnknown _ len bs -> putUnknown len bs -- | Parse in known tcp options. -getTcpOptions :: Int -> Get [TcpOption] -getTcpOptions len = label ("Tcp Options (" ++ show len ++ ")") - $ isolate (len * 4) loop +getTcpOptions :: Get [TcpOption] +getTcpOptions = label "Tcp Options" loop where loop = do left <- remaining - if left <= 0 then return [] else body + if left > 0 then body else return [] body = do - opt <- getTcpOption + opt <- getTcpOption case opt of - OptNoOption -> loop OptEndOfOptions -> do skip =<< remaining @@ -340,6 +355,8 @@ OptTagNoOption -> return OptNoOption OptTagMaxSegmentSize -> getMaxSegmentSize OptTagWindowScaling -> getWindowScaling + OptTagSackPermitted -> getSackPermitted + OptTagSack -> getSack OptTagTimestamp -> getTimestamp OptTagUnknown ty -> getUnknown ty @@ -354,6 +371,44 @@ putWord8 4 putWord16be w16 +getSackPermitted :: Get TcpOption +getSackPermitted = label "Sack Permitted" $ isolate 1 $ do + len <- getWord8 + unless (len == 2) (fail ("Unexpected length: " ++ show len)) + return OptSackPermitted + +putSackPermitted :: Put +putSackPermitted = do + putWord8 2 + +getSack :: Get TcpOption +getSack = label "Sack" $ do + len <- getWord8 + let edgeLen = fromIntegral len - 2 + OptSack `fmap` isolate edgeLen (replicateM (edgeLen `shiftR` 3) getSackBlock) + +putSack :: Putter [SackBlock] +putSack bs = do + putWord8 (fromIntegral (sackLength bs)) + mapM_ putSackBlock bs + +getSackBlock :: Get SackBlock +getSackBlock = do + l <- getTcpSeqNum + r <- getTcpSeqNum + return $! SackBlock + { sbLeft = l + , sbRight = r + } + +putSackBlock :: Putter SackBlock +putSackBlock sb = do + putTcpSeqNum (sbLeft sb) + putTcpSeqNum (sbRight sb) + +sackLength :: [SackBlock] -> Int +sackLength bs = length bs * 8 + 2 + getWindowScaling :: Get TcpOption getWindowScaling = label "Window Scaling" $ isolate 2 $ do len <- getWord8 @@ -373,7 +428,6 @@ putTimestamp :: Word32 -> Word32 -> Put putTimestamp v r = do - putWord8 8 putWord8 10 putWord32be v putWord32be r @@ -384,63 +438,61 @@ body <- isolate (fromIntegral len - 2) (getBytes =<< remaining) return (OptUnknown ty len body) -putUnknown :: Word8 -> Word8 -> S.ByteString -> Put -putUnknown ty len body = do - putWord8 ty +putUnknown :: Word8 -> S.ByteString -> Put +putUnknown len body = do putWord8 len putByteString body -- Tcp Packet ------------------------------------------------------------------ -data TcpPacket = TcpPacket - { tcpHeader :: !TcpHeader - , tcpBody :: !S.ByteString - } deriving Show +{-# INLINE parseTcpPacket #-} +parseTcpPacket :: S.ByteString -> Either String (TcpHeader,S.ByteString) +parseTcpPacket bytes = runGet getTcpPacket bytes -- | Parse a TcpPacket. -getTcpPacket :: Get TcpPacket +getTcpPacket :: Get (TcpHeader,S.ByteString) getTcpPacket = do pktLen <- remaining (hdr,hdrLen) <- getTcpHeader body <- getBytes (pktLen - hdrLen) - return (TcpPacket hdr body) + return (hdr,body) -- | Render out a TcpPacket, without calculating its checksum. -putTcpPacket :: Putter TcpPacket -putTcpPacket (TcpPacket hdr body) = do +putTcpPacket :: TcpHeader -> L.ByteString -> Put +putTcpPacket hdr body = do putTcpHeader hdr - putByteString body + putLazyByteString body -- | Calculate the checksum of a TcpHeader, and its body. -renderWithTcpChecksumIP4 :: IP4 -> IP4 -> TcpPacket -> S.ByteString -renderWithTcpChecksumIP4 src dst pkt@(TcpPacket _ body) = hdrbs `S.append` body +renderWithTcpChecksumIP4 :: IP4 -> IP4 -> TcpHeader -> L.ByteString + -> L.ByteString +renderWithTcpChecksumIP4 src dst hdr body = chunk hdrbs `L.append` body where - (hdrbs,_) = computeTcpChecksumIP4 src dst pkt + (hdrbs,_) = computeTcpChecksumIP4 src dst hdr body -- | Calculate the checksum of a tcp packet, and return its rendered header. -computeTcpChecksumIP4 :: IP4 -> IP4 -> TcpPacket -> (S.ByteString,Word16) -computeTcpChecksumIP4 src dst (TcpPacket hdr body) = +computeTcpChecksumIP4 :: IP4 -> IP4 -> TcpHeader -> L.ByteString + -> (S.ByteString,Word16) +computeTcpChecksumIP4 src dst hdr body = -- this is safe, as the header bytestring that gets modified is modified at -- its creation time. (cs `seq` unsafePerformIO (pokeChecksum cs hdrbs 16), cs) where - hdrbs = runPut (putTcpHeader hdr { tcpChecksum = 0 }) - phcs = computePartialChecksum 0 + phcs = computePartialChecksum emptyPartialChecksum $ mkIP4PseudoHeader src dst tcpProtocol - $ S.length hdrbs + S.length body + $ S.length hdrbs + fromIntegral (L.length body) + hdrbs = runPut (putTcpHeader hdr { tcpChecksum = 0 }) hdrcs = computePartialChecksum phcs hdrbs - cs = computeChecksum hdrcs body + cs = finalizeChecksum (computePartialChecksumLazy hdrcs body) -- | Re-create the checksum, minimizing duplication of the original, rendered -- TCP packet. -recreateTcpChecksumIP4 :: IP4 -> IP4 -> S.ByteString -> Word16 -recreateTcpChecksumIP4 src dst bytes = computeChecksum hdrcs rest +validateTcpChecksumIP4 :: IP4 -> IP4 -> S.ByteString -> Bool +validateTcpChecksumIP4 src dst bytes = + finalizeChecksum (computePartialChecksum phcs bytes) == 0 where - phcs = computePartialChecksum 0 - $ mkIP4PseudoHeader src dst tcpProtocol - $ S.length bytes - (hdrbs,rest) = S.splitAt 18 bytes - hdrbs' = unsafePerformIO (pokeChecksum 0 (S.copy hdrbs) 16) - hdrcs = computePartialChecksum phcs hdrbs' + phcs = computePartialChecksum emptyPartialChecksum + $ mkIP4PseudoHeader src dst tcpProtocol + $ S.length bytes diff --git a/src/Hans/Message/Types.hs b/src/Hans/Message/Types.hs --- a/src/Hans/Message/Types.hs +++ b/src/Hans/Message/Types.hs @@ -1,8 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Hans.Message.Types where -import Data.Serialize (Serialize) +import Control.Applicative ((<$>)) +import Data.Serialize.Get (Get,getWord16be) +import Data.Serialize.Put (Putter,putWord16be) import Data.Word (Word16) -newtype Lifetime = Lifetime Word16 - deriving (Show,Eq,Ord,Num,Serialize) +newtype Lifetime = Lifetime { getLifetime :: Word16 } + deriving (Show,Eq,Ord,Num) + +parseLifetime :: Get Lifetime +parseLifetime = Lifetime <$> getWord16be + +renderLifetime :: Putter Lifetime +renderLifetime = putWord16be . getLifetime diff --git a/src/Hans/Message/Udp.hs b/src/Hans/Message/Udp.hs --- a/src/Hans/Message/Udp.hs +++ b/src/Hans/Message/Udp.hs @@ -1,59 +1,105 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} module Hans.Message.Udp where +import Hans.Address.IP4 +import Hans.Message.Ip4 import Hans.Utils import Hans.Utils.Checksum -import Data.Serialize (Serialize(..)) -import Data.Serialize.Get (Get,getWord16be,getByteString,isolate,label) -import Data.Serialize.Put (runPut,putWord16be,putByteString) +import Control.Applicative ((<$>)) +import Data.Serialize.Get (Get,getWord16be,isolate,label,getBytes,remaining) +import Data.Serialize.Put (Put,Putter,runPut,putWord16be) +import Data.Typeable (Typeable) import Data.Word (Word16) -import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S + +-- Udp Protocol Number --------------------------------------------------------- + +udpProtocol :: IP4Protocol +udpProtocol = IP4Protocol 0x11 + + +-- Udp Ports ------------------------------------------------------------------- + newtype UdpPort = UdpPort { getUdpPort :: Word16 } - deriving (Eq,Ord,Num,Show,Serialize,Enum,Bounded) + deriving (Eq,Ord,Num,Read,Show,Enum,Bounded,Typeable) -data UdpPacket = UdpPacket - { udpHeader :: !UdpHeader - , udpPayload :: S.ByteString - } deriving Show +parseUdpPort :: Get UdpPort +parseUdpPort = UdpPort <$> getWord16be +renderUdpPort :: Putter UdpPort +renderUdpPort = putWord16be . getUdpPort + + +-- Udp Header ------------------------------------------------------------------ + data UdpHeader = UdpHeader { udpSourcePort :: !UdpPort , udpDestPort :: !UdpPort , udpChecksum :: !Word16 - } deriving Show + } deriving (Eq,Show) -parseUdpPacket :: Get UdpPacket +udpHeaderSize :: Int +udpHeaderSize = 8 + +-- | Parse out a @UdpHeader@, and the size of the payload. +parseUdpHeader :: Get (UdpHeader,Int) +parseUdpHeader = do + src <- parseUdpPort + dst <- parseUdpPort + len <- getWord16be + cs <- getWord16be + let hdr = UdpHeader src dst cs + return (hdr,fromIntegral len - udpHeaderSize) + +-- | Render a @UdpHeader@. +renderUdpHeader :: UdpHeader -> Int -> Put +renderUdpHeader hdr bodyLen = do + renderUdpPort (udpSourcePort hdr) + renderUdpPort (udpDestPort hdr) + putWord16be (fromIntegral (bodyLen + udpHeaderSize)) + putWord16be (udpChecksum hdr) + + +-- Udp Packets ----------------------------------------------------------------- + +parseUdpPacket :: Get (UdpHeader,S.ByteString) parseUdpPacket = do - src <- get - dst <- get - b16 <- getWord16be - let len = fromIntegral b16 - label "UDPPacket" $ isolate (len - 6) $ do - cs <- getWord16be - bs <- getByteString (len - 8) - let hdr = UdpHeader - { udpSourcePort = src - , udpDestPort = dst - , udpChecksum = cs - } - return $! UdpPacket hdr bs + (hdr,len) <- parseUdpHeader + label "UDPPacket" $ isolate len $ do + bs <- getBytes =<< remaining + return (hdr,bs) -- | Given a way to make the pseudo header, render the UDP packet. -renderUdpPacket :: UdpPacket -> MkPseudoHeader -> IO Packet -renderUdpPacket (UdpPacket hdr bs) mk = do - let hdrSize = 8 - let len = S.length bs + hdrSize - let ph = mk len - let pcs = computePartialChecksum 0 ph - let bytes = runPut $ do - put (udpSourcePort hdr) - put (udpDestPort hdr) - putWord16be (fromIntegral len) - putWord16be 0 -- initial checksum - putByteString bs +renderUdpPacket :: UdpHeader -> L.ByteString -> MkPseudoHeader + -> IO L.ByteString +renderUdpPacket hdr body mk = do -- the checksum is 6 bytes into the rendered packet - let cs = computeChecksum pcs bytes - pokeChecksum cs bytes 6 + hdrBytes' <- pokeChecksum cs hdrBytes 6 + return (L.fromChunks [hdrBytes'] `L.append` body) + where + -- pseudo header + bodyLen = fromIntegral (L.length body) + ph = mk (bodyLen + udpHeaderSize) + pcs = computePartialChecksum emptyPartialChecksum ph + + -- real header + hdrBytes = runPut (renderUdpHeader (hdr { udpChecksum = 0 }) bodyLen) + + -- body, and final checksum + hcs = computePartialChecksum pcs hdrBytes + cs = finalizeChecksum (computePartialChecksumLazy hcs body) + +-- | Recreate the UDP checksum, given a rendered packet, and the source and +-- destination. +validateUdpChecksum :: IP4 -> IP4 -> S.ByteString -> Bool +validateUdpChecksum src dst bytes = + finalizeChecksum (computePartialChecksum phcs bytes) == 0 + where + phcs = computePartialChecksum emptyPartialChecksum + $ mkIP4PseudoHeader src dst udpProtocol + $ S.length bytes diff --git a/src/Hans/NetworkStack.hs b/src/Hans/NetworkStack.hs new file mode 100644 --- /dev/null +++ b/src/Hans/NetworkStack.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.NetworkStack ( + module Hans.NetworkStack + + -- * Re-exported Types + , UdpPort + , TcpPort + + -- * DNS + , Dns.HostName + , Dns.HostEntry(..) + + -- * Sockets + , Tcp.Socket() + + -- ** Socket Functions + , Tcp.sockRemoteHost + , Tcp.sockRemotePort + , Tcp.sockLocalPort + , Tcp.accept + , Tcp.close + , Tcp.sendBytes + , Tcp.recvBytes + + -- ** Socket Exceptions + , Tcp.AcceptError(..) + , Tcp.CloseError(..) + , Tcp.ConnectError(..) + , Tcp.ListenError(..) + ) where + +import Hans.Address (getMaskComponents) +import Hans.Address.IP4 (IP4Mask,IP4) +import Hans.Address.Mac (Mac) +import Hans.Channel (newChannel) +import Hans.Message.Ip4 (IP4Protocol,IP4Header) +import Hans.Message.Tcp (TcpPort) +import Hans.Message.Udp (UdpPort) +import qualified Hans.Layer.Arp as Arp +import qualified Hans.Layer.Ethernet as Eth +import qualified Hans.Layer.Dns as Dns +import qualified Hans.Layer.Icmp4 as Icmp4 +import qualified Hans.Layer.IP4 as IP4 +import qualified Hans.Layer.Tcp as Tcp +import qualified Hans.Layer.Tcp.Socket as Tcp +import qualified Hans.Layer.Udp as Udp + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + + +-- Generic Network Stack ------------------------------------------------------- + +-- | An example implementation of the whole network stack. +data NetworkStack = NetworkStack + { nsArp :: Arp.ArpHandle + , nsEthernet :: Eth.EthernetHandle + , nsIp4 :: IP4.IP4Handle + , nsIcmp4 :: Icmp4.Icmp4Handle + , nsUdp :: Udp.UdpHandle + , nsTcp :: Tcp.TcpHandle + , nsDns :: Dns.DnsHandle + } + +instance HasArp NetworkStack where arpHandle = nsArp +instance HasEthernet NetworkStack where ethernetHandle = nsEthernet +instance HasIP4 NetworkStack where ip4Handle = nsIp4 +instance HasIcmp4 NetworkStack where icmp4Handle = nsIcmp4 +instance HasTcp NetworkStack where tcpHandle = nsTcp +instance HasUdp NetworkStack where udpHandle = nsUdp +instance HasDns NetworkStack where dnsHandle = nsDns + +newNetworkStack :: IO NetworkStack +newNetworkStack = do + nsEthernet <- newChannel + nsArp <- newChannel + nsIp4 <- newChannel + nsIcmp4 <- newChannel + nsUdp <- newChannel + nsTcp <- newChannel + nsDns <- newChannel + + let ns = NetworkStack { .. } + + startEthernetLayer ns + startArpLayer ns + startIcmp4Layer ns + startIP4Layer ns + startUdpLayer ns + startTcpLayer ns + startDnsLayer ns + + return ns + + + +-- Ethernet Layer Interface ---------------------------------------------------- + +class HasEthernet stack where + ethernetHandle :: stack -> Eth.EthernetHandle + +-- | Start the ethernet layer in a network stack. +startEthernetLayer :: HasEthernet stack => stack -> IO () +startEthernetLayer stack = + Eth.runEthernetLayer (ethernetHandle stack) + +-- | Add an ethernet device to the ethernet layer. +addDevice :: HasEthernet stack => stack -> Mac -> Eth.Tx -> Eth.Rx -> IO () +addDevice stack = Eth.addEthernetDevice (ethernetHandle stack) + +-- | Remove a device from the ethernet layer. +removeDevice :: HasEthernet stack => stack -> Mac -> IO () +removeDevice stack = Eth.removeEthernetDevice (ethernetHandle stack) + +-- | Bring an ethernet device in the ethernet layer up. +deviceUp :: HasEthernet stack => stack -> Mac -> IO () +deviceUp stack = Eth.startEthernetDevice (ethernetHandle stack) + +-- | Bring an ethernet device in the ethernet layer down. +deviceDown :: HasEthernet stack => stack -> Mac -> IO () +deviceDown stack = Eth.stopEthernetDevice (ethernetHandle stack) + + +-- Arp Layer Interface --------------------------------------------------------- + +class HasArp stack where + arpHandle :: stack -> Arp.ArpHandle + +-- | Start the arp layer in a network stack. +startArpLayer :: (HasEthernet stack, HasArp stack) => stack -> IO () +startArpLayer stack = + Arp.runArpLayer (arpHandle stack) (ethernetHandle stack) + + +-- Icmp4 Layer Interface ------------------------------------------------------- + +class HasIcmp4 stack where + icmp4Handle :: stack -> Icmp4.Icmp4Handle + +-- | Start the icmp4 layer in a network stack.. +startIcmp4Layer :: (HasIcmp4 stack, HasIP4 stack) => stack -> IO () +startIcmp4Layer stack = + Icmp4.runIcmp4Layer (icmp4Handle stack) (ip4Handle stack) + + +-- IP4 Layer Interface --------------------------------------------------------- + +class HasIP4 stack where + ip4Handle :: stack -> IP4.IP4Handle + +-- | Start the IP4 layer in a network stack. +startIP4Layer :: (HasArp stack, HasEthernet stack, HasIP4 stack) + => stack -> IO () +startIP4Layer stack = + IP4.runIP4Layer (ip4Handle stack) (arpHandle stack) (ethernetHandle stack) + +type Mtu = Int + +-- | Add an IP4 address to a network stack. +addIP4Addr :: (HasArp stack, HasIP4 stack) + => stack -> IP4Mask -> Mac -> Mtu -> IO () +addIP4Addr stack mask mac mtu = do + let (addr,_) = getMaskComponents mask + Arp.addLocalAddress (arpHandle stack) addr mac + IP4.addIP4RoutingRule (ip4Handle stack) (IP4.Direct mask addr mtu) + +-- | Add a route for a network, via an address. +routeVia :: HasIP4 stack => stack -> IP4Mask -> IP4 -> IO () +routeVia stack mask addr = + IP4.addIP4RoutingRule (ip4Handle stack) (IP4.Indirect mask addr) + +-- | Register a handler for an IP4 protocol +listenIP4Protocol :: HasIP4 stack + => stack -> IP4Protocol -> IP4.Handler -> IO () +listenIP4Protocol stack = IP4.addIP4Handler (ip4Handle stack) + +-- | Register a handler for an IP4 protocol +ignoreIP4Protocol :: HasIP4 stack => stack -> IP4Protocol -> IO () +ignoreIP4Protocol stack = IP4.removeIP4Handler (ip4Handle stack) + + +-- Udp Layer Interface --------------------------------------------------------- + +class HasUdp stack where + udpHandle :: stack -> Udp.UdpHandle + +-- | Start the UDP layer of a network stack. +startUdpLayer :: (HasIP4 stack, HasIcmp4 stack, HasUdp stack) => stack -> IO () +startUdpLayer stack = + Udp.runUdpLayer (udpHandle stack) (ip4Handle stack) (icmp4Handle stack) + +-- | Add a handler for a UDP port. +addUdpHandler :: HasUdp stack => stack -> UdpPort -> Udp.Handler -> IO () +addUdpHandler stack = Udp.addUdpHandler (udpHandle stack) + +-- | Remove a handler for a UDP port. +removeUdpHandler :: HasUdp stack => stack -> UdpPort -> IO () +removeUdpHandler stack = Udp.removeUdpHandler (udpHandle stack) + +-- | Inject a packet into the UDP layer. +queueUdp :: HasUdp stack => stack -> IP4Header -> S.ByteString -> IO () +queueUdp stack = Udp.queueUdp (udpHandle stack) + +-- | Send a UDP packet. +sendUdp :: HasUdp stack + => stack -> IP4 -> Maybe UdpPort -> UdpPort -> L.ByteString -> IO () +sendUdp stack = Udp.sendUdp (udpHandle stack) + + +-- Tcp Layer Interface --------------------------------------------------------- + +class HasIP4 stack => HasTcp stack where + tcpHandle :: stack -> Tcp.TcpHandle + +-- | Start the TCP layer of a network stack. +startTcpLayer :: HasTcp stack => stack -> IO () +startTcpLayer stack = + Tcp.runTcpLayer (tcpHandle stack) (ip4Handle stack) + +-- | Listen for incoming connections. +listen :: HasTcp stack => stack -> IP4 -> TcpPort -> IO Tcp.Socket +listen stack = Tcp.listen (tcpHandle stack) + +-- | Make a remote connection. +connect :: HasTcp stack => stack -> IP4 -> TcpPort -> Maybe TcpPort -> IO Tcp.Socket +connect stack = Tcp.connect (tcpHandle stack) + + +-- Dns Layer Interface --------------------------------------------------------- + +class HasUdp stack => HasDns stack where + dnsHandle :: stack -> Dns.DnsHandle + +startDnsLayer :: HasDns stack => stack -> IO () +startDnsLayer stack = + Dns.runDnsLayer (dnsHandle stack) (udpHandle stack) + +addNameServer :: HasDns stack => stack -> IP4 -> IO () +addNameServer stack = Dns.addNameServer (dnsHandle stack) + +removeNameServer :: HasDns stack => stack -> IP4 -> IO () +removeNameServer stack = Dns.removeNameServer (dnsHandle stack) + +getHostByName :: HasDns stack => stack -> Dns.HostName -> IO Dns.HostEntry +getHostByName stack = Dns.getHostByName (dnsHandle stack) + +getHostByAddr :: HasDns stack => stack -> IP4 -> IO Dns.HostEntry +getHostByAddr stack = Dns.getHostByAddr (dnsHandle stack) diff --git a/src/Hans/Ports.hs b/src/Hans/Ports.hs --- a/src/Hans/Ports.hs +++ b/src/Hans/Ports.hs @@ -1,56 +1,60 @@ +{-# LANGUAGE RecordWildCards #-} module Hans.Ports ( -- * Port Management PortManager , emptyPortManager - , isReserved + , isUsed , reserve , unreserve , nextPort ) where -import Control.Monad (MonadPlus(mzero),guard) -import Data.List (delete) +import Control.Monad (guard) import qualified Data.Set as Set -- Port Management ------------------------------------------------------------- data PortManager i = PortManager - { portNext :: [i] - , portActive :: Set.Set i + { portNext :: [i] + , portReserved :: Set.Set i + , portActive :: Set.Set i } +instance Show i => Show (PortManager i) where + show pm = "" + emptyPortManager :: [i] -> PortManager i emptyPortManager range = PortManager - { portNext = range - , portActive = Set.empty + { portNext = range + , portReserved = Set.empty + , portActive = Set.empty } -isReserved :: (Eq i, Ord i) => i -> PortManager i -> Bool -isReserved i pm = i `Set.member` portActive pm +isUsed :: (Eq i, Ord i) => i -> PortManager i -> Bool +isUsed i PortManager { .. } = i `Set.member` portActive + || i `Set.member` portReserved -reserve :: (MonadPlus m, Eq i, Ord i) => i -> PortManager i -> m (PortManager i) +reserve :: (Eq i, Ord i, Show i) => i -> PortManager i -> Maybe (PortManager i) reserve i pm = do - guard (not (isReserved i pm)) + guard (not (isUsed i pm)) return $! pm - { portNext = delete i (portNext pm) - , portActive = Set.insert i (portActive pm) + { portReserved = Set.insert i (portReserved pm) } -unreserve :: (MonadPlus m, Eq i, Ord i) - => i -> PortManager i -> m (PortManager i) -unreserve i pm = do - guard (isReserved i pm) - return $! pm - { portNext = i : portNext pm - , portActive = Set.delete i (portActive pm) - } +unreserve :: (Eq i, Ord i, Show i) => i -> PortManager i -> Maybe (PortManager i) +unreserve i pm @ PortManager { .. } + | Set.member i portReserved = Just pm { portReserved = Set.delete i portReserved } + | Set.member i portActive = Just pm' { portActive = Set.delete i portActive } + | otherwise = Nothing + where + pm' = pm { portNext = i : portNext } -nextPort :: (MonadPlus m, Eq i, Ord i) - => PortManager i -> m (i, PortManager i) -nextPort pm = case portNext pm of - [] -> mzero - i:_ -> do - pm' <- reserve i pm - return $! (i,pm') +nextPort :: (Eq i, Ord i, Show i) => PortManager i -> Maybe (i, PortManager i) +nextPort pm = case span (`isUsed` pm) (portNext pm) of + + (_,i:rest) -> return (i, pm { portNext = rest + , portActive = Set.insert i (portActive pm) }) + + _ -> Nothing diff --git a/src/Hans/Setup.hs b/src/Hans/Setup.hs deleted file mode 100644 --- a/src/Hans/Setup.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} - -module Hans.Setup where - -import Hans.Address -import Hans.Address.IP4 -import Hans.Address.Mac -import Hans.Channel -import Hans.Layer.Arp -import Hans.Layer.Ethernet -import Hans.Layer.IP4 -import Hans.Layer.Icmp4 -import Hans.Layer.Tcp -import Hans.Layer.Timer -import Hans.Layer.Udp - - -data NetworkStack = NetworkStack - { nsArp :: ArpHandle - , nsEthernet :: EthernetHandle - , nsIp4 :: IP4Handle - , nsIcmp4 :: Icmp4Handle - , nsTimers :: TimerHandle - , nsUdp :: UdpHandle - , nsTcp :: TcpHandle - } - - -setup :: IO NetworkStack -setup = do - eth <- newChannel - arp <- newChannel - ip4 <- newChannel - icmp <- newChannel - th <- newChannel - udp <- newChannel - tcp <- newChannel - - runTimerLayer th - runEthernetLayer eth - runArpLayer arp eth th - runIP4Layer ip4 arp eth - runIcmp4Layer icmp ip4 - runUdpLayer udp ip4 icmp - runTcpLayer tcp ip4 th - - return NetworkStack - { nsArp = arp - , nsEthernet= eth - , nsIp4 = ip4 - , nsIcmp4 = icmp - , nsTimers = th - , nsUdp = udp - , nsTcp = tcp - } - - -data SomeOption = forall o. Option o => SomeOption o - -instance Show SomeOption where - showsPrec p (SomeOption o) = parens (showsPrec 11 o) - where - parens body | p > 10 = showString "(SomeOption " . body . showChar ')' - | otherwise = showString "SomeOption " . body - -toOption :: Option o => o -> SomeOption -toOption = SomeOption - -class Show o => Option o where - apply :: o -> NetworkStack -> IO () - - -instance Option SomeOption where - apply (SomeOption o) ns = apply o ns - -instance Option o => Option [o] where - apply os ns = mapM_ (`apply` ns) os - - -data OptEthernet mask = LocalEthernet mask Mac - deriving Show - -instance Option (OptEthernet IP4Mask) where - apply (LocalEthernet mask mac) ns = do - let (addr,_) = getMaskComponents mask - addLocalAddress (nsArp ns) addr mac - addIP4RoutingRule (nsIp4 ns) (Direct mask addr 1500) - - -data OptRoute mask addr = Route mask addr - deriving Show - -instance Option (OptRoute IP4Mask IP4) where - apply (Route mask addr) ns = addIP4RoutingRule (nsIp4 ns) (Indirect mask addr) diff --git a/src/Hans/Simple.hs b/src/Hans/Simple.hs --- a/src/Hans/Simple.hs +++ b/src/Hans/Simple.hs @@ -10,15 +10,15 @@ ) where import Hans.Address.IP4 (IP4) -import Hans.Message.Ip4 (IP4Packet(..),IP4Header(..),IP4Protocol(..) - ,mkIP4PseudoHeader,splitPacket,renderIP4Packet - ,emptyIP4Header) -import Hans.Message.Udp (UdpHeader(..),UdpPort,UdpPacket(..),renderUdpPacket) +import Hans.Message.Ip4 + (IP4Header(..),IP4Protocol(..) ,mkIP4PseudoHeader,splitPacket + ,renderIP4Packet,emptyIP4Header) +import Hans.Message.Udp (UdpHeader(..),UdpPort,renderUdpPacket) import qualified Hans.Message.Ip4 as IP4 import Control.Concurrent (MVar,newMVar,modifyMVar) import Data.Word (Word16) -import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L newtype Ident = Ident (MVar IP4.Ident) @@ -36,8 +36,8 @@ -- | Render a UDP message to an unfragmented IP4 packet. renderUdp :: Ident -> Maybe MTU -> IP4 -> IP4 -> UdpPort -> UdpPort - -> S.ByteString - -> IO [S.ByteString] + -> L.ByteString + -> IO [L.ByteString] renderUdp i mb source dest srcPort destPort payload = do let prot = IP4Protocol 0x11 let mk = mkIP4PseudoHeader source dest prot @@ -46,14 +46,19 @@ , udpDestPort = destPort , udpChecksum = 0 } - udp <- renderUdpPacket (UdpPacket hdr payload) mk + udp <- renderUdpPacket hdr payload mk renderIp4 i mb prot source dest udp -- | Render an IP4 packet. -renderIp4 :: Ident -> Maybe MTU -> IP4Protocol -> IP4 -> IP4 -> S.ByteString - -> IO [S.ByteString] +renderIp4 :: Ident -> Maybe MTU -> IP4Protocol -> IP4 -> IP4 -> L.ByteString + -> IO [L.ByteString] renderIp4 ident mb prot source dest payload = do i <- nextIdent ident - let hdr = (emptyIP4Header prot source dest) { ip4Ident = i } - mapM renderIP4Packet (splitPacket (fromMTU mb) (IP4Packet hdr payload)) + let hdr = emptyIP4Header + { ip4Protocol = prot + , ip4SourceAddr = source + , ip4DestAddr = dest + , ip4Ident = i + } + mapM (uncurry renderIP4Packet) (splitPacket (fromMTU mb) hdr payload) diff --git a/src/Hans/Timers.hs b/src/Hans/Timers.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Timers.hs @@ -0,0 +1,55 @@ +module Hans.Timers ( + Milliseconds + , Timer() + , delay + , delay_ + , cancel + , expired + ) where + +import Control.Concurrent (forkIO,ThreadId,threadDelay,killThread + ,mkWeakThreadId) +import GHC.Conc (threadStatus,ThreadStatus(..)) +import System.Mem.Weak (Weak,deRefWeak) + + +type Milliseconds = Int + +-- | A handle to a scheduled timer. +-- +-- NOTE: This keeps a weak reference to the thread containing the timer, to +-- allow it to still receive exceptions (see mkWeakThreadId). +newtype Timer = Timer (Weak ThreadId) + +-- | Delay an action, giving back a handle to allow the timer to be cancelled. +delay :: Milliseconds -> IO () -> IO Timer +delay n body = + do tid <- forkIO (threadDelay (n * 1000) >> body) + wid <- mkWeakThreadId tid + return (Timer wid) + +-- | Delay an action. +delay_ :: Milliseconds -> IO () -> IO () +delay_ n body = + do _ <- forkIO (threadDelay (n * 1000) >> body) + return () + +-- | Cancel a delayed action. +cancel :: Timer -> IO () +cancel (Timer wid) = + do mb <- deRefWeak wid + case mb of + Just tid -> killThread tid + Nothing -> return () + +expired :: Timer -> IO Bool +expired (Timer wid) = + do mb <- deRefWeak wid + case mb of + Just tid -> do status <- threadStatus tid + case status of + ThreadRunning -> return False + ThreadBlocked _ -> return False + _ -> return True + + Nothing -> return True diff --git a/src/Hans/Utils.hs b/src/Hans/Utils.hs --- a/src/Hans/Utils.hs +++ b/src/Hans/Utils.hs @@ -1,14 +1,14 @@ module Hans.Utils where import Control.Monad (MonadPlus(mzero)) -import Data.ByteString (ByteString) import Numeric (showHex) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S type DeviceName = String -type Packet = ByteString - -type MkPseudoHeader = Int -> Packet +-- | Pseudo headers are constructed strictly. +type MkPseudoHeader = Int -> S.ByteString type Endo a = a -> a @@ -17,7 +17,7 @@ void m = m >> return () -- | Show a single hex number, padded with a leading 0. -showPaddedHex :: (Integral a) => a -> ShowS +showPaddedHex :: (Integral a, Show a) => a -> ShowS showPaddedHex x | x < 0x10 = showChar '0' . base | otherwise = base @@ -30,3 +30,10 @@ -- | Make a singleton list. singleton :: a -> [a] singleton x = [x] + +-- | Make a lazy bytestring from a strict one. +chunk :: S.ByteString -> L.ByteString +chunk bs = L.fromChunks [bs] + +strict :: L.ByteString -> S.ByteString +strict = S.concat . L.toChunks diff --git a/src/Hans/Utils/Checksum.hs b/src/Hans/Utils/Checksum.hs --- a/src/Hans/Utils/Checksum.hs +++ b/src/Hans/Utils/Checksum.hs @@ -11,16 +11,21 @@ -- complement of the one's complement sum of the data). module Hans.Utils.Checksum( computeChecksum + , finalizeChecksum , computePartialChecksum + , computePartialChecksumLazy , clearChecksum , pokeChecksum + , emptyPartialChecksum ) where import Control.Exception (assert) import Data.Bits (Bits(shiftL,shiftR,complement,clearBit,(.&.),rotate)) +import Data.List (foldl') import Data.Word (Word8,Word16,Word32) import Foreign.Storable (pokeByteOff) +import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S @@ -37,24 +42,58 @@ assert (off < len + 1) (pokeByteOff ptr off (rotate cs 8)) return b +data PartialChecksum = PartialChecksum + { pcAccum :: !Word32 + , pcCarry :: Maybe Word8 + } + +emptyPartialChecksum :: PartialChecksum +emptyPartialChecksum = PartialChecksum + { pcAccum = 0 + , pcCarry = Nothing + } + +finalizeChecksum :: PartialChecksum -> Word16 +finalizeChecksum pc = complement (fromIntegral (fold32 (fold32 result))) + where + result = case pcCarry pc of + Nothing -> pcAccum pc + Just prev -> step (pcAccum pc) prev 0 + -- | Compute the final checksum, using the given initial value. computeChecksum :: Word32 -> S.ByteString -> Word16 -computeChecksum c0 = - complement . fromIntegral . fold32 . fold32 . computePartialChecksum c0 +computeChecksum c0 = finalizeChecksum . computePartialChecksum PartialChecksum + { pcAccum = c0 + , pcCarry = Nothing + } +-- | Compute the checksum of a lazy bytestring. +computePartialChecksumLazy :: PartialChecksum -> L.ByteString -> PartialChecksum +computePartialChecksumLazy c0 = foldl' computePartialChecksum c0 . L.toChunks + -- | Compute a partial checksum, yielding a value suitable to be passed to -- computeChecksum. -computePartialChecksum :: Word32 -> S.ByteString -> Word32 -computePartialChecksum base b = result - where +computePartialChecksum :: PartialChecksum -> S.ByteString -> PartialChecksum +computePartialChecksum pc b + | S.null b = pc + | otherwise = case pcCarry pc of + Nothing -> result + Just prev -> computePartialChecksum (pc + { pcCarry = Nothing + , pcAccum = step (pcAccum pc) prev (S.unsafeIndex b 0) + }) (S.tail b) + where + !n' = S.length b - !result - | odd n' = step most hi 0 - | otherwise = most - where hi = S.unsafeIndex b (n'-1) + result = PartialChecksum + { pcAccum = loop (fromIntegral (pcAccum pc)) 0 + , pcCarry = carry + } - !most = loop (fromIntegral base) 0 + carry + | odd n' = Just (S.unsafeIndex b (n' - 1)) + | otherwise = Nothing loop !acc off | off < n = loop (step acc hi lo) (off + 2) diff --git a/src/Network/TCP/Aux/Misc.hs b/src/Network/TCP/Aux/Misc.hs deleted file mode 100644 --- a/src/Network/TCP/Aux/Misc.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Aux.Misc where - -import Network.TCP.Type.Base -import Network.TCP.Type.Timer -import Network.TCP.Type.Datagram -import Network.TCP.Type.Socket -import Network.TCP.Aux.Param -import Foreign -import Data.Map as Map -import Data.List as List -import Data.Maybe -import Data.List as List -import System.IO.Unsafe -import Control.Exception - -debug :: (Monad m) => String -> m a -debug s = seq (unsafePerformIO $ putStrLn s) return undefined - - -bound_ports :: Map SocketID (TCPSocket threadt) -> [Port] -bound_ports sockmap = List.map get_local_port (keys sockmap) - --- not considering SO_REUSEADDR --- bound_port_allowed :: Map SocketID (TCPSocket threadt) -> Port -> Bool --- bound_port_allowed m p = not $ List.elem p (bound_ports m) - --- lookup_socketid_by_seg :: Map SocketID (TCPSocket threadt) -> TCPSegment -> Maybe SocketID --- lookup_socketid_by_seg m s = --- let fakeid = (tcp_dst s, tcp_src s) in --- if (member fakeid m) then --- Just fakeid --- else --- Nothing --- -create_timer (curr_time :: Time) (offset :: Time) = curr_time + offset -slow_timer = create_timer - -create_timewindow (curr_time :: Time) (offset :: Time) a = Just (Timed a (create_timer curr_time offset)) - --- queues - --- enqueue_message msg q = addToQueue q msg --- enqueue_messages msgs q = foldl addToQueue q msgs --- -accept_incoming_q0 :: SocketListen -> Bool -accept_incoming_q0 lis = - (length $ lis_q lis) < (backlog_fudge (lis_qlimit lis)) -accept_incoming_q lis = - (length $ lis_q lis) < 3 * (backlog_fudge (lis_qlimit lis `div` 2)) -drop_from_q0 lis = - (length $ lis_q0 lis) >= tcp_q0maxlimit - -do_tcp_options :: Time -> Bool -> (TimeWindow Timestamp) -> Timestamp -> Maybe (Timestamp,Timestamp) -do_tcp_options curr_time cb_tf_doing_tstmp cb_ts_recent cb_ts_val = - if cb_tf_doing_tstmp then - let ts_ecr' = case timewindow_val curr_time cb_ts_recent of - Just x -> x - Nothing -> Timestamp 0 - in Just(cb_ts_val, ts_ecr') - else - Nothing - -calculate_tcp_options_len cb_tf_doing_tstmp = - if cb_tf_doing_tstmp then 12 else 0 - -rounddown bs v = if v < bs then v else (v `div` bs) * bs -roundup bs v = ((v+(bs-1)) `div` bs) * bs - -calculate_buf_sizes (cb_t_maxseg :: Int) - (seg_mss :: Maybe Int) - (bw_delay_product_for_rt :: Maybe Int) - (is_local_conn :: Bool) - (rcvbufsize :: Int) - (sndbufsize :: Int) - (cb_tf_doing_tstmp :: Bool) - = let t_maxseg' = - let maxseg = (min cb_t_maxseg (max 64 $ (case seg_mss of Nothing -> mssdflt; Just x-> x))) in - -- BSD - maxseg - (calculate_tcp_options_len cb_tf_doing_tstmp) - in - let t_maxseg'' = rounddown mclbytes (t_maxseg') in - let rcvbufsize' = case bw_delay_product_for_rt of Nothing->rcvbufsize; Just x->x in - let (rcvbufsize'', t_maxseg''') = ( if rcvbufsize' < t_maxseg'' - then (rcvbufsize', rcvbufsize') - else (min (sb_max) (roundup (t_maxseg'') rcvbufsize'), - t_maxseg'')) in - let sndbufsize' = case bw_delay_product_for_rt of Nothing->sndbufsize; Just x->x in - let sndbufsize'' = (if sndbufsize' < t_maxseg''' - then sndbufsize' - else min (sb_max) (roundup (t_maxseg'') sndbufsize')) in - let snd_cwnd = t_maxseg''' * ((if is_local_conn then ss_fltsz_local else ss_fltsz)) in - (rcvbufsize'', sndbufsize'', t_maxseg''', snd_cwnd) - - -calculate_bsd_rcv_wnd :: TCPSocket t -> Int -calculate_bsd_rcv_wnd (tcp_sock :: TCPSocket t)= - let cb = cb_rcv tcp_sock in - assert ((rcv_adv cb) >= (rcv_nxt cb)) $ -- assertion for debugging - max (seq_diff (rcv_adv cb) (rcv_nxt cb)) - (freebsd_so_rcvbuf - (bufc_length $ rcvq cb)) - -send_queue_space sndq_max sndq_size = (sndq_max - sndq_size) - - - -update_idle (curr_time :: Time) tcp_sock = - let tt_keep' = if not (st tcp_sock == SYN_RECEIVED && tf_needfin (cb tcp_sock)) then - Just (slow_timer curr_time tcptv_keep_idle) - else - tt_keep $ cb_time tcp_sock - tt_fin_wait_2' = if st tcp_sock == FIN_WAIT_2 then - Just (slow_timer curr_time tcptv_maxidle ) - else - tt_fin_wait_2 $ cb_time tcp_sock - in - (tt_keep', tt_fin_wait_2') - --- tcp timing and rtt - - -tcp_backoffs = tcp_bsd_backoffs -tcp_syn_backoffs = tcp_syn_backoffs - -mode_of :: Maybe (Timed (RexmtMode,Int)) -> Maybe RexmtMode -mode_of (Just (Timed (x,_) _)) = Just x -mode_of Nothing = Nothing - -shift_of :: Maybe (Timed (RexmtMode,Int)) -> Int -shift_of (Just (Timed (_,shift) _ )) = shift - --- todo: check types! - --- compute the retransmit timeout to use -computed_rto :: [Int] -> Int -> Rttinf -> Time -computed_rto (backoffs :: [Int]) (shift :: Int) (ri::Rttinf) = - (to_Int64 $ backoffs !! shift ) * (max (t_rttmin ri) ((t_srtt ri) + 4*(t_rttvar ri))) - --- compute the last-used rxtcur -computed_rxtcur (ri :: Rttinf) = - max (t_rttmin ri) - (min (tcptv_rexmtmax) - ((computed_rto ( if t_wassyn ri then tcp_syn_backoffs else tcp_backoffs ) - (t_lastshift ri) ri ))) - -start_tt_rexmt_gen (mode :: RexmtMode) (backoffs :: [Int]) (shift :: Int) - (wantmin :: Bool) (ri :: Rttinf) (curr_time :: Time) = - let rxtcur = max (if wantmin - then max (t_rttmin ri) (t_lastrtt ri + (2*1000*1000 `div` 100)) -- 2s/100 - else t_rttmin ri ) - ( min (tcptv_rexmtmax ) - ( computed_rto backoffs shift ri) ) - in - Just ( Timed (mode,shift) (create_timer curr_time rxtcur ) ) - -start_tt_rexmt = start_tt_rexmt_gen Rexmt tcp_backoffs -start_tt_rexmtsyn = start_tt_rexmt_gen RexmtSyn tcp_syn_backoffs - -start_tt_persist (shift :: Int) (ri::Rttinf) (curr_time :: Time) = - let cur = max (tcptv_persmin) - (min (tcptv_persmax) - (computed_rto tcp_backoffs shift ri) ) - in - Just ( Timed (Persist, shift) (create_timer curr_time cur)) - -update_rtt :: Time -> Rttinf -> Rttinf -update_rtt rtt ri = - let (t_srtt'', t_rttvar'') - = if tf_srtt_valid ri then - let delta = (rtt - 1000*10) - (t_srtt ri) -- 1000*10 = 1/HZ - vardelta = (abs delta) - (t_rttvar ri) - t_srtt' = max (1000*1000 `div` (32*100)) (t_srtt ri + (delta `div` 8)) - t_rttvar'=max (1000*1000 `div` (16*100)) (t_rttvar ri + (vardelta `div` 4)) - in (t_srtt', t_rttvar') - else - let t_srtt' = rtt - t_rttvar' = rtt `div` 2 - in (t_srtt',t_rttvar') - in - ri { t_rttupdated = t_rttupdated ri + 1 - , tf_srtt_valid = True - , t_srtt = t_srtt'' - , t_rttvar = t_rttvar'' - , t_lastrtt = rtt - , t_lastshift = 0 - , t_wassyn = False - } - -expand_cwnd ssthresh maxseg maxwin cwnd - = min maxwin (cwnd + (if cwnd > ssthresh then (maxseg * maxseg) `div` cwnd else maxseg)) - --- Path MTU Discovery - -mtu_tab = [65535, 32000, 17914, 8166, 4352, 2002, 1492, 1006, 508, 296, 88] - -next_smaller :: [Int] -> Int -> Int -next_smaller (x:xs) value = if value >= x then x else next_smaller xs value - - -initial_cb_time = TCBTiming - { tt_keep = Nothing - , tt_conn_est = Nothing - , tt_fin_wait_2 = Nothing - , tt_2msl = Nothing - , t_idletime = 0 - , ts_recent = Nothing - , t_badrxtwin = Nothing - } - -initial_cb_snd = TCBSending - { sndq = bufferchain_empty - , snd_una = SeqLocal 0 - , snd_wnd = 0 - , snd_wl1 = SeqForeign 0 - , snd_wl2 = SeqLocal 0 - , snd_cwnd = tcp_maxwin `shiftL` tcp_maxwinscale - , snd_nxt = SeqLocal 0 - , snd_max = SeqLocal 0 - , t_dupacks = 0 - , t_rttinf = Rttinf { t_rttupdated = 0 - , tf_srtt_valid = False - , t_srtt = tcptv_rtobase - , t_rttvar = tcptv_rttvarbase - , t_rttmin = tcptv_min - , t_lastrtt = 0 - , t_lastshift = 0 - , t_wassyn = False - } - , t_rttseg = Nothing - , tt_rexmt = Nothing - } - -{-# INLINE hasfin #-} -{-# INLINE tcp_reass #-} -{-# INLINE tcp_reass_prune #-} - -hasfin seg = case trs_FIN seg of True -> 1; False -> 0 - --- returns (1) the string --- (2) the SEQ for the next byte --- (3) whether FIN has been reached --- (4) remaining... --- this is a very SLOW algorithm and should be replaced .... - -tcp_reass :: SeqForeign -> [TCPReassSegment] -> (BufferChain, SeqForeign, Bool, [TCPReassSegment]) -tcp_reass seq rsegq = - let searchpkt rseg = - let seq1 = (trs_seq rseg) - seq2 = seq1 `seq_plus` (bufc_length $ trs_data rseg) `seq_plus` (hasfin rseg) - in (seq >= seq1 && seq < seq2) - in - case List.find searchpkt rsegq of - Nothing -> - (bufferchain_empty, seq, False, rsegq) - Just rseg -> - let data_to_trim = seq `seq_diff` (trs_seq rseg) in - let result_buf = bufferchain_drop data_to_trim (trs_data rseg) in - let next_seq = (trs_seq rseg) `seq_plus` (bufc_length $ trs_data rseg) `seq_plus` (hasfin rseg) in - let new_rsegq = tcp_reass_prune next_seq rsegq in - if trs_FIN rseg then - (result_buf - , next_seq - , True - , new_rsegq - ) - else - let (bufc2, next_seq2, hasfin2, rsegq2) = tcp_reass next_seq new_rsegq in - ( bufferchain_concat result_buf bufc2 - , next_seq2 - , hasfin2 - , rsegq2 - ) - -tcp_reass_prune :: SeqForeign -> [TCPReassSegment] -> [TCPReassSegment] -tcp_reass_prune seq rsegq = - List.filter (\seg -> - let nxtseq = (trs_seq seg) `seq_plus` (bufc_length $ trs_data seg) `seq_plus` (hasfin seg) - in nxtseq > seq - ) rsegq - -initial_cb_rcv = TCBReceiving - { last_ack_sent = SeqForeign 0 - , tf_rxwin0sent = False - , tf_shouldacknow = False - , tt_delack = False - , rcv_adv = SeqForeign 0 - , rcv_wnd = 0 - , rcv_nxt = SeqForeign 0 - , rcvq = bufferchain_empty - , t_segq = [] - } - -initial_cb_misc = TCBMisc - { -- retransmission - snd_ssthresh = tcp_maxwin `shiftL` tcp_maxwinscale - , snd_cwnd_prev = 0 - , snd_ssthresh_prev = 0 - , snd_recover = SeqLocal 0 - -- some tags - , cantsndmore = False - , cantrcvmore = False - , bsd_cantconnect = False - -- initialization parameters - , self_id = SocketID (0,TCPAddr (IPAddr 0,0)) - , parent_id = SocketID (0,TCPAddr (IPAddr 0,0)) - , local_addr = TCPAddr (IPAddr 0,0) - , remote_addr = TCPAddr (IPAddr 0,0) - , t_maxseg = mssdflt - , t_advmss = Nothing - , tf_doing_ws = False - , tf_doing_tstmp = False - , tf_req_tstmp = False - , request_r_scale = Nothing - , snd_scale = 0 - , rcv_scale = 0 - , iss = SeqLocal 0 - , irs = SeqForeign 0 - -- other things i don't use for the moment - , sndurp = Nothing - , rcvurp = Nothing - , iobc = NO_OOBDATA - , rcv_up = SeqForeign 0 - , tf_needfin = False - } - -initial_tcp_socket = TCPSocket - { st = CLOSED - , cb_time = initial_cb_time - , cb_snd = initial_cb_snd - , cb_rcv = initial_cb_rcv - , cb = initial_cb_misc - , sock_listen = SocketListen [] [] 0 - , waiting_list = [] - } - -empty_sid :: SocketID -empty_sid = SocketID (0,TCPAddr (IPAddr 0,0)) - - diff --git a/src/Network/TCP/Aux/Output.hs b/src/Network/TCP/Aux/Output.hs deleted file mode 100644 --- a/src/Network/TCP/Aux/Output.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Aux.Output where - -import Hans.Message.Tcp - -import Network.TCP.Type.Base -import Network.TCP.Type.Timer -import Network.TCP.Type.Datagram as Datagram -import Network.TCP.Type.Socket -import Network.TCP.Type.Syscall -import Network.TCP.Aux.Param -import Network.TCP.Aux.Misc -import Hans.Layer.Tcp.Monad -import Foreign -import Control.Exception -import Control.Monad - -make_syn_segment :: Time -> TCPSocket t -> Timestamp -> TCPSegment -make_syn_segment curr_time sock (ts_val::Timestamp) = - let ws = request_r_scale $ cb sock -- should assert it's <= tcp_maxwinscale ? - mss = t_advmss $ cb $ sock - ts = do_tcp_options curr_time (tf_req_tstmp $ cb sock) (ts_recent $ cb_time $ sock ) ts_val - hdr = - set_tcp_mss mss $ - set_tcp_ws ws $ - set_tcp_ts ts $ emptyTcpHeader - { tcpSeqNum = TcpSeqNum (seq_val (iss (cb sock))) - , tcpAckNum = TcpAckNum 0 - , tcpSyn = True - , tcpWindow = fromIntegral (rcv_wnd (cb_rcv sock)) - } - in mkTCPSegment' - (local_addr (cb sock)) (remote_addr (cb sock)) hdr bufferchain_empty - -make_syn_ack_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) = - let urp_any = 0 - tcb = cb sock - win = rcv_wnd (cb_rcv sock) -- `shiftR` (rcv_scale $ cb sock) - ws = if tf_doing_ws tcb then Just (rcv_scale tcb) else Nothing - mss = t_advmss tcb - ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val - hdr = - set_tcp_mss mss $ - set_tcp_ws ws $ - set_tcp_ts ts $ emptyTcpHeader - { tcpSeqNum = TcpSeqNum (seq_val (iss tcb)) - , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) - , tcpAck = True - , tcpSyn = True - , tcpWindow = fromIntegral win - , tcpUrgentPointer = urp_any - } - in mkTCPSegment' addrfrom addrto hdr bufferchain_empty - -make_ack_segment curr_time sock (fin::Bool) (ts_val::Timestamp) = - let urp_garbage = 0 - tcb = cb sock - win = (rcv_wnd $ cb_rcv sock) `shiftR` (rcv_scale tcb) - ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val - sn | fin = snd_una (cb_snd sock) - | otherwise = snd_nxt (cb_snd sock) - hdr = - set_tcp_ts ts $ emptyTcpHeader - { tcpSeqNum = TcpSeqNum (seq_val sn) - , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) - , tcpAck = True - , tcpFin = fin - , tcpWindow = fromIntegral win - , tcpUrgentPointer = urp_garbage - } - in mkTCPSegment' (local_addr tcb) (remote_addr tcb) hdr bufferchain_empty - -bsd_make_phantom_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) (cantsendmore::Bool) = - let urp_garbage = 0 - tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - win = (rcv_wnd rcb) `shiftR` (rcv_scale tcb) - fin = (cantsendmore && seq_lt (snd_una scb) (seq_minus (snd_max scb) 1)) - ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val - sn | fin = snd_una scb - | otherwise = snd_max scb - hdr = - set_tcp_ts ts emptyTcpHeader - { tcpSourcePort = TcpPort 0 - , tcpDestPort = TcpPort 0 - , tcpSeqNum = TcpSeqNum (seq_val sn) - , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt rcb)) - , tcpFin = fin - , tcpWindow = fromIntegral win - , tcpUrgentPointer = urp_garbage - } - in - mkTCPSegment' addrfrom addrto hdr bufferchain_empty - -make_rst_segment_from_cb sock (addrfrom::TCPAddr) (addrto::TCPAddr) = - let hdr = emptyTcpHeader - { tcpSourcePort = TcpPort 0 - , tcpDestPort = TcpPort 0 - , tcpSeqNum = TcpSeqNum (seq_val (snd_nxt (cb_snd sock))) - , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) - , tcpAck = False - , tcpRst = False - } - in mkTCPSegment' addrfrom addrto hdr bufferchain_empty - -make_rst_segment_from_seg (seg::TCPSegment) = - let tcp_ACK' = not (tcp_ACK seg) - seq' = if tcp_ACK seg then tcp_ack seg else 0 - ack' = if tcp_ACK' - then let s1 = tcp_seq seg - in s1 `seq_plus` bufc_length (tcp_data seg) - `seq_plus` (if tcp_SYN seg then 1 else 0) - else 0 - - - hdr = emptyTcpHeader - { tcpSeqNum = TcpSeqNum seq' - , tcpAckNum = TcpAckNum ack' - , tcpAck = tcp_ACK' - , tcpRst = True - } - in - mkTCPSegment' (tcp_src seg) (tcp_dst seg) hdr bufferchain_empty - - -dropwithreset (seg::TCPSegment) = - if tcp_RST seg then [] - else let seg' = make_rst_segment_from_seg seg - in [TCPMessage seg'] - -dropwithreset_ignore_or_fail = dropwithreset - -tcp_close_temp sock = - sock { cb = (cb sock) { cantrcvmore = True - , cantsndmore = True - , local_addr = TCPAddr (IPAddr 0,0) - , remote_addr = TCPAddr (IPAddr 0,0) - , bsd_cantconnect = True - } - , st = CLOSED - , cb_snd = (cb_snd sock) { sndq = bufferchain_empty } - } - - -tcp_close :: SocketID -> HMonad t () -tcp_close sid = - do b <- has_sock sid - when b $ do - sock <- lookup_sock sid - let pending_tasks = waiting_list sock - has_parent = (get_local_port $ parent_id $ cb sock) /= 0 - let result = map (\(_,cont) -> cont (SockError "tcpclose")) pending_tasks - emit_ready result - delete_sock sid - when (not has_parent) $ free_local_port $ get_local_port sid - -tcp_drop_and_close :: SocketID -> HMonad t () -tcp_drop_and_close sid = - do b <- has_sock sid - when b $ do - sock <- lookup_sock sid - let outsegs = if st sock `notElem` [CLOSED,LISTEN,SYN_SENT] - then [TCPMessage $ make_rst_segment_from_cb - (sock) (local_addr $ cb sock) (remote_addr $ cb sock)] - else [] - emit_segs outsegs - tcp_close sid - -alloc_local_port :: HMonad t (Maybe Port) -alloc_local_port = do - h <- get_host - case local_ports h of - [] -> return Nothing - port:rest -> do put_host $ h { local_ports = rest } - return $ Just port - -free_local_port port = - modify_host $ \h -> h { local_ports = port:(local_ports h) } - diff --git a/src/Network/TCP/Aux/Param.hs b/src/Network/TCP/Aux/Param.hs deleted file mode 100644 --- a/src/Network/TCP/Aux/Param.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Aux.Param where - -import Network.TCP.Type.Base - -dschedmax = seconds_to_time 1 -dinput_queuemax = seconds_to_time 1 -doutput_queuemax = seconds_to_time 1 - -hz = 100 - -tickintvlmin = seconds_to_time $ 100/(105*hz) -tickintvlmax = seconds_to_time $ 105/(100*hz) - -slow_timer_intvl = seconds_to_time $ 1/2 --- slow_timer_model_intvl = seconds_to_time $ 1/1000 - -fast_timer_intvl = seconds_to_time $ 1/5 --- fast_timer_model_intvl = seconds_to_time $ 1/1000 - -kern_timer_intvl = tickintvlmax --- kern_timer_model_intvl = - - --- listen queue length -somaxconn ::Int= 128 - --- buffers -mclbytes ::Int= 2048 -msize ::Int= 256 -sb_max ::Int= 256*1024 - --- rfc limits - -dtsinval::Time = seconds_to_time $ 24*24*60*60 -tcp_maxwin :: Int = 65535 -tcp_maxwinscale :: Int = 14 - - ---default -freebsd_so_rcvbuf :: Int = 42080 -freebsd_so_sndbuf :: Int = 9216 - --- tcp parameters - -mssdflt :: Int = 1400 -- 512 -ss_fltsz_local :: Int = 4 -ss_fltsz :: Int = 1 -tcp_do_newreno = True -tcp_q0minlimit :: Int = 30 -tcp_q0maxlimit :: Int = 512*30 - -backlog_fudge :: Int -> Int -backlog_fudge n = min somaxconn n - --- time values (TCP only) - -tcptv_delack = seconds_to_time 0.1 -tcptv_rtobase = seconds_to_time 3 -tcptv_rttvarbase = seconds_to_time 0 -tcptv_min = seconds_to_time 1 -tcptv_rexmtmax = seconds_to_time 64 -tcptv_msl = seconds_to_time 1 -- this is too stringent... good for testing -tcptv_persmin = seconds_to_time 5 -tcptv_persmax = seconds_to_time 60 -tcptv_keep_init = seconds_to_time 75 -tcptv_keep_idle = seconds_to_time $ 120*60 -tcptv_keepintvl = seconds_to_time $ 75 -tcptv_keepcnt = seconds_to_time $ 8 -tcptv_maxidle = tcptv_keepintvl*8 - - --- timing related parameters (TCP only) - -tcp_bsd_backoffs :: [Int]= [1,2,4,8,16,32,64, 64,64,64, 64,64,64] -tcp_linux_backoffs = [1,2,4,8,16,32,64, 128,256,512, 512] -tcp_winxp_backoffs = [1,2,4,8,16] - ---tcp_maxrxtshift = 12 -tcp_maxrxtshift :: Int = 3 -- this is not right... for testing only -tcp_synackmaxrxtshift :: Int = 3 - -tcp_syn_bsd_backoffs :: [Int] = [1,1,1,1,1,2,4,8,16,32,64,64,64] -tcp_syn_linux_backoffs =[1,2,4,8,16] -tcp_syn_winxp_backoffs=[1,2] - -listen_qlimit :: Int = 100 diff --git a/src/Network/TCP/Aux/SockMonad.hs b/src/Network/TCP/Aux/SockMonad.hs deleted file mode 100644 --- a/src/Network/TCP/Aux/SockMonad.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Aux.SockMonad where - -import Network.TCP.Type.Base -import Network.TCP.Type.Socket -import Network.TCP.Aux.Misc -import Hans.Layer.Tcp.Monad -import Control.Exception - -data HState t = HState - { hs_host :: !(Host t) - , hs_sock :: !(TCPSocket t) - } - -newtype SMonad t a = SMonad (HState t -> (a, HState t)) - -instance Monad (SMonad t) where - return a = SMonad $ \s -> (a,s) - x >>= f = bindSMonad x f - {-# INLINE return #-} - {-# INLINE (>>=) #-} - -bindSMonad :: SMonad t a -> (a -> SMonad t b) -> SMonad t b -bindSMonad (SMonad x) f = - SMonad $ \s -> let (res, s') = x s - (SMonad z) = f res in z s' -{-# INLINE bindSMonad #-} - -get_host_ :: SMonad t (Host t) -get_host_ = SMonad $ \s -> (hs_host s,s) - -modify_host_ f = SMonad $ \s -> ((), s { hs_host = f (hs_host s)}) -emit_segs_ segs = modify_host_ $ \h -> h { output_queue = (output_queue h)++ segs} -emit_ready_ threads = modify_host_ $ \h -> h { ready_list = (ready_list h)++ threads} - -{-# INLINE get_host_ #-} -{-# INLINE modify_host_ #-} -{-# INLINE emit_segs_ #-} -{-# INLINE emit_ready_ #-} - --------------------------------------------------- --- get_sid = do --- SMonad $ \s -> (hs_sid s,s) --- {-# INLINE get_sid #-} - -get_sock = do - SMonad $ \s -> (hs_sock s,s) - -put_sock sock = do - SMonad $ \s -> ((), s { hs_sock = sock}) - -modify_sock f = do - SMonad $ \s -> ((), s { hs_sock = f (hs_sock s)}) -modify_cb f = - SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb =f (cb sock) }}) -modify_cb_snd f = - SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb_snd=f (cb_snd sock) }}) -modify_cb_rcv f = - SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb_rcv=f (cb_rcv sock) }}) -modify_cb_time f= - SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock {cb_time=f (cb_time sock)}}) -{-# INLINE get_sock #-} -{-# INLINE put_sock #-} -{-# INLINE modify_sock #-} -{-# INLINE modify_cb #-} -{-# INLINE modify_cb_snd #-} -{-# INLINE modify_cb_rcv #-} -{-# INLINE modify_cb_time #-} - - ------------------------------------------------------ --- has_sock_ :: SocketID -> SMonad t Bool --- has_sock_ sid = do --- h <- get_host_ --- return $ Map.member sid (sock_map h) --- --- lookup_sock_ sid = do --- h <- get_host_ --- res <- Map.lookup sid (sock_map h) --- return res --- --- {-# INLINE has_sock_ #-} --- {-# INLINE lookup_sock_ #-} --- ------------------- - -runSMonad :: SocketID -> (SMonad t a) -> HMonad t a -runSMonad sid (SMonad m) = do - h <- get_host - sock <- lookup_sock sid - let initstate = HState h sock - let (res, finalstate) = m initstate - put_host $ hs_host finalstate - update_sock sid $ \_ -> hs_sock finalstate - return res diff --git a/src/Network/TCP/LTS/In.hs b/src/Network/TCP/LTS/In.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/In.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.In - ( tcp_deliver_in_packet - ) -where - -import Hans.Layer.Tcp.Monad -import Hans.Message.Tcp - -import Foreign -import Foreign.C -import Data.List as List -import Control.Exception -import Control.Monad - -import Network.TCP.Type.Base -import Network.TCP.Type.Syscall -import Network.TCP.Type.Timer -import Network.TCP.Type.Socket -import Network.TCP.Type.Datagram -import Network.TCP.Aux.Param - -import Network.TCP.Aux.Misc -import Network.TCP.Aux.Output -import Network.TCP.Aux.SockMonad -import Network.TCP.Aux.Output - -import Network.TCP.LTS.InPassive -import Network.TCP.LTS.InActive -import Network.TCP.LTS.InData -import Network.TCP.LTS.User -import Network.TCP.LTS.Out - -tcp_deliver_in_packet seg = do - let sid = SocketID (get_port (tcp_dst seg), tcp_src seg) - ok <- has_sock sid - if ok - then tcp_deliver_packet_to_sock sid seg - else if tcp_SYN seg && (not $ tcp_ACK seg) && (not $ tcp_RST seg) - then tcp_deliver_syn_packet seg - else emit_segs $ dropwithreset seg - --- Note: if there exists a socket in TIME_WAIT state, and an SYN --- packet matches it, the SYN packet will always be delivered to this --- socket; it will never be delivered to a listening socket. This --- makes the implementation simpler... - ---pre-condition: sid exists -tcp_deliver_packet_to_sock :: SocketID -> TCPSegment -> HMonad t () -tcp_deliver_packet_to_sock sid seg = - do h <- get_host - sock <- lookup_sock sid - let tcb = cb sock - rcb = cb_rcv sock - scb = cb_snd sock - seqnum = SeqForeign (tcp_seq seg) - acknum = SeqLocal (tcp_ack seg) - - success <- header_prediction seg h sid sock tcb rcb scb seqnum acknum - when (not success) $ - case st sock of - CLOSED -> assert (False) return () - LISTEN -> assert (False) return () - SYN_SENT -> let goodack = (iss tcb) < acknum && acknum <= (snd_max scb) in - if tcp_RST seg then - when (tcp_ACK seg && goodack) $ tcp_close sid - else - if tcp_SYN seg && tcp_ACK seg then - if goodack then runSMonad sid $ deliver_in_2 seg - else emit_segs $ dropwithreset seg - else return () - SYN_RECEIVED -> - let invalidack = acknum <= snd_una scb || acknum > snd_max scb in - if tcp_RST seg then - tcp_close sid - else if tcp_SYN seg || not (tcp_ACK seg) then -- check with spec? - return () - else if invalidack || (seqnum < (irs tcb)) then - return () - else do - sock <- runSMonad sid $ deliver_in_3 seg - if st sock == CLOSED then - tcp_close sid - else when (st sock /= SYN_RECEIVED) $ - di3_socks_update sid - _ -> if tcp_RST seg then - when (st sock /= TIME_WAIT) $ tcp_close sid - else if tcp_SYN seg then - when (st sock==TIME_WAIT) $ emit_segs $ dropwithreset seg - else - if st sock `elem` [FIN_WAIT_1, CLOSING, LAST_ACK, FIN_WAIT_2, TIME_WAIT] - && seqnum `seq_plus` (bufc_length $ tcp_data seg) > (rcv_nxt rcb) - then return () -- data coming into closing socket? - else do sock <- runSMonad sid $ deliver_in_3 seg - --debug $ (show $ st sock) - when (st sock == CLOSED) $ tcp_close sid - -{-# INLINE header_prediction #-} -header_prediction seg h sid sock tcb rcb scb seqnum acknum = - if st sock == ESTABLISHED - && not (tcp_SYN seg) - && not (tcp_FIN seg) - && not (tcp_URG seg) - && not (tcp_RST seg) - && tcp_ACK seg - && seqnum == rcv_nxt rcb - && snd_wnd scb == fromIntegral (tcp_win seg) `shiftL` snd_scale tcb - && snd_max scb == snd_nxt scb - then if bufc_length (tcp_data seg) == 0 - && acknum > (snd_una scb) - && acknum <= (snd_max scb) - && snd_cwnd scb >= snd_wnd scb - && t_dupacks scb < 3 - then do -- pure ack for outstanding data - -------------------------------------------------------------------------------- - --debug $ "prediction 2.1!" - let emission_time = case (tcp_ts seg, t_rttseg scb) of - (Just (ts_val, ts_ecr), _ ) -> Just (ts_ecr `seq_minus` 1) - (Nothing, Just (ts0, seq0)) -> if acknum > seq0 then Just ts0 else Nothing - (Nothing, Nothing) -> Nothing - let t_rttinf' = case emission_time of - Just emtime -> assert ((ticks h) >= emtime) $ - update_rtt ( ((ticks h) `seq_diff` emtime)*10000 ) (t_rttinf scb) - Nothing -> t_rttinf scb - let tt_rexmt' = if acknum == snd_max scb then - Nothing - else case mode_of (tt_rexmt scb) of - Nothing -> start_tt_rexmt 0 True t_rttinf' (clock h) - Just Rexmt -> start_tt_rexmt 0 True t_rttinf' (clock h) - _ -> tt_rexmt scb - let acked = acknum `seq_diff` (snd_una scb) - let snd_wnd' = snd_wnd scb - acked - let sndq' = bufferchain_drop acked (sndq scb) - runSMonad sid $ do - modify_sock $ \s -> s { cb_snd = scb - { sndq = sndq' - , t_dupacks = 0 - , t_rttinf = t_rttinf' - , tt_rexmt = tt_rexmt' - , t_rttseg = if emission_time == Nothing then t_rttseg scb else Nothing - , snd_cwnd = expand_cwnd (snd_ssthresh tcb) - (t_maxseg tcb) - (tcp_maxwin `shiftL` (snd_scale tcb)) - (snd_cwnd scb) - , snd_wnd = snd_wnd' - , snd_una = acknum - --, snd_nxt = max acknum (snd_nxt scb) - } - } - tcp_wakeup - tcp_output_all - return True - -------------------------------------------------------------------------------- - else if acknum == snd_una scb - && List.null (t_segq rcb) - && bufc_length (tcp_data seg) < (freebsd_so_rcvbuf - (bufc_length $ rcvq rcb)) - then do -- pure in-sequence data packet - -------------------------------------------------------------------------------- - return False - -------------------------------------------------------------------------------- - else do - -- debug $ "predictions 2.1, 2.2 fail!" - return False - else do - -- debug $ "prediction 1 fail!" ++ (show $ snd_wnd tcb) - -- ++ " " ++ (show (tcp_win seg)) ++ " " ++ (show $ snd_scale tcb) - return False - diff --git a/src/Network/TCP/LTS/InActive.hs b/src/Network/TCP/LTS/InActive.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/InActive.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.InActive where - -import Foreign -import Foreign.C -import Data.Maybe -import Network.TCP.Type.Base -import Network.TCP.Type.Syscall -import Network.TCP.Aux.Misc -import Network.TCP.Aux.Param -import Network.TCP.Aux.Output -import Network.TCP.Type.Socket -import Network.TCP.Type.Datagram -import Network.TCP.Aux.SockMonad -import Network.TCP.LTS.User - -deliver_in_2 seg = do - sock <- get_sock - h <- get_host_ - --debug $ "deliver_in_3 " ++ (show seg) - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - acknum = SeqLocal (tcp_ack seg) - seqnum = SeqForeign (tcp_seq seg) - let { - -- window scaling - (rcv_scale', snd_scale', tf_doing_ws') = - ( case (request_r_scale tcb, tcp_ws seg) of - (Just rs, Just ss) -> (rs, ss, True) - _ -> (0,0,False) - ); - - -- timestamping - - tf_rcvd_tstmp' = isJust $ tcp_ts seg; - tf_doing_tstmp' = tf_rcvd_tstmp' && (tf_req_tstmp tcb); - -- mss negotiation - ourmss = ( case (t_advmss tcb) of - Nothing -> (t_maxseg tcb) - Just v -> v - ); - - (rcvbufsize', sndbufsize', t_maxseg'', snd_cwnd') = - calculate_buf_sizes ourmss (tcp_mss seg) Nothing False - (freebsd_so_rcvbuf) (freebsd_so_sndbuf) tf_doing_tstmp'; - - rcv_window = min tcp_maxwin freebsd_so_rcvbuf; - - emission_time = - ( case tcp_ts seg of - Just (ts_val, ts_ecr) -> Just (ts_ecr `seq_minus` 1) - Nothing -> case t_rttseg scb of - Just (ts0, seq0) -> if acknum > seq0 then Just ts0 else Nothing - Nothing -> Nothing; - ); - - t_rttseg' = ( case emission_time of - Nothing -> Nothing - Just _ -> t_rttseg scb ); - - t_rttinf' = ( case emission_time of - Just emtime -> update_rtt ( ((ticks h) `seq_diff` emtime)*10*1000 ) (t_rttinf scb) - Nothing -> t_rttinf scb ); - - tt_rexmt' = if acknum == snd_max scb then Nothing else tt_rexmt scb; - - fin' = tcp_FIN seg; - rcvq' = tcp_data seg; - rcv_nxt' = seqnum `seq_plus` 1 `seq_plus` (if fin' then 1 else 0); - rcv_wnd' = rcv_window - (bufc_length $ tcp_data seg); - - cantrcvmore' = if fin' then True else cantrcvmore tcb; - - new_st = if fin' then - if cantsndmore tcb then LAST_ACK else CLOSE_WAIT - else - if cantsndmore tcb then - if snd_max scb > iss tcb `seq_plus` 1 && acknum >= snd_max scb then - FIN_WAIT_2 - else - FIN_WAIT_1 - else - ESTABLISHED; - - newsock = sock - { st = new_st - , cb_time = (cb_time sock) - { t_idletime = clock h - , tt_keep = Just (create_timer (clock h) tcptv_keep_idle) - , tt_conn_est = Nothing - , ts_recent = case tcp_ts seg of - Nothing -> ts_recent $ cb_time sock - Just (ts_val, ts_ecr) -> create_timewindow (clock h) dtsinval (ts_val) - } - , cb_snd = scb - { tt_rexmt = tt_rexmt' - , snd_una = acknum - , snd_nxt = if cantsndmore tcb then acknum else snd_nxt scb - , snd_max = if cantsndmore tcb && acknum > snd_max scb then acknum else snd_max scb - , snd_wl1 = seqnum `seq_plus` 1 - , snd_wl2 = acknum - , snd_wnd = fromIntegral (tcp_win seg) `shiftL` snd_scale' - , snd_cwnd = if acknum > (iss tcb `seq_plus` 1) - then min snd_cwnd' (tcp_maxwin `shiftL` snd_scale') - else snd_cwnd' - , t_rttseg = t_rttseg' - , t_rttinf = t_rttinf' - } - , cb_rcv = rcb - { rcvq = rcvq' - , tt_delack = False - , rcv_nxt = rcv_nxt' - , rcv_wnd = rcv_wnd' - , tf_rxwin0sent = (rcv_wnd' == 0) - , rcv_adv = rcv_nxt' `seq_plus` (( rcv_wnd' `shiftR` rcv_scale') `shiftL` rcv_scale') - , last_ack_sent = rcv_nxt' - } - , cb = tcb - { --local_addr = tcp_dst seg - rcv_scale = rcv_scale' - , snd_scale = snd_scale' - , tf_doing_ws = tf_doing_ws' - , irs = seqnum - , t_maxseg = t_maxseg'' - , tf_req_tstmp = tf_doing_tstmp' - , tf_doing_tstmp = tf_doing_tstmp' - , cantrcvmore = cantrcvmore' - } - }; - } - put_sock newsock - emit_segs_ [ TCPMessage $ make_ack_segment (clock h) newsock - (cantsndmore tcb && acknum < (iss tcb `seq_plus` 2)) (ticks h)] - tcp_wakeup - return () - - diff --git a/src/Network/TCP/LTS/InData.hs b/src/Network/TCP/LTS/InData.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/InData.hs +++ /dev/null @@ -1,385 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.InData where - -import Foreign -import Foreign.C -import Control.Exception -import Control.Monad -import Data.List as List - -import Network.TCP.Type.Base -import Network.TCP.Type.Timer -import Network.TCP.Type.Socket -import Network.TCP.Type.Datagram as Datagram -import Network.TCP.Type.Syscall - -import Network.TCP.Aux.Param -import Network.TCP.Aux.Misc -import Network.TCP.Aux.Output -import Hans.Layer.Tcp.Monad -import Network.TCP.Aux.SockMonad - -import Network.TCP.LTS.User -import Network.TCP.LTS.Out - -deliver_in_3 seg = - do sock <- get_sock - h <- get_host_ - --debug $ "deliver_in_3 " ++ (show seg) - let tcb = cb sock - scb = cb_snd sock - acknum = SeqLocal (tcp_ack seg) - seqnum = SeqForeign (tcp_seq seg) `seq_plus` - if tcp_SYN seg then 1 else 0 - seg_win = fromIntegral (tcp_win seg) `shiftL` (snd_scale tcb) - let wesentafin = (snd_max scb) > (snd_una scb `seq_plus` (bufc_length $ sndq scb)) - ourfinisacked = wesentafin && tcp_ACK seg && acknum >= (snd_max scb) - - -- update idle time - -- seqnum bound checking - drop_it <- di3_topstuff seg seqnum acknum h - when (not drop_it) $ do - -- acknum bound checking - -- fast retransmit - -- correct bad retransmit - -- update send queue - ack_ok <- di3_ackstuff seg seqnum acknum seg_win h ourfinisacked - when ack_ok $ do - -- update send window - -- receive data - fin_reass <- di3_datastuff seg seqnum acknum seg_win h ourfinisacked - -- update socket state - di3_ststuff fin_reass h ourfinisacked acknum - tcp_wakeup - tcp_output_all - get_sock - -{-# INLINE di3_topstuff #-} -di3_topstuff seg seqnum acknum h = - do sock <- get_sock - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - let rseq = seqnum `seq_plus` (bufc_length $ tcp_data seg) - let seg_ts = tcp_ts seg - -- PAWS check: -- todo - let paws_failed = False - let rcv_wnd' = calculate_bsd_rcv_wnd sock - let segment_off_right_hand_edge = - (seqnum >= (rcv_nxt rcb `seq_plus` rcv_wnd')) - && (rseq > (rcv_nxt rcb `seq_plus` rcv_wnd')) - && (rcv_wnd' /= 0) - let drop_it = paws_failed || segment_off_right_hand_edge - let Just seg_ts_val = seg_ts - let (tt_keep', tt_fin_wait_2') = update_idle (clock h) sock - let ts_recent'' = if not drop_it && seg_ts /= Nothing && seqnum <= (last_ack_sent rcb) - then create_timewindow (clock h) dtsinval (fst $ seg_ts_val) - else ts_recent $ cb_time sock - modify_cb_time $ \t -> t { tt_keep = tt_keep' - , tt_fin_wait_2 = tt_fin_wait_2' - , t_idletime = clock h - , ts_recent = ts_recent'' - } - return drop_it - -{-# INLINE di3_ackstuff #-} -di3_ackstuff seg seqnum acknum seg_win h ourfinisacked = - do sock <- get_sock - let scb = cb_snd sock - if acknum > snd_max scb then return False - else if acknum > snd_una scb - then di3_newackstuff sock seg acknum h ourfinisacked - else di3_oldackstuff sock seg seqnum acknum seg_win h - -{-# INLINE di3_oldackstuff #-} -di3_oldackstuff sock seg seqnum acknum seg_win h = - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock in - let has_data = bufc_length (tcp_data seg) > 0 - && (rcv_nxt rcb) < (seqnum `seq_plus` (bufc_length $ tcp_data seg)) - && seqnum < ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb)) in - let maybe_dup_ack = not has_data - && seg_win == (snd_wnd scb) - && mode_of (tt_rexmt scb) == Just Rexmt in - if not maybe_dup_ack then do - modify_cb_snd $ \c -> c { t_dupacks = 0 } - return True - else - let t_dupacks' = t_dupacks scb + 1 in - if acknum < (snd_una scb) then - do modify_cb_snd $ \c -> c { t_dupacks = 0} - return False - else if t_dupacks' < 3 then - do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks'} - return True -- in case FIN is set - else if t_dupacks' > 3 || (t_dupacks' == 3 && tcp_do_newreno && acknum < (snd_recover tcb)) then - do modify_cb_snd $ \c -> c { t_dupacks = if t_dupacks' == 3 then 0 else t_dupacks' - , snd_cwnd = (snd_cwnd scb) + (t_maxseg tcb) - } - tcp_output False - return False - else -- t_dupacks' == 3 && not (tcp_do_newreno && acknum < (snd_recover tcb)) - do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks' - , tt_rexmt = Nothing - , t_rttseg = Nothing - , snd_nxt = acknum - , snd_cwnd = t_maxseg tcb - } - modify_cb $ \c -> c { snd_ssthresh = (max 2 ( (min (snd_wnd scb) (snd_cwnd scb)) - `div` 2 `div` (t_maxseg tcb))) - * (t_maxseg tcb) - , snd_recover = if tcp_do_newreno then snd_max scb else snd_recover c - } - tcp_output False - modify_cb_snd $ \c -> c { snd_cwnd = (snd_ssthresh tcb) + (t_maxseg tcb) * t_dupacks' - , snd_nxt = max (snd_nxt scb) (snd_nxt c) - } - return False - -{-# INLINE di3_newackstuff #-} -di3_newackstuff sock seg acknum h ourfinisacked = - do let seg_ts = tcp_ts seg - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - if (not tcp_do_newreno) || t_dupacks scb < 3 then - modify_cb_snd $ \c->c { t_dupacks = 0 - , snd_cwnd = if t_dupacks c >= 3 - then min (snd_cwnd c) (snd_ssthresh tcb) - else snd_cwnd c } - -- below: tcp_do_newreno && t_dupacks scb >= 3 - else if acknum < (snd_recover tcb) then - do modify_cb_snd $ \c -> c { tt_rexmt = Nothing - , t_rttseg = Nothing - , snd_nxt = acknum - , snd_cwnd = t_maxseg tcb } - tcp_output False - modify_cb_snd $ \c->c{ snd_cwnd = (snd_cwnd c-(acknum `seq_diff` (snd_una c))+(t_maxseg tcb)) - , snd_nxt = snd_nxt scb } - else --acknum >= snd_recover tcb - modify_cb_snd $ \c -> c { t_dupacks = 0 - , snd_cwnd = if snd_max c `seq_diff` acknum < (snd_ssthresh tcb) - then snd_max c `seq_diff` acknum + (t_maxseg tcb) - else snd_ssthresh tcb } - - let revert_rexmt = mode_of (tt_rexmt scb) `elem` [ Just Rexmt, Just RexmtSyn ] - && shift_of (tt_rexmt scb) == 1 - && timewindow_open (clock h) (t_badrxtwin $ cb_time sock) - when revert_rexmt $ do - modify_cb_snd $ \c -> c { snd_cwnd = snd_cwnd_prev tcb - , snd_nxt = snd_max scb - } - modify_cb_time $ \c -> c { t_badrxtwin = Nothing } - modify_cb $ \c -> c { snd_ssthresh = snd_ssthresh_prev tcb } - - -- to understand: timestamping - let emission_time = case (seg_ts, t_rttseg scb) of - (Just (ts_val, ts_ecr), _ ) -> Just (ts_ecr `seq_minus` 1) - (Nothing, Just (ts0, seq0)) -> if acknum > seq0 then Just ts0 else Nothing - (Nothing, Nothing) -> Nothing - -- to understand: rtt update - let t_rttinf' = case emission_time of - Just emtime -> assert ((ticks h) >= emtime) $ - update_rtt ( ((ticks h) `seq_diff` emtime)*10*1000 ) (t_rttinf scb) - Nothing -> t_rttinf scb - let tt_rexmt' = if acknum == snd_max scb then - Nothing - else case mode_of (tt_rexmt scb) of - Nothing -> start_tt_rexmt 0 True t_rttinf' (clock h) - Just Rexmt -> start_tt_rexmt 0 True t_rttinf' (clock h) - _ -> tt_rexmt scb - let (snd_wnd', sndq') = if ourfinisacked then - (snd_wnd scb - (bufc_length $ sndq scb), bufferchain_empty) - else - (snd_wnd scb - (acknum `seq_diff` (snd_una scb)), - bufferchain_drop (acknum `seq_diff` (snd_una scb)) (sndq scb)) - - modify_cb_snd $ \c -> c { t_rttinf = t_rttinf' - , tt_rexmt = tt_rexmt' - , t_rttseg = if emission_time == Nothing then t_rttseg c else Nothing - , snd_cwnd = if not tcp_do_newreno || t_dupacks scb == 0 then - expand_cwnd (snd_ssthresh tcb) - (t_maxseg tcb) - (tcp_maxwin `shiftL` (snd_scale tcb)) - (snd_cwnd c) - else snd_cwnd c - , snd_wnd = snd_wnd' - , snd_una = acknum - , snd_nxt = max acknum (snd_nxt c) - , sndq = sndq' - } - - when (st sock == TIME_WAIT) $ - modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl))} - - if (st sock == LAST_ACK) && ourfinisacked then do - modify_sock tcp_close_temp - return False - else return True - -{-# INLINE di3_datastuff #-} -di3_datastuff seg seqnum acknum seg_win h ourfinisacked = do - sock <- get_sock - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - let update_send_window = - tcp_ACK seg - && seqnum <= ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb) ) - && ( snd_wl1 scb < seqnum - || ( snd_wl1 scb == seqnum - && ( snd_wl2 scb < acknum - || ( snd_wl2 scb == acknum && seg_win > snd_wnd scb ) - ) - ) - || (st sock == SYN_RECEIVED && not (tcp_FIN seg) ) - ) - let seq_trimmed = max seqnum (min (rcv_nxt rcb) (seqnum `seq_plus` (bufc_length $ tcp_data seg))) - when update_send_window $ - --debug $ "send window updated" - modify_cb_snd $ \c -> c { snd_wnd = seg_win - , snd_wl1 = seq_trimmed - , snd_wl2 = acknum - } - if st sock == TIME_WAIT || (st sock == CLOSING && ourfinisacked) - then do modify_cb $ \c -> c { rcv_up = max (rcv_up c) (rcv_nxt rcb) } - return False - else di3_datastuff_really seg seqnum acknum seg_win h - -{-# INLINE di3_datastuff_really #-} -di3_datastuff_really seg seqnum acknum seg_win h = - do let dat = tcp_data seg - sock <- get_sock - let tcb = cb sock - scb = cb_snd sock - rcb = cb_rcv sock - - let trim_amt_left = if rcv_nxt rcb > seqnum - then min (rcv_nxt rcb `seq_diff` seqnum) (bufc_length dat) - else 0 - data_trimmed_left = bufferchain_drop trim_amt_left dat - seq_trimmed = seqnum `seq_plus` trim_amt_left - let data_trimmed_left_right = bufferchain_take (rcv_wnd rcb) data_trimmed_left - fin_trimmed = if bufc_length data_trimmed_left_right == - bufc_length data_trimmed_left then tcp_FIN seg else False - let rseg = TCPReassSegment { trs_seq = seq_trimmed - , trs_FIN = fin_trimmed - , trs_data = data_trimmed_left_right - } - -- processing incoming data - if seq_trimmed == rcv_nxt rcb - && seq_trimmed `seq_plus` (bufc_length data_trimmed_left_right) - `seq_plus` (if fin_trimmed then 1 else 0) > (rcv_nxt rcb) - && rcv_wnd rcb > 0 - then do - -- case 1: reassambling possible - let have_stuff_to_ack = bufc_length data_trimmed_left_right >0 || fin_trimmed - let delay_ack = st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, FIN_WAIT_2, CLOSING, LAST_ACK] - && have_stuff_to_ack && not fin_trimmed && List.null (t_segq rcb) - && not (tf_rxwin0sent rcb) - && tt_delack rcb == False - let rsegq = rseg:(t_segq rcb) - let (data_reass, rcv_nxt', fin_reass0, t_segq') = tcp_reass (rcv_nxt rcb) rsegq - let rcvq' = bufferchain_concat (rcvq rcb) data_reass - let rcv_wnd' = rcv_wnd rcb - (bufc_length data_reass) - modify_cb_rcv $ \c -> c - { tt_delack = if delay_ack then True else tt_delack c - , tf_shouldacknow = if have_stuff_to_ack then not delay_ack else tf_shouldacknow c - , t_segq = t_segq' - , rcv_nxt = rcv_nxt' - , rcv_wnd = rcv_wnd' - , rcvq = rcvq' - } - return fin_reass0 - else if seq_trimmed > (rcv_nxt rcb) - && seq_trimmed < ((rcv_nxt rcb) `seq_plus` (rcv_wnd rcb)) - && bufc_length data_trimmed_left_right + (if fin_trimmed then 1 else 0) > 0 - && rcv_wnd rcb > 0 - then do - -- case 2: wait for future reassambling - modify_cb_rcv $ \c -> c { t_segq = rseg:(t_segq c) - , tf_shouldacknow = True - } - return False - else if tcp_ACK seg && seq_trimmed == rcv_nxt rcb - && bufc_length dat + (if tcp_FIN seg then 1 else 0) == 0 then - -- case 3: no data - return False - else do - -- case 4: other cases... maybe windows is closed - modify_cb_rcv $ \c -> c { tf_shouldacknow = True } - return False - -{-# INLINE di3_ststuff #-} -di3_ststuff fin_reass h ourfinisacked acknum = - do sock <- get_sock - let tcb = cb sock - let enter_TIME_WAIT = do - modify_sock $ \s -> s { st = TIME_WAIT } - modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl)) - , tt_keep = Nothing - , tt_conn_est = Nothing - , tt_fin_wait_2 = Nothing - } - modify_cb_snd $ \c -> c { tt_rexmt = Nothing } - modify_cb_rcv $ \c -> c { tt_delack = False } - - when fin_reass $ - modify_cb $ \s -> s { cantrcvmore = True } - - case (st sock, fin_reass) of - (SYN_RECEIVED,False) -> when (acknum >= (iss tcb) `seq_plus` 1 ) $ - modify_sock $ \s -> s - { st = if not (cantsndmore tcb) then ESTABLISHED else - if ourfinisacked then FIN_WAIT_2 else FIN_WAIT_1 - } - (SYN_RECEIVED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT } - (ESTABLISHED, False) -> return () - (ESTABLISHED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT } - (CLOSE_WAIT, _ ) -> return () - (FIN_WAIT_1, False) -> when ourfinisacked $ do - modify_sock $ \s -> s { st = FIN_WAIT_2 } - when (cantrcvmore tcb) $ - modify_cb_time $ \c -> c { tt_fin_wait_2 = - Just (create_timer (clock h) (tcptv_maxidle)) } - (FIN_WAIT_1, True) -> if ourfinisacked then enter_TIME_WAIT - else modify_sock $ \s->s { st=CLOSING } - (FIN_WAIT_2, False) -> return () - (FIN_WAIT_2, True) -> enter_TIME_WAIT - (CLOSING, _) -> when ourfinisacked enter_TIME_WAIT - (LAST_ACK, False) -> return () - (LAST_ACK, True) -> error "di3_ststuff" - (TIME_WAIT, _ ) -> return () diff --git a/src/Network/TCP/LTS/InMisc.hs b/src/Network/TCP/LTS/InMisc.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/InMisc.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.InMisc where - - diff --git a/src/Network/TCP/LTS/InPassive.hs b/src/Network/TCP/LTS/InPassive.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/InPassive.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.InPassive where -import Data.List as List -import Control.Exception -import Control.Monad - ---import Foreign.C -import Network.TCP.Type.Base -import Network.TCP.Type.Syscall -import Network.TCP.Type.Timer -import Network.TCP.Type.Socket -import Network.TCP.Type.Datagram -import Network.TCP.Aux.Misc -import Network.TCP.Aux.Param -import Network.TCP.Aux.Output -import Hans.Layer.Tcp.Monad -import Network.TCP.Aux.SockMonad - -import Network.TCP.LTS.Out -import Network.TCP.LTS.User - -tcp_deliver_syn_packet seg = do - -- precondition: sid does not exist - -- try if seg matches a listening socket... - let sidlisten = SocketID ((get_port $ tcp_dst seg), TCPAddr (IPAddr 0,0)) - h <- get_host - haslisten <- has_sock sidlisten - if not haslisten then return () else do - -- matches a socket... - sock <- lookup_sock sidlisten - if st sock /= LISTEN then return () else do - -- now we find a listening socket maching incoming SYN=1 ACK=0 RST=0 - if accept_incoming_q0 (sock_listen sock) - then deliver_in_1 sidlisten sock seg - else return () - -deliver_in_1 sid sock seg = - do let newsid = SocketID ((get_port $ tcp_dst seg), tcp_src seg) - h <- get_host - -- at this point, newsid is an unique socket id in the system... - - -- drop the first sid from q0 if needed, append newsid to q0. - let lis1 = sock_listen sock - should_drop = drop_from_q0 lis1 - drop_sid = head $ lis_q0 lis1 - oldq = lis_q0 lis1 - newq = if should_drop then tail oldq else oldq - lis2 = lis1 { lis_q0 = newq++[newsid]} - -- update listening socket (sid) - update_sock sid $ \_ -> sock { sock_listen = lis2 } - -- delete old socket if needed - when should_drop $ tcp_close drop_sid - - -- Create a new socket - let advmss = mssdflt -- todo: lookup interface mss - advmss' = Nothing -- not advertising MSS (todo: change it) - - tf_rcvd_tstmp = case tcp_ts seg of Just _ -> True; Nothing -> False - tf_doing_tstmp' = False -- not doing timestamping (todo: change it) - - (rcvbufsize', sndbufsize', t_maxseg', snd_cwnd') = - calculate_buf_sizes advmss (tcp_mss seg) Nothing False - (freebsd_so_rcvbuf) (freebsd_so_sndbuf) tf_doing_tstmp' - - tf_doing_ws' = False -- not doing window scaling (todo: change it) - rcv_scale' = 0 - snd_scale' = 0 - rcv_window = min tcp_maxwin freebsd_so_rcvbuf - - newiss = SeqLocal 1000 -- beginning iss. (todo: add more randomness) - t_rttseg' = Just (ticks h, newiss) - seqnum = SeqForeign (tcp_seq seg) - acknum = SeqLocal (tcp_ack seg) - ack' = seqnum `seq_plus` 1 - cb_time' = (cb_time sock) - { tt_keep = Just (create_timer (clock h) tcptv_keep_idle) - , ts_recent = case (tcp_ts seg) of - Nothing -> ts_recent (cb_time sock) - Just (ts_val, ts_ecr) -> create_timewindow (clock h) (dtsinval) ts_val - } - cb_snd' = (cb_snd sock) - { tt_rexmt = start_tt_rexmt 0 False (t_rttinf (cb_snd sock)) (clock h) - , snd_una = newiss - , snd_max = newiss `seq_plus` 1 - , snd_nxt = newiss `seq_plus` 1 - , snd_cwnd = snd_cwnd' - , t_rttseg = t_rttseg' - } - cb_rcv' = (cb_rcv sock) - { rcv_wnd = rcv_window - , tf_rxwin0sent = (rcv_window == 0) - , last_ack_sent = ack' - , rcv_adv = ack' `seq_plus` rcv_window - , rcv_nxt = ack' - } - cb' = (cb sock) - { iss = newiss - , irs = seqnum - , rcv_up = seqnum `seq_plus` 1 - , t_maxseg = t_maxseg' - , t_advmss = advmss' - , rcv_scale = rcv_scale' - , snd_scale = snd_scale' - , tf_doing_ws = tf_doing_ws' - , tf_req_tstmp = tf_doing_tstmp' - , tf_doing_tstmp = tf_doing_tstmp' - , local_addr = tcp_dst seg - , remote_addr = tcp_src seg - , self_id = newsid - , parent_id = sid - } - -- create new socket (newsid) - let newsock = initial_tcp_socket - { st = SYN_RECEIVED - , cb = cb' - , cb_time = cb_time' - , cb_snd = cb_snd' - , cb_rcv = cb_rcv' - } - insert_sock newsid newsock - -- emit [SYN,ACK] packet - emit_segs [TCPMessage $ make_syn_ack_segment (clock h) newsock - (tcp_dst seg) (tcp_src seg) (ticks h) ] - --- After receiving ACK on SYN_RECEIVED, a connection is established. --- Now we need to update the queues of the listening socket... -di3_socks_update sid = do - h <- get_host - -- precondition: sid exists - newsock <- lookup_sock sid - let tcb = cb newsock - rcb = cb_rcv newsock - sidlisten = parent_id tcb - haslisten <- has_sock sidlisten - assert (haslisten) return () - listensock <- lookup_sock sidlisten - let lis1 = sock_listen listensock - assert (sid `elem` (lis_q0 lis1)) return () - -- found the listening socket! - if accept_incoming_q lis1 then do - -- delete socket from q0 - -- move into completed queue - let lis2 = lis1 { lis_q0 = List.delete sid (lis_q0 lis1) - , lis_q = sid : (lis_q lis1) - } - let rcv_window = calculate_bsd_rcv_wnd newsock - let newcb = (cb_rcv newsock) { rcv_wnd = rcv_window - , rcv_adv = (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb) - } - update_sock sidlisten $ \_ -> listensock { sock_listen = lis2 } - update_sock sid $ \_ -> newsock { cb_rcv = newcb } - runSMonad sidlisten $ tcp_wakeup - else do - -- delete socket from q0, backlog full -> delete socket - let lis2 = lis1 { lis_q0 = List.delete sid (lis_q0 lis1) } - update_sock sidlisten $ \_ -> listensock { sock_listen = lis2 } - tcp_close sid - --endif - - diff --git a/src/Network/TCP/LTS/Out.hs b/src/Network/TCP/LTS/Out.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/Out.hs +++ /dev/null @@ -1,225 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.Out - ( tcp_output_all - , tcp_output - , tcp_close - , tcp_drop_and_close - ) -where - -import Hans.Message.Tcp - -import Data.List as List -import Network.TCP.Aux.Output -import Network.TCP.Aux.Misc -import Network.TCP.Type.Base -import Network.TCP.Type.Syscall -import Network.TCP.Type.Socket -import Hans.Layer.Tcp.Monad -import Network.TCP.Aux.SockMonad -import Control.Monad -import Control.Exception -import Foreign -import Network.TCP.Type.Timer -import Network.TCP.Type.Datagram as Datagram -import Network.TCP.Aux.Param - -tcp_output_all :: SMonad t () -tcp_output_all = do - h <- get_host_ - sock <- get_sock - let scb = cb_snd sock - tcb = cb sock - when ((st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, - FIN_WAIT_2, CLOSING, LAST_ACK, TIME_WAIT] - && (snd_una scb /= iss tcb)) -- does this make sense? - || ( st sock `elem` [SYN_SENT, SYN_RECEIVED] && - cantsndmore tcb && (tf_shouldacknow $ cb_rcv sock))) $ - output_loop h sock - -output_loop h sock = - let (sock1, outsegs) = tcp_output_really (clock h) False (ticks h) sock in - if List.null outsegs then - put_sock sock1 - else do - --debug $ "tcp_output_all: " ++ (show outsegs) - emit_segs_ $! outsegs - output_loop h sock1 - -{-# INLINE tcp_output_all #-} -{-# INLINE output_loop #-} - - -{-# INLINE tcp_output_really #-} - -tcp_output_really (curr_time :: Time) (window_probe::Bool) (ts_val'::Timestamp) tcp_sock = - let tcb = cb tcp_sock - scb = cb_snd tcp_sock - rcb = cb_rcv tcp_sock - in - assert ((rcv_adv rcb) >= (rcv_nxt rcb)) $ - assert ((snd_nxt scb) >= (snd_una scb)) $ - let snd_cwnd' = if snd_max scb == snd_una scb && - (t_idletime $ cb_time tcp_sock) - curr_time - >= (computed_rxtcur $ t_rttinf scb) - then (t_maxseg tcb) * ss_fltsz -- has been idle for a while, slowstart - else snd_cwnd scb - win0 = min (snd_wnd scb) snd_cwnd' - win = if window_probe && win0==0 then 1 else win0 - snd_wnd_unused ::Int = win - ((snd_nxt scb) `seq_diff` (snd_una scb)) - syn_not_acked = (st tcp_sock `elem` [SYN_SENT, SYN_RECEIVED]) - fin_required = (cantsndmore tcb && st tcp_sock `notElem` [FIN_WAIT_2, TIME_WAIT]) - last_sndq_data_seq = (snd_una scb) `seq_plus` (bufc_length $ sndq scb) - last_sndq_data_and_fin_seq = last_sndq_data_seq `seq_plus` - (if fin_required then 1 else 0) `seq_plus` - (if syn_not_acked then 1 else 0) - have_data_to_send = (snd_nxt scb) < last_sndq_data_seq - have_data_or_fin_to_send = (snd_nxt scb) < last_sndq_data_and_fin_seq - window_update_delta = (min (tcp_maxwin `shiftL` (rcv_scale tcb)) - (freebsd_so_rcvbuf - (bufc_length $ rcvq rcb)) - ) - ( (rcv_adv rcb) `seq_diff` (rcv_nxt rcb)) - need_to_send_a_window_update = (window_update_delta >= 2 * (t_maxseg tcb)) || - (2*window_update_delta >= freebsd_so_rcvbuf) - do_output = ( have_data_or_fin_to_send && (if have_data_to_send then snd_wnd_unused>0 else True) ) - || need_to_send_a_window_update -- sndurp tcp_sock /= Nothing - || tf_shouldacknow rcb - cant_send = (not do_output) && - (bufc_length (sndq scb) > 0 ) && - mode_of (tt_rexmt scb) == Nothing - window_shrunk = win==0 && - snd_wnd_unused <0 && - st tcp_sock /= SYN_SENT - tcp_sock0 = if cant_send then - tcp_sock { cb_snd = scb {tt_rexmt = start_tt_persist 0 (t_rttinf scb) curr_time}} - else if window_shrunk then - tcp_sock { cb_snd = scb { - tt_rexmt = case tt_rexmt scb of - Just(Timed (Persist, shift) d ) -> Just (Timed (Persist, 0) d) - _ -> start_tt_persist 0 (t_rttinf scb) curr_time - , snd_nxt = snd_una scb - }} - else tcp_sock - in - if (not do_output) then (tcp_sock0, []) else - ------------ really do it --------------------------------------------- - let tcp_sock = tcp_sock0 - scb = cb_snd tcp_sock - - data' = bufferchain_drop (snd_nxt scb `seq_diff` (snd_una scb)) (sndq scb) - data_to_send = bufferchain_take (min (snd_wnd_unused) ( t_maxseg tcb)) data' - bFIN = fin_required && (snd_nxt scb) `seq_plus` (bufc_length data_to_send) >= last_sndq_data_seq - bACK = if bFIN && st tcp_sock == SYN_SENT then False else True - snd_nxt' = if bFIN && - ((snd_nxt scb `seq_plus` (bufc_length data_to_send) == - last_sndq_data_seq `seq_plus` 1 && snd_una scb /= iss tcb ) - || (snd_nxt scb) `seq_diff` (iss tcb) == 2) - then snd_nxt scb `seq_minus` 1 - else snd_nxt scb - bPSH = bufc_length data_to_send > 0 && - snd_nxt scb `seq_plus` (bufc_length data_to_send) == last_sndq_data_seq - rcv_wnd'' = calculate_bsd_rcv_wnd tcp_sock - rcv_wnd' = max (rcv_adv rcb `seq_diff` (rcv_nxt rcb)) - (min (tcp_maxwin `shiftL` (rcv_scale tcb)) - (if rcv_wnd'' < (freebsd_so_rcvbuf `div` 4) && rcv_wnd'' < (t_maxseg tcb) - then 0 else rcv_wnd'')) - want_tstmp = if st tcp_sock == SYN_SENT then tf_req_tstmp tcb else tf_doing_tstmp tcb - ts_ = do_tcp_options curr_time want_tstmp (ts_recent $ cb_time tcp_sock) ts_val' - in - let win_ = rcv_wnd' `shiftR` (rcv_scale tcb) - hdr = set_tcp_ts ts_ emptyTcpHeader - { tcpSeqNum = TcpSeqNum (seq_val snd_nxt') - , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt rcb)) - , tcpAck = bACK - , tcpPsh = bPSH - , tcpFin = bFIN - , tcpWindow = fromIntegral win_ - } - seg = mkTCPSegment' (local_addr tcb) (remote_addr tcb) hdr data_to_send - st' = if bFIN then - case st tcp_sock of - ESTABLISHED -> FIN_WAIT_1 - CLOSE_WAIT -> LAST_ACK - xxx -> xxx - else - st tcp_sock - snd_nxt'' = snd_nxt' `seq_plus` (bufc_length data_to_send) `seq_plus` (if bFIN then 1 else 0) - snd_max' = max (snd_max scb) snd_nxt'' - tt_rexmt' = if (mode_of (tt_rexmt scb) == Nothing || - (mode_of (tt_rexmt scb) == Just Persist && not window_probe)) && - snd_nxt'' > (snd_una scb) then - start_tt_rexmt 0 False (t_rttinf scb) curr_time - else if (window_probe {-- || sndurp tcp_sock /= Nothing --} ) && win0 /= 0 && - mode_of (tt_rexmt scb) == Just Persist then - Nothing - else - tt_rexmt scb - t_rttseg' = if t_rttseg scb == Nothing && (bufc_length data_to_send > 0 || bFIN) && - snd_nxt'' > (snd_max scb) && not window_probe then - Just (ts_val', snd_nxt') - else - t_rttseg scb - tcp_sock' = tcp_sock - { st = st' - , cb_snd = scb { tt_rexmt = tt_rexmt' - , snd_cwnd = snd_cwnd' - , t_rttseg = t_rttseg' - , snd_max = snd_max' - , snd_nxt = snd_nxt'' - } - , cb_rcv = rcb { last_ack_sent = rcv_nxt rcb - , rcv_adv = rcv_nxt rcb `seq_plus` rcv_wnd' - , tt_delack = False - , rcv_wnd = rcv_wnd' - , tf_rxwin0sent = (rcv_wnd' == 0) - , tf_shouldacknow = False - } - } - outsegs' = [TCPMessage seg] - in - (tcp_sock', outsegs') - -{-# INLINE tcp_output #-} -tcp_output :: Bool -> SMonad t () -tcp_output win_probe = - do sock <- get_sock - h <- get_host_ - let (newsock, segs) = tcp_output_really (clock h) win_probe (ticks h) sock - put_sock newsock - emit_segs_ segs - --if List.null segs then return () else debug $ "tcp_output: " ++ (show segs) - - - diff --git a/src/Network/TCP/LTS/User.hs b/src/Network/TCP/LTS/User.hs deleted file mode 100644 --- a/src/Network/TCP/LTS/User.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.LTS.User - ( tcp_process_user_request - , tcp_wakeup - ) -where - -import Foreign.C -import Data.List as List -import Control.Monad -import Data.Maybe -import Network.TCP.Type.Base -import Network.TCP.Type.Datagram -import Network.TCP.Type.Syscall -import Network.TCP.Type.Socket -import Hans.Layer.Tcp.Monad -import Network.TCP.Aux.SockMonad -import Network.TCP.Aux.Misc -import Network.TCP.Aux.Param -import Network.TCP.Aux.Output - -import Network.TCP.LTS.Out - ---------------------------------------------------------------------------------------- --- input: a list of sock request --- output: threads that have taken the completed requests (back in running state) --- side effect: host state changes --- blocked threads goes into the wait queue of each socket --- tcp_process_user_requests :: (Monad m) => [(SockReq,SockRsp->t)] -> HMonad t m [t] --- tcp_process_user_requests reqs = --- do r <- mapM tcp_process_user_request reqs --- return $ concat r - -tcp_process_user_request :: (SockReq,SockRsp->t) -> HMonad t (Maybe t) -tcp_process_user_request (req, cont) = - case req of - SockListen addr -> process_listen addr cont - SockClose sid -> process_close sid cont - SockConnect local addr -> process_connect local addr cont - SockAccept sid -> process_accept sid cont - SockSend sid d -> process_send sid d cont - SockRecv sid -> process_recv sid cont - -tcp_wakeup_request req cont = - case req of - SockConnect local addr -> wakeup_connect cont - SockAccept sid -> wakeup_accept sid cont - SockSend sid d -> wakeup_send sid d cont - SockRecv sid -> wakeup_recv sid cont - --- pre-cond: sock is set --- post-cond: sock is set, tcp_output needed -tcp_wakeup = - do sock <- get_sock - case waiting_list sock of - [] -> return () - (req,cont):reqs -> do - res <- tcp_wakeup_request req cont - case res of - Nothing -> return () - Just th -> do - emit_ready_ [th] - modify_sock $ \s -> s {waiting_list = reqs} - --- pre-cond: sock not set --- post-cond: sock not set -process_listen :: Port -> (SockRsp->t) -> HMonad t (Maybe t) -process_listen port cont = - do let sock_id = SocketID (port, TCPAddr (IPAddr 0,0)) - h <- get_host - -- check if port has been used... - if port `elem` (local_ports h) then - do let listen = SocketListen [] [] listen_qlimit - let newsock = initial_tcp_socket - { cb = (cb initial_tcp_socket) { local_addr = TCPAddr (IPAddr 0,port), self_id=sock_id } - , st = LISTEN - , sock_listen = listen - } - insert_sock sock_id newsock - modify_host $ \h -> h { local_ports = List.delete port (local_ports h) } - return $ Just $ cont $ SockNew sock_id - else - return $ Just $ cont $ SockError "Port not available" - -process_close :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) -process_close sid cont = - do ok <- has_sock sid - if not ok then - return $ Just $ cont $ SockError "Socket not found" - else do - sock <- lookup_sock sid - if st sock `elem` [CLOSED,SYN_SENT,SYN_RECEIVED] then do - -- close_7 : delete sid - tcp_close sid - return $ Just $ cont $ SockOK - else if st sock /= LISTEN then runSMonad sid $ do - -- close_1 : change the flags so FIN can be sent later - modify_sock $ \sock-> sock { cb = (cb sock) { cantsndmore=True, cantrcvmore=True} - , cb_rcv = (cb_rcv sock) { rcvq=bufferchain_empty } - } - tcp_output_all - return $ Just $ cont $ SockOK - else do - -- close_8 : closing a LISTEN socket - -- todo: not implemented yet - return $ Just $ cont $ SockError "not implemented yet: close_8 : closing a LISTEN socket" - --- pre-cond: sock not set --- post-cond: sock not set -process_accept :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) -process_accept sid cont = - do ok <- has_sock sid - if not ok then - return $ Just $ cont $ SockError "Socket not found" - else runSMonad sid $ do - res <- try_accept cont - when (isNothing res) $ - -- put thread in waiting list - modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockAccept sid, cont)] } - return res -wakeup_accept sid cont - = try_accept cont - --- pre-cond: sock is set --- post-cond: sock is set, listening queue updated -try_accept :: (SockRsp->t) -> SMonad t (Maybe t) -try_accept cont = - do sock <- get_sock - if st sock /= LISTEN then - return $ Just $ cont $ SockError "Socket not in LISTEN state" - else do - -- find the listen queue - let listen = sock_listen sock - case lis_q listen of - [] -> return Nothing -- no connection to accept, can't proceed - (sid2:qs) -> do -- try to accept sid2, either success or fail - modify_sock $ \sock -> sock { sock_listen = listen { lis_q = qs } } - return $ Just $ cont $ SockNew sid2 - -process_recv :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) -process_recv sid cont = - do ok <- has_sock sid - if not ok then - return $ Just $ cont $ SockError "Socket not found" - else runSMonad sid $ do - res <- try_recv cont - when (isNothing res) $ - -- put thread in waiting list - modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockRecv sid, cont)] } - return res - -wakeup_recv sid cont = - try_recv cont - -try_recv :: (SockRsp->t) -> SMonad t (Maybe t) -try_recv cont = - do sock <- get_sock - let q = rcvq $ cb_rcv sock - if st sock `elem` [ CLOSED, SYN_SENT, SYN_RECEIVED] then - return $ Just $ cont $ SockError "Socket not in synchronized state" - else if bufc_length q == 0 then - if cantrcvmore $ cb sock - then return $ Just $ cont $ SockData buffer_empty -- EOF - else return Nothing -- no data, can't proceed - else do - -- let rcvnum = min size (length q) - -- (q1,q2) = splitAt rcvnum q - put_sock $ sock { cb_rcv = (cb_rcv sock) {rcvq = bufferchain_tail q }} - return $ Just $ cont $ SockData $ bufferchain_head q - -process_send :: SocketID -> Buffer -> (SockRsp->t) -> HMonad t (Maybe t) -process_send sid d cont = - do ok <- has_sock sid - if not ok then - return $ Just $ cont $ SockError "Socket not found" - else runSMonad sid $ do - (res,remain) <- try_send d cont - when (isNothing res) $ - -- put thread in waiting list - modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockSend sid remain, cont)] } - return res - -wakeup_send sid d cont = - do (res,remain) <- try_send d cont - when (isNothing res) $ - -- put thread in waiting list again - modify_sock $ \sock -> sock {waiting_list = (tail $ waiting_list sock)++[(SockSend sid remain, cont)] } - return res - -try_send :: Buffer -> (SockRsp->t) -> SMonad t (Maybe t, Buffer) -try_send d cont = - do sock <- get_sock - if st sock `notElem` [ ESTABLISHED, CLOSE_WAIT] then - return (Just $ cont $ SockError "Socket not in synchronized state", buffer_empty ) - else if cantsndmore $ cb sock then - return (Just $ cont $ SockError "Socket cantsndmore=true, cannot send...", buffer_empty) - else do - let max_can_send = freebsd_so_sndbuf - (bufc_length $ sndq $ cb_snd sock) - num_to_send = min max_can_send (buf_len d) - (d1,d2) = buffer_split num_to_send d - modify_cb_snd $ \c -> c { sndq = (sndq c) `bufferchain_append` d1 } - --if (bufc_length (sndq $ cb_snd $ sock) == 0) then - -- modify_cb_rcv $ \c -> c { tt_delack = True } - -- else - tcp_output_all - if buf_len d2 == 0 then return (Just $ cont $ SockOK, d2) - else return (Nothing, d2) - - -process_connect :: IPAddr -> TCPAddr -> (SockRsp->t) -> HMonad t (Maybe t) -process_connect local addr cont = do - h <- get_host - m_port <- alloc_local_port - if m_port == Nothing then return $ Just $ cont $ SockError "cannot allocate local port" else do - let (Just port) = m_port - sock_id = SocketID (port, addr) - newiss = SeqLocal 1000 -- beginning iss. (todo: add more randomness) - request_r_scale' = 0 - rcv_wnd' = freebsd_so_rcvbuf - adv_mss = Just mssdflt - tf_req_tstmp' = False -- todo: change it - t_rttseg' = Just (ticks h, newiss) - let { newsock = initial_tcp_socket - { st = SYN_SENT - , cb_time = initial_cb_time - { tt_conn_est = Just (create_timer (clock h) tcptv_keep_init) - } - , cb_snd = initial_cb_snd - { tt_rexmt = start_tt_rexmtsyn 0 False (t_rttinf initial_cb_snd) (clock h) - , snd_una = newiss - , snd_nxt = newiss `seq_plus` 1 - , snd_max = newiss `seq_plus` 1 - , t_rttseg = t_rttseg' - } - , cb_rcv = initial_cb_rcv - { rcv_wnd = rcv_wnd' - , rcv_adv = (rcv_nxt initial_cb_rcv) `seq_plus` rcv_wnd' - , tf_rxwin0sent = (rcv_wnd' == 0) - } - , cb = initial_cb_misc - { local_addr = TCPAddr (local,port) - , remote_addr = addr - , self_id=sock_id - , cantsndmore = False - , cantrcvmore = False - , iss = newiss - , request_r_scale = Just request_r_scale' - , t_advmss = adv_mss - , tf_req_tstmp = tf_req_tstmp' - } - }} - insert_sock sock_id newsock - emit_segs $ [TCPMessage $ make_syn_segment (clock h) newsock (ticks h)] - return $ Nothing - -wakeup_connect :: (SockRsp->t) -> SMonad t (Maybe t) -wakeup_connect cont = do - sock <- get_sock - if st sock == SYN_SENT - then return Nothing - else return $ Just $ cont $ SockNew $ self_id $ cb sock diff --git a/src/Network/TCP/Type/Base.hs b/src/Network/TCP/Type/Base.hs deleted file mode 100644 --- a/src/Network/TCP/Type/Base.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Type.Base where - -import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime) -import Foreign -import Foreign.C -import System.IO.Unsafe -import Control.Exception -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - - -to_Int x = (fromIntegral x)::Int -to_Int8 x = (fromIntegral x)::Int8 -to_Int16 x = (fromIntegral x)::Int16 -to_Int32 x = (fromIntegral x)::Int32 -to_Int64 x = (fromIntegral x)::Int64 - -to_Word x = (fromIntegral x)::Word -to_Word8 x = (fromIntegral x)::Word8 -to_Word16 x = (fromIntegral x)::Word16 -to_Word32 x = (fromIntegral x)::Word32 -to_Word64 x = (fromIntegral x)::Word64 - - -{-# INLINE to_Int #-} -{-# INLINE to_Int8 #-} -{-# INLINE to_Int16 #-} -{-# INLINE to_Int32 #-} -{-# INLINE to_Int64 #-} -{-# INLINE to_Word #-} -{-# INLINE to_Word8 #-} -{-# INLINE to_Word16 #-} -{-# INLINE to_Word32 #-} -{-# INLINE to_Word64 #-} - --- Port numbers, IP addresses - -type Port = Word16 -newtype IPAddr = IPAddr Word32 deriving (Eq,Ord) -newtype TCPAddr = TCPAddr (IPAddr, Port) deriving (Eq,Ord) -newtype SocketID = SocketID (Port, TCPAddr) deriving (Eq,Ord,Show) - -instance Show IPAddr where - show (IPAddr w) = (show $ w .&. 255) ++ "." ++ - (show $ (w `shiftR` 8) .&. 255) ++ "." ++ - (show $ (w `shiftR` 16) .&. 255) ++ "." ++ - (show $ (w `shiftR` 24) .&. 255) -instance Show TCPAddr where - show (TCPAddr (ip,pt)) = (show ip) ++ ":" ++ (show pt) - - -get_ip :: TCPAddr -> IPAddr -get_ip (TCPAddr (i,p)) = i - -get_port :: TCPAddr -> Port -get_port (TCPAddr (i,p)) = p - -get_remote_addr :: SocketID -> TCPAddr -get_remote_addr (SocketID (p,a)) = a - -get_local_port :: SocketID -> Port -get_local_port (SocketID (p,a)) = p - -{-# INLINE get_ip #-} -{-# INLINE get_port #-} -{-# INLINE get_remote_addr #-} -{-# INLINE get_local_port #-} - --- TCP Sequence numbers - -class (Eq a) => Seq32 a where - seq_val :: a -> Word32 - seq_lt :: a -> a -> Bool - seq_leq :: a -> a -> Bool - seq_gt :: a -> a -> Bool - seq_geq :: a -> a -> Bool - seq_plus :: (Integral n) => a -> n -> a - seq_minus :: (Integral n) => a -> n -> a - seq_diff :: (Integral n) => a -> a -> n - -instance Seq32 Word32 where - seq_val w = w - seq_lt x y = (to_Int32 (x-y)) < 0 - seq_leq x y = (to_Int32 (x-y)) <= 0 - seq_gt x y = (to_Int32 (x-y)) > 0 - seq_geq x y = (to_Int32 (x-y)) >= 0 - seq_plus s i = assert (i>=0) $ s + (to_Word32 i) - seq_minus s i = assert (i>=0) $ s - (to_Word32 i) - seq_diff s t = let res=fromIntegral $ to_Int32 (s-t) in assert (res>=0) res - {-# INLINE seq_val #-} - {-# INLINE seq_lt #-} - {-# INLINE seq_leq #-} - {-# INLINE seq_gt #-} - {-# INLINE seq_geq #-} - {-# INLINE seq_plus #-} - {-# INLINE seq_minus #-} - {-# INLINE seq_diff #-} - -newtype SeqLocal = SeqLocal Word32 deriving (Eq,Show,Seq32) -newtype SeqForeign = SeqForeign Word32 deriving (Eq,Show,Seq32) -newtype Timestamp = Timestamp Word32 deriving (Eq,Show,Seq32) - -instance Ord SeqLocal where - (<) = seq_lt - (>) = seq_gt - (<=) = seq_leq - (>=) = seq_geq - {-# INLINE (<) #-} - {-# INLINE (>) #-} - {-# INLINE (<=) #-} - {-# INLINE (>=) #-} -instance Ord SeqForeign where - (<) = seq_lt - (>) = seq_gt - (<=) = seq_leq - (>=) = seq_geq - {-# INLINE (<) #-} - {-# INLINE (>) #-} - {-# INLINE (<=) #-} - {-# INLINE (>=) #-} -instance Ord Timestamp where - (<) = seq_lt - (>) = seq_gt - (<=) = seq_leq - (>=) = seq_geq - {-# INLINE (<) #-} - {-# INLINE (>) #-} - {-# INLINE (<=) #-} - {-# INLINE (>=) #-} - -seq_flip_ltof (SeqLocal w) = SeqForeign w -seq_flip_ftol (SeqForeign w) = SeqLocal w - -fseq_val :: SeqForeign -> Word32 -fseq_val (SeqForeign w32) = w32 - -{-# INLINE seq_flip_ltof #-} -{-# INLINE seq_flip_ftol #-} - - --- | Clock time, in microseconds. -type Time = Int64 - -seconds_to_time :: RealFrac a => a -> Time -seconds_to_time f = round (f * 1000*1000) - -{-# INLINE seconds_to_time #-} - -get_current_time :: IO Time -get_current_time = posixtime_to_time `fmap` getPOSIXTime - -posixtime_to_time :: POSIXTime -> Time -posixtime_to_time = seconds_to_time . toRational - ---------------------------------------------------------------------------- - -type Buffer = S.ByteString - -buf_len :: Buffer -> Int -buf_len = S.length - -buffer_ok :: Buffer -> Bool -buffer_ok _ = True - -buffer_empty :: Buffer -buffer_empty = S.empty - -buffer_to_string :: Buffer -> IO String -buffer_to_string = return . map (toEnum . fromEnum) . S.unpack - -string_to_buffer :: String -> IO Buffer -string_to_buffer = return . S.pack . map (toEnum . fromEnum) - -buffer_split :: Int -> Buffer -> (Buffer,Buffer) -buffer_split = S.splitAt - -buffer_take = S.take -buffer_drop = S.drop - -buffer_merge :: Buffer -> Buffer -> [Buffer] -buffer_merge bs1 bs2 - | S.length bs1 == 0 = [bs2] - | S.length bs2 == 0 = [bs1] - | otherwise = [bs1,bs2] - - -type BufferChain = L.ByteString - -bufc_length :: BufferChain -> Int -bufc_length = fromIntegral . L.length - -bufferchain_empty = L.empty -bufferchain_singleton b - | S.null b = L.empty - | otherwise = L.fromChunks [b] - -bufferchain_add bs bc = bufferchain_singleton bs `L.append` bc - -bufferchain_get :: BufferChain -> Int -> BufferChain -bufferchain_get bc ix = L.take 1 (L.drop (fromIntegral ix) bc) - -bufferchain_append bc bs = bc `L.append` bufferchain_singleton bs - -bufferchain_concat :: BufferChain -> BufferChain -> BufferChain -bufferchain_concat = L.append - -bufferchain_head :: BufferChain -> Buffer -bufferchain_head = head . L.toChunks - -bufferchain_tail :: BufferChain -> BufferChain -bufferchain_tail = L.fromChunks . tail . L.toChunks - -bufferchain_take :: Int -> BufferChain -> BufferChain -bufferchain_take = L.take . fromIntegral - -bufferchain_drop :: Int -> BufferChain -> BufferChain -bufferchain_drop = L.drop . fromIntegral - -bufferchain_split_at :: Int -> BufferChain -> (BufferChain,BufferChain) -bufferchain_split_at = L.splitAt . fromIntegral - -bufferchain_collapse :: BufferChain -> IO Buffer -bufferchain_collapse = return . S.concat . L.toChunks - --- bufferchain_output bc@(BufferChain lst len) (ptr::Ptr CChar) = --- copybuf ptr lst --- where copybuf ptrDest [] = return () --- copybuf ptrDest (x:xs) = --- withForeignPtr (buf_ptr x) --- (\ptrSrc -> do --- copyArray ptrDest (ptrSrc `plusPtr` (buf_offset x)) (buf_len x) --- copybuf (ptrDest `plusPtr` (buf_len x)) xs --- ) - -bufferchain_ok :: BufferChain -> Bool -bufferchain_ok _ = True diff --git a/src/Network/TCP/Type/Datagram.hs b/src/Network/TCP/Type/Datagram.hs deleted file mode 100644 --- a/src/Network/TCP/Type/Datagram.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Type.Datagram -( TCPSegment (..) -, UDPDatagram (..) -, Protocol (..) -, ICMPType (..) -, ICMPDatagram (..) -, IPMessage (..) -, tcp_ws -, set_tcp_ws -, tcp_mss -, set_tcp_mss -, tcp_ts -, set_tcp_ts -, tcp_seq -, tcp_ack -, tcp_URG -, tcp_ACK -, tcp_PSH -, tcp_RST -, tcp_SYN -, tcp_FIN -, tcp_win -, tcp_urp -, mkTCPSegment -, mkTCPSegment' -) -where - -import Hans.Address.IP4 (IP4,convertToWord32) -import Hans.Message.Tcp - (TcpHeader(..),TcpPacket(..),TcpPort(..),TcpAckNum(..),TcpSeqNum(..) - ,findTcpOption,setTcpOption,TcpOptionTag(..),TcpOption(..)) - -import Network.TCP.Type.Base - -data TCPSegment = TCPSegment - { tcp_src :: !TCPAddr - , tcp_dst :: !TCPAddr - , tcp_header :: !TcpHeader - , tcp_data :: !BufferChain - } - -mkTCPSegment :: IP4 -> IP4 -> TcpPacket -> TCPSegment -mkTCPSegment src dst (TcpPacket hdr body) = TCPSegment - { tcp_src = TCPAddr (IPAddr (convertToWord32 src),srcP) - , tcp_dst = TCPAddr (IPAddr (convertToWord32 dst),dstP) - , tcp_header = hdr - , tcp_data = bufferchain_singleton body - } - where - TcpPort srcP = tcpSourcePort hdr - TcpPort dstP = tcpDestPort hdr - -mkTCPSegment' :: TCPAddr -> TCPAddr -> TcpHeader -> BufferChain -> TCPSegment -mkTCPSegment' s@(TCPAddr (_, srcP)) d@(TCPAddr (_, dstP)) hdr body = - TCPSegment - { tcp_src = s - , tcp_dst = d - , tcp_header = hdr - { tcpSourcePort = TcpPort srcP - , tcpDestPort = TcpPort dstP - } - , tcp_data = body - } - where - -tcp_seq = getSeqNum . tcpSeqNum . tcp_header -tcp_ack = getAckNum . tcpAckNum . tcp_header -tcp_URG = tcpUrg . tcp_header -tcp_ACK = tcpAck . tcp_header -tcp_PSH = tcpPsh . tcp_header -tcp_RST = tcpRst . tcp_header -tcp_SYN = tcpSyn . tcp_header -tcp_FIN = tcpFin . tcp_header -tcp_win = tcpWindow . tcp_header -tcp_urp = tcpUrgentPointer . tcp_header - -tcp_ws :: TCPSegment -> Maybe Int -tcp_ws = fmap prj . findTcpOption OptTagWindowScaling . tcp_header - where - prj (OptWindowScaling ws) = fromIntegral ws - -set_tcp_ws :: Maybe Int -> TcpHeader -> TcpHeader -set_tcp_ws Nothing = id -set_tcp_ws (Just ws) = setTcpOption (OptWindowScaling (fromIntegral ws)) - -tcp_mss :: TCPSegment -> Maybe Int -tcp_mss = fmap prj . findTcpOption OptTagMaxSegmentSize . tcp_header - where - prj (OptMaxSegmentSize mss) = fromIntegral mss - -set_tcp_mss :: Maybe Int -> TcpHeader -> TcpHeader -set_tcp_mss Nothing = id -set_tcp_mss (Just mss) = setTcpOption (OptMaxSegmentSize (fromIntegral mss)) - -tcp_ts :: TCPSegment -> Maybe (Timestamp,Timestamp) -tcp_ts = fmap prj . findTcpOption OptTagTimestamp . tcp_header - where - prj (OptTimestamp v r) = (Timestamp v, Timestamp r) - -set_tcp_ts :: Maybe (Timestamp,Timestamp) -> TcpHeader -> TcpHeader -set_tcp_ts Nothing = id -set_tcp_ts (Just (Timestamp v, Timestamp r)) = setTcpOption (OptTimestamp v r) - -{- -data TCPSegment = TCPSegment - { tcp_src :: !TCPAddr - , tcp_dst :: !TCPAddr - , tcp_seq :: !SeqLocal - , tcp_ack :: !SeqForeign - , tcp_URG :: !Bool - , tcp_ACK :: !Bool - , tcp_PSH :: !Bool - , tcp_RST :: !Bool - , tcp_SYN :: !Bool - , tcp_FIN :: !Bool - , tcp_win :: !Int - , tcp_urp :: !Int - , tcp_data :: !BufferChain - -- option: window scaling - , tcp_ws :: !(Maybe Int) - -- option: max segment size - , tcp_mss :: !(Maybe Int) - -- option: RFC1323 - , tcp_ts :: !(Maybe (Timestamp, Timestamp)) - } -} - -instance Show TCPSegment where - show seg = - let part1 = - if (get_port $ tcp_src seg) > 9999 || (get_port $ tcp_dst seg) == 8888 then - "<==" ++ (show $ tcp_src seg) - ++ " ack=" ++(show $ seq_val $ tcp_ack seg) - ++ " seq=" ++(show $ seq_val $ tcp_seq seg) - else - "==>" ++ (show $ tcp_dst seg) - ++ " seq=" ++(show $ seq_val $ tcp_seq seg) - ++ " ack=" ++(show $ seq_val $ tcp_ack seg) - in - let part2 = - " ["++ - (if tcp_URG seg then " URG(urp="++ (show $ tcp_urp seg) ++ ")" else "") ++ - (if tcp_SYN seg then " SYN" else "") ++ - (if tcp_FIN seg then " FIN" else "") ++ - (if tcp_RST seg then " RST" else "") ++ - (if tcp_ACK seg then " ACK" else "") ++ - (if tcp_PSH seg then " PSH" else "") ++ - " ]" - in - part1 - ++ " WIN=" ++(show $ tcp_win seg) - ++ " LEN=" ++(show $ bufc_length $ tcp_data seg) - ++ part2 - -data UDPDatagram = UDPDatagram - { udp_src :: TCPAddr - , udp_dst :: TCPAddr - , udp_data :: [Char] - } deriving (Show, Eq) - -data Protocol = PROTO_TCP | PROTO_UDP deriving (Show, Eq) - -data ICMPType = - ICMP_UNREACH Int - | ICMP_SOURCE_QUENCE Int - | ICMP_REDIRECT Int - | ICMP_TIME_EXCEEDED Int - | ICMP_PARAMPROB Int - deriving (Show, Eq) - -data ICMPDatagram = ICMPDatagram - { icmp_send :: IPAddr - , icmp_recv :: IPAddr - , icmp_src :: Maybe TCPAddr - , icmp_dst :: Maybe TCPAddr - , icmp_proto :: Protocol - , icmp_seq :: Maybe SeqLocal - , icmp_t :: ICMPType - } deriving (Show, Eq) - -data IPMessage = TCPMessage !TCPSegment - | ICMPMessage !ICMPDatagram - | UDPMessage !UDPDatagram - deriving (Show) diff --git a/src/Network/TCP/Type/Socket.hs b/src/Network/TCP/Type/Socket.hs deleted file mode 100644 --- a/src/Network/TCP/Type/Socket.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Type.Socket -where - -import Network.TCP.Type.Base -import Network.TCP.Type.Timer -import Network.TCP.Type.Datagram -import Network.TCP.Type.Syscall -import Data.Map as Map - -data TCPState = CLOSED - | LISTEN - | SYN_SENT - | SYN_RECEIVED - | ESTABLISHED - | CLOSE_WAIT - | FIN_WAIT_1 - | FIN_WAIT_2 - | CLOSING - | LAST_ACK - | TIME_WAIT - deriving (Show,Eq) - -data TCPReassSegment = TCPReassSegment - { trs_seq :: !SeqForeign - , trs_FIN :: !Bool - , trs_data :: !BufferChain - } deriving (Show) - -data RexmtMode = RexmtSyn - | Rexmt - | Persist - deriving (Show,Eq) - -data Rttinf = Rttinf - { t_rttupdated :: !Int - , tf_srtt_valid :: !Bool - , t_srtt :: !Time - , t_rttvar :: !Time - , t_rttmin :: !Time - , t_lastrtt :: !Time - , t_lastshift :: !Int - , t_wassyn :: !Bool - } deriving (Show) - - -data IOBC = NO_OOBDATA | OOBDATA Buffer | HAD_OOBDATA deriving (Show) - -data SocketListen = SocketListen - { lis_q0 :: ![SocketID] -- q0 - , lis_q :: ![SocketID] -- q - , lis_qlimit :: !Int - } deriving (Show,Eq) - -data TCBTiming = TCBTiming - { tt_keep :: !(Maybe Time) - , tt_conn_est :: !(Maybe Time) - , tt_fin_wait_2 :: !(Maybe Time) - , tt_2msl :: !(Maybe Time) - , t_idletime :: !Time - , ts_recent :: !(TimeWindow Timestamp) - , t_badrxtwin :: !(TimeWindow ()) - } deriving (Show) -data TCBSending = TCBSending - { sndq :: !BufferChain - , snd_una :: !SeqLocal - , snd_wnd :: !Int - , snd_wl1 :: !SeqForeign - , snd_wl2 :: !SeqLocal - , snd_cwnd :: !Int - , snd_nxt :: !SeqLocal - , snd_max :: !SeqLocal - , t_dupacks :: !Int - , t_rttinf :: !Rttinf - , t_rttseg :: !(Maybe (Timestamp, SeqLocal)) - , tt_rexmt :: !(Maybe (Timed (RexmtMode, Int))) - } deriving (Show) -data TCBReceiving = TCBReceiving - { last_ack_sent :: !SeqForeign - , tf_rxwin0sent :: !Bool - , tf_shouldacknow :: !Bool - , tt_delack :: !Bool - , rcv_adv :: !SeqForeign - , rcv_wnd :: !Int - , rcv_nxt :: !SeqForeign - , rcvq :: !BufferChain - , t_segq :: ![TCPReassSegment] - } deriving (Show) -data TCBMisc = TCBMisc - { -- retransmission - snd_ssthresh :: !Int - , snd_cwnd_prev :: !Int - , snd_ssthresh_prev :: !Int - , snd_recover :: !SeqLocal - -- some tags - , cantsndmore :: !Bool - , cantrcvmore :: !Bool - , bsd_cantconnect :: !Bool -- not very useful... - -- initialization parameters - , self_id :: !SocketID - , parent_id :: !SocketID - , local_addr :: !TCPAddr - , remote_addr :: !TCPAddr - , t_maxseg :: !Int - , t_advmss :: !(Maybe Int) - , tf_doing_ws :: !Bool - , tf_doing_tstmp :: !Bool - , tf_req_tstmp :: !Bool - , request_r_scale :: !(Maybe Int) - , snd_scale :: !Int - , rcv_scale :: !Int - , iss :: !SeqLocal - , irs :: !SeqForeign - -- other things i don't use for the moment - , sndurp :: !(Maybe Int) - , rcvurp :: !(Maybe Int) - , iobc :: !IOBC - , rcv_up :: !SeqForeign - , tf_needfin :: !Bool - } deriving (Show) - -data TCPSocket threadt = TCPSocket - { st :: !TCPState - , cb_time :: !TCBTiming - , cb_snd :: !TCBSending - , cb_rcv :: !TCBReceiving - , cb :: !TCBMisc - , sock_listen :: !SocketListen - -- suspended commands (threads) - , waiting_list :: ![(SockReq, SockRsp -> threadt)] - } - -instance Show (TCPSocket t) where - show (TCPSocket s cb1 cb2 cb3 cb4 lis wl) = - "TCPSocket state ="++(show s) ++ "\n" ++ - " " ++ (show cb1) ++ "\n" ++ - " " ++ (show cb2) ++ "\n" ++ - " " ++ (show cb3) ++ "\n" ++ - " " ++ (show cb4) ++ "\n" ++ - " " ++ (show lis) ++ "\n" ++ - " waiting: " ++ (show $ length wl) - -data Host threadt = Host - { sock_map :: !(Map SocketID (TCPSocket threadt)) - , output_queue :: ![IPMessage] - , ready_list :: ![threadt] - , ticks :: !Timestamp - , clock :: !Time - , next_timers :: !(Time,Time) -- fast timer, slow timer - , local_ports :: ![Port] - } - -empty_host :: Host t -empty_host = Host - { sock_map = Map.empty - , output_queue = [] - , ready_list = [] - , ticks = Timestamp 0 - , clock = 0 - , next_timers = (0,0) - , local_ports = [0..65535] - } - -update_host_time :: Time -> Host t -> Host t -update_host_time now h = h - { clock = now - } diff --git a/src/Network/TCP/Type/Syscall.hs b/src/Network/TCP/Type/Syscall.hs deleted file mode 100644 --- a/src/Network/TCP/Type/Syscall.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Type.Syscall -( SocketID -, TCPAddr -, Buffer (..) -, SockReq (..) -, SockRsp (..) -) - -where - -import Network.TCP.Type.Base - -data SockReq = SockConnect !IPAddr !TCPAddr -- create a client socket and connect (return: SockNew sock) - | SockListen !Port -- create a listening Socket (return: SockNew sock) - | SockAccept !SocketID -- accept connection from a listening socket (return: SockNew sock) - | SockSend !SocketID !Buffer -- (return: SockOK) - | SockRecv !SocketID -- (return: SockData) - | SockClose !SocketID -- (return: SockOK) - -data SockRsp = SockOK - | SockError !String - | SockNew !SocketID - | SockData !Buffer - deriving Show diff --git a/src/Network/TCP/Type/Timer.hs b/src/Network/TCP/Type/Timer.hs deleted file mode 100644 --- a/src/Network/TCP/Type/Timer.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-- -Copyright (c) 2006, Peng Li - 2006, Stephan A. Zdancewic -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -* Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -* Neither the name of the copyright owners nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---} - -module Network.TCP.Type.Timer - -where - -import Network.TCP.Type.Base - -data Timed a = Timed { timed_val :: a - , timed_exp :: Time - } deriving (Show, Eq) - -timed_expires :: Time -> Timed a -> Bool -timed_expires t (Timed x tm) = t >= tm - -timer_expires :: Time -> Time -> Bool -timer_expires t tm = t >= tm - -maybe_timed_expires :: Time -> Maybe (Timed a) -> Bool -maybe_timed_expires _ Nothing = False -maybe_timed_expires curr_time (Just t) = timed_expires curr_time t - -maybe_timer_expires :: Time -> Maybe Time -> Bool -maybe_timer_expires _ Nothing = False -maybe_timer_expires curr_time (Just t) = curr_time >= t - -type TimeWindow a = Maybe (Timed a) - -timewindow_open :: Time -> TimeWindow a -> Bool -timewindow_open = maybe_timed_expires - -timewindow_val :: Time -> TimeWindow a -> Maybe a -timewindow_val t Nothing = Nothing -timewindow_val t (Just tmd) = - if timed_expires t tmd then Nothing else Just (timed_val tmd) - - diff --git a/tcp-test/Main.hs b/tcp-test/Main.hs new file mode 100644 --- /dev/null +++ b/tcp-test/Main.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Hans.Address +import Hans.DhcpClient +import Hans.Address.Mac +import Hans.Address.IP4 +import Hans.NetworkStack + +#ifdef HaLVM_HOST_OS +import Hans.Device.Xen +import Hypervisor.Console +import Hypervisor.XenStore +import XenDevice.NIC +#else +import Hans.Device.Tap +#endif + +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 + + +localAddr :: IP4 +localAddr = IP4 192 168 90 2 + +main :: IO () +main = do + ns <- newNetworkStack + mac <- initEthernetDevice ns + deviceUp ns mac + putStrLn "Network stack running..." + + 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) + + putStrLn "Looking up galois.com..." + HostEntry { .. } <- getHostByName ns "galois.com" + print hostAddresses + + server ns + + else do setAddress mac ns + server ns + +server :: NetworkStack -> IO () +server ns = do + sock <- listen ns localAddr 9001 + + forever $ do + putStrLn "Waiting..." + conn <- accept sock + _ <- forkIO (handleClient conn) + return () + +handleClient :: Socket -> IO () +handleClient conn = + do putStrLn ("Got one: " ++ show (sockRemoteHost conn)) + loop + where + loop = + do buf <- recvBytes conn 512 + if L.null buf + then do putStrLn "Client closed connection" + close conn + else do _ <- sendBytes conn buf + loop + +message :: L.ByteString +message = "Hello, world\n" + +sleep :: Int -> IO () +sleep s = threadDelay (s * 1000 * 1000) + +setAddress :: Mac -> NetworkStack -> IO () +setAddress mac ns = do + addIP4Addr ns (localAddr `withMask` 24) mac 1500 + routeVia ns (IP4 0 0 0 0 `withMask` 0) (IP4 192 168 90 1) + +#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 0x56 + Just dev <- openTapDevice "tap6" + addDevice ns mac (tapSend dev) (tapReceiveLoop dev) + return mac +#endif diff --git a/tests/IP4.hs b/tests/IP4.hs new file mode 100644 --- /dev/null +++ b/tests/IP4.hs @@ -0,0 +1,11 @@ +module IP4 where + +import IP4.Packet + +import Test.Framework (Test,testGroup) + + +ip4Tests :: Test +ip4Tests = testGroup "ip4" + [ ip4PacketTests + ] diff --git a/tests/IP4/Addr.hs b/tests/IP4/Addr.hs new file mode 100644 --- /dev/null +++ b/tests/IP4/Addr.hs @@ -0,0 +1,15 @@ +module IP4.Addr where + +import Hans.Address.IP4 + +import Control.Applicative ((<$>),(<*>)) +import System.Random () +import Test.QuickCheck (Gen,arbitraryBoundedRandom) + + +arbitraryIP4 :: Gen IP4 +arbitraryIP4 = IP4 + <$> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom diff --git a/tests/IP4/Packet.hs b/tests/IP4/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/IP4/Packet.hs @@ -0,0 +1,66 @@ +module IP4.Packet where + +import IP4.Addr +import Utils + +import Hans.Message.Ip4 + +import Control.Applicative ((<$>)) +import Data.Word (Word16) +import System.Random () +import Test.Framework (Test,testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Gen,arbitrary,arbitraryBoundedRandom,choose,forAll) + + +-- Packet Generation ----------------------------------------------------------- + +arbitraryIP4Header :: Gen IP4Header +arbitraryIP4Header = do + tos <- arbitraryBoundedRandom + ident <- arbitraryIdent + df <- arbitrary + mf <- arbitrary + off <- arbitraryFragmentOffset + ttl <- arbitraryBoundedRandom + prot <- arbitraryIP4Protocol + src <- arbitraryIP4 + dst <- arbitraryIP4 + return emptyIP4Header + { ip4TypeOfService = tos + , ip4DontFragment = df + , ip4MoreFragments = mf + , ip4FragmentOffset = off + , ip4TimeToLive = ttl + , ip4Protocol = prot + , ip4SourceAddr = src + , ip4DestAddr = dst + } + +arbitraryIdent :: Gen Ident +arbitraryIdent = Ident <$> arbitraryBoundedRandom + +arbitraryFragmentOffset :: Gen Word16 +arbitraryFragmentOffset = (8*) <$> choose (0,0x1fff) + +arbitraryIP4Protocol :: Gen IP4Protocol +arbitraryIP4Protocol = IP4Protocol <$> arbitraryBoundedRandom + +arbitraryIP4PacketLen :: Gen Int +arbitraryIP4PacketLen = choose (0,65535 - 20) + + +-- Packet Tests ---------------------------------------------------------------- + +ip4PacketTests :: Test +ip4PacketTests = testGroup "packet parsing" + [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip + ] + +prop_headerRoundTrip = forAll arbitraryIP4PacketLen $ \ pktLen -> + let parse = do + (hdr,_,_) <- getIP4Packet + return hdr + render hdr = putIP4Header hdr pktLen + in roundTrip arbitraryIP4Header parse render + diff --git a/tests/Icmp4.hs b/tests/Icmp4.hs new file mode 100644 --- /dev/null +++ b/tests/Icmp4.hs @@ -0,0 +1,11 @@ +module Icmp4 where + +import Icmp4.Packet (icmp4PacketTests) + +import Test.Framework (Test,testGroup) + + +icmp4Tests :: Test +icmp4Tests = testGroup "icmp4" + [ icmp4PacketTests + ] diff --git a/tests/Icmp4/Packet.hs b/tests/Icmp4/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/Icmp4/Packet.hs @@ -0,0 +1,139 @@ +module Icmp4.Packet where + +import IP4.Addr +import Utils + +import Hans.Message.Icmp4 +import Hans.Message.Types (Lifetime(..)) + +import Control.Applicative ((<$>),(<*>),pure) +import System.Random () +import Test.Framework (Test,testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + (Gen,oneof,arbitraryBoundedRandom,elements,listOf,listOf1,vectorOf) +import qualified Data.ByteString as S + + +-- Packet Generation ----------------------------------------------------------- + +arbitraryIcmp4Packet :: Gen Icmp4Packet +arbitraryIcmp4Packet = oneof + [ EchoReply <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + <*> arbitraryEchoPayload + , DestinationUnreachable <$> arbitraryDestinationUnreachableCode + <*> arbitraryPayload + , SourceQuench <$> arbitraryPayload + , Redirect <$> arbitraryRedirectCode + <*> arbitraryIP4 + <*> arbitraryPayload + , Echo <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + <*> arbitraryEchoPayload + , RouterAdvertisement <$> arbitraryLifetime + <*> listOf1 arbitraryRouterAddress + , pure RouterSolicitation + , TimeExceeded <$> arbitraryTimeExceededCode + <*> arbitraryPayload + , ParameterProblem <$> arbitraryBoundedRandom + <*> arbitraryPayload + , Timestamp <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + , TimestampReply <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + , Information <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + , InformationReply <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + , TraceRoute <$> arbitraryTraceRouteCode + <*> arbitraryIdentifier + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + <*> arbitraryBoundedRandom + , AddressMask <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + , AddressMaskReply <$> arbitraryIdentifier + <*> arbitrarySequenceNumber + <*> arbitraryBoundedRandom + ] + +arbitraryIdentifier :: Gen Identifier +arbitraryIdentifier = Identifier <$> arbitraryBoundedRandom + +arbitrarySequenceNumber :: Gen SequenceNumber +arbitrarySequenceNumber = SequenceNumber <$> arbitraryBoundedRandom + +arbitraryEchoPayload :: Gen S.ByteString +arbitraryEchoPayload = S.pack <$> listOf arbitraryBoundedRandom + +arbitraryPayload :: Gen S.ByteString +arbitraryPayload = S.pack <$> vectorOf 28 arbitraryBoundedRandom + +arbitraryDestinationUnreachableCode :: Gen DestinationUnreachableCode +arbitraryDestinationUnreachableCode = elements + [ NetUnreachable + , HostUnreachable + , ProtocolUnreachable + , PortUnreachable + , FragmentationUnreachable + , SourceRouteFailed + , DestinationNetworkUnknown + , DestinationHostUnknown + , SourceHostIsolatedError + , AdministrativelyProhibited + , HostAdministrativelyProhibited + , NetworkUnreachableForTOS + , HostUnreachableForTOS + , CommunicationAdministrativelyProhibited + , HostPrecedenceViolation + , PrecedenceCutoffInEffect + ] + +arbitraryRedirectCode :: Gen RedirectCode +arbitraryRedirectCode = elements + [ RedirectForNetwork + , RedirectForHost + , RedirectForTypeOfServiceAndNetwork + , RedirectForTypeOfServiceAndHost + ] + +arbitraryLifetime :: Gen Lifetime +arbitraryLifetime = Lifetime <$> arbitraryBoundedRandom + +arbitraryRouterAddress :: Gen RouterAddress +arbitraryRouterAddress = RouterAddress + <$> arbitraryIP4 + <*> arbitraryPreferenceLevel + +arbitraryPreferenceLevel :: Gen PreferenceLevel +arbitraryPreferenceLevel = PreferenceLevel <$> arbitraryBoundedRandom + +arbitraryTimeExceededCode :: Gen TimeExceededCode +arbitraryTimeExceededCode = elements + [ TimeToLiveExceededInTransit + , FragmentReassemblyTimeExceeded + ] + +arbitraryTraceRouteCode :: Gen TraceRouteCode +arbitraryTraceRouteCode = elements + [ TraceRouteForwarded + , TraceRouteDiscarded + ] + +-- Packet Tests ---------------------------------------------------------------- + +icmp4PacketTests :: Test +icmp4PacketTests = testGroup "packet parsing" + [ testProperty "roundTrip" prop_roundTrip + ] + +prop_roundTrip = + roundTrip arbitraryIcmp4Packet getIcmp4Packet putIcmp4Packet diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,16 @@ +module Main where + +import Icmp4 (icmp4Tests) +import IP4 (ip4Tests) +import Tcp (tcpTests) +import Udp (udpTests) + +import Test.Framework (defaultMain) + + +main = defaultMain + [ tcpTests + , udpTests + , icmp4Tests + , ip4Tests + ] diff --git a/tests/Tcp.hs b/tests/Tcp.hs new file mode 100644 --- /dev/null +++ b/tests/Tcp.hs @@ -0,0 +1,14 @@ +module Tcp ( + tcpTests + ) where + +import Tcp.Packet +import Tcp.Window + +import Test.Framework (Test,testGroup) + +tcpTests :: Test +tcpTests = testGroup "tcp" + [ tcpPacketTests + , tcpWindowTests + ] diff --git a/tests/Tcp/Packet.hs b/tests/Tcp/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/Tcp/Packet.hs @@ -0,0 +1,140 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tcp.Packet where + +import Utils + +import Hans.Message.Tcp + (TcpHeader(..),emptyTcpHeader,TcpPort(..),TcpOption(..),SackBlock(..) + ,getTcpHeader,putTcpHeader,getTcpOption,putTcpOption,tcpOptionsLength) + +import Control.Applicative (pure,(<*>),(<$>)) +import Control.Monad (replicateM) +import Data.Serialize (runGet,runPut) +import Data.Word (Word8) +import System.Random () +import Test.Framework (Test,testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + (Gen,choose,arbitrarySizedIntegral,sized,arbitrary,listOf,oneof,forAll + ,suchThat) +import Test.QuickCheck.Property (Result(..),failed,succeeded) +import qualified Data.ByteString as S +import qualified Data.Sequence as Seq + + +-- Utilities ------------------------------------------------------------------- + +-- | Generate a strict bytestring of nonzero length, that falls within the MSS +-- off the HaNS tcp layer. +arbitraryPayload :: Gen S.ByteString +arbitraryPayload = do + len <- choose (1,10) + S.pack `fmap` replicateM len arbitrarySizedIntegral + +-- | Generate the starting point of a data packet stream. +arbitraryDataPacket :: Gen (TcpHeader,S.ByteString) +arbitraryDataPacket = do + body <- arbitraryPayload + sn <- arbitrarySizedIntegral + an <- arbitrarySizedIntegral + let hdr = emptyTcpHeader + { tcpSeqNum = sn + , tcpAckNum = an + , tcpAck = True + } + return (hdr,body) + +-- | Increment the sequence number, and generate some new data. +nextDataPacket :: (TcpHeader,S.ByteString) -> Gen (TcpHeader,S.ByteString) +nextDataPacket (hdr,body) = do + body' <- arbitraryPayload + let hdr' = hdr { tcpSeqNum = tcpSeqNum hdr + fromIntegral (S.length body) } + return (hdr',body') + +-- | Generate a sequence of headers and packet payloads. This will yield a +-- non-empty stream whose length depends on the size parameter. +packetStream :: Gen (Seq.Seq (TcpHeader,S.ByteString)) +packetStream = do + pkt@(hdr,body) <- arbitraryDataPacket + sized (loop Seq.empty pkt) + where + loop segs pkt len + | len == 0 = return (segs Seq.|> pkt) + | otherwise = do + pkt' <- nextDataPacket pkt + loop (segs Seq.|> pkt) pkt' (len - 1) + + +arbitraryTcpPort :: Gen TcpPort +arbitraryTcpPort = TcpPort `fmap` arbitrarySizedIntegral + +-- | Generate a completely arbitrary header. This may be a semantically +-- incorrect header, and is mainly useful for testing the parser. +arbitraryTcpHeader :: Gen TcpHeader +arbitraryTcpHeader = TcpHeader + <$> arbitraryTcpPort + <*> arbitraryTcpPort + <*> arbitrarySizedIntegral + <*> arbitrarySizedIntegral + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrarySizedIntegral + <*> pure 0 -- checksum + <*> pure 0 -- urgent pointer + <*> arbitraryTcpOptions + +arbitraryTcpOptions :: Gen [TcpOption] +arbitraryTcpOptions = listOf arbitraryTcpOption `suchThat` (not . tooBig) + where + tooBig opts = fst (tcpOptionsLength opts) > 10 + +arbitraryTcpOption :: Gen TcpOption +arbitraryTcpOption = oneof + [ pure OptNoOption + , OptMaxSegmentSize <$> arbitrarySizedIntegral + , OptWindowScaling <$> arbitrarySizedIntegral + , pure OptSackPermitted + , do len <- choose (0,10) + OptSack <$> replicateM len arbitrarySackBlock + , OptTimestamp <$> arbitrarySizedIntegral + <*> arbitrarySizedIntegral + , do code <- unusedTcpOptionNumber + len <- choose (0, 20) + bytes <- replicateM (fromIntegral len) arbitrarySizedIntegral + return (OptUnknown code (len + 2) (S.pack bytes)) + ] + +-- | Choose an unused tcp option number. +unusedTcpOptionNumber :: Gen Word8 +unusedTcpOptionNumber = + arbitrarySizedIntegral `suchThat` (not . (`elem` avoid)) + where + -- it would be nice if this could could be generated from TcpOptionTag + avoid = [0, 1, 2, 3, 4, 5, 8] + +arbitrarySackBlock :: Gen SackBlock +arbitrarySackBlock = SackBlock + <$> arbitrarySizedIntegral + <*> arbitrarySizedIntegral + + +-- Properties ------------------------------------------------------------------ + +tcpPacketTests :: Test +tcpPacketTests = testGroup "packet parsing" + [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip + , testProperty "prop_optionRoundTrip" prop_optionRoundTrip + ] + +prop_headerRoundTrip = + roundTrip arbitraryTcpHeader (fst <$> getTcpHeader) putTcpHeader + +prop_optionRoundTrip = + roundTrip arbitraryTcpOption getTcpOption putTcpOption diff --git a/tests/Tcp/Window.hs b/tests/Tcp/Window.hs new file mode 100644 --- /dev/null +++ b/tests/Tcp/Window.hs @@ -0,0 +1,61 @@ +module Tcp.Window where + +import Tcp.Packet + +import Hans.Layer.Tcp.Window + (emptyLocalWindow,addInSegment,stepWindow,InSegment(..) + ,localWindowSackBlocks) +import Hans.Message.Tcp (TcpHeader(..)) + +import Control.Arrow ((&&&)) +import Test.Framework (Test,testGroup) +import Test.QuickCheck (forAll) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import qualified Data.ByteString as S +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq + + +tcpWindowTests :: Test +tcpWindowTests = testGroup "tcp window" + [ testProperty "prop_localOrdered" prop_localOrdered + , testProperty "prop_localRandom" prop_localRandom + , testProperty "prop_sackOrdered" prop_sackOrdered + ] + + +-- Local Window ---------------------------------------------------------------- + +fromInSegment :: InSegment -> (TcpHeader,S.ByteString) +fromInSegment = inHeader &&& inBody + +-- | Check that if a stream of packets goes into the @LocalWindow@ in order, +-- that they will come out in the same order. +prop_localOrdered = forAll packetStream $ \ segs -> + let (hdr,_) = Seq.index segs 0 + win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 + step w (h,body) = addInSegment h body w + win' = F.foldl step win segs + (segs',_) = stepWindow win' + in segs == fmap fromInSegment segs' + +-- | Check that if a stream of initially ordered packets goes into the +-- @LocalWindow@ in a random order, that they come out ordered again. In this +-- case, we just reverse the stream, as that should be the degenrate case for +-- incoming packets. +prop_localRandom = forAll packetStream $ \ segs -> + let (hdr,_) = Seq.index segs 0 + win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 + step (h,body) w = addInSegment h body w + win' = F.foldr step win segs + (segs',_) = stepWindow win' + in segs == fmap fromInSegment segs' + +-- | Generating a sequence of sack blocks from a window constructed of in-order +-- packets should generate a single sack block. +prop_sackOrdered = forAll packetStream $ \ segs -> + let (hdr,_) = Seq.index segs 0 + win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 + step w (h,body) = addInSegment h body w + win' = F.foldl step win segs + in Seq.length (localWindowSackBlocks win') == 1 diff --git a/tests/Udp.hs b/tests/Udp.hs new file mode 100644 --- /dev/null +++ b/tests/Udp.hs @@ -0,0 +1,11 @@ +module Udp where + +import Udp.Packet + +import Test.Framework (Test,testGroup) + + +udpTests :: Test +udpTests = testGroup "udp" + [ udpPacketTests + ] diff --git a/tests/Udp/Packet.hs b/tests/Udp/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/Udp/Packet.hs @@ -0,0 +1,43 @@ +module Udp.Packet where + +import Hans.Message.Udp + (UdpHeader(..),UdpPort(..),parseUdpHeader,renderUdpHeader) + +import Control.Applicative ((<$>),(<*>)) +import Data.Serialize (runGet,runPut) +import System.Random (Random) +import Test.Framework (Test,testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Gen,forAll,arbitraryBoundedRandom,arbitrary,choose) +import Test.QuickCheck.Property (Result(..),failed,succeeded) + + +-- Utilities ------------------------------------------------------------------- + +arbitraryUdpPacketSize :: (Random a, Num a) => Gen a +arbitraryUdpPacketSize = choose (0,65535 - 8) + +arbitraryUdpPort :: Gen UdpPort +arbitraryUdpPort = UdpPort <$> arbitraryBoundedRandom + +arbitraryUdpHeader :: Gen UdpHeader +arbitraryUdpHeader = UdpHeader + <$> arbitraryUdpPort + <*> arbitraryUdpPort + <*> arbitraryBoundedRandom -- not necessarily right + + +-- Properties ------------------------------------------------------------------ + +udpPacketTests :: Test +udpPacketTests = testGroup "packet parsing" + [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip + ] + +prop_headerRoundTrip = forAll packet $ \ (len,hdr) -> + case runGet parseUdpHeader (runPut (renderUdpHeader hdr len)) of + Right (hdr',len') | hdr == hdr' && len == len' -> succeeded + | otherwise -> failed + Left err -> failed { reason = err } + where + packet = (,) <$> arbitraryUdpPacketSize <*> arbitraryUdpHeader diff --git a/tests/Utils.hs b/tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Utils.hs @@ -0,0 +1,16 @@ +module Utils where + +import Data.Serialize (runGet,runPut,Putter,Get) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Gen,forAll) +import Test.QuickCheck.Property (Property,Result(..),succeeded,failed) + + +-- | Round trip something through cereal, making sure that rendered version +-- parses to the same initial value. +roundTrip :: (Show a, Eq a) => Gen a -> Get a -> Putter a -> Property +roundTrip gen decode encode = forAll gen $ \ a -> + case runGet decode (runPut (encode a)) of + Right a' | a == a' -> succeeded + | otherwise -> failed + Left err -> failed { reason = err } diff --git a/web-server/Main.hs b/web-server/Main.hs new file mode 100644 --- /dev/null +++ b/web-server/Main.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- 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 +-- terms and conditions. +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSC +import Data.Char +import Data.Time +import Data.Version +import Data.Word +import GHC.Stats +import Hans.Address.Mac +import Hans.Address.IP4 +import Hans.Device.Tap +import Hans.DhcpClient +import Hans.Layer.Dns(DnsException) +import Hans.NetworkStack hiding (close) +import qualified Hans.NetworkStack as Hans +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.Attributes(href) +import Text.Blaze.Html.Renderer.String +import Text.Blaze.Internal(string) + +instance Stream Socket where + readLine s = loop "" + where loop acc = + do bstr <- recvBytes s 1 + if | BS.null bstr -> return (Left ErrorClosed) + | BS.head bstr == 10 -> return (Right (acc ++ "\n")) + | otherwise -> loop (acc ++ BSC.unpack bstr) + + 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 + if | BS.length bstr == x -> loop 0 (acc `BS.append` bstr) + | BS.length bstr == 0 -> return (Left ErrorClosed) + | otherwise -> loop (x - BS.length bstr) + (acc `BS.append` bstr) + + writeBlock s str = loop (BSC.pack str) + where loop x | BS.null x = return (Right ()) + | otherwise = + do amt <- sendBytes s x + loop (BS.drop amt x) + + close s = Hans.close s + + closeOnEnd _ _ = return () + +data ServerState = ServerState { + startTime :: String + , responseCount :: MVar Word64 + , lastHosts :: MVar [(IP4, Maybe String)] + } + +main :: IO () +main = + do startTime <- formatTime defaultTimeLocale "%c" `fmap` getZonedTime + responseCount <- newMVar 0 + lastHosts <- newMVar [] + startServer ServerState { .. } + +initEthernetDevice :: NetworkStack -> IO Mac +initEthernetDevice ns = + do let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x89 + Just dev <- openTapDevice "tap6" + addDevice ns mac (tapSend dev) (tapReceiveLoop dev) + return mac + +startServer :: ServerState -> IO () +startServer state = + do ns <- newNetworkStack + mac <- initEthernetDevice ns + 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) + + 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{} = + do putStrLn ("Unable to listen on port 80\n") + threadDelay (5 * 1000000) + exitFailure + +handleClient :: Socket -> ServerState -> IO () +handleClient sock state = + do mreq <- receiveHTTP sock + case mreq of + Left err -> putStrLn ("ReqERROR: " ++ show err) + Right req -> + do body <- buildBody req state + putStrLn "Built response" + let lenstr = show (length body) + keepAlive = [ mkHeader HdrConnection "keep-alive" + | hdr <- retrieveHeaders HdrConnection req + , map toLower (hdrValue hdr) == "keep-alive" ] + conn | null keepAlive = [ mkHeader HdrConnection "Close" ] + | otherwise = keepAlive + resp = Response { + rspCode = (2,0,0) + , rspReason = "OK" + , rspHeaders = mkHeader HdrContentLength lenstr + : mkHeader HdrContentType "text/html" + : conn + , rspBody = body + } + respondHTTP sock resp + if null keepAlive + then Hans.close sock + else handleClient sock state + +buildBody :: Request String -> ServerState -> IO String +buildBody req state = + do numReqs <- modifyMVar (responseCount state) (\ x -> return (x + 1, x)) + prevHosts <- readMVar (lastHosts state) + putStrLn ("prevHosts: " ++ show prevHosts ++ "\n") + return $ renderHtml $ + docTypeHtml $ do + H.head (title "HaLVM Test Server") + body $ do + h1 "Hi!" + p $ do "I'm a HaLVM. Technically I'm " >> string compilerName + " version " >> string (showVersion compilerVersion) + ", ported to run on Xen. I started running on " + string (startTime state) >> ". You didn't know there was a " + "HaLVM standard time, did you? Well, there is. Really." + p $ do "I have responded to " >> (string (show numReqs)) >> " " + "requests since I started, not including yours." + p $ do "I am using: " + ul $ do + 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 " + "pretty HTML." + li $ do "... and a host of other libraries to do other, more " + "standard, things." + p $ do "Here are the last 5 hosts that I did something for:" + ol $ forM_ prevHosts $ \ x -> li (renderHost x) + where + hans, http, blaze, network_hans :: Html + hans = a ! href "http://hackage.haskell.org/package/hans" $ "HaNS" + http = a ! href "http://hackage.haskell.org/package/HTTP" $ "HTTP" + blaze = a ! href "http://hackage.haskell.org/package/blaze-html"$"blaze-html" + network_hans = a ! href "http://github.com/GaloisInc/network-hans" $ + "network-hans" + +renderHost :: (IP4, Maybe String) -> Html +renderHost (addr, Nothing) = string (show addr) +renderHost (addr, Just n) = string (n ++ " (" ++ show addr ++ ")") + +addHost :: NetworkStack -> IP4 -> MVar [(IP4, Maybe String)] -> IO () +addHost ns addr hostsMV = + do putStrLn ("addHost " ++ show addr) + entry <- catch (name `fmap` getHostByAddr ns addr) handleDnsError + list <- takeMVar hostsMV + putStrLn ("list: " ++ show list) + case lookup addr list of + Just _ -> putMVar hostsMV list >> putStrLn "put old list" + Nothing -> putMVar hostsMV (take 5 ((addr, entry) : list )) >> putStrLn "put new list" + where + name = Just . hostName + handleDnsError :: DnsException -> IO (Maybe String) + handleDnsError e = print e >> return Nothing