hans 2.1.0.0 → 2.4.0.0
raw patch · 74 files changed
+5987/−4662 lines, 74 filesdep +HTTPdep +QuickCheckdep +blaze-htmldep −RendezvousLibdep −communicationdep ~HALVMCoredep ~XenDevicedep ~basenew-component:exe:tcp-testnew-component:exe:test-suitenew-component:exe:web-server
Dependencies added: HTTP, QuickCheck, blaze-html, blaze-markup, test-framework, test-framework-quickcheck2
Dependencies removed: RendezvousLib, communication
Dependency ranges changed: HALVMCore, XenDevice, base, bytestring, cereal, containers, fingertree, monadLib, old-locale, random, time
Files
- cbits/tapdevice.c +85/−19
- example/WebServer.hs +4/−5
- example/test.hs +8/−18
- hans.cabal +140/−64
- src/Hans/Address/IP4.hs +16/−7
- src/Hans/Address/Mac.hs +28/−12
- src/Hans/Device/Ivc.hs +8/−19
- src/Hans/Device/Tap.hs +17/−10
- src/Hans/Device/Xen.hs +2/−27
- src/Hans/DhcpClient.hs +64/−61
- src/Hans/Layer.hs +41/−18
- src/Hans/Layer/Arp.hs +29/−32
- src/Hans/Layer/Dns.hs +362/−0
- src/Hans/Layer/Ethernet.hs +22/−17
- src/Hans/Layer/IP4.hs +38/−48
- src/Hans/Layer/IP4/Fragmentation.hs +21/−17
- src/Hans/Layer/Icmp4.hs +45/−24
- src/Hans/Layer/Tcp.hs +35/−27
- src/Hans/Layer/Tcp/Handlers.hs +490/−58
- src/Hans/Layer/Tcp/Messages.hs +264/−0
- src/Hans/Layer/Tcp/Monad.hs +384/−54
- src/Hans/Layer/Tcp/Socket.hs +248/−150
- src/Hans/Layer/Tcp/Timers.hs +190/−0
- src/Hans/Layer/Tcp/Types.hs +304/−0
- src/Hans/Layer/Tcp/WaitBuffer.hs +166/−0
- src/Hans/Layer/Tcp/Window.hs +299/−0
- src/Hans/Layer/Timer.hs +0/−131
- src/Hans/Layer/Udp.hs +137/−53
- src/Hans/Message/Arp.hs +52/−47
- src/Hans/Message/Dhcp4.hs +13/−6
- src/Hans/Message/Dns.hs +601/−0
- src/Hans/Message/EthernetFrame.hs +37/−21
- src/Hans/Message/Icmp4.hs +266/−222
- src/Hans/Message/Ip4.hs +75/−67
- src/Hans/Message/Tcp.hs +143/−91
- src/Hans/Message/Types.hs +12/−3
- src/Hans/Message/Udp.hs +84/−38
- src/Hans/NetworkStack.hs +251/−0
- src/Hans/Ports.hs +32/−28
- src/Hans/Setup.hs +0/−96
- src/Hans/Simple.hs +17/−12
- src/Hans/Timers.hs +55/−0
- src/Hans/Utils.hs +12/−5
- src/Hans/Utils/Checksum.hs +49/−10
- src/Network/TCP/Aux/Misc.hs +0/−372
- src/Network/TCP/Aux/Output.hs +0/−213
- src/Network/TCP/Aux/Param.hs +0/−120
- src/Network/TCP/Aux/SockMonad.hs +0/−127
- src/Network/TCP/LTS/In.hs +0/−200
- src/Network/TCP/LTS/InActive.hs +0/−170
- src/Network/TCP/LTS/InData.hs +0/−385
- src/Network/TCP/LTS/InMisc.hs +0/−36
- src/Network/TCP/LTS/InPassive.hs +0/−192
- src/Network/TCP/LTS/Out.hs +0/−225
- src/Network/TCP/LTS/User.hs +0/−293
- src/Network/TCP/Type/Base.hs +0/−271
- src/Network/TCP/Type/Datagram.hs +0/−217
- src/Network/TCP/Type/Socket.hs +0/−199
- src/Network/TCP/Type/Syscall.hs +0/−57
- src/Network/TCP/Type/Timer.hs +0/−68
- tcp-test/Main.hs +109/−0
- tests/IP4.hs +11/−0
- tests/IP4/Addr.hs +15/−0
- tests/IP4/Packet.hs +66/−0
- tests/Icmp4.hs +11/−0
- tests/Icmp4/Packet.hs +139/−0
- tests/Main.hs +16/−0
- tests/Tcp.hs +14/−0
- tests/Tcp/Packet.hs +140/−0
- tests/Tcp/Window.hs +61/−0
- tests/Udp.hs +11/−0
- tests/Udp/Packet.hs +43/−0
- tests/Utils.hs +16/−0
- web-server/Main.hs +189/−0
cbits/tapdevice.c view
@@ -1,8 +1,8 @@- #include <string.h> #include <unistd.h> #include <fcntl.h> +#if defined(__linux) #include <sys/types.h> #include <sys/socket.h> #include <sys/ioctl.h>@@ -10,27 +10,93 @@ #include <linux/if_tun.h> 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 <stdlib.h>+#include <stdio.h>+#include <sys/ioctl.h>+#include <net/if.h>+#include <errno.h>+#include <string.h>++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+
example/WebServer.hs view
@@ -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)
example/test.hs view
@@ -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: <prog> dhcp" putStrLn " <prog> <ip> <gateway>" 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
hans.cabal view
@@ -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
src/Hans/Address/IP4.hs view
@@ -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
src/Hans/Address/Mac.hs view
@@ -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
src/Hans/Device/Ivc.hs view
@@ -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)
src/Hans/Device/Tap.hs view
@@ -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+
src/Hans/Device/Xen.hs view
@@ -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
src/Hans/DhcpClient.hs view
@@ -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
src/Hans/Layer.hs view
@@ -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 ------------------------------------------------------
src/Hans/Layer/Arp.hs view
@@ -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
+ src/Hans/Layer/Dns.hs view
@@ -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)
src/Hans/Layer/Ethernet.hs view
@@ -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.
src/Hans/Layer/IP4.hs view
@@ -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 ()
src/Hans/Layer/IP4/Fragmentation.hs view
@@ -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)
src/Hans/Layer/Icmp4.hs view
@@ -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.
src/Hans/Layer/Tcp.hs view
@@ -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
src/Hans/Layer/Tcp/Handlers.hs view
@@ -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
+ src/Hans/Layer/Tcp/Messages.hs view
@@ -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)
src/Hans/Layer/Tcp/Monad.hs view
@@ -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
src/Hans/Layer/Tcp/Socket.hs view
@@ -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)
+ src/Hans/Layer/Tcp/Timers.hs view
@@ -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')))+ }
+ src/Hans/Layer/Tcp/Types.hs view
@@ -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)
+ src/Hans/Layer/Tcp/WaitBuffer.hs view
@@ -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 })
+ src/Hans/Layer/Tcp/Window.hs view
@@ -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)
− src/Hans/Layer/Timer.hs
@@ -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
src/Hans/Layer/Udp.hs view
@@ -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
src/Hans/Message/Arp.hs view
@@ -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
src/Hans/Message/Dhcp4.hs view
@@ -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
+ src/Hans/Message/Dns.hs view
@@ -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)
src/Hans/Message/EthernetFrame.hs view
@@ -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)
src/Hans/Message/Icmp4.hs view
@@ -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
src/Hans/Message/Ip4.hs view
@@ -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
src/Hans/Message/Tcp.hs view
@@ -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
src/Hans/Message/Types.hs view
@@ -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
src/Hans/Message/Udp.hs view
@@ -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
+ src/Hans/NetworkStack.hs view
@@ -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)
src/Hans/Ports.hs view
@@ -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 = "<Active ports: " ++ show (portActive 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
− src/Hans/Setup.hs
@@ -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)
src/Hans/Simple.hs view
@@ -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)
+ src/Hans/Timers.hs view
@@ -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
src/Hans/Utils.hs view
@@ -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
src/Hans/Utils/Checksum.hs view
@@ -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)
− src/Network/TCP/Aux/Misc.hs
@@ -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))--
− src/Network/TCP/Aux/Output.hs
@@ -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) }-
− src/Network/TCP/Aux/Param.hs
@@ -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
− src/Network/TCP/Aux/SockMonad.hs
@@ -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
− src/Network/TCP/LTS/In.hs
@@ -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-
− src/Network/TCP/LTS/InActive.hs
@@ -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 ()--
− src/Network/TCP/LTS/InData.hs
@@ -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 ()
− src/Network/TCP/LTS/InMisc.hs
@@ -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--
− src/Network/TCP/LTS/InPassive.hs
@@ -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--
− src/Network/TCP/LTS/Out.hs
@@ -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)---
− src/Network/TCP/LTS/User.hs
@@ -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
− src/Network/TCP/Type/Base.hs
@@ -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
− src/Network/TCP/Type/Datagram.hs
@@ -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)
− src/Network/TCP/Type/Socket.hs
@@ -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- }
− src/Network/TCP/Type/Syscall.hs
@@ -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
− src/Network/TCP/Type/Timer.hs
@@ -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)--
+ tcp-test/Main.hs view
@@ -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
+ tests/IP4.hs view
@@ -0,0 +1,11 @@+module IP4 where++import IP4.Packet++import Test.Framework (Test,testGroup)+++ip4Tests :: Test+ip4Tests = testGroup "ip4"+ [ ip4PacketTests+ ]
+ tests/IP4/Addr.hs view
@@ -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
+ tests/IP4/Packet.hs view
@@ -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+
+ tests/Icmp4.hs view
@@ -0,0 +1,11 @@+module Icmp4 where++import Icmp4.Packet (icmp4PacketTests)++import Test.Framework (Test,testGroup)+++icmp4Tests :: Test+icmp4Tests = testGroup "icmp4"+ [ icmp4PacketTests+ ]
+ tests/Icmp4/Packet.hs view
@@ -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
+ tests/Main.hs view
@@ -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+ ]
+ tests/Tcp.hs view
@@ -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+ ]
+ tests/Tcp/Packet.hs view
@@ -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
+ tests/Tcp/Window.hs view
@@ -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
+ tests/Udp.hs view
@@ -0,0 +1,11 @@+module Udp where++import Udp.Packet++import Test.Framework (Test,testGroup)+++udpTests :: Test+udpTests = testGroup "udp"+ [ udpPacketTests+ ]
+ tests/Udp/Packet.hs view
@@ -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
+ tests/Utils.hs view
@@ -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 }
+ web-server/Main.hs view
@@ -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