diff --git a/cbits/tapdevice.c b/cbits/tapdevice.c --- a/cbits/tapdevice.c +++ b/cbits/tapdevice.c @@ -9,8 +9,8 @@ #include #include -int init_tap_device(char *name) { - int fd, ret; +int init_tap_device(char *name, unsigned char *mac) { + int fd, ret, sock; struct ifreq ifr; if(name == NULL) { @@ -32,6 +32,25 @@ return -3; } + // generate a MAC address based on the one in the linux side. + sock = socket(AF_INET, SOCK_DGRAM, 0); + if(sock == -1) { + close(fd); + return -4; + } + + if(ioctl(sock,SIOCGIFHWADDR,&ifr) == -1) { + close(fd); + close(sock); + return -5; + } + + // flip the last bit of the mac to generate a new one on the same link + memcpy(mac, ifr.ifr_hwaddr.sa_data, 6); + mac[5] ^= 1; + + close(sock); + return fd; } @@ -43,19 +62,24 @@ #include #include #include +#include +#include #include #include -int init_tap_device(char *name) +int init_tap_device(char *name, char *mac) { char *pathname = alloca(32); struct ifreq ifr; - int fd, sock, flags; + int fd, sock, flags, found, i; + struct ifaddrs *iflist; + struct ifaddrs *cur; + struct sockaddr_dl *sdl; snprintf(pathname, 32, "/dev/%s", name); fd = open(pathname, O_RDWR); if(fd < 0) { - printf("Open failed (%s)\n", pathname); + printf("Open failed (%s) (%d)\n", pathname, fd); return -2; } printf("fd = %d\n", fd); @@ -78,6 +102,31 @@ printf("Set failed: %d (%s)\n", errno, strerror(errno)); return -errno; } + + found = 0; + if(getifaddrs(&iflist) == 0) { + for(cur = iflist; cur; cur = cur->ifa_next) { + if((cur->ifa_addr->sa_family == AF_LINK) && + cur->ifa_addr && + strcmp(cur->ifa_name, name) == 0) { + sdl = (struct sockaddr_dl*)cur->ifa_addr; + memcpy(mac, LLADDR(sdl), sdl->sdl_alen); + + // flip the last bit of the mac address to generate a new address. + mac[5] ^= 1; + found = 1; + break; + } + } + } + + if(found == 0) { + return -2; + } + + + + close(sock); flags = fcntl(fd, F_GETFL, 0); if(flags == -1) { diff --git a/echo-client/Main.hs b/echo-client/Main.hs deleted file mode 100644 --- a/echo-client/Main.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Main where - -import Control.Concurrent (threadDelay) -import Hans.Address.Mac -import Hans.DhcpClient -import Hans.NetworkStack -import System.Environment (getArgs) - -#ifdef HaLVM_HOST_OS -import Hans.Device.Xen -import Hypervisor.Console -import Hypervisor.XenStore -import XenDevice.NIC -#else -import Hans.Device.Tap -#endif - -main :: IO () -main = do - - [ip] <- getArgs - let addr = read ip - - ns <- newNetworkStack - mac <- initEthernetDevice ns - - deviceUp ns mac - putStrLn "Network stack running..." - - putStrLn "Discovering address" - - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just self -> do - putStrLn ("Bound to address: " ++ show self) - - sock <- connect ns addr 9001 Nothing - putStrLn ("Connected to: " ++ show addr) - - putStrLn "Sending bytes..." - sent <- sendBytes sock "Hello" - - putStrLn ("Sent " ++ show sent ++ " bytes") - print =<< recvBytes sock 512 - - threadDelay 1000000 - - close sock - -#ifdef HaLVM_HOST_OS -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = - do xs <- initXenStore - _ <- initXenConsole -- should set up putStrLn - nics <- listNICs xs - case nics of - [] -> fail "No NICs found to use!" - (macstr:_) -> - do let mac = read macstr - nic <- openNIC xs macstr - addDevice ns mac (xenSend nic) (xenReceiveLoop nic) - return mac -#else -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = do - let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x57 - Just dev <- openTapDevice "tap7" - addDevice ns mac (tapSend dev) (tapReceiveLoop dev) - return mac -#endif diff --git a/example/WebServer.hs b/example/WebServer.hs deleted file mode 100644 --- a/example/WebServer.hs +++ /dev/null @@ -1,152 +0,0 @@ -module WebServer where - -import Control.Concurrent (forkIO,threadDelay) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (UTCTime(..),addUTCTime) -import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime,posixSecondsToUTCTime) -import Data.Time.Format (formatTime) -import Hans.Message.Tcp (TcpPort) -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 -import qualified Data.ByteString as S - -webserver :: NetworkStack -> TcpPort -> IO () -webserver ns port = body `X.catch` \se -> print (se :: X.SomeException) - where - body = do - start <- getPOSIXTime - sock <- initServer ns port - serverLoop start sock - -accept :: Socket -> IO Socket -accept sock = loop - where - loop = X.catch (acceptSocket sock) $ \se -> do - case se of - AcceptError err -> putStrLn ("Accept error: " ++ err) - _ -> putStrLn ("Socket error: " ++ show se) - loop - -serverLoop :: POSIXTime -> Socket -> IO () -serverLoop start sock = loop - where - loop = do - client <- accept sock - _ <- forkIO (handleClient start client) - loop - -initServer :: NetworkStack -> TcpPort -> IO Socket -initServer ns port = listenPort (tcpHandle ns) port `X.catch` h - where - h ListenError{} = do - putStrLn ("Unable to listen on port: " ++ show port) - exitFailure - h se = do - print se - exitFailure - -handleClient :: POSIXTime -> Socket -> IO () -handleClient start client = body `X.catch` \se -> print (se :: X.SomeException) - where - body = do - mb <- processRequest client - case mb of - Nothing -> closeSocket client - Just (url,req) -> do - sendSocket client =<< makeResponse start url req - threadDelay 1000000 - closeSocket client - -processRequest :: Socket -> IO (Maybe (String,[S.ByteString])) -processRequest sock = do - ls <- readRequest sock - case ls of - [] -> return Nothing - l:_ -> return (Just (parseUrl l, ls)) - -crlf :: S.ByteString -crlf = S.pack [0x0d, 0x0a] - -readRequest :: Socket -> IO [S.ByteString] -readRequest sock = loop - where - loop = do - line <- readLine sock - if line == crlf - then return [] - else do - rest <- loop - return (line:rest) - -parseUrl :: S.ByteString -> String -parseUrl = head . drop 1 . words . toString - -fromString :: String -> S.ByteString -fromString = S.pack . map (toEnum . fromEnum) - -toString :: S.ByteString -> String -toString = map (toEnum . fromEnum) . S.unpack - -status200 :: S.ByteString -status200 = fromString "HTTP/1.1 200 OK\r\n" - -contentLength :: Int -> S.ByteString -contentLength len = fromString ("Content-Length: " ++ show len) - -contentType :: String -> S.ByteString -contentType ty = fromString ("Content-Type: " ++ ty) - -response404 :: S.ByteString -response404 = fromString $ concat - [ "HTTP/1.1 404 Not Found\r\n" - , "Content-Length: 0\r\n" - , "\r\n" - ] - -connectionClose :: S.ByteString -connectionClose = fromString "Connection: close" - -makeResponse :: POSIXTime -> String -> [S.ByteString] -> IO S.ByteString -makeResponse start url req - | url == "/favicon.ico" = return response404 - | otherwise = do - uptime <- timePassed start - let date = posixSecondsToUTCTime start - body = fromString (concat - [ "HaLVM" - , "

Welcome to the HaLVM!


\r\n\r\n" - , "Started on: " - , formatDate date - , ", and up for " - , uptime - , "\r\n

HTTP Request:

\r\n
"
-               ]) `S.append` S.concat req
-                  `S.append` fromString "
" - return $! S.concat - [ status200 - , contentLength (S.length body), crlf - , contentType "text/html", crlf - , connectionClose, crlf - , crlf - , body - ] - -formatDate :: UTCTime -> String -formatDate = formatTime defaultTimeLocale "%c" - -zeroUTCTime :: UTCTime -zeroUTCTime = UTCTime (ModifiedJulianDay 0) 0 - -timePassed :: POSIXTime -> IO String -timePassed start = do - now <- getPOSIXTime - let date@(UTCTime day _) = addUTCTime (now - start) zeroUTCTime - return $ concat - [ show (toModifiedJulianDay day) - , " days, " - , formatTime defaultTimeLocale "%k hours, %M minutes, %S seconds." date - ] diff --git a/example/test.hs b/example/test.hs deleted file mode 100644 --- a/example/test.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Main where - -import WebServer - -import Hans.Address -import Hans.Address.IP4 -import Hans.Address.Mac -import Hans.DhcpClient (dhcpDiscover) -import Hans.Message.Tcp (TcpPort(..)) -import Hans.NetworkStack - -import System.Exit (exitFailure) -import qualified Data.ByteString as S - -#ifdef xen_HOST_OS -import Communication.IVC (InChannelEx,OutChannelEx,Bin) -import Hans.Device.Ivc -import Hans.Device.Xen -import Hypervisor.Debug -import Hypervisor.Kernel -import RendezvousLib.PeerToPeer (p2pConnection) -import XenDevice.NIC -#else -import Hans.Device.Tap -import System.Environment (getArgs) -#endif - -output :: String -> IO () -outputBS :: S.ByteString -> IO () - -#ifdef xen_HOST_OS -output str = writeDebugConsole (showString str "\n") -outputBS = output . map (toEnum . fromEnum) . S.unpack - -_buildInput :: IO (OutChannelEx Bin Bytes) -buildInput :: IO (InChannelEx Bin Bytes) -(_buildInput,buildInput) = p2pConnection "ethernet_dev_input" - -_buildOutput :: IO (InChannelEx Bin Bytes) -buildOutput :: IO (OutChannelEx Bin Bytes) -(_buildOutput,buildOutput) = p2pConnection "ethernet_dev_output" - -#else -output = putStrLn -outputBS = S.putStrLn -#endif - - - -initEthernetDevice :: NetworkStack -> IO Mac -#ifdef xen_HOST_OS -initEthernetDevice ns = do - Just nic <- openXenDevice "" - let mac = read (getNICName nic) - print mac - addDevice mac (xenSend nic) (xenReceiveLoop nic) ns - --let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56 - --putStrLn "Waiting for input channel..." - --input <- buildInput - --putStrLn "Waiting for output channel..." - --output <- buildOutput - --addEthernetDevice (nsEthernet ns) mac (ivcSend output) (ivcReceiveLoop input) - return mac -#else -initEthernetDevice ns = do - let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56 - Just dev <- openTapDevice "tap0" - addDevice ns mac (tapSend dev) (tapReceiveLoop dev) - return mac -#endif - -main :: IO () -#ifdef xen_HOST_OS -main = halvm_kernel [dNICs] $ \ args -> do -#else -main = do - args <- getArgs -#endif - ns <- newNetworkStack - mac <- initEthernetDevice ns - deviceUp ns mac - setAddress args mac ns - webserver ns (TcpPort 8000) - -setAddress :: [String] -> Mac -> NetworkStack -> IO () -setAddress args mac ns = - case args of - ["dhcp"] -> dhcpDiscover ns mac print - [ip,gw] -> do - addIP4Addr ns (read ip `withMask` 24) mac 1500 - routeVia ns (IP4 0 0 0 0 `withMask` 0) (read gw) - _ -> do - putStrLn "Usage: dhcp" - putStrLn " " - exitFailure diff --git a/examples/echo-server/Main.hs b/examples/echo-server/Main.hs new file mode 100644 --- /dev/null +++ b/examples/echo-server/Main.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Hans +import Hans.Dns +import Hans.Device +import Hans.Nat +import Hans.Socket +import Hans.IP4.Packet (pattern WildcardIP4) +import Hans.IP4.Dhcp.Client (DhcpLease(..),defaultDhcpConfig,dhcpClient) + +import Control.Concurrent (forkIO,threadDelay) +import Control.Exception +import Control.Monad (forever) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import System.Environment (getArgs) +import System.Exit (exitFailure) + + +main :: IO () +main = + do args <- getArgs + (name,dhcp) <- case args of + [name,"dhcp"] -> return (S8.pack name,True) + name:_ -> return (S8.pack name,False) + _ -> fail "Expected a device name" + + ns <- newNetworkStack defaultConfig + dev <- addDevice ns name defaultDeviceConfig + + _ <- forkIO (showExceptions "processPackets" (processPackets ns)) + + -- start receiving data + startDevice dev + + if dhcp + then + do mbLease <- dhcpClient ns defaultDhcpConfig dev + case mbLease of + + Just lease -> + do putStrLn ("Assigned IP: " ++ show (unpackIP4 (dhcpAddr lease))) + print =<< getHostByName ns "galois.com" + + Nothing -> + do putStrLn "Dhcp failed" + exitFailure + + else + do putStrLn "Static IP: 192.168.71.11/24" + + addIP4Route ns False Route + { routeNetwork = IP4Mask (packIP4 192 168 71 11) 24 + , routeType = Direct + , routeDevice = dev + } + + addIP4Route ns True Route + { routeNetwork = IP4Mask (packIP4 192 168 71 11) 0 + , routeType = Indirect (packIP4 192 168 71 1) + , routeDevice = dev + } + + forwardTcpPort ns WildcardIP4 22 (packIP4 172 16 181 1) 22 + forwardUdpPort ns WildcardIP4 9090 (packIP4 172 16 181 128) 9090 + + sock <- sListen ns defaultSocketConfig WildcardIP4 9001 10 + + _ <- forkIO $ forever $ + do putStrLn "Waiting for a client" + client <- sAccept (sock :: TcpListenSocket IP4) + putStrLn "Got a client" + _ <- forkIO (handleClient client) + return () + + threadDelay (300 * 1000000) + + dumpStats (devStats dev) + + +showExceptions :: String -> IO a -> IO a +showExceptions l m = m `catch` \ e -> + do print (l, e :: SomeException) + throwIO e + + +handleClient :: TcpSocket IP4 -> IO () +handleClient sock = loop `finally` sClose sock + where + loop = + do str <- sRead sock 1024 + if L8.null str + then putStrLn "Closing client" + else do _ <- sWrite sock str + loop diff --git a/hans.cabal b/hans.cabal --- a/hans.cabal +++ b/hans.cabal @@ -1,243 +1,159 @@ name: hans -version: 2.6.0.0 -cabal-version: >= 1.8 +version: 3.0.2 +cabal-version: >= 1.18 license: BSD3 license-file: LICENSE -author: Galois Inc., Peng Li, Stephan Zdancewic +author: Galois Inc. maintainer: halvm-devel@community.galois.com category: Networking -synopsis: IPv4 Network Stack +synopsis: Network Stack build-type: Simple +tested-with: GHC == 7.8.4, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1 description: HaNS is a lightweight, pure Haskell network stack that can be used for Haskell - networking in the context of the HaLVM, or with a Linux tap device. Currently, - HaNS supports 802.3, IPv4, ARP, DHCP (partially), ICMP, UDP, and TCP. + networking in the context of the HaLVM, or with a Linux tap device. source-repository head type: git location: git://github.com/GaloisInc/HaNS.git -flag bounded-channels +flag examples + description: Build example programs 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 web-server - description: Build a simple web-server example - -flag word32-in-random - default: False - description: Word32 in Random - library - 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 + if os(HALVM) + cpp-options: -DHANS_TARGET_XEN + build-depends: XenDevice >= 2.0.0 && < 3, + HALVMCore >= 2.0.0 && < 3 + other-modules: Hans.Device.Xen + + if os(darwin) || os(linux) + cpp-options: -DHANS_TARGET_UNIX build-depends: unix + other-modules: Hans.Device.Tap include-dirs: cbits c-sources: cbits/tapdevice.c - exposed-modules: Hans.Device.Tap - if flag(bounded-channels) - build-depends: BoundedChan - cpp-options: -DBOUNDED_CHANNELS + -- XXX: Tap devices are supported on windows, someone should add support - ghc-options: -Wall + default-language: Haskell2010 + + ghc-options: -Wall -O2 hs-source-dirs: src 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, - stm >= 2.4 + cereal >= 0.5.0.0, + heaps <= 0.3.3, + psqueues, + bytestring, + containers, + array, + time, + hashable, + array, + BoundedChan, + random, + monadLib, + SHA - 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 + -- XXX: which of these should be exposed? + exposed-modules: Hans + Hans.Addr + Hans.Addr.Types + Hans.Checksum + Hans.Config + Hans.Device + Hans.Device.Loopback + Hans.Device.Types + Hans.Dns + Hans.Dns.Packet + Hans.Ethernet + Hans.Ethernet.Types + Hans.HashTable + Hans.IP4 + Hans.IP4.ArpTable + Hans.IP4.Dhcp.Client + Hans.IP4.Dhcp.Codec + Hans.IP4.Dhcp.Packet + Hans.IP4.Dhcp.Options + Hans.IP4.Fragments + Hans.IP4.Icmp4 + Hans.IP4.Input + Hans.IP4.Output + Hans.IP4.Packet + Hans.IP4.RoutingTable + Hans.IP4.State + Hans.Input + Hans.Lens + Hans.Monad + Hans.Nat + Hans.Network + Hans.Network.Types + Hans.Serialize + Hans.Socket + Hans.Socket.Handle + Hans.Tcp.Input + Hans.Tcp.Message + Hans.Tcp.Output + Hans.Tcp.Packet + Hans.Tcp.RecvWindow + Hans.Tcp.SendWindow + Hans.Tcp.State + Hans.Tcp.Tcb + Hans.Tcp.Timers + Hans.Time + Hans.Types + Hans.Udp.Input + Hans.Udp.Output + Hans.Udp.Packet + Hans.Udp.State - exposed-modules: Data.PrefixTree, - Hans.Address, - Hans.Address.IP4, - Hans.Address.Mac, - Hans.Channel, - Hans.DhcpClient, - 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.Tcp.Timers, - Hans.Layer.Tcp.Types, - Hans.Layer.Tcp.WaitBuffer, - Hans.Layer.Tcp.Window, - Hans.Layer.Udp, - Hans.Message.Arp, - Hans.Message.Dhcp4, - Hans.Message.Dhcp4Codec, - Hans.Message.Dhcp4Options, - Hans.Message.Dns, - Hans.Message.EthernetFrame, - Hans.Message.Icmp4, - 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 + other-modules: Hans.Buffer.Datagram + Hans.Buffer.Signal + Hans.Buffer.Stream + Hans.Nat.Forward + Hans.Nat.State + Hans.Socket.Tcp + Hans.Socket.Types + Hans.Socket.Udp + Hans.Threads +executable echo-server + if flag(examples) + build-depends: base >= 4.0.0.0 && < 5, + bytestring, + hans -executable test - if flag(example) - buildable: True else buildable: False - if(flag(bounded-channels)) - build-depends: BoundedChan - cpp-options: -DBOUNDED_CHANNELS - - main-is: test.hs - other-modules: WebServer - ghc-options: -Wall - hs-source-dirs: example - 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 - else - ghc-options: -threaded - -executable web-server - main-is: Main.hs - hs-source-dirs: web-server - ghc-options: -Wall -threaded -rtsopts -fno-warn-unused-do-bind - -fno-warn-orphans - - 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 -rtsopts -threaded - build-depends: base >= 4.0.0.0 && < 5, - cereal >= 0.3.5.2, - bytestring >= 0.9.1.0, - containers >= 0.3.0.0, - monadLib >= 3.6.0, - time >= 1.1.0.0, - old-locale >= 1.0.0.0, - hans - if os(HaLVM) - build-depends: XenDevice >= 2.0.0 && < 3.0.0, - HALVMCore >= 2.0.0 && < 3.0.0 - -executable echo-client - main-is: Main.hs - hs-source-dirs: echo-client - ghc-options: -Wall -rtsopts -threaded - build-depends: base >= 4.0.0.0 && < 5, - cereal >= 0.3.5.2, - bytestring >= 0.9.1.0, - containers >= 0.3.0.0, - monadLib >= 3.6.0, - time >= 1.1.0.0, - old-locale >= 1.0.0.0, - hans - if os(HaLVM) - build-depends: XenDevice >= 2.0.0 && < 3.0.0, - HALVMCore >= 2.0.0 && < 3.0.0 - -executable tcp-test-client - main-is: Main.hs - hs-source-dirs: tcp-test-client - if os(HaLVM) - buildable: False - else - build-depends: base, - bytestring, - network + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: examples/echo-server + ghc-options: -Wall -threaded -O2 -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, +test-suite hans-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base >= 4.4 && < 5, + bytestring, + tasty >= 0.11, + tasty-quickcheck, + tasty-ant-xml, + QuickCheck, + cereal, hans - else - buildable: False + ghc-options: -Wall -threaded + + hs-source-dirs: tests + main-is: Main.hs + other-modules: Tests.Checksum + Tests.Ethernet + Tests.IP4 + Tests.IP4.Fragmentation + Tests.IP4.Icmp4 + Tests.IP4.Packet + Tests.Network + Tests.Utils diff --git a/src/Data/PrefixTree.hs b/src/Data/PrefixTree.hs deleted file mode 100644 --- a/src/Data/PrefixTree.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Data.PrefixTree ( - PrefixTree - - -- * Construction - , empty - , singleton - , insert - , delete - , toList - , fromList - - -- * Querying - , lookup - , member - , matches - , match - , elems - , keys - , key - ) where - -import Prelude hiding (lookup) -import Data.Maybe (isJust,listToMaybe) - -#ifdef TESTS -import Data.List (nub) -import Test.QuickCheck -#endif - -data PrefixTree a - = Empty - | Prefix Key (Maybe a) (PrefixTree a) - | Branch (PrefixTree a) (PrefixTree a) - deriving Show - -type Key = [Bool] - --- Prefix Manipulation --------------------------------------------------------- - -matchPrefix :: Key -> Key -> (Key,Key,Key) -matchPrefix = loop id - where - loop k (a:as) (b:bs) | a == b = loop (k . (a:)) as bs - loop k as bs = (k [], as, bs) - - --- Construction ---------------------------------------------------------------- - -empty :: PrefixTree a -empty = Empty - -singleton :: Key -> a -> PrefixTree a -singleton ks a = Prefix ks (Just a) empty - -fromList :: [(Key,a)] -> PrefixTree a -fromList = foldr (uncurry insert) empty - -toList :: PrefixTree a -> [([Bool], a)] -toList t = - case t of - Empty -> [] - - Prefix ls mb t' -> - case mb of - Nothing -> map (prefix ls) (toList t') - Just a -> (ls,a) : map (prefix ls) (toList t') - - Branch l r -> toList l ++ toList r - - where - prefix ls (ks,a) = (ls ++ ks, a) - -elems :: PrefixTree a -> [a] -elems t = - case t of - Empty -> [] - Prefix _ (Just a) t' -> a : elems t' - Prefix _ _ t' -> elems t' - Branch l r -> elems l ++ elems r - -insert :: Key -> a -> PrefixTree a -> PrefixTree a -insert ks a t = - case t of - - Empty -> singleton ks a - - Prefix ls mb t' -> - case matchPrefix ks ls of - -- empty node - ([],[],[]) -> Prefix [] (Just a) t' - - -- empty key - ([],[],_) -> Prefix [] (Just a) t - - -- empty node, full key - ([],_,[]) -> Prefix [] mb (insert ks a t') - - -- no common prefix, branch. - ([], k:_, _) - | k -> Branch (singleton ks a) t - | otherwise -> Branch t (singleton ks a) - - -- complete match, replace the value - (_, [], []) -> Prefix ks (Just a) t' - - -- complete prefix match, but partial key match - (_ ,ks',[]) -> Prefix ls mb (insert ks' a t') - - -- complete key match, partial prefix match - (_,[],ls') -> Prefix ks (Just a) (Prefix ls' mb t') - - -- partial common prefix, but not the full key - (ps,ks'@(k:_),ls') -> Prefix ps Nothing br - where - t1 = singleton ks' a - t2 = Prefix ls' mb t' - br | k = Branch t1 t2 - | otherwise = Branch t2 t1 - - Branch l r -> - case ks of - [] -> Prefix [] (Just a) t - b:_ | b -> Branch (insert ks a l) r - | otherwise -> Branch l (insert ks a r) - - -delete :: Key -> PrefixTree a -> PrefixTree a -delete ks t = - case t of - - Empty -> Empty - - Prefix ls mb t' -> - case matchPrefix ks ls of - (_,[],[]) -> compact (Prefix ls Nothing t') - ([],ks',[]) -> compact (Prefix ls mb (delete ks' t')) - _ -> t - - Branch l r -> - case ks of - [] -> t - b:bs | b -> compact (Branch (delete bs l) r) - | otherwise -> compact (Branch l (delete bs r)) - -compact :: PrefixTree a -> PrefixTree a -compact t = - case t of - - Prefix ls Nothing (Prefix ks mb t') -> Prefix (ls ++ ks) mb t' - - Branch l Empty -> l - Branch Empty r -> r - - _ -> t - - --- Querying -------------------------------------------------------------------- - -member :: Key -> PrefixTree a -> Bool -member ks t = - case t of - - Empty -> False - - Prefix ls mb t' -> - case matchPrefix ks ls of - (_,[], []) -> isJust mb - (_,ks',[]) -> member ks' t' - _ -> False - - Branch l r -> - case ks of - [] -> False - b:_ | b -> member ks l - | otherwise -> member ks r - -matches :: Key -> PrefixTree a -> [a] -matches = loop [] - where - loop ms ks t = - case t of - - Empty -> ms - - Prefix ls mb t' -> - case matchPrefix ks ls of - (_,[], []) -> maybe ms (:ms) mb - (_,ks',[]) -> loop (maybe ms (:ms) mb) ks' t' - _ -> ms - - Branch l r -> - case ks of - [] -> ms - b:_ | b -> loop ms ks l - | otherwise -> loop ms ks r - -match :: Key -> PrefixTree a -> Maybe a -match k t = listToMaybe (matches k t) - -lookup :: Key -> PrefixTree a -> Maybe a -lookup = match - -keys :: Key -> PrefixTree a -> [Key] -keys = keys' [] [] - where - keys' as p ks t = - case t of - - Empty -> as - - Prefix ls _ t' -> - case matchPrefix ks ls of - (ps,ks',[]) -> keys' (p':as) p' ks' t' - where p' = p ++ ps - _ -> as - - Branch l r -> keys' ls p ks r - where ls = keys' as p ks l - -key :: Key -> PrefixTree a -> Maybe Key -key ks t = listToMaybe (keys ks t) - - --- Tests ----------------------------------------------------------------------- - -#ifdef TESTS -forAllUniqueLists :: (Testable prop, Arbitrary a, Show a, Eq a) - => ([a] -> prop) -> Property -forAllUniqueLists = forAll (nub `fmap` arbitrary) - -prop_toList_fromList = forAllUniqueLists p - where - p :: [([Bool],())] -> Bool - p bs = length bs == length bs' && all (`elem` bs) bs' - where bs' = toList (fromList bs) - -prop_matchesOrder bs = and (map (f . fst) bs) - where - t1 = fromList bs - t2 = fromList (reverse bs) - f k = matches k t1 == matches k t2 -#endif diff --git a/src/Hans.hs b/src/Hans.hs new file mode 100644 --- /dev/null +++ b/src/Hans.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE CPP #-} + +module Hans ( + -- * Network Stack + NetworkStack(), Config(..), defaultConfig, + newNetworkStack, + processPackets, + + -- * Devices + DeviceName, + Device(), DeviceConfig(..), defaultDeviceConfig, + addDevice, + listDevices, + closeDevice, + startDevice, + + -- * Network Layer + Addr(), sameFamily, + NetworkAddr(..), + Network(..), + RouteInfo(..), + + -- ** IP4 + IP4.IP4(), IP4.packIP4, IP4.unpackIP4, + IP4.IP4Mask(..), + IP4.Route(..), IP4.RouteType(Direct,Indirect), + addIP4Route, + + ) where + +import Hans.Addr (NetworkAddr(..),Addr(),sameFamily) +import Hans.Config +import Hans.Device +import Hans.Device.Loopback +import qualified Hans.IP4.State as IP4 +import qualified Hans.IP4.Packet as IP4 +import qualified Hans.IP4.RoutingTable as IP4 (Route(..),RouteType(..)) +import qualified Hans.IP4.Output as IP4 (responder) +import Hans.Input +import Hans.Network +import Hans.Threads (forkNamed) +import Hans.Types +import qualified Hans.Tcp.Output as Tcp (responder) +import qualified Hans.Tcp.Timers as Tcp +import qualified Hans.Udp.Output as Udp (responder) + +import Control.Concurrent.BoundedChan (newBoundedChan) +import Data.IORef (newIORef,atomicModifyIORef') + +#ifdef HANS_TARGET_XEN +import Hypervisor.XenStore (XenStore) +#endif + + +-- | Create a network stack with no devices registered. +newNetworkStack :: Config -> IO NetworkStack +newNetworkStack nsConfig = + do nsInput <- newBoundedChan (cfgInputQueueSize nsConfig) + nsNat <- newNatState nsConfig + nsDevices <- newIORef [] + nsIP4State <- newIP4State nsConfig + nsUdpState <- newUdpState nsConfig + nsTcpState <- newTcpState nsConfig + nsNameServers4 <- newIORef [] + + rec nsIP4Responder <- forkNamed "IP4.responder" (IP4.responder ns) + nsTcpTimers <- forkNamed "Tcp.tcpTimers" (Tcp.tcpTimers ns) + nsTcpResponder <- forkNamed "Tcp.responder" (Tcp.responder ns) + nsUdpResponder <- forkNamed "Udp.responder" (Udp.responder ns) + let ns = NetworkStack { .. } + + registerLoopback ns + + return ns + +-- | Create and register the loopback device. Additionally, add its routing +-- information. +registerLoopback :: NetworkStack -> IO () +registerLoopback ns = + do lo <- newLoopbackDevice ns + atomicModifyIORef' (nsDevices ns) (\devs -> (lo : devs, ())) + + -- add the route for 127.0.0.0/8 + addIP4Route ns False + IP4.Route { routeNetwork = IP4.IP4Mask (IP4.packIP4 127 0 0 1) 8 + , routeType = IP4.Direct + , routeDevice = lo } + +-- | Initialize and register a device with the network stack. +-- NOTE: this does not start the device. + +#ifdef HANS_TARGET_XEN +addDevice :: XenStore -> NetworkStack -> DeviceName -> DeviceConfig -> IO Device +addDevice xs ns devName devConfig = + do dev <- openDevice xs ns devName devConfig + atomicModifyIORef' (nsDevices ns) (\devs -> (dev : devs, ())) + return dev +#else +addDevice :: NetworkStack -> DeviceName -> DeviceConfig -> IO Device +addDevice ns devName devConfig = + do dev <- openDevice ns devName devConfig + atomicModifyIORef' (nsDevices ns) (\devs -> (dev : devs, ())) + return dev +#endif + +-- | Add a route to the IP4 layer. +addIP4Route :: NetworkStack -> Bool -> IP4.Route -> IO () +addIP4Route NetworkStack { .. } = IP4.addRoute nsIP4State +{-# INLINE addIP4Route #-} diff --git a/src/Hans/Addr.hs b/src/Hans/Addr.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Addr.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Hans.Addr ( + Addr(), sameFamily, + NetworkAddr(..), + putAddr, + showAddr, + ) where + +import Hans.Addr.Types +import qualified Hans.IP4.Packet as IP4 + +import Data.Hashable (Hashable) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + + +class (Hashable addr, Show addr, Typeable addr, Eq addr, Generic addr) + => NetworkAddr addr where + -- | Forget what kind of address this is. + toAddr :: addr -> Addr + + -- | Try to remember what this opaque address was. + fromAddr :: Addr -> Maybe addr + + -- | Check to see if this address is the wildcard address. + isWildcardAddr :: addr -> Bool + + -- | The wildcard address + wildcardAddr :: addr -> addr + + -- | Check to see if this address is the broadcast address. + isBroadcastAddr :: addr -> Bool + + -- | The broadcast address. + broadcastAddr :: addr -> addr + + +instance NetworkAddr Addr where + toAddr = id + fromAddr addr = Just addr + isWildcardAddr (Addr4 addr) = isWildcardAddr addr + wildcardAddr (Addr4 addr) = Addr4 (wildcardAddr addr) + isBroadcastAddr (Addr4 addr) = isBroadcastAddr addr + broadcastAddr (Addr4 addr) = Addr4 (broadcastAddr addr) + {-# INLINE toAddr #-} + {-# INLINE fromAddr #-} + {-# INLINE isWildcardAddr #-} + {-# INLINE wildcardAddr #-} + {-# INLINE isBroadcastAddr #-} + {-# INLINE broadcastAddr #-} + + +instance NetworkAddr IP4.IP4 where + toAddr = Addr4 + fromAddr (Addr4 addr) = Just addr + isWildcardAddr IP4.WildcardIP4 = True + isWildcardAddr _ = False + wildcardAddr _ = IP4.WildcardIP4 + isBroadcastAddr IP4.BroadcastIP4 = True + isBroadcastAddr _ = False + broadcastAddr _ = IP4.BroadcastIP4 + {-# INLINE toAddr #-} + {-# INLINE fromAddr #-} + {-# INLINE isWildcardAddr #-} + {-# INLINE wildcardAddr #-} + {-# INLINE isBroadcastAddr #-} + {-# INLINE broadcastAddr #-} diff --git a/src/Hans/Addr/Types.hs b/src/Hans/Addr/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Addr/Types.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Hans.Addr.Types where + +import Hans.IP4.Packet (IP4,putIP4,showIP4) + +import Data.Hashable (Hashable) +import Data.Serialize (Put) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +data Addr = Addr4 !IP4 + deriving (Eq,Ord,Show,Generic,Typeable) + +instance Hashable Addr + +putAddr :: Addr -> Put +putAddr (Addr4 ip) = putIP4 ip + +showAddr :: Addr -> ShowS +showAddr (Addr4 ip4) = showIP4 ip4 + + +sameFamily :: Addr -> Addr -> Bool +sameFamily Addr4{} Addr4{} = True diff --git a/src/Hans/Address.hs b/src/Hans/Address.hs deleted file mode 100644 --- a/src/Hans/Address.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleContexts #-} - -module Hans.Address where - -import Data.Serialize (Serialize) -import Data.Word (Word8) - -class (Ord a, Serialize a) => Address a where - addrSize :: a -> Word8 - toBits :: a -> [Bool] - - -class Address addr => Mask mask addr | addr -> mask, mask -> addr where - masksAddress :: mask -> addr -> Bool - withMask :: addr -> Int -> mask - getMaskComponents :: mask -> (addr,Int) - getMaskRange :: mask -> (addr,addr) - broadcastAddress :: mask -> addr - - -isBroadcast :: (Eq addr, Mask mask addr) => mask -> addr -> Bool -isBroadcast m a = broadcastAddress m == a diff --git a/src/Hans/Address/IP4.hs b/src/Hans/Address/IP4.hs deleted file mode 100644 --- a/src/Hans/Address/IP4.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Hans.Address.IP4 where - -import Hans.Address -import Hans.Utils (Endo) - -import Control.Monad (guard,liftM2) -import Data.Serialize (Serialize(..)) -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) - - -data IP4 = IP4 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - deriving (Ord,Eq,Typeable,Data,Generic) - -broadcastIP4 :: IP4 -broadcastIP4 = IP4 255 255 255 255 - -instance Address IP4 where - addrSize _ = 4 - - toBits (IP4 a b c d) = f 0x80 a (f 0x80 b (f 0x80 c (f 0x80 d []))) - where - 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 = parseIP4 - put = renderIP4 - -instance Show IP4 where - showsPrec _ (IP4 a b c d) = foldl (.) id - $ intersperse (showChar '.') - [shows a, shows b, shows c, shows d] - -instance Read IP4 where - readsPrec _ rest0 = do - (a, '.':rest1) <- readDec rest0 - (b, '.':rest2) <- readDec rest1 - (c, '.':rest3) <- readDec rest2 - (d, rest4) <- readDec rest3 - return (IP4 a b c d, rest4) - -convertToWord32 :: IP4 -> Word32 -convertToWord32 (IP4 a b c d) - = fromIntegral a `shiftL` 24 - + fromIntegral b `shiftL` 16 - + fromIntegral c `shiftL` 8 - + fromIntegral d - -convertFromWord32 :: Word32 -> IP4 -convertFromWord32 n = IP4 a b c d - where - a = fromIntegral (n `shiftR` 24) - b = fromIntegral (n `shiftR` 16) - c = fromIntegral (n `shiftR` 8) - d = fromIntegral n - - -data IP4Mask = IP4Mask - {-# UNPACK #-} !IP4 - {-# UNPACK #-} !Word8 - deriving (Eq,Ord,Typeable,Data,Show) - -instance Serialize IP4Mask where - put (IP4Mask i m) = put i >> put m - get = liftM2 IP4Mask get get - -instance Read IP4Mask where - readsPrec x rest0 = do - (addr,'/':rest1) <- readsPrec x rest0 - (bits, rest2) <- readsPrec x rest1 - guard (bits >= 0 && bits <= 32) - return (IP4Mask addr bits, rest2) - -instance Mask IP4Mask IP4 where - masksAddress mask@(IP4Mask _ bits) a2 = - clearHostBits mask == clearHostBits (IP4Mask a2 bits) - getMaskRange x = (clearHostBits x, setHostBits x) - withMask addr bits = IP4Mask addr (fromIntegral bits) - getMaskComponents (IP4Mask addr bits) = (addr,fromIntegral bits) - broadcastAddress = setHostBits - -modifyAsWord32 :: Endo Word32 -> Endo IP4 -modifyAsWord32 f = convertFromWord32 . f . convertToWord32 - -clearHostBits :: IP4Mask -> IP4 -clearHostBits (IP4Mask addr bits) = modifyAsWord32 (.&. mask) addr - where mask = -2 ^ (32 - bits) - -setHostBits :: IP4Mask -> IP4 -setHostBits (IP4Mask addr bits) = modifyAsWord32 (.|. mask) addr - where mask = 2 ^ (32 - bits) - 1 diff --git a/src/Hans/Address/Mac.hs b/src/Hans/Address/Mac.hs deleted file mode 100644 --- a/src/Hans/Address/Mac.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Hans.Address.Mac ( - Mac(..) - , parseMac - , renderMac - , broadcastMac - , showsMac - , macMask - ) where - -import Hans.Address -import Hans.Utils (showPaddedHex) - -import Control.Applicative ((<*>),(<$>)) -import Data.Serialize (Serialize(..)) -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 - - --- | Mac addresses. -data Mac = Mac - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - {-# UNPACK #-} !Word8 - deriving ( Eq, Ord, Generic ) - - --- | Show a Mac address. -showsMac :: Mac -> ShowS -showsMac (Mac a b c d e f) = foldl1 (.) - $ intersperse (showChar ':') - $ map showPaddedHex [a,b,c,d,e,f] - --- | Generates a mask tailored to the given MAC address. -macMask :: Mac -> Mac -macMask (Mac a b c d e f) = - Mac (complement a) - (complement b) - (complement c) - (complement d) - (complement e) - (complement f) - --- | The broadcast mac address. -broadcastMac :: Mac -broadcastMac = Mac 0xff 0xff 0xff 0xff 0xff 0xff - -instance Show Mac where - showsPrec _ = showsMac - -instance Read Mac where - readsPrec _ = loop 6 [] - where - loop :: Int -> [Word8] -> String -> [(Mac,String)] - loop 0 [f,e,d,c,b,a] str = [(Mac a b c d e f,str)] - loop 0 _ _ = [] - loop n acc str = case readHex str of - [(a,':':rest)] -> loop (n-1) (a:acc) rest - [(a, rest)] -> loop 0 (a:acc) rest - _ -> [] - - -instance Address Mac where - addrSize _ = 6 - - toBits (Mac a b c d e f) = concatMap k [a,b,c,d,e,f] - where k i = map (testBit i) [0 .. 7] - -parseMac :: Get Mac -parseMac = Mac - <$> getWord8 - <*> getWord8 - <*> getWord8 - <*> getWord8 - <*> getWord8 - <*> getWord8 - -renderMac :: Putter Mac -renderMac (Mac a b c d e f) = putByteString (S.pack [a,b,c,d,e,f]) - -instance Serialize Mac where - get = parseMac - put = renderMac diff --git a/src/Hans/Buffer/Datagram.hs b/src/Hans/Buffer/Datagram.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Buffer/Datagram.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Buffer.Datagram ( + Buffer, + newBuffer, + writeChunk, + readChunk, + tryReadChunk, + isEmptyBuffer + ) where + +import Hans.Buffer.Signal + +import Control.Monad (when) +import qualified Data.ByteString as S +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import qualified Data.Sequence as Seq + + +-- Buffers --------------------------------------------------------------------- + +data Buffer a = Buffer { bufContents :: {-# UNPACK #-} !(IORef (BufContents a)) + , bufSignal :: {-# UNPACK #-} !Signal + -- ^ The wait queue. Waiters queue up trying to take the + -- MVar, and are unblocked when there are chunks + -- available in the queue. + } + +newBuffer :: Int -> IO (Buffer a) +newBuffer size = + do bufContents <- newIORef (emptyBufContents size) + bufSignal <- newSignal + return Buffer { .. } + +-- | Write a chunk to the buffer. Returns 'False' if the chunk could not be +-- written. +writeChunk :: Buffer a -> a -> S.ByteString -> IO Bool +writeChunk Buffer { .. } a bytes = + do (written,more) <- atomicModifyIORef' bufContents (queueChunk a bytes) + when more (signal bufSignal) + return written + + +-- | Read a chunk from the buffer, blocking until one is ready. +readChunk :: Buffer a -> IO (a,S.ByteString) +readChunk Buffer { .. } = loop + where + loop = + do mb <- atomicModifyIORef' bufContents dequeueChunk + case mb of + Just (c,more) -> + do when more (signal bufSignal) + return c + + Nothing -> + do waitSignal bufSignal + loop + + +-- | Poll for a ready chunk. +tryReadChunk :: Buffer a -> IO (Maybe (a,S.ByteString)) +tryReadChunk Buffer { .. } = + do mb <- atomicModifyIORef' bufContents dequeueChunk + case mb of + Just (a,more) -> + do when more (signal bufSignal) + return (Just a) + + Nothing -> + return Nothing + +-- | See if the buffer is empty. +isEmptyBuffer :: Buffer a -> IO Bool +isEmptyBuffer Buffer { .. } = + (Seq.null . bufChunks) `fmap` readIORef bufContents + +-- Buffer State ---------------------------------------------------------------- + +data BufContents a = BufContents { bufAvail :: {-# UNPACK #-} !Int + -- ^ Available space in the buffer, in bytes. + + , bufChunks :: !(Seq.Seq (a,S.ByteString)) + -- ^ Chunks present in the buffer. + } + + +emptyBufContents :: Int -> BufContents a +emptyBufContents bufAvail = BufContents { bufChunks = Seq.empty, .. } + +chunksAvailable :: BufContents a -> Bool +chunksAvailable BufContents { .. } = not (Seq.null bufChunks) + +-- | The return value is as follows: +-- +-- The first element is 'True' when the chunk has been written to the queue +-- The second element is 'True' when there is more data present in the queue +-- +-- This covers a funny case where the queue was empty, and the chunk that was +-- given was too big for the whole buffer -- the buffer wasn't written, and the +-- queue is still empty. +queueChunk :: a -> S.ByteString -> BufContents a -> (BufContents a,(Bool,Bool)) +queueChunk a chunk buf + | bufAvail buf >= chunkLen = + (BufContents { bufAvail = bufAvail buf - chunkLen + , bufChunks = bufChunks buf Seq.|> (a,chunk) }, (True,True)) + + | otherwise = + (buf, (False,chunksAvailable buf)) + + where + chunkLen = S.length chunk + +dequeueChunk :: BufContents a -> (BufContents a, Maybe ((a,S.ByteString),Bool)) +dequeueChunk buf = + case Seq.viewl (bufChunks buf) of + c Seq.:< cs -> + let buf' = BufContents { bufAvail = bufAvail buf + S.length (snd c) + , bufChunks = cs } + in (buf', Just (c, chunksAvailable buf')) + + _ -> (buf, Nothing) diff --git a/src/Hans/Buffer/Signal.hs b/src/Hans/Buffer/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Buffer/Signal.hs @@ -0,0 +1,23 @@ +module Hans.Buffer.Signal where + +import Control.Concurrent (MVar,newEmptyMVar,tryPutMVar,takeMVar,tryTakeMVar) + +type Signal = MVar () + +newSignal :: IO Signal +newSignal = newEmptyMVar + +signal :: Signal -> IO () +signal var = + do _ <- tryPutMVar var () + return () + +waitSignal :: Signal -> IO () +waitSignal = takeMVar + +tryWaitSignal :: Signal -> IO Bool +tryWaitSignal var = + do mb <- tryTakeMVar var + case mb of + Just () -> return True + Nothing -> return False diff --git a/src/Hans/Buffer/Stream.hs b/src/Hans/Buffer/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Buffer/Stream.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | The rationale behind this buffer not tracking any size parameter, is that +-- it will always be used as part of the receive window. As such, there should +-- only ever be at most a full window's worth of data queued, as other data will +-- be rejected. + +module Hans.Buffer.Stream ( + Buffer(), + newBuffer, + closeBuffer, + bytesAvailable, + putBytes, + takeBytes, + tryTakeBytes, + ) where + +import Hans.Buffer.Signal + +import Control.Monad (when,unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import qualified Data.Sequence as Seq + + +-- Stream Buffers -------------------------------------------------------------- + +data Buffer = Buffer { bufState :: !(IORef State) + -- ^ The buffer and current size + + , bufSignal :: !Signal + -- ^ Data available signal + } + +newBuffer :: IO Buffer +newBuffer = + do bufState <- newIORef emptyState + bufSignal <- newSignal + return Buffer { .. } + +closeBuffer :: Buffer -> IO () +closeBuffer Buffer { .. } = + do atomicModifyIORef' bufState sClose + signal bufSignal + +bytesAvailable :: Buffer -> IO Bool +bytesAvailable Buffer { .. } = + do st <- readIORef bufState + return (not (sNull st)) + +putBytes :: S.ByteString -> Buffer -> IO () +putBytes bytes Buffer { .. } = + do unless (S.null bytes) (atomicModifyIORef' bufState (sPut bytes)) + signal bufSignal + +-- | Take up to n bytes from the buffer, blocking until some data is ready. +takeBytes :: Int -> Buffer -> IO L.ByteString +takeBytes n Buffer { .. } + | n <= 0 = return L.empty + | otherwise = loop + where + loop = + do (bytes,more,closed) <- atomicModifyIORef' bufState (sTake n) + if L.null bytes && not closed + then do waitSignal bufSignal + loop + else do when (more || closed) (signal bufSignal) + return bytes + +-- | Take up to n bytes from the buffer, returning immediately if no data is +-- available. +tryTakeBytes :: Int -> Buffer -> IO (Maybe L.ByteString) +tryTakeBytes n Buffer { .. } + | n <= 0 = return Nothing + | otherwise = + do (bytes,more,closed) <- atomicModifyIORef' bufState (sTake n) + when (more || closed) (signal bufSignal) + if L.null bytes + then return Nothing + else return (Just bytes) + + +-- Internal State -------------------------------------------------------------- + +data State = State { stBuf :: !(Seq.Seq S.ByteString) + , stClosed :: !Bool + } + +emptyState :: State +emptyState = State { stBuf = Seq.empty, stClosed = False } + +sNull :: State -> Bool +sNull State { .. } = Seq.null stBuf + +sClose :: State -> (State, ()) +sClose State { .. } = (State { stClosed = True, .. }, ()) + +-- | Remove up to n bytes of data from the internal state. +sTake :: Int -> State -> (State, (L.ByteString,Bool,Bool)) +sTake n0 State { .. } = go [] n0 stBuf + where + + go acc n mem + | n > 0 = + case Seq.viewl mem of + + buf Seq.:< mem' + + | S.length buf > n -> + let (as,bs) = S.splitAt n buf + in finalize (L.fromStrict as:acc) (bs Seq.<| mem') + + | otherwise -> + go (L.fromStrict buf:acc) (n - S.length buf) mem' + + + Seq.EmptyL -> + finalize acc Seq.empty + + | otherwise = + finalize acc mem + + finalize acc mem = + ( State { stBuf = mem, .. } + , (L.concat (reverse acc), not (Seq.null mem), stClosed) + ) + + +sPut :: S.ByteString -> State -> (State, ()) +sPut bytes State { .. } = (State { stBuf = stBuf Seq.|> bytes, .. }, ()) diff --git a/src/Hans/Channel.hs b/src/Hans/Channel.hs deleted file mode 100644 --- a/src/Hans/Channel.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} - -module Hans.Channel where - -#ifdef BOUNDED_CHANNELS -import Control.Concurrent.BoundedChan as C - -type Channel a = BoundedChan a - -newChannel :: IO (Channel a) -newChannel = newBoundedChan 20 - -receive :: Channel a -> IO a -receive c = readChan c - -send :: Channel a -> a -> IO () -send c a = writeChan c $! a - -#else -import Control.Concurrent.Chan as C - -type Channel a = Chan a - -newChannel :: IO (Channel a) -newChannel = newChan - -receive :: Channel a -> IO a -receive = readChan - -send :: Channel a -> a -> IO () -send c a = writeChan c $! a - -#endif diff --git a/src/Hans/Checksum.hs b/src/Hans/Checksum.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Checksum.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +-- BANNERSTART +-- - Copyright 2006-2008, 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. +-- Author: Adam Wick +-- BANNEREND +-- |A module providing checksum computations to other parts of Hans. The +-- checksum here is the standard Internet 16-bit checksum (the one's +-- complement of the one's complement sum of the data). + +module Hans.Checksum( + -- * Checksums + computeChecksum, + Checksum(..), + PartialChecksum(), + emptyPartialChecksum, + finalizeChecksum, + stepChecksum, + + Pair8(..), + ) where + +import Data.Bits (Bits(shiftL,shiftR,complement,clearBit,(.&.))) +import Data.List (foldl') +import Data.Word (Word8,Word16,Word32) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as Sh +import qualified Data.ByteString.Unsafe as S + + +data PartialChecksum = PartialChecksum { pcAccum :: {-# UNPACK #-} !Word32 + , pcCarry :: !(Maybe Word8) + } deriving (Eq,Show) + +emptyPartialChecksum :: PartialChecksum +emptyPartialChecksum = PartialChecksum + { pcAccum = 0 + , pcCarry = Nothing + } + +finalizeChecksum :: PartialChecksum -> Word16 +finalizeChecksum pc = complement (fromIntegral (fold32 (fold32 result))) + where + fold32 :: Word32 -> Word32 + fold32 x = (x .&. 0xFFFF) + (x `shiftR` 16) + + result = case pcCarry pc of + Nothing -> pcAccum pc + Just prev -> stepChecksum (pcAccum pc) prev 0 +{-# INLINE finalizeChecksum #-} + + +computeChecksum :: Checksum a => a -> Word16 +computeChecksum a = finalizeChecksum (extendChecksum a emptyPartialChecksum) +{-# INLINE computeChecksum #-} + +-- | Incremental checksum computation interface. +class Checksum a where + extendChecksum :: a -> PartialChecksum -> PartialChecksum + + +data Pair8 = Pair8 !Word8 !Word8 + +instance Checksum Pair8 where + extendChecksum (Pair8 hi lo) = \ PartialChecksum { .. } -> + case pcCarry of + Nothing -> PartialChecksum { pcAccum = stepChecksum pcAccum hi lo + , pcCarry = Nothing } + Just c -> PartialChecksum { pcAccum = stepChecksum pcAccum c hi + , pcCarry = Just lo } + {-# INLINE extendChecksum #-} + +instance Checksum Word16 where + extendChecksum w = \pc -> extendChecksum (Pair8 hi lo) pc + where + lo = fromIntegral w + hi = fromIntegral (w `shiftR` 8) + {-# INLINE extendChecksum #-} + +instance Checksum Word32 where + extendChecksum w = \pc -> + extendChecksum (fromIntegral w :: Word16) $ + extendChecksum (fromIntegral (w `shiftR` 16) :: Word16) pc + {-# INLINE extendChecksum #-} + +instance Checksum a => Checksum [a] where + extendChecksum as = \pc -> foldl' (flip extendChecksum) pc as + {-# INLINE extendChecksum #-} + +instance Checksum L.ByteString where + extendChecksum lbs = \pc -> extendChecksum (L.toChunks lbs) pc + {-# INLINE extendChecksum #-} + +-- XXX this could be faster if we could mirror the structure of the instance for +-- S.ByteString +instance Checksum Sh.ShortByteString where + extendChecksum shb = \ pc -> extendChecksum (Sh.fromShort shb) pc + + +instance Checksum S.ByteString where + extendChecksum b pc + | S.null b = pc + | otherwise = case pcCarry pc of + Nothing -> result + Just prev -> extendChecksum (S.tail b) PartialChecksum + { pcCarry = Nothing + , pcAccum = stepChecksum (pcAccum pc) prev (S.unsafeIndex b 0) + } + where + + n' = S.length b + n = clearBit n' 0 -- aligned to two + + result = PartialChecksum + { pcAccum = loop (pcAccum pc) 0 + , pcCarry = carry + } + + carry + | odd n' = Just $! S.unsafeIndex b n + | otherwise = Nothing + + loop !acc off + | off < n = loop (stepChecksum acc hi lo) (off + 2) + | otherwise = acc + where hi = S.unsafeIndex b off + lo = S.unsafeIndex b (off+1) + +stepChecksum :: Word32 -> Word8 -> Word8 -> Word32 +stepChecksum acc hi lo = acc + fromIntegral hi `shiftL` 8 + fromIntegral lo +{-# INLINE stepChecksum #-} diff --git a/src/Hans/Config.hs b/src/Hans/Config.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Config.hs @@ -0,0 +1,111 @@ +module Hans.Config ( + Config(..), + defaultConfig, + HasConfig(..), + ) where + +import Hans.Lens + +import Data.Time.Clock (NominalDiffTime) +import Data.Word (Word8) + + +-- | General network stack configuration. +data Config = Config { cfgInputQueueSize :: !Int + + , cfgArpTableSize :: !Int + -- ^ Best to pick a prime number. + + , cfgArpTableLifetime :: !NominalDiffTime + + , cfgArpRetry :: !Int + -- ^ Number of times to retry an arp request before + -- failing + + , cfgArpRetryDelay :: !Int + -- ^ The amount of time to wait between arp request + -- retransmission. + + , cfgIP4FragTimeout :: !NominalDiffTime + -- ^ Number of seconds to wait before expiring a + -- partially reassembled IP4 packet + + , cfgIP4InitialTTL :: !Word8 + + , cfgIP4MaxFragTableEntries :: !Int + -- ^ Maximum packets being reassembled at any time. + + , cfgUdpSocketTableSize :: !Int + -- ^ Number of buckets in the udp socket table + + , cfgDnsResolveTimeout :: !Int + -- ^ In microseconds + + , cfgTcpListenTableSize :: !Int + -- ^ Small-ish prime number + + , cfgTcpActiveTableSize :: !Int + -- ^ Best to pick a prime number + + , cfgTcpTimeoutTimeWait :: !NominalDiffTime + -- ^ Time to remain in TimeWait, in seconds. + + , cfgTcpInitialMSS :: !Int + -- ^ Initial MSS for tcp connections + + , cfgTcpMaxSynBacklog :: !Int + -- ^ Maximum number of connections waiting for an + -- acknowledgement. + + , cfgTcpInitialWindow :: !Int + -- ^ Initial local window for tcp connections. + + , cfgTcpMSL :: !Int + -- ^ Maximum segment lifetime + + , cfgTcpTSClockFrequency :: !NominalDiffTime + -- ^ Frequency (in Hz) of timestamp clock updates. + -- Should be between 1Hz and 1000Hz, according to + -- RFC-1323. + + , cfgTcpTimeWaitSocketLimit :: !Int + -- ^ The max number of threads allowed in the time + -- wait heap. + + , cfgNatMaxEntries :: !Int + -- ^ The maximum number of entries allowed in the TCP or + -- UDP NAT tables + } + +defaultConfig :: Config +defaultConfig = Config { cfgInputQueueSize = 128 + , cfgArpTableSize = 67 + , cfgArpTableLifetime = 60 -- 60 seconds + , cfgArpRetry = 10 + , cfgArpRetryDelay = 2000 -- 2 seconds + , cfgIP4FragTimeout = 30 + , cfgIP4InitialTTL = 128 + , cfgIP4MaxFragTableEntries= 32 + , cfgUdpSocketTableSize = 31 + , cfgDnsResolveTimeout = 5000000 + , cfgTcpListenTableSize = 5 + , cfgTcpActiveTableSize = 67 + , cfgTcpTimeoutTimeWait = 60.0 -- one minute + , cfgTcpInitialMSS = 1380 + -- ^ 1500 - (max (20 for IPv4) (60 for IPv6) + -- + 60 for maximum TCP header) + , cfgTcpMaxSynBacklog = 128 + , cfgTcpInitialWindow = 14600 + , cfgTcpMSL = 60 -- one minute + , cfgTcpTSClockFrequency = 1000 -- 1000hz, update every 1ms + , cfgTcpTimeWaitSocketLimit = 70 + , cfgNatMaxEntries = 200 + } + +class HasConfig cfg where + config :: Getting r cfg Config + +instance HasConfig Config where + config = id + {-# INLINE config #-} + diff --git a/src/Hans/Device.hs b/src/Hans/Device.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} + +module Hans.Device ( + module Exports, + closeDevice, + startDevice + ) where + +#if defined(HANS_TARGET_UNIX) +import Hans.Device.Tap as Exports (listDevices,openDevice) +#elif defined(HANS_TARGET_XEN) +import Hans.Device.Xen as Exports (listDevices,openDevice) +#endif + +import Hans.Device.Types as Exports + + +-- | Stop packets flowing, and cleanup any resources associated with this +-- device. +closeDevice :: Device -> IO () +closeDevice Device { .. } = + do devStop + devCleanup + +-- | Start processing packets through this device. +startDevice :: Device -> IO () +startDevice Device { .. } = devStart diff --git a/src/Hans/Device/Ivc.hs b/src/Hans/Device/Ivc.hs deleted file mode 100644 --- a/src/Hans/Device/Ivc.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -module Hans.Device.Ivc ( - ivcSend - , ivcReceiveLoop - ) where - -import Hans.Layer.Ethernet (EthernetHandle,queueEthernet) -import Communication.IVC as IVC -import Control.Monad (forever,when) -import qualified Data.ByteString as S - -ivcSend :: IVC.WriteableChan c S.ByteString => c -> S.ByteString -> IO () -ivcSend chan = IVC.put chan - -ivcReceiveLoop :: IVC.ReadableChan c S.ByteString => c -> EthernetHandle -> IO () -ivcReceiveLoop chan eth = forever $ - do bs <- IVC.get chan - when (S.length bs > 14) (queueEthernet eth bs) diff --git a/src/Hans/Device/Loopback.hs b/src/Hans/Device/Loopback.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Loopback.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hans.Device.Loopback where + +import Hans.Device.Types +import Hans.Ethernet.Types (Mac(..)) +import Hans.Types + + +import Control.Concurrent.BoundedChan (newBoundedChan) + + + +-- | A device that just posts outgoing packets back to the input queue. +newLoopbackDevice :: NetworkStack -> IO Device +newLoopbackDevice _ns = + do let noChecksum = ChecksumOffload { coIP4 = True + , coUdp = True + , coTcp = True + , coIcmp4 = True } + + let devConfig = defaultDeviceConfig { dcSendQueueLen = 1 + , dcTxOffload = noChecksum + , dcRxOffload = noChecksum } + let devName = "lo" + let devMac = Mac 0 0 0 0 0 0 + + devStats <- newDeviceStats + devSendQueue <- newBoundedChan (dcSendQueueLen devConfig) + + return $! Device { devStart = return () + , devStop = return () + , devCleanup = return () + , .. } diff --git a/src/Hans/Device/Tap.hs b/src/Hans/Device/Tap.hs deleted file mode 100644 --- a/src/Hans/Device/Tap.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module Hans.Device.Tap where - -import Hans.Layer.Ethernet -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(..),CInt(..)) -import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -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. -openTapDevice :: DeviceName -> IO (Maybe Fd) -openTapDevice "" = return Nothing -openTapDevice name = withCString name $ \str -> do - ret <- c_init_tap_device str - if ret < 0 then return Nothing else return (Just ret) - - --- | Send an ethernet frame via a tap device. --- --- TODO: make more use of the lazy bytestring -tapSend :: Fd -> L.ByteString -> IO () -tapSend fd packet = do - 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 () - - --- | Fork a reciever loop, and return an IO action to kill the running thread. -tapReceiveLoop :: Fd -> EthernetHandle -> IO () -tapReceiveLoop fd eh = forever (k =<< tapReceive fd) - where k pkt = queueEthernet eh pkt - --- | Recieve an ethernet frame from a tap device. -tapReceive :: Fd -> IO S.ByteString -tapReceive fd = do - threadWaitRead fd - 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 - -foreign import ccall unsafe "write" - c_write :: Fd -> Ptr Word8 -> CSize -> IO CLong - -foreign import ccall safe "read" - c_read :: Fd -> Ptr Word8 -> CSize -> IO CLong - diff --git a/src/Hans/Device/Tap.hsc b/src/Hans/Device/Tap.hsc new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Tap.hsc @@ -0,0 +1,171 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Hans.Device.Tap (listDevices,openDevice) where + +#include +#include +#include + +import Hans.Ethernet.Types (Mac(..)) +import Hans.Device.Types +import Hans.Threads (forkNamed) +import Hans.Types (NetworkStack(..),InputPacket(..)) + +import Control.Concurrent + (threadWaitRead,killThread,newMVar,modifyMVar_) +import Control.Concurrent.BoundedChan + (BoundedChan,newBoundedChan,readChan,tryWriteChan) +import qualified Control.Exception as X +import Control.Monad (forever,when,foldM_) +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Unsafe as S +import Data.Word (Word8) +import Foreign.C.String (CString) +import Foreign.C.Types (CSize(..),CLong(..),CInt(..),CChar(..)) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (allocaArray,peekArray) +import Foreign.Ptr (Ptr,plusPtr) +import Foreign.Storable (pokeByteOff) +import System.Posix.Types (Fd(..)) + + +-- | Not sure how this should work yet... Should it only ever show tap device +-- names? Maybe this should return a singleton list of an ephemeral device? +listDevices :: IO [DeviceName] +listDevices = return [] + +openDevice :: NetworkStack -> DeviceName -> DeviceConfig -> IO Device +openDevice ns devName devConfig = + do (fd,devMac) <- initTapDevice devName + + -- The `starting` lock makes sure that only one set of threads will be + -- started at once, while the `running` var holds the ids of the running + -- threads. + threadIds <- newMVar Nothing + + devStats <- newDeviceStats + + devSendQueue <- newBoundedChan (dcSendQueueLen devConfig) + + let dev = Device { .. } + + devStart = modifyMVar_ threadIds $ \ mbTids -> + case mbTids of + + Nothing -> + do recvThread <- forkNamed "tapRecvLoop" + (tapRecvLoop ns dev fd) + + sendThread <- forkNamed "tapSendLoop" + (tapSendLoop devStats fd devSendQueue) + + return (Just (recvThread,sendThread)) + + Just {} -> + return mbTids + + devStop = modifyMVar_ threadIds $ \ mbTids -> + case mbTids of + Just (recvThread,sendThread) -> + do killThread recvThread + killThread sendThread + return Nothing + + Nothing -> + return Nothing + + devCleanup = + do tapClose fd + + return dev + +initTapDevice :: DeviceName -> IO (Fd,Mac) +initTapDevice devName = + do (fd,[a,b,c,d,e,f]) <- + allocaArray 6 $ \ macPtr -> + do fd <- S.unsafeUseAsCString devName $ \ devNamePtr -> + c_init_tap_device devNamePtr macPtr + + mac <- peekArray 6 macPtr + return (fd,mac) + + when (fd < 0) (X.throwIO (FailedToOpen devName)) + + return (fd, Mac a b c d e f) + + +-- | Send a packet out over the tap device. +tapSendLoop :: DeviceStats -> Fd -> BoundedChan L.ByteString -> IO () +tapSendLoop stats fd queue = forever $ + do bs <- readChan queue + + let chunks = L.toChunks bs + len = length chunks + + allocaBytes (fromIntegral ((#size struct iovec) * len)) $ \ iov -> + do foldM_ writeChunk iov chunks + bytesWritten <- c_writev fd iov (fromIntegral len) + if fromIntegral bytesWritten == L.length bs + then do updateBytes statTX stats (fromIntegral bytesWritten) + updatePackets statTX stats + + else updateError statTX stats + where + + -- write the chunk address and length into the iovec entry + writeChunk iov chunk = + do S.unsafeUseAsCStringLen chunk $ \ (ptr,clen) -> + writeIOVec iov ptr (fromIntegral clen) + + return (iov `plusPtr` (#size struct iovec)) + + +-- | Receive a packet from the tap device. +tapRecvLoop :: NetworkStack -> Device -> Fd -> IO () +tapRecvLoop ns dev @ Device { .. } fd = forever $ + do threadWaitRead fd + + bytes <- S.createUptoN 1514 $ \ ptr -> + do actual <- c_read fd ptr 1514 + return (fromIntegral actual) + + -- tap devices don't appear to pad received packets out to the minimum size + -- of 60 bytes, so just don't do that check here. + + success <- tryWriteChan (nsInput ns) $! FromDevice dev bytes + if success + then do updateBytes statRX devStats (S.length bytes) + updatePackets statRX devStats + + else updateError statRX devStats + + +tapClose :: Fd -> IO () +tapClose fd = + do c_close fd + + +-- Foreign Interface ----------------------------------------------------------- + +foreign import ccall unsafe "init_tap_device" + c_init_tap_device :: CString -> Ptr Word8 -> IO Fd + +type IOVec = () + +writeIOVec :: Ptr IOVec -> Ptr CChar -> CSize -> IO () +writeIOVec iov ptr len = + do (#poke struct iovec, iov_base) iov ptr + (#poke struct iovec, iov_len) iov len + + +foreign import ccall unsafe "writev" + c_writev :: Fd -> Ptr IOVec -> CSize -> IO CLong + +foreign import ccall safe "read" + c_read :: Fd -> Ptr Word8 -> CSize -> IO CLong + +foreign import ccall safe "close" + c_close :: Fd -> IO () diff --git a/src/Hans/Device/Types.hs b/src/Hans/Device/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Types.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.Device.Types where + +import Hans.Ethernet.Types (Mac) +import Hans.Lens + +import Control.Concurrent.BoundedChan (BoundedChan) +import qualified Control.Exception as X +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import Data.Typeable (Typeable) + + +type DeviceName = S.ByteString + +data ChecksumOffload = ChecksumOffload { coIP4 :: !Bool + , coUdp :: !Bool + , coTcp :: !Bool + , coIcmp4 :: !Bool + } deriving (Show) + +defaultChecksumOffload :: ChecksumOffload +defaultChecksumOffload = ChecksumOffload { coIP4 = False + , coUdp = False + , coTcp = False + , coIcmp4 = False } + +-- | Static configuration data for creating a device. +data DeviceConfig = DeviceConfig { dcSendQueueLen :: {-# UNPACK #-} !Int + -- ^ How large the send queue should be. + + , dcTxOffload :: !ChecksumOffload + , dcRxOffload :: !ChecksumOffload + + , dcMtu :: !Int + } deriving (Show) + +class HasDeviceConfig cfg where + deviceConfig :: Getting r cfg DeviceConfig + +instance HasDeviceConfig DeviceConfig where + deviceConfig = id + {-# INLINE deviceConfig #-} + +instance HasDeviceConfig Device where + deviceConfig = to devConfig + {-# INLINE deviceConfig #-} + +-- | The TX checksum offload config. +txOffload :: HasDeviceConfig cfg => Getting r cfg ChecksumOffload +txOffload = deviceConfig . to dcTxOffload + +-- | The RX checksum offload config. +rxOffload :: HasDeviceConfig cfg => Getting r cfg ChecksumOffload +rxOffload = deviceConfig . to dcRxOffload + +defaultDeviceConfig :: DeviceConfig +defaultDeviceConfig = DeviceConfig { dcSendQueueLen = 128 + , dcTxOffload = defaultChecksumOffload + , dcRxOffload = defaultChecksumOffload + , dcMtu = 1500 + } + +data Device = Device { devName :: !DeviceName + -- ^ The name of this device + + , devMac :: !Mac + -- ^ The mac address associated with this device + + , devConfig :: !DeviceConfig + -- ^ Static configuration information for this device + + , devSendQueue :: !(BoundedChan L.ByteString) + -- ^ Outgoing message queue for this device + + , devStart :: !(IO ()) + -- ^ Start packet flow + + , devStop :: !(IO ()) + -- ^ Stop packet flow + + , devCleanup :: !(IO ()) + -- ^ Cleanup resources associated with a 'Device' + + , devStats :: !DeviceStats + -- ^ Statistics about this device + } + +-- Devices are compared by mac address +instance Eq Device where + a == b = devMac a == devMac b + a /= b = devMac a == devMac b + + {-# INLINE (==) #-} + {-# INLINE (/=) #-} + +instance Ord Device where + compare a b = compare (devMac a) (devMac b) + {-# INLINE compare #-} + + +data DeviceException = FailedToOpen !DeviceName + deriving (Typeable,Show) + +instance X.Exception DeviceException + + +-- Statistics ------------------------------------------------------------------ + +type Stat = IORef Int + +incrementStat :: Stat -> IO () +incrementStat ref = atomicModifyIORef' ref (\ i -> (i + 1, ())) + +addStat :: Stat -> Int -> IO () +addStat ref n = atomicModifyIORef' ref (\ i -> (i + n, ())) + +data StatGroup = StatGroup { _statBytes :: !Stat + , _statPackets :: !Stat + , _statErrors :: !Stat + , _statDropped :: !Stat + } + +statBytes, statPackets, statErrors, statDropped :: Getting r StatGroup Stat +statBytes = to _statBytes +statPackets = to _statPackets +statErrors = to _statErrors +statDropped = to _statDropped + +newStatGroup :: IO StatGroup +newStatGroup = + do _statBytes <- newIORef 0 + _statPackets <- newIORef 0 + _statErrors <- newIORef 0 + _statDropped <- newIORef 0 + return $! StatGroup { .. } + +dumpStatGroup :: String -> StatGroup -> IO () +dumpStatGroup pfx = \ StatGroup { .. } -> + do putStrLn header + mapM_ showStat [_statBytes,_statPackets,_statErrors,_statDropped] + putStrLn "" + where + header = unwords (map pad [ pfx ++ " bytes", "packets", "errors", "dropped" ]) + pad xs = xs ++ replicate (19 - length xs) ' ' + + showStat ref = + do val <- readIORef ref + putStr (pad (show val)) + putStr " " +{-# INLINE dumpStatGroup #-} + +data DeviceStats = DeviceStats { _statTX :: !StatGroup + , _statRX :: !StatGroup + } + +statTX, statRX :: Getting r DeviceStats StatGroup +statTX = to _statTX +statRX = to _statRX + +newDeviceStats :: IO DeviceStats +newDeviceStats = + do _statTX <- newStatGroup + _statRX <- newStatGroup + return $! DeviceStats { .. } + +dumpStats :: DeviceStats -> IO () +dumpStats DeviceStats { .. } = + do dumpStatGroup "RX:" _statRX + dumpStatGroup "TX:" _statTX + + +-- | Add one to the count of dropped packets for this device. +updateDropped :: Getting Stat DeviceStats StatGroup -> DeviceStats -> IO () +updateDropped group stats = incrementStat (view (group . statDropped) stats) + +-- | Add one to the error count for this device. +updateError :: Getting Stat DeviceStats StatGroup -> DeviceStats -> IO () +updateError group stats = incrementStat (view (group . statErrors) stats) + +-- | Update information about bytes received. +updateBytes :: Getting Stat DeviceStats StatGroup -> DeviceStats -> Int -> IO () +updateBytes group stats n = addStat (view (group . statBytes) stats) n + +-- | Update information about bytes received. +updatePackets :: Getting Stat DeviceStats StatGroup -> DeviceStats -> IO () +updatePackets group stats = incrementStat (view (group . statPackets) stats) diff --git a/src/Hans/Device/Xen.hs b/src/Hans/Device/Xen.hs --- a/src/Hans/Device/Xen.hs +++ b/src/Hans/Device/Xen.hs @@ -1,18 +1,95 @@ +{-# LANGUAGE RecordWildCards #-} + module Hans.Device.Xen where -import Hans.Layer.Ethernet +import Hans.Device.Types +import Hans.Ethernet.Types (readMac) +import Hans.Threads (forkNamed) +import Hans.Types -import XenDevice.NIC as Xen -import qualified Data.ByteString as S +import Control.Concurrent (newMVar,modifyMVar_,killThread) +import Control.Concurrent.BoundedChan + (BoundedChan,newBoundedChan,tryWriteChan,readChan) +import Control.Exception(try) +import Control.Monad (forever) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Hypervisor.ErrorCodes(ErrorCode) +import Hypervisor.XenStore (XenStore) +import XenDevice.NIC (NIC,listNICs,openNIC,setReceiveHandler,sendPacket) --- Xen NIC --------------------------------------------------------------------- +listDevices :: XenStore -> IO [DeviceName] +listDevices xs = + do nics <- listNICs xs + return (map S8.pack nics) -xenSend :: NIC -> L.ByteString -> IO () -xenSend = Xen.sendPacket +openDevice :: XenStore -> NetworkStack -> DeviceName -> DeviceConfig -> IO Device +openDevice xs ns devName devConfig = + do let macStr = S8.unpack devName + nic <- openNIC xs macStr -xenReceiveLoop :: NIC -> EthernetHandle -> IO () -xenReceiveLoop nic eh = Xen.setReceiveHandler nic k - where - k bs | L.length bs <= 14 = return () - | otherwise = queueEthernet eh (S.concat (L.toChunks bs)) + devStats <- newDeviceStats + devSendQueue <- newBoundedChan (dcSendQueueLen devConfig) + + thread <- newMVar Nothing + + devMac <- case readMac macStr of + [(x,_)] -> return x + _ -> fail ("Unable to parse mac address: " ++ macStr) + + let dev = Device { .. } + + devStart = modifyMVar_ thread $ \ mbTid -> + case mbTid of + + Nothing -> + do sendThread <- forkNamed "xenSendLoop" + (xenSendLoop devStats nic devSendQueue) + + setReceiveHandler nic (xenRecv ns dev) + + return (Just sendThread) + + Just {} -> + return mbTid + + devStop = modifyMVar_ thread $ \ mbTid -> + case mbTid of + + Just tid -> + do killThread tid + return Nothing + + Nothing -> + return Nothing + + -- NOTE: there's no way to cleanup a NIC + devCleanup = + return () + + return dev + + +-- NOTE: No way to update stats here, as we can't tell if sendPacket failed. +xenSendLoop :: DeviceStats -> NIC -> BoundedChan L.ByteString -> IO () +xenSendLoop stats nic chan = forever $ + do bs <- readChan chan + res <- try $ sendPacket nic bs + + case res :: Either ErrorCode () of + Right () -> + do updateBytes statTX stats (fromIntegral (L.length bs)) + updatePackets statTX stats + Left _ -> + updateError statTX stats + +xenRecv :: NetworkStack -> Device -> L.ByteString -> IO () +xenRecv ns dev @ Device { .. } = \ bytes -> + do let bytes' = L.toStrict bytes + success <- tryWriteChan (nsInput ns) $! FromDevice dev bytes' + if success + then do updateBytes statRX devStats (S.length bytes') + updatePackets statRX devStats + + else updateError statRX devStats diff --git a/src/Hans/DhcpClient.hs b/src/Hans/DhcpClient.hs deleted file mode 100644 --- a/src/Hans/DhcpClient.hs +++ /dev/null @@ -1,267 +0,0 @@ -module Hans.DhcpClient ( - dhcpDiscover - ) where - -import Hans.Address -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.Message.Dhcp4 -import Hans.Message.Dhcp4Codec -import Hans.Message.Dhcp4Options -import Hans.Message.EthernetFrame -import Hans.Message.Ip4 -import Hans.Message.Udp -import Hans.NetworkStack -import Hans.Timers (delay_) - -import Control.Monad (guard,unless) -import Control.Concurrent.STM -import Data.Maybe (fromMaybe,mapMaybe) -import System.Random (randomIO) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - - --- Protocol Constants ---------------------------------------------------------- - --- | BOOTP server port. -bootps :: UdpPort -bootps = UdpPort 67 - --- | BOOTP client port. -bootpc :: UdpPort -bootpc = UdpPort 68 - -currentNetwork :: IP4 -currentNetwork = IP4 0 0 0 0 - -ethernetIp4 :: EtherType -ethernetIp4 = EtherType 0x0800 - -defaultRoute :: IP4Mask -defaultRoute = IP4 0 0 0 0 `withMask` 0 - - --- DHCP ------------------------------------------------------------------------ - --- | Discover a dhcp server, and request an address. -dhcpDiscover :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack - , HasDns stack ) - => stack -> Mac -> IO (Maybe IP4) -dhcpDiscover ns mac = do - addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) - - offerTMV <- newEmptyTMVarIO - addUdpHandler ns bootpc (handleOffer ns offerTMV) - - w32 <- randomIO - let xid = Xid (fromIntegral (w32 :: Int)) - disc = discoverToMessage (mkDiscover xid mac) - - -- waitResult sends our DHCP discover and waits for an offer. - mbOffer <- waitResult retries disc offerTMV - case mbOffer of - - -- We exceeded our retries, give up. - Nothing -> return Nothing - - -- We got an offer - -- - Install an DHCP Ack handler. - -- - Send a DHCP Request via waitResult, and wait for an IP to appear in resp. - Just offer -> do - resp <- newEmptyTMVarIO - addUdpHandler ns bootpc (handleAck ns offer (Just (atomically . putTMVar resp))) - let req = requestToMessage (offerToRequest offer) - waitResult retries req resp - - where - -- RFC 2131 says to do exponential backoff starting at 4s and going to 64s. - -- It also says to add random noise between -1s and +1s, but we're skipping that for now. - initialTimeout :: Int - initialTimeout = 4000000 -- 4 seconds in µs - - retries :: Int - retries = 6 - - -- Sends a message and waits for a response (indicated by a value appearing the TMVar) - -- until timeout. Retries a given number of times doubling the backoff each time. - waitResult :: Int -> Dhcp4Message -> TMVar a -> IO (Maybe a) - waitResult n msg result = go n initialTimeout - where - go 0 _to = return Nothing - go i to = - do sendMessage ns msg currentNetwork broadcastIP4 broadcastMac - timeout <- registerDelay to - -- If there is a result, return Just it. - -- If not, and we aren't timed out, retry. - -- If we are timed out, return Nothing. - mb <- atomically $ orElse (fmap Just (takeTMVar result)) - (do isTimedOut <- readTVar timeout - unless isTimedOut retry - return Nothing) - -- Exponential backoff on timeout, return result on success. - case mb of - Just _ -> return mb - Nothing -> go (i-1) (to * 2) - --- | Restore the connection between the Ethernet and IP4 layers. -restoreIp4 :: (HasEthernet stack, HasIP4 stack) => stack -> IO () -restoreIp4 ns = connectEthernet (ip4Handle ns) (ethernetHandle ns) - --- | Handle IP4 messages from the Ethernet layer, passing all relevant DHCP --- messages to the UDP layer. -dhcpIP4Handler :: (HasUdp stack) - => stack -> S.ByteString -> IO () -dhcpIP4Handler ns bytes = - case parseIP4Packet bytes of - Left err -> putStrLn err >> return () - Right (hdr,ihl,len) - | ip4Protocol hdr == udpProtocol -> queue - | otherwise -> return () - where - queue = queueUdp ns hdr - $ S.take (len - ihl) - $ S.drop ihl bytes - --- | Handle a DHCP Offer message. --- --- * Remove the current UDP handler --- * Write offer to TMV for retrieval. -handleOffer :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack - , HasDns stack ) - => stack -> TMVar Offer -> IP4 -> UdpPort - -> S.ByteString -> IO () -handleOffer ns tmv _src _srcPort bytes = - case getDhcp4Message bytes of - Right msg -> case parseDhcpMessage msg of - - Just (Right (OfferMessage offer)) -> do - removeUdpHandler ns bootpc - atomically $ putTMVar tmv offer - - msg1 -> do - putStrLn (show msg) - putStrLn (show msg1) - - Left err -> putStrLn err - --- | Handle a DHCP Ack message. --- --- The optional handler (mbh) is present only the first time handleAck is --- installed, so we can update the main thread on our IP assignment. After --- that (when dhcpRenew installs handleAck) it is Nothing, because we just --- have to update the network stack. --- --- * Remove the custom IP4 handler --- * Restore the connection between the Ethernet and IP4 layers --- * Remove the bootpc UDP listener --- * 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 :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack - , HasDns stack ) - => stack -> Offer -> Maybe (IP4 -> IO ()) -> IP4 -> UdpPort - -> S.ByteString -> IO () -handleAck ns offer mbh _src _srcPort bytes = - case getDhcp4Message bytes of - Right msg -> case parseDhcpMessage msg of - - Just (Right (AckMessage ack)) -> do - removeUdpHandler ns bootpc - restoreIp4 ns - ackNsOptions ack ns - let ms = fromIntegral (ackLeaseTime ack) * 500 - delay_ ms (dhcpRenew ns offer) - - case mbh of - Nothing -> return () - Just h -> h (ackYourAddr ack) - - msg1 -> do - putStrLn (show msg) - putStrLn (show msg1) - - Left err -> putStrLn err - --- | Perform a DHCP Renew. --- --- * Re-install the DHCP IP4 handler --- * Add a UDP handler for an Ack message --- * Re-send a request message, generated from the offer given. -dhcpRenew :: ( HasEthernet stack, HasArp stack, HasIP4 stack, HasUdp stack - , HasDns stack ) - => stack -> Offer -> IO () -dhcpRenew ns offer = do - addEthernetHandler (ethernetHandle ns) ethernetIp4 (dhcpIP4Handler ns) - - let req = requestToMessage (offerToRequest offer) - addUdpHandler ns bootpc (handleAck ns offer Nothing) - sendMessage ns req currentNetwork broadcastIP4 broadcastMac - - --- NetworkStack Config --------------------------------------------------------- - -lookupGateway :: [Dhcp4Option] -> Maybe IP4 -lookupGateway = foldr p Nothing - where - p (OptRouters rs) _ = guard (not (null rs)) >> Just (head rs) - p _ a = a - -lookupSubnet :: [Dhcp4Option] -> Maybe Int -lookupSubnet = foldr p Nothing - where - p (OptSubnetMask (SubnetMask i)) _ = Just i - p _ a = a - --- | Produce options for the network stack from a DHCP Ack. -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 :: HasEthernet stack - => stack -> Dhcp4Message -> IP4 -> IP4 -> Mac -> IO () -sendMessage ns resp src dst hwdst = do - ipBytes <- mkIpBytes src dst bootpc bootps (putDhcp4Message resp) - let mac = dhcp4ClientHardwareAddr resp - let frame = EthernetFrame - { etherDest = hwdst - , etherSource = mac - , etherType = ethernetIp4 - } - sendEthernet (ethernetHandle ns) frame ipBytes - -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 - mk = mkIP4PseudoHeader srcAddr dstAddr udpProtocol - renderUdpPacket udpHdr payload mk - - ipBytes <- do - let ipHdr = emptyIP4Header - { ip4SourceAddr = srcAddr - , ip4DestAddr = dstAddr - , ip4Protocol = udpProtocol - } - renderIP4Packet ipHdr udpBytes - - return ipBytes diff --git a/src/Hans/Dns.hs b/src/Hans/Dns.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Dns.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hans.Dns where + +import Hans.Config +import Hans.Dns.Packet +import Hans.IP4.Packet +import Hans.Lens +import Hans.Serialize (runPutPacket) +import Hans.Socket +import Hans.Types + +import Control.Exception +import Control.Monad (when) +import qualified Data.Foldable as F +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Serialize (runGetLazy) +import Data.Typeable (Typeable) +import Data.Word (Word16) +import System.Timeout (timeout) + + +type HostName = S8.ByteString + +data HostEntry = HostEntry { hostName :: HostName + , hostAliases :: [HostName] + , hostAddresses :: [IP4] + } deriving (Show) + +parseHostEntry :: Source -> [RR] -> HostEntry +parseHostEntry (FromHost host) = parseAddr host +parseHostEntry (FromAddr4 addr) = parsePtr addr + +-- | Parse the A and CNAME parts out of a response. +parseAddr :: HostName -> [RR] -> HostEntry +parseAddr host = F.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 = S8.intercalate "." ns + , hostAliases = hostName he : hostAliases he } + _ -> he + +parsePtr :: IP4 -> [RR] -> HostEntry +parsePtr addr = F.foldl' processAnswer emptyHostEntry + where + emptyHostEntry = HostEntry { hostName = "" + , hostAliases = [] + , hostAddresses = [addr] } + + processAnswer he RR { .. } = case rrRData of + RDPTR name -> he { hostName = S8.intercalate "." name } + _ -> he + + +data DnsException = NoNameServers + deriving (Show,Typeable) + +instance Exception DnsException + + +getHostByName :: HasNetworkStack ns => ns -> HostName -> IO (Maybe HostEntry) +getHostByName ns host = sendRequest ns (FromHost host) + +sendRequest :: HasNetworkStack ns => ns -> Source -> IO (Maybe HostEntry) +sendRequest ns src = + do nameServers <- getNameServers4 ns + + when (null nameServers) (throwIO NoNameServers) + + bracket (newUdpSocket ns defaultSocketConfig Nothing WildcardIP4 Nothing) + sClose $ \ sock -> + do let req = runPutPacket 1450 1450 L.empty (putDNSPacket (mkPacket src 0)) + + mbResp <- queryServers4 sock req nameServers + case mbResp of + Just DNSPacket { .. } + | DNSHeader { .. } <- dnsHeader + , dnsRC == RespNoError -> + return (Just (parseHostEntry src dnsAnswers)) + _ -> + return Nothing + + +queryServers4 :: UdpSocket IP4 -> L.ByteString -> [IP4] -> IO (Maybe DNSPacket) +queryServers4 sock req = go + where + go (addr:addrs) = + do sendto sock addr 53 req + mbRes <- timeout (cfgDnsResolveTimeout (view config (view networkStack sock))) + (recvfrom sock) + + -- require that the server we sent a request to is the one that responded + case mbRes of + Just (_,srcIp,srcPort,bytes) + | srcIp == addr, srcPort == 53 -> + case runGetLazy getDNSPacket bytes of + Right res -> return (Just res) + Left _ -> return Nothing + + _ -> go addrs + + go [] = return Nothing + + +data Source = FromHost HostName + | FromAddr4 IP4 + deriving (Show) + +sourceHost :: Source -> Name +sourceHost (FromHost host) = toLabels host +sourceHost (FromAddr4 ip4) = let (a,b,c,d) = unpackIP4 ip4 + showByte x = S8.pack (show x) + in map showByte [d,c,b,a] ++ ["in-addr","arpa"] + +toLabels :: HostName -> Name +toLabels str = + case S8.break (== '.') str of + (as,bs) | S8.null bs -> [as] + | otherwise -> as : toLabels (S8.tail bs) + +sourceQType :: Source -> [QType] +sourceQType FromHost{} = [QType A] +sourceQType FromAddr4{} = [QType PTR] + +mkPacket :: Source -> Word16 -> DNSPacket +mkPacket src dnsId = + DNSPacket { dnsHeader = hdr + , dnsQuestions = [ mkQuery q | q <- sourceQType src ] + , dnsAnswers = [] + , dnsAuthorityRecords = [] + , dnsAdditionalRecords = [] + } + where + n = sourceHost src + + hdr = + DNSHeader { dnsQuery = True + , dnsOpCode = OpQuery + , dnsAA = False + , dnsTC = False + , dnsRD = True + , dnsRA = False + , dnsRC = RespNoError + , .. } + + mkQuery qType = + Query { qName = n + , qClass = QClass IN + , .. } diff --git a/src/Hans/Dns/Packet.hs b/src/Hans/Dns/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Dns/Packet.hs @@ -0,0 +1,594 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} + +module Hans.Dns.Packet ( + DNSPacket(..) + , DNSHeader(..) + , OpCode(..) + , RespCode(..) + , Query(..) + , QClass(..) + , QType(..) + , RR(..) + , Type(..) + , Class(..) + , RData(..) + , Name + + , getDNSPacket + , putDNSPacket + ) where + +import Hans.IP4.Packet (IP4,getIP4,putIP4) + +import Control.Monad +import Data.Bits +import qualified Data.ByteString as S +import qualified Data.Map.Strict as Map +import qualified Data.Serialize.Get as C +import qualified Data.Foldable as F +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 ) + + + +-- 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 = F.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 --------------------------------------------------------------------- + +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 getIP4 + 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 ------------------------------------------------------------------- + +putDNSPacket :: Putter DNSPacket +putDNSPacket DNSPacket{ .. } = + do putDNSHeader dnsHeader + + putWord16be (fromIntegral (length dnsQuestions)) + putWord16be (fromIntegral (length dnsAnswers)) + putWord16be (fromIntegral (length dnsAuthorityRecords)) + putWord16be (fromIntegral (length dnsAdditionalRecords)) + + F.traverse_ putQuery dnsQuestions + F.traverse_ putRR dnsAnswers + F.traverse_ putRR dnsAuthorityRecords + F.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 (putIP4 addr) + RDNS name -> rdata NS (putName name) + RDMD name -> rdata MD (putName name) + RDMF name -> rdata MF (putName name) + RDCNAME name -> rdata CNAME (putName name) + RDSOA m r s f t ex ttl -> + rdata SOA $ do putName m + putName r + putWord32be s + putInt32be f + putInt32be t + putInt32be ex + putWord32be ttl + + RDMB name -> rdata MB (putName name) + RDMG name -> rdata MG (putName name) + RDMR name -> rdata MR (putName name) + RDNULL bytes -> rdata NULL $ do putWord8 (fromIntegral (S.length bytes)) + putByteString bytes + RDPTR name -> rdata PTR (putName name) + RDHINFO cpu os -> rdata HINFO $ do putWord8 (fromIntegral (S.length cpu)) + putByteString cpu + putWord8 (fromIntegral (S.length os)) + putByteString os + RDMINFO rm em -> rdata MINFO $ do putName rm + putName em + RDMX pref ex -> rdata MX $ do putWord16be pref + putName ex + RDUnknown ty bytes -> (ty,bytes) + where + rdata tag m = (tag,runPut m) diff --git a/src/Hans/Ethernet.hs b/src/Hans/Ethernet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Ethernet.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Ethernet ( + module Exports, + module Hans.Ethernet + ) where + +import Hans.Device.Types +import Hans.Ethernet.Types as Exports +import Hans.Serialize (runPutPacket) + +import Control.Concurrent.BoundedChan (tryWriteChan) +import Control.Monad (unless) +import qualified Data.ByteString.Lazy as L + + +-- | Send a message out via a device. +sendEthernet :: Device -> Mac -> EtherType -> L.ByteString -> IO () +sendEthernet Device { .. } eDest eType payload = + do let packet = runPutPacket 14 100 payload + $ putEthernetHeader EthernetHeader { eSource = devMac, .. } + + -- if the packet is too big for the device, throw it away + if (fromIntegral (L.length packet) > dcMtu devConfig + 14) + then updateError statTX devStats + else do queued <- tryWriteChan devSendQueue packet + unless queued (updateDropped statTX devStats) diff --git a/src/Hans/Ethernet/Types.hs b/src/Hans/Ethernet/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Ethernet/Types.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Ethernet.Types ( + -- * Ethernet Headers + EthernetHeader(..), getEthernetHeader, putEthernetHeader, + EtherType, + + -- ** MAC addresses + Mac(..), getMac, putMac, showMac, readMac, + pattern BroadcastMac, + + -- ** EtherType Patterns + pattern ETYPE_IPV4, + pattern ETYPE_ARP, + pattern ETYPE_IPV6 + + ) where + +import Data.Serialize + (Get,getWord8,getWord16be,Putter,putWord16be,putWord8 + ,Serialize(..)) +import Data.Word (Word8,Word16) +import Numeric (readHex,showHex) + + +-- Mac Addresses --------------------------------------------------------------- + +data Mac = Mac {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + deriving (Eq,Ord,Show,Read) + +instance Serialize Mac where + get = getMac + put = putMac + {-# INLINE get #-} + {-# INLINE put #-} + + +getMac :: Get Mac +getMac = + do a <- getWord8 + b <- getWord8 + c <- getWord8 + d <- getWord8 + e <- getWord8 + f <- getWord8 + return $! Mac a b c d e f + +putMac :: Putter Mac +putMac (Mac a b c d e f) = + do putWord8 a + putWord8 b + putWord8 c + putWord8 d + putWord8 e + putWord8 f + +showMac :: Mac -> ShowS +showMac (Mac a b c d e f) = pad a . showChar ':' + . pad b . showChar ':' + . pad c . showChar ':' + . pad d . showChar ':' + . pad e . showChar ':' + . pad f + where + pad x | x < 0x10 = showChar '0' . showHex x + | otherwise = showHex x + + +readMac :: ReadS Mac +readMac str = + do (a,':':rest1) <- readHex str + (b,':':rest2) <- readHex rest1 + (c,':':rest3) <- readHex rest2 + (d,':':rest4) <- readHex rest3 + (e,':':rest5) <- readHex rest4 + (f,rest6) <- readHex rest5 + return (Mac a b c d e f, rest6) + +-- | The broadcast MAC address. +pattern BroadcastMac = Mac 0xff 0xff 0xff 0xff 0xff 0xff + + +-- Ethernet Headers ------------------------------------------------------------ + +type EtherType = Word16 + +data EthernetHeader = EthernetHeader + { eDest :: {-# UNPACK #-} !Mac + , eSource :: {-# UNPACK #-} !Mac + , eType :: {-# UNPACK #-} !EtherType + } deriving (Eq,Show) + +getEthernetHeader :: Get EthernetHeader +getEthernetHeader = + do eDest <- getMac + eSource <- getMac + eType <- getWord16be + return EthernetHeader { .. } + +putEthernetHeader :: Putter EthernetHeader +putEthernetHeader EthernetHeader { .. } = + do putMac eDest + putMac eSource + putWord16be eType + + +-- Common Ether-Types ---------------------------------------------------------- + +pattern ETYPE_IPV4 = 0x0800 +pattern ETYPE_ARP = 0x0806 +pattern ETYPE_IPV6 = 0x86DD diff --git a/src/Hans/HashTable.hs b/src/Hans/HashTable.hs new file mode 100644 --- /dev/null +++ b/src/Hans/HashTable.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.HashTable ( + HashTable(), + newHashTable, + lookup, + delete, deletes, + mapHashTable, mapHashTableM_, + filterHashTable, + alter, + keys, + hasKey, + size, + ) where + +import Prelude hiding (lookup) + +import Control.Monad (replicateM,forM_) +import Data.Array (Array,listArray,(!)) +import Data.Function (on) +import Data.Hashable (Hashable,hash) +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import qualified Data.List as List +import Data.Ord (comparing) + + +data HashTable k a = + HashTable { htSize :: {-# UNPACK #-} !Int + , htBuckets :: {-# UNPACK #-} !(Array Int (Bucket k a)) + } + +type Bucket k a = IORef [(k,a)] + +cons' :: a -> [a] -> [a] +cons' h tl = h `seq` tl `seq` (h:tl) +{-# INLINE cons' #-} + +nfList :: [a] -> () +nfList [] = () +nfList (a:rest) = a `seq` nfList rest +{-# INLINE nfList #-} + +nfListId :: [a] -> [a] +nfListId xs = nfList xs `seq` xs +{-# INLINE nfListId #-} + +-- | Create a new hash table with the given size. +newHashTable :: (Eq k, Hashable k) => Int -> IO (HashTable k a) +newHashTable htSize = + do buckets <- replicateM htSize (newIORef []) + return HashTable { htBuckets = listArray (0,htSize - 1) buckets + , .. } + +mapBuckets :: (Eq k, Hashable k) => ([(k,a)] -> [(k,a)]) -> HashTable k a -> IO () +mapBuckets f HashTable { .. } = go 0 + where + update bucket = (f bucket, ()) + + go ix | ix < htSize = do atomicModifyIORef' (htBuckets ! ix) update + go (succ ix) + | otherwise = return () +{-# INLINE mapBuckets #-} + +filterHashTable :: (Eq k, Hashable k) + => (k -> a -> Bool) -> HashTable k a -> IO () +filterHashTable p = mapBuckets go + where + go [] = [] + go (x@(k,a):rest) | p k a = cons' x (go rest) + | otherwise = go rest +{-# INLINE filterHashTable #-} + +-- | Monadic mapping over the values of a hash table. +mapHashTableM_ :: (Eq k, Hashable k) + => (k -> a -> IO ()) -> HashTable k a -> IO () +mapHashTableM_ f HashTable { .. } = go 0 + where + go ix | ix < htSize = do bs <- readIORef (htBuckets ! ix) + mapM_ (\(k,a) -> f k a) bs + go (ix + 1) + + | otherwise = return () +{-# INLINE mapHashTableM_ #-} + +mapHashTable :: (Eq k, Hashable k) => (k -> a -> a) -> HashTable k a -> IO () +mapHashTable f = mapBuckets go + where + go [] = [] + go ((k,a):rest) = cons' ((,) k $! f k a) (go rest) +{-# INLINE mapHashTable #-} + +getBucket :: Hashable k => HashTable k a -> k -> Bucket k a +getBucket HashTable { .. } k = htBuckets ! key + where + key = hash k `mod` htSize +{-# INLINE getBucket #-} + +modifyBucket :: Hashable k + => HashTable k a -> k -> ([(k,a)] -> ([(k,a)],b)) -> IO b +modifyBucket ht k = atomicModifyIORef' (getBucket ht k) +{-# INLINE modifyBucket #-} + +lookup :: (Eq k, Hashable k) => k -> HashTable k a -> IO (Maybe a) +lookup k ht = + do bucket <- readIORef (getBucket ht k) + return $! List.lookup k bucket +{-# INLINE lookup #-} + +delete :: (Eq k, Hashable k) => k -> HashTable k a -> IO () +delete k ht = modifyBucket ht k (\ bucket -> (nfListId (removeEntry bucket), ())) + + where + + removeEntry (entry @ (k',_):rest) + | k' == k = rest + | otherwise = let rest' = removeEntry rest + in rest' `seq` (entry : rest') + + removeEntry [] = [] +{-# INLINE delete #-} + + +-- | Delete a collection of keys from the table. This is good for multiple +-- deletes, as deletes from the same bucket can be grouped together. +deletes :: (Eq k, Hashable k) => [k] -> HashTable k a -> IO () +deletes ks ht = + forM_ groups $ \ grp -> + case grp of + (_,ix):_ -> atomicModifyIORef' (htBuckets ht ! ix) + (\ bucket -> (bucket `without` grp, ())) + _ -> return () + where + + -- keys grouped by bucket + groups = List.groupBy ((==) `on` snd) + $ List.sortBy (comparing snd) + $ [ (k, hash k `mod` htSize ht) | k <- ks ] + + -- remove entries from the bucket + without = List.foldl' (\b (k,_) -> remove k b) + + remove k = go + where + go [] = [] + go (e@(k',_):rest) | k == k' = rest + | otherwise = e:go rest + + +-- | Create, update, or delete an entry in the hash table, returning some +-- additional value derived from the operation. +-- NOTE: This operation is only useful when you need to perform any of these +-- operations at the same time -- the specialized versions of the individual +-- behaviors all perform slightly better. +alter :: (Eq k, Hashable k) + => (Maybe a -> (Maybe a, b)) -> k -> HashTable k a -> IO b +alter f k ht = modifyBucket ht k (update nfListId) + where + + update mkBucket (e@(k',a):rest) + | k == k' = finish mkBucket (Just a) rest + | otherwise = update (\l -> mkBucket ( e : l )) rest + + update mkBucket [] = finish mkBucket Nothing [] + + finish mkBucket mb rest = + case f mb of + (Just a, b) -> (mkBucket ((k,a):rest), b) + (Nothing,b) -> (mkBucket rest , b) +{-# INLINE alter #-} + + +size :: HashTable k a -> IO Int +size HashTable { .. } = loop 0 0 + where + loop acc ix | ix < htSize = do bucket <- readIORef (htBuckets ! ix) + (loop $! acc + length bucket) (ix + 1) + | otherwise = return acc + + +-- | Gives back an (unsorted) list of all the keys present in the hash table. +keys :: HashTable k a -> IO [k] +keys HashTable { .. } = go [] 0 + where + go acc ix | ix < htSize = do bucket <- readIORef (htBuckets ! ix) + go (map fst bucket ++ acc) (ix + 1) + + | otherwise = return acc + +hasKey :: (Eq k, Hashable k) => k -> HashTable k a -> IO Bool +hasKey k ht = + do b <- readIORef (getBucket ht k) + return $! any (\ (k',_) -> k == k') b +{-# INLINE hasKey #-} diff --git a/src/Hans/IP4.hs b/src/Hans/IP4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} +module Hans.IP4 ( + module Exports + ) where + + +import Hans.IP4.Packet as Exports + (IP4,packIP4,unpackIP4,pattern BroadcastIP4,pattern WildcardIP4 + ,ip4PseudoHeader) + +import Hans.IP4.Output as Exports + +import Hans.IP4.State as Exports (SendSource(..)) diff --git a/src/Hans/IP4/ArpTable.hs b/src/Hans/IP4/ArpTable.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/ArpTable.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.IP4.ArpTable ( + -- * Arp Table + ArpTable(), newArpTable, + + -- ** Update + addEntry, + markUnreachable, + + -- ** Query + lookupEntry, + resolveAddr, QueryResult(..), + WaitStrategy(), blockingStrategy, writeChanStrategy + + ) where + +import Hans.Config (Config(..)) +import Hans.Device.Types (DeviceStats,updateError,statTX) +import Hans.Ethernet (Mac) +import qualified Hans.HashTable as HT +import Hans.IP4.Packet (IP4) +import Hans.Threads (forkNamed) +import Hans.Time (toUSeconds) + +import Control.Concurrent + (threadDelay,MVar,newEmptyMVar,ThreadId,tryPutMVar) +import qualified Control.Concurrent.BoundedChan as BC +import Control.Monad (forever) +import Data.Time.Clock + (UTCTime,NominalDiffTime,addUTCTime,getCurrentTime) + + +-- | The Arp table consists of a map of IP4 to Mac, as well as a heap that +-- orders the IP4 addresses according to when their corresponding entries should +-- be expired. +-- +-- NOTE: There's currently no way to limit the memory use of the arp table, but +-- that might not be a huge problem as the entries are added based on requests +-- from higher layers. +-- +-- INVARIANT: there should never be entries in the map that aren't also in the +-- heap. +data ArpTable = ArpTable { atMacs :: !(HT.HashTable IP4 Entry) + , atLifetime :: !NominalDiffTime + , atPurgeThread :: !ThreadId + } + +data Entry = Waiting [Maybe Mac -> IO ()] + | Present !UTCTime !Mac + + +newArpTable :: Config -> IO ArpTable +newArpTable Config { .. } = + do atMacs <- HT.newHashTable cfgArpTableSize + atPurgeThread <- forkNamed "Arp Purge Thread" + (purgeArpTable cfgArpTableLifetime atMacs) + return ArpTable { atLifetime = cfgArpTableLifetime, .. } + + +-- | Loops forever, delaying until the next arp table entry needs to be purged. +-- If no entries exist, it waits for the maximum entry lifetime before checking +-- again. +purgeArpTable :: NominalDiffTime -> HT.HashTable IP4 Entry -> IO () +purgeArpTable lifetime table = forever $ + do now <- getCurrentTime + HT.filterHashTable (update now) table + threadDelay delay + + where + + update _ _ Waiting{} = False + update now _ (Present expire _) = expire < now + + delay = toUSeconds lifetime + + +-- | Lookup an entry in the Arp table. +lookupEntry :: ArpTable -> IP4 -> IO (Maybe Mac) +lookupEntry ArpTable { .. } spa = + do mb <- HT.lookup spa atMacs + case mb of + Just (Present _ mac) -> return (Just mac) + _ -> return Nothing + + +-- | Insert an entry into the Arp table, and unblock any waiting actions. +addEntry :: ArpTable -> IP4 -> Mac -> IO () +addEntry ArpTable { .. } spa sha = + do now <- getCurrentTime + let end = addUTCTime atLifetime now + + waiters <- HT.alter (update end) spa atMacs + + -- NOTE: as we don't allow user-supplied IO actions to be registered as + -- callbacks, we don't catch any exceptions here; the only way that an + -- action can end up in this list is through the constructors for the + -- WaitStrategy type defined below. + -- + -- If it turns out that it's significantly impacting the performance of the + -- fast path, we should consider forking a thread to run the waiters. + mapM_ ($ Just sha) waiters + + where + + update expire (Just (Waiting ks)) = (Just (Present expire sha), ks) + update expire (Just Present{}) = (Just (Present expire sha), []) + update expire Nothing = (Just (Present expire sha), []) + + +-- | If nobody has responded to queries for this address, notify any waiters +-- that there is no mac associated. +-- +-- NOTE: in the future, it might be nice to keep an entry in the table that +-- indicates that this host is unreachable. +markUnreachable :: ArpTable -> IP4 -> IO () +markUnreachable ArpTable { .. } addr = + do waiters <- HT.alter update addr atMacs + + -- See the note in addEntry about why we don't need to sandbox the + -- callbacks. + mapM_ ($ Nothing) waiters + + where + + update (Just (Waiting ks)) = (Nothing, ks) + update ent@(Just Present{}) = (ent, []) + update Nothing = (Nothing,[]) + + + +newtype WaitStrategy res = WaitStrategy { getWaiter :: IO (Maybe Mac -> IO (), res) } + + +-- | Have the entry block on a +blockingStrategy :: WaitStrategy (MVar (Maybe Mac)) +blockingStrategy = WaitStrategy $ + do mvar <- newEmptyMVar + + let write mb = do _ <- tryPutMVar mvar mb + return () + + return (write, mvar) + + +-- | Write the discovered Mac to a bounded channel, passing it through a +-- filtering function first. +writeChanStrategy :: Maybe DeviceStats -> (Maybe Mac -> Maybe msg) -> BC.BoundedChan msg + -> WaitStrategy () +writeChanStrategy mbStats f chan = WaitStrategy (return (handler,())) + where + handler mb = + case f mb of + Just msg -> do written <- BC.tryWriteChan chan msg + case mbStats of + Just stats | not written -> updateError statTX stats + _ -> return () + + -- XXX should this update a stat? + Nothing -> return () + + +data QueryResult res = Known !Mac + | Unknown !Bool res + + +-- | Returns either the address, or an empty 'MVar' that will eventually contain +-- the 'Mac', or 'Nothing' if the Arp request fails. +resolveAddr :: ArpTable -> IP4 -> WaitStrategy res -> IO (QueryResult res) +resolveAddr arp addr strategy = + do mb <- lookupEntry arp addr + case mb of + Just mac -> return (Known mac) + Nothing -> registerWaiter arp addr strategy + + +-- | Register to wait on an entry in the table. +registerWaiter :: ArpTable -> IP4 -> WaitStrategy res -> IO (QueryResult res) +registerWaiter ArpTable { .. } addr strategy = + do waiter <- getWaiter strategy + HT.alter (update waiter) addr atMacs + where + update (w,r) (Just (Waiting ws)) = (Just (Waiting (w:ws)), Unknown False r) + update _ ent@(Just (Present _ mac)) = (ent, Known mac) + update (w,r) Nothing = (Just (Waiting [w]), Unknown True r) diff --git a/src/Hans/IP4/Dhcp/Client.hs b/src/Hans/IP4/Dhcp/Client.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Dhcp/Client.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.IP4.Dhcp.Client ( + DhcpConfig(..), + defaultDhcpConfig, + DhcpLease(..), + dhcpClient, + ) where + +import Hans.Device.Types (Device(devMac)) +import Hans.IP4.Dhcp.Codec (SubnetMask(..)) +import Hans.IP4.Dhcp.Packet +import Hans.IP4.Dhcp.Options +import Hans.IP4.Packet (IP4,pattern WildcardIP4,pattern BroadcastIP4,IP4Mask(..)) +import Hans.IP4.RoutingTable(Route(..),RouteType(..)) +import Hans.Lens +import Hans.Socket + (UdpSocket,newUdpSocket,sClose,sendto,recvfrom,SockPort + ,defaultSocketConfig) +import Hans.Serialize (runPutPacket) +import Hans.Threads (forkNamed) +import Hans.Time (toUSeconds) +import Hans.Types (NetworkStack,networkStack,addRoute,addNameServer4) + +import Control.Concurrent (threadDelay,killThread) +import Control.Monad (guard) +import qualified Data.ByteString.Lazy as L +import Data.Maybe (fromMaybe,mapMaybe) +import Data.Serialize.Get (runGetLazy) +import Data.Time.Clock (NominalDiffTime) +import System.Random (randomIO,randomRIO) +import System.Timeout (timeout) + + +-- | BOOTP server port. +bootps :: SockPort +bootps = 67 + +-- | BOOTP client port. +bootpc :: SockPort +bootpc = 68 + +mkXid :: IO Xid +mkXid = do w <- randomIO + return (Xid w) + + +renderMessage :: Dhcp4Message -> L.ByteString +renderMessage msg = runPutPacket 236 256 L.empty (putDhcp4Message msg) + +data DhcpConfig = DhcpConfig { dcInitialTimeout :: !NominalDiffTime + -- ^ Initial timeout + + , dcRetries :: !Int + -- ^ Number of retries + + , dcDefaultRoute :: Bool + -- ^ Whether or not routing information received + -- from the DHCP server should be used as the + -- default route for the network stack. + + , dcAutoRenew :: Bool + -- ^ Whether or not to fork a renew thread once + -- configuration information has been received. + } + +defaultDhcpConfig :: DhcpConfig +defaultDhcpConfig = DhcpConfig { dcInitialTimeout = 4.0 + , dcRetries = 6 + , dcDefaultRoute = True + , dcAutoRenew = True } + + +-- | Wait for a result on a socket +waitResponse :: DhcpConfig -> IO () -> IO a -> IO (Maybe a) +waitResponse DhcpConfig { .. } send recv = + go dcRetries (toUSeconds dcInitialTimeout) + where + go retries toVal = + do send + mb <- timeout toVal recv + case mb of + + Just{} -> return mb + + -- adjust the timeout by two, and add some slack before trying again + Nothing | retries > 0 -> + do slack <- randomRIO (500,1000) + go (retries - 1) (toVal * 2 + slack * 1000) + + _ -> return Nothing + + +data DhcpLease = DhcpLease { dhcpRenew :: !(IO ()) + , dhcpAddr :: !IP4 + } + + +dhcpClient :: NetworkStack -> DhcpConfig -> Device -> IO (Maybe DhcpLease) +dhcpClient ns cfg dev = + do sock <- newUdpSocket ns defaultSocketConfig (Just dev) WildcardIP4 (Just bootpc) + dhcpDiscover cfg dev sock + + +-- | Discover a dhcp server, and request an address. +dhcpDiscover :: DhcpConfig -> Device -> UdpSocket IP4 -> IO (Maybe DhcpLease) +dhcpDiscover cfg dev sock = + do xid <- mkXid + let msg = renderMessage (discoverToMessage (mkDiscover xid (devMac dev))) + + mb <- waitResponse cfg (sendto sock BroadcastIP4 bootps msg) (awaitOffer sock) + case mb of + Just offer -> dhcpRequest cfg dev sock offer + Nothing -> do sClose sock + return Nothing + + +-- | Only accept an offer. +awaitOffer :: UdpSocket IP4 -> IO Offer +awaitOffer sock = go + where + go = + do (_,_,srcPort,bytes) <- recvfrom sock + + if srcPort /= bootps + then go + else case runGetLazy getDhcp4Message bytes of + + Right msg + | Just (Right (OfferMessage o)) <- parseDhcpMessage msg -> + return o + + _ -> go + + +-- | Respond to an offer with a request, and configure the network stack if an +-- acknowledgement is received. +dhcpRequest :: DhcpConfig -> Device -> UdpSocket IP4 -> Offer -> IO (Maybe DhcpLease) +dhcpRequest cfg dev sock offer = + do let req = renderMessage (requestToMessage (offerToRequest offer)) + mb <- waitResponse cfg (sendto sock BroadcastIP4 bootps req) (awaitAck sock) + sClose sock + case mb of + + Nothing -> return Nothing + + Just ack -> + do lease <- handleAck (view networkStack sock) cfg dev offer ack + return (Just lease) + + +awaitAck :: UdpSocket IP4 -> IO Ack +awaitAck sock = go + where + go = + do (_,_,srcPort,bytes) <- recvfrom sock + + if srcPort /= bootps + then go + else case runGetLazy getDhcp4Message bytes of + + Right msg + | Just (Right (AckMessage a)) <- parseDhcpMessage msg -> + return a + + _ -> go + + + +-- | Perform a DHCP Renew. +renew :: NetworkStack -> DhcpConfig -> Device -> Offer -> IO () +renew ns cfg dev offer = + do sock <- newUdpSocket ns defaultSocketConfig (Just dev) WildcardIP4 (Just bootpc) + _ <- dhcpRequest cfg dev sock offer + + return () + + +-- Ack Management -------------------------------------------------------------- + +-- | Apply the information in the Ack to the NetworkStack, and Device. Returns +-- information about the lease, as well as an IO action that can be used to +-- renew it. +handleAck :: NetworkStack -> DhcpConfig -> Device -> Offer -> Ack -> IO DhcpLease +handleAck ns cfg dev offer Ack { .. } = + do let addr = ackYourAddr + mask = fromMaybe 24 (lookupSubnet ackOptions) + + let nameServers = concat (mapMaybe getNameServers ackOptions) + mapM_ (addNameServer4 ns) nameServers + + addRoute ns False Route + { routeNetwork = IP4Mask addr mask + , routeType = Direct + , routeDevice = dev + } + + case lookupGateway ackOptions of + Just gw | dcDefaultRoute cfg -> + addRoute ns True Route + { routeNetwork = IP4Mask addr 0 + , routeType = Indirect gw + , routeDevice = dev + } + + _ -> return () + + dhcpRenew <- + if dcAutoRenew cfg + then -- wait for half of the lease time, then automatically renew + -- XXX: what happens on a 32-bit system here? + do tid <- forkNamed "dhcpRenew" $ + do threadDelay (fromIntegral ackLeaseTime * 500000) + renew ns cfg dev offer + + return $ do killThread tid + renew ns cfg dev offer + + else return (renew ns cfg dev offer) + + return $! DhcpLease { dhcpAddr = addr, .. } + + +lookupGateway :: [Dhcp4Option] -> Maybe IP4 +lookupGateway = foldr p Nothing + where + p (OptRouters rs) _ = guard (not (null rs)) >> Just (head rs) + p _ a = a + +lookupSubnet :: [Dhcp4Option] -> Maybe Int +lookupSubnet = foldr p Nothing + where + p (OptSubnetMask (SubnetMask i)) _ = Just i + p _ a = a + +getNameServers :: Dhcp4Option -> Maybe [IP4] +getNameServers (OptNameServers addrs) = Just addrs +getNameServers _ = Nothing diff --git a/src/Hans/IP4/Dhcp/Codec.hs b/src/Hans/IP4/Dhcp/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Dhcp/Codec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hans.IP4.Dhcp.Codec where + +import Hans.Ethernet (Mac,getMac,putMac) +import Hans.IP4.Packet (IP4,IP4Mask(..),getIP4,putIP4) + +import Data.List (find) +import Data.Serialize.Get +import Data.Serialize.Put +import Data.Word (Word8, Word16, Word32) + + +class CodecAtom a where + getAtom :: Get a + putAtom :: a -> Put + atomSize :: a -> Int + +instance (CodecAtom a, CodecAtom b) => CodecAtom (a,b) where + getAtom = do a <- getAtom + b <- getAtom + return (a,b) + putAtom (a,b) = do putAtom a + putAtom b + atomSize (a,b)= atomSize a + atomSize b + +instance CodecAtom Word8 where + getAtom = getWord8 + putAtom n = putWord8 n + atomSize _ = 1 + +instance CodecAtom Word16 where + getAtom = getWord16be + putAtom n = putWord16be n + atomSize _ = 2 + +instance CodecAtom Word32 where + getAtom = getWord32be + putAtom n = putWord32be n + atomSize _ = 4 + +instance CodecAtom Bool where + getAtom = do b <- getWord8 + case b of + 0 -> return False + 1 -> return True + _ -> fail "Expected 0/1 in boolean option" + putAtom False = putWord8 0 + putAtom True = putWord8 1 + atomSize _ = 1 + +instance CodecAtom IP4 where + getAtom = getIP4 + putAtom = putIP4 + atomSize _ = 4 + +instance CodecAtom IP4Mask where + getAtom = + do addr <- getAtom + SubnetMask mask <- getAtom + return $! IP4Mask addr mask + + putAtom (IP4Mask addr mask) = + do putAtom addr + putAtom (SubnetMask mask) + + atomSize _ = atomSize (undefined :: IP4) + + atomSize (undefined :: SubnetMask) + +instance CodecAtom Mac where + getAtom = getMac + putAtom = putMac + atomSize _ = 6 + +----------------------------------------------------------------------- +-- Subnet parser/unparser operations ---------------------------------- +----------------------------------------------------------------------- + +newtype SubnetMask = SubnetMask { unmask :: Int + } deriving (Show, Eq) + +word32ToSubnetMask :: Word32 -> Maybe SubnetMask +word32ToSubnetMask mask = + do i <- find (\ i -> computeMask i == mask) [0..32] + return (SubnetMask i) + +subnetMaskToWord32 :: SubnetMask -> Word32 +subnetMaskToWord32 (SubnetMask n) = computeMask n + +computeMask :: Int -> Word32 +computeMask n = 0-2^(32-n) + +instance CodecAtom SubnetMask where + getAtom = do x <- getAtom + case word32ToSubnetMask x of + Just mask -> return mask + Nothing -> fail "Invalid subnet mask" + putAtom = putAtom . subnetMaskToWord32 + atomSize _ = atomSize (undefined :: Word32) diff --git a/src/Hans/IP4/Dhcp/Options.hs b/src/Hans/IP4/Dhcp/Options.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Dhcp/Options.hs @@ -0,0 +1,884 @@ +module Hans.IP4.Dhcp.Options where + +import Hans.IP4.Dhcp.Codec +import Hans.IP4.Packet (IP4,IP4Mask) + +import qualified Control.Applicative as A +import Control.Monad (unless) +import Data.Maybe (fromMaybe) +import Data.Foldable (traverse_) +import qualified Data.Traversable as T +import Data.Word (Word8, Word16, Word32) +import Data.Serialize.Get +import Data.Serialize.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Numeric (showHex) + + +----------------------------------------------------------------------- +-- Magic constants ---------------------------------------------------- +----------------------------------------------------------------------- + +data MagicCookie = MagicCookie + +dhcp4MagicCookie :: Word32 +dhcp4MagicCookie = 0x63825363 + +instance CodecAtom MagicCookie where + getAtom = do cookie <- getAtom + unless (cookie == dhcp4MagicCookie) + (fail "Incorrect magic cookie.") + return MagicCookie + putAtom MagicCookie = putAtom dhcp4MagicCookie + atomSize MagicCookie = atomSize dhcp4MagicCookie + + +----------------------------------------------------------------------- +-- DHCP option type and operations ------------------------------------ +----------------------------------------------------------------------- + +data Dhcp4Option + = OptSubnetMask SubnetMask + | OptTimeOffset Word32 + | OptRouters [IP4] + | OptTimeServers [IP4] + | OptIEN116NameServers [IP4] + | OptNameServers [IP4] + | OptLogServers [IP4] + | OptCookieServers [IP4] + | OptLPRServers [IP4] + | OptImpressServers [IP4] + | OptResourceLocationServers [IP4] + | OptHostName NVTAsciiString + | OptBootFileSize Word16 + | OptMeritDumpFile NVTAsciiString + | OptDomainName NVTAsciiString + | OptSwapServer IP4 + | OptRootPath NVTAsciiString + | OptExtensionsPath NVTAsciiString + | OptEnableIPForwarding Bool + | OptEnableNonLocalSourceRouting Bool + | OptPolicyFilters [IP4Mask] + | OptMaximumDatagramReassemblySize Word16 + | OptDefaultTTL Word8 + | OptPathMTUAgingTimeout Word32 + | OptPathMTUPlateauTable [Word16] + | OptInterfaceMTU Word16 + | OptAllSubnetsAreLocal Bool + | OptBroadcastAddress IP4 + | OptPerformMaskDiscovery Bool + | OptShouldSupplyMasks Bool + | OptShouldPerformRouterDiscovery Bool + | OptRouterSolicitationAddress IP4 + | OptStaticRoutes [(IP4,IP4)] + | OptShouldNegotiateArpTrailers Bool + | OptArpCacheTimeout Word32 + | OptUseRFC1042EthernetEncapsulation Bool + | OptTcpDefaultTTL Word8 + | OptTcpKeepaliveInterval Word32 + | OptTcpKeepaliveUseGarbage Bool + | OptNisDomainName NVTAsciiString + | OptNisServers [IP4] + | OptNtpServers [IP4] + | OptVendorSpecific ByteString + | OptNetBiosNameServers [IP4] + | OptNetBiosDistributionServers [IP4] + | OptNetBiosNodeType NetBiosNodeType + | OptNetBiosScope NVTAsciiString + | OptXWindowsFontServer [IP4] + | OptXWindowsDisplayManagers [IP4] + | OptNisPlusDomain NVTAsciiString + | OptNisPlusServers [IP4] + | OptSmtpServers [IP4] + | OptPopServers [IP4] + | OptNntpServers [IP4] + | OptWwwServers [IP4] + | OptFingerServers [IP4] + | OptIrcServers [IP4] + | OptStreetTalkServers [IP4] + | OptStreetTalkDirectoryAssistanceServers [IP4] + | OptFQDN NVTAsciiString -- RFC 4702 + | OptRequestIPAddress IP4 + | OptIPAddressLeaseTime Word32 + | OptOverload OverloadOption + | OptTftpServer NVTAsciiString + | OptBootfileName NVTAsciiString + | OptMessageType Dhcp4MessageType + | OptServerIdentifier IP4 + | OptParameterRequestList [OptionTagOrError] + | OptErrorMessage NVTAsciiString + | OptMaxDHCPMessageSize Word16 + | OptRenewalTime Word32 + | OptRebindingTime Word32 + | OptVendorClass NVTAsciiString + | OptClientIdentifier ByteString + | OptNetWareDomainName NVTAsciiString -- RFC 2242 + | OptNetWareInfo ByteString -- RFC 2242 + | OptAutoconfiguration Bool -- RFC 2563 + deriving (Show,Eq) + +getDhcp4Option :: Get (Either ControlTag Dhcp4Option) +getDhcp4Option = do + mb_tag <- getOptionTag + case mb_tag of + UnknownTag t -> do xs <- getBytes =<< remaining + fail ("getDhcp4Option failed tag (" ++ show t ++ ") " ++ show xs) + KnownTag tag -> do + let r con = (Right . con) `fmap` getOption + case tag of + OptTagPad -> A.pure (Left ControlPad) + OptTagEnd -> A.pure (Left ControlEnd) + OptTagSubnetMask -> r OptSubnetMask + OptTagTimeOffset -> r OptTimeOffset + OptTagRouters -> r OptRouters + OptTagTimeServers -> r OptTimeServers + OptTagIEN116NameServers -> r OptIEN116NameServers + OptTagNameServers -> r OptNameServers + OptTagLogServers -> r OptLogServers + OptTagCookieServers -> r OptCookieServers + OptTagLPRServers -> r OptLPRServers + OptTagImpressServers -> r OptImpressServers + OptTagResourceLocationServers -> r OptResourceLocationServers + OptTagHostName -> r OptHostName + OptTagBootFileSize -> r OptBootFileSize + OptTagMeritDumpFile -> r OptMeritDumpFile + OptTagDomainName -> r OptDomainName + OptTagSwapServer -> r OptSwapServer + OptTagRootPath -> r OptRootPath + OptTagExtensionsPath -> r OptExtensionsPath + OptTagEnableIPForwarding -> r OptEnableIPForwarding + OptTagEnableNonLocalSourceRouting -> r OptEnableNonLocalSourceRouting + OptTagPolicyFilters -> r OptPolicyFilters + OptTagMaximumDatagramReassemblySize -> r OptMaximumDatagramReassemblySize + OptTagDefaultTTL -> r OptDefaultTTL + OptTagPathMTUAgingTimeout -> r OptPathMTUAgingTimeout + OptTagPathMTUPlateauTable -> r OptPathMTUPlateauTable + OptTagInterfaceMTU -> r OptInterfaceMTU + OptTagAllSubnetsAreLocal -> r OptAllSubnetsAreLocal + OptTagBroadcastAddress -> r OptBroadcastAddress + OptTagPerformMaskDiscovery -> r OptPerformMaskDiscovery + OptTagShouldSupplyMasks -> r OptShouldSupplyMasks + OptTagShouldPerformRouterDiscovery -> r OptShouldPerformRouterDiscovery + OptTagRouterSolicitationAddress -> r OptRouterSolicitationAddress + OptTagStaticRoutes -> r OptStaticRoutes + OptTagShouldNegotiateArpTrailers -> r OptShouldNegotiateArpTrailers + OptTagArpCacheTimeout -> r OptArpCacheTimeout + OptTagUseRFC1042EthernetEncapsulation -> r OptUseRFC1042EthernetEncapsulation + OptTagTcpDefaultTTL -> r OptTcpDefaultTTL + OptTagTcpKeepaliveInterval -> r OptTcpKeepaliveInterval + OptTagTcpKeepaliveUseGarbage -> r OptTcpKeepaliveUseGarbage + OptTagNisDomainName -> r OptNisDomainName + OptTagNisServers -> r OptNisServers + OptTagNtpServers -> r OptNtpServers + OptTagVendorSpecific -> r OptVendorSpecific + OptTagNetBiosNameServers -> r OptNetBiosNameServers + OptTagNetBiosDistributionServers -> r OptNetBiosDistributionServers + OptTagNetBiosNodeType -> r OptNetBiosNodeType + OptTagNetBiosScope -> r OptNetBiosScope + OptTagXWindowsFontServer -> r OptXWindowsFontServer + OptTagXWindowsDisplayManagers -> r OptXWindowsDisplayManagers + OptTagNisPlusDomain -> r OptNisPlusDomain + OptTagNisPlusServers -> r OptNisPlusServers + OptTagSmtpServers -> r OptSmtpServers + OptTagPopServers -> r OptPopServers + OptTagNntpServers -> r OptNntpServers + OptTagWwwServers -> r OptWwwServers + OptTagFingerServers -> r OptFingerServers + OptTagIrcServers -> r OptIrcServers + OptTagStreetTalkServers -> r OptStreetTalkServers + OptTagStreetTalkDirectoryAssistanceServers -> r OptStreetTalkDirectoryAssistanceServers + OptTagFQDN -> r OptFQDN + OptTagRequestIPAddress -> r OptRequestIPAddress + OptTagIPAddressLeaseTime -> r OptIPAddressLeaseTime + OptTagOverload -> r OptOverload + OptTagTftpServer -> r OptTftpServer + OptTagBootfileName -> r OptBootfileName + OptTagMessageType -> r OptMessageType + OptTagServerIdentifier -> r OptServerIdentifier + OptTagParameterRequestList -> r OptParameterRequestList + OptTagErrorMessage -> r OptErrorMessage + OptTagMaxDHCPMessageSize -> r OptMaxDHCPMessageSize + OptTagRenewalTime -> r OptRenewalTime + OptTagRebindingTime -> r OptRebindingTime + OptTagVendorClass -> r OptVendorClass + OptTagClientIdentifier -> r OptClientIdentifier + OptTagNetWareDomainName -> r OptNetWareDomainName + OptTagNetWareInfo -> r OptNetWareInfo + OptTagAutoconfiguration -> r OptAutoconfiguration + +putDhcp4Option :: Dhcp4Option -> Put +putDhcp4Option opt = + let p tag val = do putAtom (KnownTag tag); putOption val in + case opt of + OptSubnetMask mask -> p OptTagSubnetMask mask + OptTimeOffset offset -> p OptTagTimeOffset offset + OptRouters routers -> p OptTagRouters routers + OptTimeServers servers -> p OptTagTimeServers servers + OptIEN116NameServers servers -> p OptTagIEN116NameServers servers + OptNameServers servers -> p OptTagNameServers servers + OptLogServers servers -> p OptTagLogServers servers + OptCookieServers servers -> p OptTagCookieServers servers + OptLPRServers servers -> p OptTagLPRServers servers + OptImpressServers servers -> p OptTagImpressServers servers + OptResourceLocationServers servers -> p OptTagResourceLocationServers servers + OptHostName hostname -> p OptTagHostName hostname + OptBootFileSize sz -> p OptTagBootFileSize sz + OptMeritDumpFile file -> p OptTagMeritDumpFile file + OptDomainName domainname -> p OptTagDomainName domainname + OptSwapServer server -> p OptTagSwapServer server + OptRootPath path -> p OptTagRootPath path + OptExtensionsPath path -> p OptTagExtensionsPath path + OptEnableIPForwarding enabled -> p OptTagEnableIPForwarding enabled + OptEnableNonLocalSourceRouting enab -> p OptTagEnableNonLocalSourceRouting enab + OptPolicyFilters filters -> p OptTagPolicyFilters filters + OptMaximumDatagramReassemblySize n -> p OptTagMaximumDatagramReassemblySize n + OptDefaultTTL ttl -> p OptTagDefaultTTL ttl + OptPathMTUAgingTimeout timeout -> p OptTagPathMTUAgingTimeout timeout + OptPathMTUPlateauTable mtus -> p OptTagPathMTUPlateauTable mtus + OptInterfaceMTU mtu -> p OptTagInterfaceMTU mtu + OptAllSubnetsAreLocal arelocal -> p OptTagAllSubnetsAreLocal arelocal + OptBroadcastAddress addr -> p OptTagBroadcastAddress addr + OptPerformMaskDiscovery perform -> p OptTagPerformMaskDiscovery perform + OptShouldSupplyMasks should -> p OptTagShouldSupplyMasks should + OptShouldPerformRouterDiscovery b -> p OptTagShouldPerformRouterDiscovery b + OptRouterSolicitationAddress addr -> p OptTagRouterSolicitationAddress addr + OptStaticRoutes routes -> p OptTagStaticRoutes routes + OptShouldNegotiateArpTrailers b -> p OptTagShouldNegotiateArpTrailers b + OptArpCacheTimeout timeout -> p OptTagArpCacheTimeout timeout + OptUseRFC1042EthernetEncapsulation b-> p OptTagUseRFC1042EthernetEncapsulation b + OptTcpDefaultTTL ttl -> p OptTagTcpDefaultTTL ttl + OptTcpKeepaliveInterval interval -> p OptTagTcpKeepaliveInterval interval + OptTcpKeepaliveUseGarbage use -> p OptTagTcpKeepaliveUseGarbage use + OptNisDomainName domainname -> p OptTagNisDomainName domainname + OptNisServers servers -> p OptTagNisServers servers + OptNtpServers servers -> p OptTagNtpServers servers + OptVendorSpecific bs -> p OptTagVendorSpecific bs + OptNetBiosNameServers servers -> p OptTagNetBiosNameServers servers + OptNetBiosDistributionServers srvs -> p OptTagNetBiosDistributionServers srvs + OptNetBiosNodeType node -> p OptTagNetBiosNodeType node + OptNetBiosScope scope -> p OptTagNetBiosScope scope + OptXWindowsFontServer servers -> p OptTagXWindowsFontServer servers + OptXWindowsDisplayManagers servers -> p OptTagXWindowsDisplayManagers servers + OptNisPlusDomain domain -> p OptTagNisPlusDomain domain + OptNisPlusServers servers -> p OptTagNisPlusServers servers + OptSmtpServers servers -> p OptTagSmtpServers servers + OptPopServers servers -> p OptTagPopServers servers + OptNntpServers servers -> p OptTagNntpServers servers + OptWwwServers servers -> p OptTagWwwServers servers + OptFingerServers servers -> p OptTagFingerServers servers + OptIrcServers servers -> p OptTagIrcServers servers + OptStreetTalkServers servers -> p OptTagStreetTalkServers servers + OptStreetTalkDirectoryAssistanceServers servers -> p OptTagStreetTalkDirectoryAssistanceServers servers + OptFQDN fqdn -> p OptTagFQDN fqdn + OptRequestIPAddress addr -> p OptTagRequestIPAddress addr + OptIPAddressLeaseTime time -> p OptTagIPAddressLeaseTime time + OptOverload overload -> p OptTagOverload overload + OptTftpServer server -> p OptTagTftpServer server + OptBootfileName filename -> p OptTagBootfileName filename + OptMessageType t -> p OptTagMessageType t + OptServerIdentifier server -> p OptTagServerIdentifier server + OptParameterRequestList ps -> p OptTagParameterRequestList ps + OptErrorMessage msg -> p OptTagErrorMessage msg + OptMaxDHCPMessageSize maxsz -> p OptTagMaxDHCPMessageSize maxsz + OptRenewalTime time -> p OptTagRenewalTime time + OptRebindingTime time -> p OptTagRebindingTime time + OptVendorClass str -> p OptTagVendorClass str + OptClientIdentifier client -> p OptTagClientIdentifier client + OptNetWareDomainName name -> p OptTagNetWareDomainName name + OptNetWareInfo info -> p OptTagNetWareInfo info + OptAutoconfiguration autoconf -> p OptTagAutoconfiguration autoconf + +----------------------------------------------------------------------- +-- Message Type type and operations ----------------------------------- +----------------------------------------------------------------------- + +data Dhcp4MessageType + = Dhcp4Discover + | Dhcp4Offer + | Dhcp4Request + | Dhcp4Decline + | Dhcp4Ack + | Dhcp4Nak + | Dhcp4Release + | Dhcp4Inform + deriving (Eq,Show) + +instance Option Dhcp4MessageType where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom Dhcp4MessageType where + getAtom = do + b <- getAtom + case b :: Word8 of + 1 -> return Dhcp4Discover + 2 -> return Dhcp4Offer + 3 -> return Dhcp4Request + 4 -> return Dhcp4Decline + 5 -> return Dhcp4Ack + 6 -> return Dhcp4Nak + 7 -> return Dhcp4Release + 8 -> return Dhcp4Inform + _ -> fail ("Unknown DHCP Message Type 0x" ++ showHex b "") + + putAtom t = putAtom $ case t of + Dhcp4Discover -> 1 :: Word8 + Dhcp4Offer -> 2 + Dhcp4Request -> 3 + Dhcp4Decline -> 4 + Dhcp4Ack -> 5 + Dhcp4Nak -> 6 + Dhcp4Release -> 7 + Dhcp4Inform -> 8 + + atomSize _ = 1 + +----------------------------------------------------------------------- +-- Control tag type and operations ------------------------------------ +----------------------------------------------------------------------- + +data ControlTag + = ControlPad + | ControlEnd + deriving (Eq, Show) + +putControlOption :: ControlTag -> Put +putControlOption opt = case opt of + ControlPad -> putAtom (KnownTag OptTagPad) + ControlEnd -> putAtom (KnownTag OptTagEnd) + +----------------------------------------------------------------------- +-- Option tag type and operations ------------------------------------- +----------------------------------------------------------------------- + +data Dhcp4OptionTag + = OptTagPad + | OptTagEnd + | OptTagSubnetMask + | OptTagTimeOffset + | OptTagRouters + | OptTagTimeServers + | OptTagIEN116NameServers + | OptTagNameServers + | OptTagLogServers + | OptTagCookieServers + | OptTagLPRServers + | OptTagImpressServers + | OptTagResourceLocationServers + | OptTagHostName + | OptTagBootFileSize + | OptTagMeritDumpFile + | OptTagDomainName + | OptTagSwapServer + | OptTagRootPath + | OptTagExtensionsPath + | OptTagEnableIPForwarding + | OptTagEnableNonLocalSourceRouting + | OptTagPolicyFilters + | OptTagMaximumDatagramReassemblySize + | OptTagDefaultTTL + | OptTagPathMTUAgingTimeout + | OptTagPathMTUPlateauTable + | OptTagInterfaceMTU + | OptTagAllSubnetsAreLocal + | OptTagBroadcastAddress + | OptTagPerformMaskDiscovery + | OptTagShouldSupplyMasks + | OptTagShouldPerformRouterDiscovery + | OptTagRouterSolicitationAddress + | OptTagStaticRoutes + | OptTagShouldNegotiateArpTrailers + | OptTagArpCacheTimeout + | OptTagUseRFC1042EthernetEncapsulation + | OptTagTcpDefaultTTL + | OptTagTcpKeepaliveInterval + | OptTagTcpKeepaliveUseGarbage + | OptTagNisDomainName + | OptTagNisServers + | OptTagNtpServers + | OptTagVendorSpecific + | OptTagNetBiosNameServers + | OptTagNetBiosDistributionServers + | OptTagNetBiosNodeType + | OptTagNetBiosScope + | OptTagXWindowsFontServer + | OptTagXWindowsDisplayManagers + | OptTagNisPlusDomain + | OptTagNisPlusServers + | OptTagSmtpServers + | OptTagPopServers + | OptTagNntpServers + | OptTagWwwServers + | OptTagFingerServers + | OptTagIrcServers + | OptTagStreetTalkServers + | OptTagStreetTalkDirectoryAssistanceServers + | OptTagFQDN + | OptTagRequestIPAddress + | OptTagIPAddressLeaseTime + | OptTagOverload + | OptTagTftpServer + | OptTagBootfileName + | OptTagMessageType + | OptTagServerIdentifier + | OptTagParameterRequestList + | OptTagErrorMessage + | OptTagMaxDHCPMessageSize + | OptTagRenewalTime + | OptTagRebindingTime + | OptTagVendorClass + | OptTagClientIdentifier + | OptTagNetWareDomainName + | OptTagNetWareInfo + | OptTagAutoconfiguration + deriving (Show,Eq) + +data OptionTagOrError = UnknownTag Word8 | KnownTag Dhcp4OptionTag + deriving (Show,Eq) + +getOptionTag :: Get OptionTagOrError +getOptionTag = f =<< getWord8 + where + r = return . KnownTag + f 0 = r OptTagPad + f 1 = r OptTagSubnetMask + f 2 = r OptTagTimeOffset + f 3 = r OptTagRouters + f 4 = r OptTagTimeServers + f 5 = r OptTagIEN116NameServers + f 6 = r OptTagNameServers + f 7 = r OptTagLogServers + f 8 = r OptTagCookieServers + f 9 = r OptTagLPRServers + f 10 = r OptTagImpressServers + f 11 = r OptTagResourceLocationServers + f 12 = r OptTagHostName + f 13 = r OptTagBootFileSize + f 14 = r OptTagMeritDumpFile + f 15 = r OptTagDomainName + f 16 = r OptTagSwapServer + f 17 = r OptTagRootPath + f 18 = r OptTagExtensionsPath + f 19 = r OptTagEnableIPForwarding + f 20 = r OptTagEnableNonLocalSourceRouting + f 21 = r OptTagPolicyFilters + f 22 = r OptTagMaximumDatagramReassemblySize + f 23 = r OptTagDefaultTTL + f 24 = r OptTagPathMTUAgingTimeout + f 25 = r OptTagPathMTUPlateauTable + f 26 = r OptTagInterfaceMTU + f 27 = r OptTagAllSubnetsAreLocal + f 28 = r OptTagBroadcastAddress + f 29 = r OptTagPerformMaskDiscovery + f 30 = r OptTagShouldSupplyMasks + f 31 = r OptTagShouldPerformRouterDiscovery + f 32 = r OptTagRouterSolicitationAddress + f 33 = r OptTagStaticRoutes + f 34 = r OptTagShouldNegotiateArpTrailers + f 35 = r OptTagArpCacheTimeout + f 36 = r OptTagUseRFC1042EthernetEncapsulation + f 37 = r OptTagTcpDefaultTTL + f 38 = r OptTagTcpKeepaliveInterval + f 39 = r OptTagTcpKeepaliveUseGarbage + f 40 = r OptTagNisDomainName + f 41 = r OptTagNisServers + f 42 = r OptTagNtpServers + f 43 = r OptTagVendorSpecific + f 44 = r OptTagNetBiosNameServers + f 45 = r OptTagNetBiosDistributionServers + f 46 = r OptTagNetBiosNodeType + f 47 = r OptTagNetBiosScope + f 48 = r OptTagXWindowsFontServer + f 49 = r OptTagXWindowsDisplayManagers + f 50 = r OptTagRequestIPAddress + f 51 = r OptTagIPAddressLeaseTime + f 52 = r OptTagOverload + f 53 = r OptTagMessageType + f 54 = r OptTagServerIdentifier + f 55 = r OptTagParameterRequestList + f 56 = r OptTagErrorMessage + f 57 = r OptTagMaxDHCPMessageSize + f 58 = r OptTagRenewalTime + f 59 = r OptTagRebindingTime + f 60 = r OptTagVendorClass + f 61 = r OptTagClientIdentifier + f 62 = r OptTagNetWareDomainName + f 63 = r OptTagNetWareInfo + f 64 = r OptTagNisPlusDomain + f 65 = r OptTagNisPlusServers + f 66 = r OptTagTftpServer + f 67 = r OptTagBootfileName + f 69 = r OptTagSmtpServers + f 70 = r OptTagPopServers + f 71 = r OptTagNntpServers + f 72 = r OptTagWwwServers + f 73 = r OptTagFingerServers + f 74 = r OptTagIrcServers + f 75 = r OptTagStreetTalkServers + f 76 = r OptTagStreetTalkDirectoryAssistanceServers + f 81 = r OptTagFQDN + f 116 = r OptTagAutoconfiguration + f 255 = r OptTagEnd + f t = return (UnknownTag t) + +putOptionTag :: OptionTagOrError -> Put +putOptionTag (UnknownTag t) = putAtom t +putOptionTag (KnownTag t) = putAtom (f t) + where + f :: Dhcp4OptionTag -> Word8 + f OptTagPad = 0 + f OptTagEnd = 255 + f OptTagSubnetMask = 1 + f OptTagTimeOffset = 2 + f OptTagRouters = 3 + f OptTagTimeServers = 4 + f OptTagIEN116NameServers = 5 + f OptTagNameServers = 6 + f OptTagLogServers = 7 + f OptTagCookieServers = 8 + f OptTagLPRServers = 9 + f OptTagImpressServers = 10 + f OptTagResourceLocationServers = 11 + f OptTagHostName = 12 + f OptTagBootFileSize = 13 + f OptTagMeritDumpFile = 14 + f OptTagDomainName = 15 + f OptTagSwapServer = 16 + f OptTagRootPath = 17 + f OptTagExtensionsPath = 18 + f OptTagEnableIPForwarding = 19 + f OptTagEnableNonLocalSourceRouting = 20 + f OptTagPolicyFilters = 21 + f OptTagMaximumDatagramReassemblySize = 22 + f OptTagDefaultTTL = 23 + f OptTagPathMTUAgingTimeout = 24 + f OptTagPathMTUPlateauTable = 25 + f OptTagInterfaceMTU = 26 + f OptTagAllSubnetsAreLocal = 27 + f OptTagBroadcastAddress = 28 + f OptTagPerformMaskDiscovery = 29 + f OptTagShouldSupplyMasks = 30 + f OptTagShouldPerformRouterDiscovery = 31 + f OptTagRouterSolicitationAddress = 32 + f OptTagStaticRoutes = 33 + f OptTagShouldNegotiateArpTrailers = 34 + f OptTagArpCacheTimeout = 35 + f OptTagUseRFC1042EthernetEncapsulation = 36 + f OptTagTcpDefaultTTL = 37 + f OptTagTcpKeepaliveInterval = 38 + f OptTagTcpKeepaliveUseGarbage = 39 + f OptTagNisDomainName = 40 + f OptTagNisServers = 41 + f OptTagNtpServers = 42 + f OptTagVendorSpecific = 43 + f OptTagNetBiosNameServers = 44 + f OptTagNetBiosDistributionServers = 45 + f OptTagNetBiosNodeType = 46 + f OptTagNetBiosScope = 47 + f OptTagXWindowsFontServer = 48 + f OptTagXWindowsDisplayManagers = 49 + f OptTagRequestIPAddress = 50 + f OptTagIPAddressLeaseTime = 51 + f OptTagOverload = 52 + f OptTagMessageType = 53 + f OptTagServerIdentifier = 54 + f OptTagParameterRequestList = 55 + f OptTagErrorMessage = 56 + f OptTagMaxDHCPMessageSize = 57 + f OptTagRenewalTime = 58 + f OptTagRebindingTime = 59 + f OptTagVendorClass = 60 + f OptTagClientIdentifier = 61 + f OptTagNetWareDomainName = 62 + f OptTagNetWareInfo = 63 + f OptTagNisPlusDomain = 64 + f OptTagNisPlusServers = 65 + f OptTagTftpServer = 66 + f OptTagBootfileName = 67 + f OptTagSmtpServers = 69 + f OptTagPopServers = 70 + f OptTagNntpServers = 71 + f OptTagWwwServers = 72 + f OptTagFingerServers = 73 + f OptTagIrcServers = 74 + f OptTagStreetTalkServers = 75 + f OptTagStreetTalkDirectoryAssistanceServers = 76 + f OptTagFQDN = 81 + f OptTagAutoconfiguration = 116 + +----------------------------------------------------------------------- +-- NetBIOS node type and operations ----------------------------------- +----------------------------------------------------------------------- + +data NetBiosNodeType + = BNode + | PNode + | MNode + | HNode + deriving (Show,Eq) + +instance Option NetBiosNodeType where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom NetBiosNodeType where + getAtom = do + b <- getAtom + case b :: Word8 of + 0x1 -> return BNode + 0x2 -> return PNode + 0x4 -> return MNode + 0x8 -> return HNode + _ -> fail "Unknown NetBIOS node type" + + putAtom t = putAtom $ case t of + BNode -> 0x1 :: Word8 + PNode -> 0x2 + MNode -> 0x4 + HNode -> 0x8 + + atomSize _ = 1 + +----------------------------------------------------------------------- +-- Overload option type and operations -------------------------------- +----------------------------------------------------------------------- + +data OverloadOption + = UsedFileField + | UsedSNameField + | UsedBothFields + deriving (Show, Eq) + +instance Option OverloadOption where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom OverloadOption where + getAtom = do b <- getAtom + case b :: Word8 of + 1 -> return UsedFileField + 2 -> return UsedSNameField + 3 -> return UsedBothFields + _ -> fail ("Bad overload value 0x" ++ showHex b "") + putAtom t = putAtom $ case t of + UsedFileField -> 1 :: Word8 + UsedSNameField -> 2 + UsedBothFields -> 3 + + atomSize _ = atomSize (undefined :: Word8) + +----------------------------------------------------------------------- +-- Options list operations -------------------------------------------- +----------------------------------------------------------------------- + +getDhcp4Options :: ByteString -> ByteString + -> Get (String, String, [Dhcp4Option]) +getDhcp4Options sname file = do + MagicCookie <- getAtom + options0 <- remainingAsOptions + case lookupOverload options0 of + Nothing -> return (nullTerminated sname, nullTerminated file, options0) + + Just UsedFileField -> do + options1 <- localParse file remainingAsOptions + let options = options0 ++ options1 + NVTAsciiString fileString + = fromMaybe (NVTAsciiString "") (lookupFile options) + return (nullTerminated sname, fileString, options) + + Just UsedSNameField -> do + options1 <- localParse sname remainingAsOptions + let options = options0 ++ options1 + NVTAsciiString snameString + = fromMaybe (NVTAsciiString "") (lookupSname options) + return (snameString, nullTerminated file, options) + + Just UsedBothFields -> do + + -- The file field MUST be interpreted for options before the sname field. + -- RFC 2131, Section 4.1, Page 24 + options1 <- localParse file remainingAsOptions + options2 <- localParse sname remainingAsOptions + let options = options0 ++ options1 ++ options2 + NVTAsciiString snameString + = fromMaybe (NVTAsciiString "") (lookupSname options) + NVTAsciiString fileString + = fromMaybe (NVTAsciiString "") (lookupFile options) + return (snameString, fileString, options) + + where + remainingAsOptions = scrubControls =<< repeatedly getDhcp4Option + + localParse bs m = case runGet m bs of + Right x -> return x + Left err -> fail err + + +putDhcp4Options :: [Dhcp4Option] -> Put +putDhcp4Options opts = + do putAtom MagicCookie + traverse_ putDhcp4Option opts + putControlOption ControlEnd + +scrubControls :: (A.Applicative m, Monad m) + => [Either ControlTag Dhcp4Option] -> m [Dhcp4Option] + +scrubControls [] = + fail "No END option found" + +scrubControls (Left ControlPad : xs) = + scrubControls xs + +scrubControls (Left ControlEnd : xs) = + do traverse_ eatPad xs + return [] + +scrubControls (Right o : xs) = + do os <- scrubControls xs + return (o:os) + +-- | 'eatPad' fails on any non 'ControlPad' option with an error message. +eatPad :: Monad m => Either ControlTag Dhcp4Option -> m () +eatPad (Left ControlPad) = return () +eatPad _ = fail "Unexpected option after END option" + +replicateA :: A.Applicative f => Int -> f a -> f [a] +replicateA n f = T.sequenceA (replicate n f) + +repeatedly :: Get a -> Get [a] +repeatedly m = go [] + where + go acc = + do done <- isEmpty + if done then return (reverse acc) + else do a <- m + go (a:acc) + +nullTerminated :: ByteString -> String +nullTerminated = takeWhile (/= '\NUL') . BS8.unpack + +lookupOverload :: [Dhcp4Option] -> Maybe OverloadOption +lookupOverload = foldr f Nothing + where f (OptOverload o) _ = Just o + f _ a = a + +lookupFile :: [Dhcp4Option] -> Maybe NVTAsciiString +lookupFile = foldr f Nothing + where f (OptBootfileName fn) _ = Just fn + f _ a = a + +lookupSname :: [Dhcp4Option] -> Maybe NVTAsciiString +lookupSname = foldr f Nothing + where f (OptTftpServer n) _ = Just n + f _ a = a + +lookupParams :: [Dhcp4Option] -> Maybe [OptionTagOrError] +lookupParams = foldr f Nothing + where f (OptParameterRequestList n) _ = Just n + f _ a = a + +lookupMessageType :: [Dhcp4Option] -> Maybe Dhcp4MessageType +lookupMessageType = foldr f Nothing + where f (OptMessageType n) _ = Just n + f _ a = a + +lookupRequestAddr :: [Dhcp4Option] -> Maybe IP4 +lookupRequestAddr = foldr f Nothing + where f (OptRequestIPAddress n) _ = Just n + f _ a = a + +lookupLeaseTime :: [Dhcp4Option] -> Maybe Word32 +lookupLeaseTime = foldr f Nothing + where f (OptIPAddressLeaseTime t) _ = Just t + f _ a = a + +----------------------------------------------------------------------- +-- Protected parser and unparser monad -------------------------------- +----------------------------------------------------------------------- + +class Option a where + getOption :: Get a + putOption :: a -> Put + +instance CodecAtom a => Option [a] where + getOption = do + let (n, m) = getRecord + len <- getLen + let (count, remainder) = divMod len n + unless (remainder == 0) (fail ("Length was not a multiple of " ++ show n)) + unless (count > 0) (fail "Minimum length not met") + replicateA count $ label "List of fixed-length values" $ isolate n m + putOption xs = do putLen (atomSize (head xs) * length xs) + traverse_ putAtom xs + +instance (CodecAtom a, CodecAtom b) => Option (a,b) where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Bool where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word8 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word16 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word32 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option IP4 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option SubnetMask where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option ByteString where + getOption = do len <- getLen + getByteString len + putOption bs = do putLen (BS.length bs) + putByteString bs + +defaultFixedGetOption :: CodecAtom a => Get a +defaultFixedGetOption = fixedLen n m + where (n,m) = getRecord + +defaultFixedPutOption :: CodecAtom a => a -> Put +defaultFixedPutOption x = do + putLen (atomSize x) + putAtom x + +fixedLen :: Int -> Get a -> Get a +fixedLen expectedLen m = do + len <- getLen + unless (len == expectedLen) (fail "Bad length on \"fixed-length\" option.") + label "Fixed length field" (isolate expectedLen m) + +getRecord :: CodecAtom a => (Int, Get a) +getRecord = (atomSize undef, m) + where + (undef, m) = (undefined, getAtom) :: CodecAtom a => (a, Get a) + + +instance CodecAtom OptionTagOrError where + getAtom = getOptionTag + putAtom x = putOptionTag x + atomSize _ = 1 + +newtype NVTAsciiString = NVTAsciiString String + deriving (Eq, Show) + +instance Option NVTAsciiString where + getOption = do len <- getLen + bs <- getByteString len + return (NVTAsciiString (nullTerminated bs)) + putOption (NVTAsciiString str) = do + putLen (length str) + putByteString (BS8.pack str) + +getLen :: Get Int +getLen = fromIntegral `fmap` getWord8 + +putLen :: Int -> Put +putLen n = putWord8 (fromIntegral n) diff --git a/src/Hans/IP4/Dhcp/Packet.hs b/src/Hans/IP4/Dhcp/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Dhcp/Packet.hs @@ -0,0 +1,662 @@ +{-# LANGUAGE PatternSynonyms #-} + +{- | The 'Hans.Message.Dhcp4' module defines the various messages and + transitions used in the DHCPv4 protocol. This module provides both + a high-level view of the message types as well as a low-level + intermediate form which is closely tied to the binary format. + + References: + RFC 2131 - Dynamic Host Configuration Protocol + http://www.faqs.org/rfcs/rfc2131.html +-} + +module Hans.IP4.Dhcp.Packet + ( + -- ** High-level client types + RequestMessage(..) + , Request(..) + , Discover(..) + + -- ** High-level server types + , ServerSettings(..) + , ReplyMessage(..) + , Ack(..) + , Offer(..) + + -- ** Low-level message types + , Dhcp4Message(..) + , Xid(..) + + -- ** Server message transition logic + , requestToAck + , discoverToOffer + + -- ** Client message transition logic + , mkDiscover + , offerToRequest + + -- ** Convert high-level message types to low-level format + , requestToMessage + , ackToMessage + , offerToMessage + , discoverToMessage + + -- ** Convert low-level message type to high-level format + , parseDhcpMessage + + -- ** Convert low-level message type to binary format + , getDhcp4Message + , putDhcp4Message + + ) where + +import Hans.Ethernet (Mac) +import Hans.IP4.Dhcp.Codec +import Hans.IP4.Dhcp.Options +import Hans.IP4.Packet (IP4(..),pattern WildcardIP4) + +import qualified Control.Applicative as A +import Control.Monad (unless) +import Data.Bits (testBit,bit) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (mapMaybe) +import Data.Serialize.Get + (Get,getByteString,isolate,remaining,label,skip) +import Data.Serialize.Put (Put,putByteString) +import Data.Word (Word8,Word16,Word32) +import Numeric (showHex) + + +-- DHCP Static Server Settings --------------------------------------------- + +-- |'ServerSettings' define all of the information that would be needed to +-- act as a DHCP server for one client. The server is defined to be able to +-- issue a single "lease" whose parameters are defined below. +data ServerSettings = Settings + { staticServerAddr :: !IP4 -- ^ The IPv4 address of the DHCP server + , staticTimeOffset :: !Word32 -- ^ Lease: timezone offset in seconds from UTC + , staticClientAddr :: !IP4 -- ^ Lease: client IPv4 address on network + , staticLeaseTime :: !Word32 -- ^ Lease: duration in seconds + , staticSubnet :: !SubnetMask -- ^ Lease: subnet mask on network + , staticBroadcast :: !IP4 -- ^ Lease: broadcast address on network + , staticRouters :: [IP4] -- ^ Lease: gateway routers on network + , staticDomainName :: String -- ^ Lease: client's assigned domain name + , staticDNS :: [IP4] -- ^ Lease: network DNS servers + } deriving (Show) + +-- Structured DHCP Messages ------------------------------------------------ + +-- |'RequestMessage' is a sum of the client request messages. +data RequestMessage = RequestMessage !Request + | DiscoverMessage !Discover + deriving (Show) + +-- |'ReplyMessage' is a sum of the server response messages. +data ReplyMessage = AckMessage !Ack + | OfferMessage !Offer + deriving (Show) + +-- |'Request' is used by the client to accept an offered lease. +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 + } deriving (Show) + + +-- |'Discover' is used by the client to discover what servers are available. +-- This message is sent to the IPv4 broadcast. +data Discover = Discover + { discoverXid :: !Xid + -- ^ Transaction ID of this and subsequent messages + + , discoverBroadcast :: Bool + -- ^ Set 'True' to instruct the server to send to broadcast hardware address + + , discoverClientHardwareAddr :: !Mac + -- ^ Hardware address of the client + + , discoverParameters :: [Dhcp4OptionTag] + -- ^ Used to specify the information that client needs in the offers + } deriving (Show) + +-- |'Ack' is sent by the DHCPv4 server to acknowledge a sucessful 'Request' +-- message. Upon receiving this message the client has completed the +-- exchange and has successfully obtained a lease. +data Ack = Ack + { ackHops :: !Word8 + -- ^ The maximum number of relays this message can use. + + , ackXid :: !Xid + -- ^ Transaction ID for this exchange + + , ackYourAddr :: !IP4 + -- ^ Lease: assigned client address + + , ackServerAddr :: !IP4 + -- ^ DHCP server's IPv4 address + + , ackRelayAddr :: !IP4 + -- ^ DHCP relay server's address + + , ackClientHardwareAddr :: !Mac + -- ^ Client's hardware address + + , ackLeaseTime :: !Word32 + -- ^ Lease: duration of lease in seconds + + , ackOptions :: [Dhcp4Option] + -- ^ Subset of information requested in previous 'Request' + } deriving (Show) + +-- |'Offer' is sent by the DHCPv4 server in response to a 'Discover'. +-- This offer is only valid for a short period of time as the client +-- might receive many offers. The client must next request a lease +-- from a specific server using the information in that server's offer. +data Offer = Offer + { offerHops :: !Word8 + -- ^ The maximum number of relays this message can use. + + , offerXid :: !Xid + -- ^ Transaction ID of this exchange + + , offerYourAddr :: !IP4 + -- ^ The IPv4 address that this server is willing to lease + + , offerServerAddr :: !IP4 + -- ^ The IPv4 address of the DHCPv4 server + + , offerRelayAddr :: !IP4 + -- ^ The IPv4 address of the DHCPv4 relay server + + , offerClientHardwareAddr :: !Mac + -- ^ The hardware address of the client + + , offerOptions :: [Dhcp4Option] + -- ^ The options that this server would include in a lease + } deriving (Show) + +-- |'requestToAck' creates 'Ack' messages suitable for responding to 'Request' +-- messages given a static 'ServerSettings' configuration. +requestToAck :: ServerSettings -- ^ DHCPv4 server settings + -> Request -- ^ Client's request message + -> Ack +requestToAck settings request = Ack + { ackHops = 1 + , ackXid = requestXid request + , ackYourAddr = staticClientAddr settings + , ackServerAddr = staticServerAddr settings + , ackRelayAddr = staticServerAddr settings + , ackClientHardwareAddr = requestClientHardwareAddress request + , ackLeaseTime = staticLeaseTime settings + , ackOptions = mapMaybe lookupOption (requestParameters request) + } + where + lookupOption tag = case tag of + OptTagSubnetMask + -> Just (OptSubnetMask (staticSubnet settings)) + OptTagBroadcastAddress + -> Just (OptBroadcastAddress (staticBroadcast settings)) + OptTagTimeOffset + -> Just (OptTimeOffset (staticTimeOffset settings)) + OptTagRouters + -> Just (OptRouters (staticRouters settings)) + OptTagDomainName + -> Just (OptDomainName (NVTAsciiString (staticDomainName settings))) + OptTagNameServers + -> Just (OptNameServers (staticDNS settings)) + _ -> Nothing + +-- |'discoverToOffer' creates a suitable 'Offer' in response to a client's +-- 'Discover' message using the configuration settings specified in the +-- given 'ServerSettings'. +discoverToOffer :: ServerSettings -- ^ DHCPv4 server settings + -> Discover -- ^ Client's discover message + -> Offer +discoverToOffer settings discover = Offer + { offerHops = 1 + , offerXid = discoverXid discover + , offerYourAddr = staticClientAddr settings + , offerServerAddr = staticServerAddr settings + , offerRelayAddr = staticServerAddr settings + , offerClientHardwareAddr = discoverClientHardwareAddr discover + , offerOptions = mapMaybe lookupOption (discoverParameters discover) + } + where + lookupOption tag = case tag of + OptTagSubnetMask + -> Just (OptSubnetMask (staticSubnet settings)) + OptTagBroadcastAddress + -> Just (OptBroadcastAddress (staticBroadcast settings)) + OptTagTimeOffset + -> Just (OptTimeOffset (staticTimeOffset settings)) + OptTagRouters + -> Just (OptRouters (staticRouters settings)) + OptTagDomainName + -> Just (OptDomainName (NVTAsciiString (staticDomainName settings))) + OptTagNameServers + -> Just (OptNameServers (staticDNS settings)) + _ -> Nothing + +-- Unstructured DHCP Message ----------------------------------------------- + +-- |'Dhcp4Message' is a low-level message container that is very close to +-- the binary representation of DHCPv4 message. It is suitable for containing +-- any DHCPv4 message. Values of this type should only be created using the +-- publicly exported functions. +data Dhcp4Message = Dhcp4Message + { dhcp4Op :: Dhcp4Op + -- ^ Message op code / message type. 1 = BOOTREQUEST, 2 = BOOTREPLY + + , dhcp4Hops :: !Word8 + -- ^ Client sets to zero, optionally used by relay agents when booting via a + -- relay agent. + + , dhcp4Xid :: !Xid + -- ^ Transaction ID, a random number chosen by the client, used by the + -- client and server to associate messages and responses between a client + -- and a server. + + , dhcp4Secs :: !Word16 + -- ^ Filled in by client, seconds elapsed since client began address + -- acquisition or renewal process. + + , dhcp4Broadcast :: Bool + -- ^ Client requests messages be sent to hardware broadcast address + + , dhcp4ClientAddr :: !IP4 + -- ^ Client IP address; only filled in if client is in BOUND, RENEW or + -- REBINDING state and can respond to ARP requests. + + , dhcp4YourAddr :: !IP4 + -- ^ 'your' (client) address + + , dhcp4ServerAddr :: !IP4 + -- ^ IP address of next server to use in bootstrap; returned in DHCPOFFER, + -- DHCPACK by server + + , dhcp4RelayAddr :: !IP4 + -- ^ Relay agent IP address, used in booting via a relay agent + + , dhcp4ClientHardwareAddr :: !Mac + -- ^ Client hardware address + + , dhcp4ServerHostname :: String + -- ^ Optional server host name, null terminated string + + , dhcp4BootFilename :: String + -- ^ Boot file name, full terminated string; "generic" name of null in + -- DHCPDISCOVER, fully qualified directory-path name in DHCPOFFER + + , dhcp4Options :: [Dhcp4Option] + -- ^ Optional parameters field. + } deriving (Eq,Show) + +-- |'getDhcp4Message' is the binary decoder for parsing 'Dhcp4Message' values. +getDhcp4Message :: Get Dhcp4Message +getDhcp4Message = + do op <- getAtom + hwtype <- getAtom + len <- getAtom + unless (len == hardwareTypeAddressLength hwtype) + (fail "Hardware address length does not match hardware type.") + hops <- label "hops" getAtom + xid <- label "xid" getAtom + secs <- label "secs" getAtom + flags <- label "flags" getAtom + ciaddr <- label "ciaddr" getAtom + yiaddr <- label "yiaddr" getAtom + siaddr <- label "siaddr" getAtom + giaddr <- label "giaddr" getAtom + chaddr <- label "chaddr" $ isolate 16 $ getAtom A.<* (skip =<< remaining) + snameBytes <- label "sname field" (getByteString 64) + fileBytes <- label "file field" (getByteString 128) + (sname, file, opts) <- getDhcp4Options snameBytes fileBytes + return $! Dhcp4Message + { dhcp4Op = op + , dhcp4Hops = hops + , dhcp4Xid = xid + , dhcp4Secs = secs + , dhcp4Broadcast = broadcastFlag flags + , dhcp4ClientAddr = ciaddr + , dhcp4YourAddr = yiaddr + , dhcp4ServerAddr = siaddr + , dhcp4RelayAddr = giaddr + , dhcp4ClientHardwareAddr = chaddr + , dhcp4ServerHostname = sname + , dhcp4BootFilename = file + , dhcp4Options = opts + } + +-- |'getDhcp4Message' is the binary encoder for rendering 'Dhcp4Message' values. +putDhcp4Message :: Dhcp4Message -> Put +putDhcp4Message dhcp = + do putAtom (dhcp4Op dhcp) + let hwType = Ethernet + putAtom hwType + putAtom (hardwareTypeAddressLength hwType) + putAtom (dhcp4Hops dhcp) + putAtom (dhcp4Xid dhcp) + putAtom (dhcp4Secs dhcp) + putAtom Flags { broadcastFlag = dhcp4Broadcast dhcp } + putAtom (dhcp4ClientAddr dhcp) + putAtom (dhcp4YourAddr dhcp) + putAtom (dhcp4ServerAddr dhcp) + putAtom (dhcp4RelayAddr dhcp) + putAtom (dhcp4ClientHardwareAddr dhcp) + putByteString $ BS.replicate (16 {- chaddr field length -} + - fromIntegral (hardwareTypeAddressLength hwType)) 0 + putPaddedByteString 64 (BS8.pack (dhcp4ServerHostname dhcp)) + putPaddedByteString 128 (BS8.pack (dhcp4BootFilename dhcp)) + putDhcp4Options (dhcp4Options dhcp) + +-- Transaction ID -------------------------------------------------------------- + +-- |'Xid' is a Transaction ID, a random number chosen by the client, +-- used by the client and server to associate messages and responses between a +-- client and a server. +newtype Xid = Xid Word32 + deriving (Eq, Show) + +instance CodecAtom Xid where + getAtom = + do w <- getAtom + return (Xid w) + + putAtom (Xid xid) = + putAtom xid + + atomSize _ = + atomSize (0 :: Word32) + +-- Opcodes --------------------------------------------------------------------- + +data Dhcp4Op = BootRequest + | BootReply + deriving (Eq,Show) + +instance CodecAtom Dhcp4Op where + getAtom = do + b <- getAtom + case b :: Word8 of + 1 -> return BootRequest + 2 -> return BootReply + _ -> fail ("Unknown DHCP op 0x" ++ showHex b "") + + putAtom BootRequest = putAtom (0x1 :: Word8) + putAtom BootReply = putAtom (0x2 :: Word8) + + atomSize _ = atomSize (0 :: Word8) + +-- | HardwareType is an enumeration of the supported hardware types as assigned +-- in the ARP RFC http://www.iana.org/assignments/arp-parameters/ +data HardwareType = Ethernet + deriving (Eq, Show) + +instance CodecAtom HardwareType where + getAtom = + do b <- getAtom + case b :: Word8 of + 1 -> return Ethernet + _ -> fail ("Unsupported hardware type 0x" ++ showHex b "") + + putAtom Ethernet = putAtom (1 :: Word8) + + atomSize _ = atomSize (1 :: Word8) + +hardwareTypeAddressLength :: HardwareType -> Word8 +hardwareTypeAddressLength Ethernet = 6 + +-- RFC 2131, Section 2, Page 11: +-- 1 1 1 1 1 1 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- |B| MBZ | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- B: BROADCAST flag +-- MBZ: MUST BE ZERO (reserved for future use) +-- Figure 2: Format of the ’flags’ field + +data Flags = Flags { broadcastFlag :: Bool + } deriving (Show, Eq) + +instance CodecAtom Flags where + getAtom = + do b <- getAtom + return Flags { broadcastFlag = testBit (b :: Word16) 15 } + + putAtom flags = putAtom $ if broadcastFlag flags then bit 15 :: Word16 + else 0 + + atomSize _ = atomSize (0 :: Word16) + +putPaddedByteString :: Int -> BS.ByteString -> Put +putPaddedByteString n bs = + do putByteString $ BS.take n bs + putByteString $ BS.replicate (n - BS.length bs) 0 + + +selectKnownTags :: [OptionTagOrError] -> [Dhcp4OptionTag] +selectKnownTags = mapMaybe aux + where + aux (KnownTag t) = Just t + aux _ = Nothing + +-- +-- Unstructured to Structured logic +-- +-- |'parseDhcpMessage' attempts to find a valid high-level message +-- contained in a low-level message. The 'Dhcp4Message' is a large +-- type and can encode invalid combinations of options. +parseDhcpMessage :: Dhcp4Message -> Maybe (Either RequestMessage ReplyMessage) +parseDhcpMessage msg = + do messageType <- lookupMessageType (dhcp4Options msg) + case dhcp4Op msg of + + BootRequest -> Left `fmap` case messageType of + + Dhcp4Request -> RequestMessage `fmap` + do params <- lookupParams (dhcp4Options msg) + let params' = selectKnownTags params + let addr = lookupRequestAddr (dhcp4Options msg) + return $! Request + { requestXid = dhcp4Xid msg + , requestBroadcast = dhcp4Broadcast msg + , requestServerAddr = dhcp4ServerAddr msg + , requestClientHardwareAddress = dhcp4ClientHardwareAddr msg + , requestParameters = params' + , requestAddress = addr + } + + Dhcp4Discover -> DiscoverMessage `fmap` + do params <- lookupParams (dhcp4Options msg) + let params' = selectKnownTags params + return $! Discover + { discoverXid = dhcp4Xid msg + , discoverBroadcast = dhcp4Broadcast msg + , discoverClientHardwareAddr = dhcp4ClientHardwareAddr msg + , discoverParameters = params' + } + + _ -> Nothing + + BootReply -> Right `fmap` case messageType of + + Dhcp4Ack -> AckMessage `fmap` + do leaseTime <- lookupLeaseTime (dhcp4Options msg) + return Ack + { ackHops = dhcp4Hops msg + , ackXid = dhcp4Xid msg + , ackYourAddr = dhcp4YourAddr msg + , ackServerAddr = dhcp4ServerAddr msg + , ackRelayAddr = dhcp4RelayAddr msg + , ackClientHardwareAddr = dhcp4ClientHardwareAddr msg + , ackLeaseTime = leaseTime + , ackOptions = dhcp4Options msg + } + + Dhcp4Offer -> return $! OfferMessage Offer + { offerHops = dhcp4Hops msg + , offerXid = dhcp4Xid msg + , offerYourAddr = dhcp4YourAddr msg + , offerServerAddr = getOfferServerAddr (dhcp4ServerAddr msg) (dhcp4Options msg) + , offerRelayAddr = dhcp4RelayAddr msg + , offerClientHardwareAddr = dhcp4ClientHardwareAddr msg + , offerOptions = dhcp4Options msg + } + + _ -> Nothing + + +getOfferServerAddr :: IP4 -> [Dhcp4Option] -> IP4 +getOfferServerAddr = foldr check + where + check (OptServerIdentifier ip) _ = ip + check _ def = def + +-- +-- Structured to unstructured logic +-- +-- |'discoverToMessage' embeds 'Discover' messages in the low-level +-- 'Dhcp4Message' type, typically for the purpose of serialization. +discoverToMessage :: Discover -> Dhcp4Message +discoverToMessage discover = Dhcp4Message + { dhcp4Op = BootRequest + , dhcp4Hops = 0 + , dhcp4Xid = discoverXid discover + , dhcp4Secs = 0 + , dhcp4Broadcast = False + , dhcp4ClientAddr = WildcardIP4 + , dhcp4YourAddr = WildcardIP4 + , dhcp4ServerAddr = WildcardIP4 + , dhcp4RelayAddr = WildcardIP4 + , dhcp4ClientHardwareAddr = discoverClientHardwareAddr discover + , dhcp4ServerHostname = "" + , dhcp4BootFilename = "" + , dhcp4Options = [ OptMessageType Dhcp4Discover + , OptParameterRequestList + $ map KnownTag + $ discoverParameters discover + ] + } + +-- |'ackToMessage' embeds 'Ack' messages in the low-level +-- 'Dhcp4Message' type, typically for the purpose of serialization. +ackToMessage :: Ack -> Dhcp4Message +ackToMessage ack = Dhcp4Message + { dhcp4Op = BootReply + , dhcp4Hops = ackHops ack + , dhcp4Xid = ackXid ack + , dhcp4Secs = 0 + , dhcp4Broadcast = False + , dhcp4ClientAddr = WildcardIP4 + , dhcp4YourAddr = ackYourAddr ack + , dhcp4ServerAddr = ackServerAddr ack + , dhcp4RelayAddr = ackRelayAddr ack + , dhcp4ClientHardwareAddr = ackClientHardwareAddr ack + , dhcp4ServerHostname = "" + , dhcp4BootFilename = "" + , dhcp4Options = OptMessageType Dhcp4Ack + : OptServerIdentifier (ackServerAddr ack) + : OptIPAddressLeaseTime (ackLeaseTime ack) + : ackOptions ack + } + +-- |'offerToMessage' embeds 'Offer' messages in the low-level +-- 'Dhcp4Message' type, typically for the purpose of serialization. +offerToMessage :: Offer -> Dhcp4Message +offerToMessage offer = Dhcp4Message + { dhcp4Op = BootReply + , dhcp4Hops = offerHops offer + , dhcp4Xid = offerXid offer + , dhcp4Secs = 0 + , dhcp4Broadcast = False + , dhcp4ClientAddr = WildcardIP4 + , dhcp4YourAddr = offerYourAddr offer + , dhcp4ServerAddr = offerServerAddr offer + , dhcp4RelayAddr = offerRelayAddr offer + , dhcp4ClientHardwareAddr = offerClientHardwareAddr offer + , dhcp4ServerHostname = "" + , dhcp4BootFilename = "" + , dhcp4Options = OptMessageType Dhcp4Offer + : OptServerIdentifier (offerServerAddr offer) + : offerOptions offer + } + +-- |'requestToMessage' embeds 'Request' messages in the low-level +-- 'Dhcp4Message' type, typically for the purpose of serialization. +requestToMessage :: Request -> Dhcp4Message +requestToMessage request = Dhcp4Message + { dhcp4Op = BootRequest + , dhcp4Hops = 0 + , dhcp4Xid = requestXid request + , dhcp4Secs = 0 + , dhcp4Broadcast = requestBroadcast request + , dhcp4ClientAddr = WildcardIP4 + , dhcp4YourAddr = WildcardIP4 + , dhcp4ServerAddr = WildcardIP4 + , dhcp4RelayAddr = WildcardIP4 + , dhcp4ClientHardwareAddr = requestClientHardwareAddress request + , dhcp4ServerHostname = "" + , dhcp4BootFilename = "" + , dhcp4Options = [ OptMessageType Dhcp4Request + , OptServerIdentifier (requestServerAddr request) + , OptParameterRequestList + $ map KnownTag + $ requestParameters request + ] ++ maybe [] (\x -> [OptRequestIPAddress x]) + (requestAddress request) + } + +-- |'mkDiscover' creates a new 'Discover' message with a set +-- of options suitable for configuring a basic network stack. +mkDiscover :: Xid -- ^ New randomly generated transaction ID + -> Mac -- ^ The client's hardware address + -> Discover +mkDiscover xid mac = Discover + { discoverXid = xid + , discoverBroadcast = False + , discoverClientHardwareAddr = mac + , discoverParameters = [ OptTagSubnetMask + , OptTagBroadcastAddress + , OptTagTimeOffset + , OptTagRouters + , OptTagDomainName + , OptTagNameServers + , OptTagHostName + ] + } + +-- |'offerToRequest' creates a 'Request' message suitable for accepting +-- an 'Offer' from the DHCPv4 server. +offerToRequest :: Offer -- ^ The offer as received from the server + -> Request +offerToRequest offer = Request + { requestXid = offerXid offer + , requestBroadcast = False + , requestServerAddr = offerServerAddr offer + , requestClientHardwareAddress = offerClientHardwareAddr offer + , requestParameters = [ OptTagSubnetMask + , OptTagBroadcastAddress + , OptTagTimeOffset + , OptTagRouters + , OptTagDomainName + , OptTagNameServers + , OptTagHostName + ] + , requestAddress = Just (offerYourAddr offer) + } diff --git a/src/Hans/IP4/Fragments.hs b/src/Hans/IP4/Fragments.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Fragments.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} + +module Hans.IP4.Fragments ( + FragTable(), + newFragTable, cleanupFragTable, + processFragment, + ) where + +import Hans.Config +import qualified Hans.HashTable as HT +import Hans.IP4.Packet +import Hans.Lens (view) +import Hans.Monad +import Hans.Network.Types (NetworkProtocol) +import Hans.Threads (forkNamed) +import Hans.Time (toUSeconds) + +import Control.Concurrent (ThreadId,threadDelay,killThread) +import Control.Monad (forever) +import qualified Data.ByteString as S +import Data.Time.Clock + (UTCTime,getCurrentTime,NominalDiffTime,addUTCTime) + + +-- | Keys are of the form @(src,dest,prot,ident)@. +type Key = (IP4,IP4,NetworkProtocol,IP4Ident) + +type Table = HT.HashTable Key Buffer + +-- XXX: there isn't any way to limit the size of the fragment table right now. +data FragTable = FragTable { ftEntries :: !Table + , ftDuration :: !NominalDiffTime + , ftPurgeThread :: !ThreadId + } + +newFragTable :: Config -> IO FragTable +newFragTable Config { .. } = + do ftEntries <- HT.newHashTable 31 + ftPurgeThread <- forkNamed "IP4 Fragment Purge Thread" + (purgeEntries cfgIP4FragTimeout ftEntries) + return FragTable { ftDuration = cfgIP4FragTimeout, .. } + + +cleanupFragTable :: FragTable -> IO () +cleanupFragTable FragTable { .. } = killThread ftPurgeThread + + +-- | Handle an incoming fragment. If the fragment is buffered, but doesn't +-- complete the packet, the escape continuation is invoked. +processFragment :: FragTable -> IP4Header -> S.ByteString + -> Hans (IP4Header,S.ByteString) + +processFragment FragTable { .. } hdr body + + -- no fragments + | not (view ip4MoreFragments hdr) && view ip4FragmentOffset hdr == 0 = + return (hdr,body) + + -- fragment + | otherwise = + do mb <- io $ do now <- getCurrentTime + let expire = addUTCTime ftDuration now + frag = mkFragment hdr body + key = mkKey hdr + + HT.alter (updateBuffer expire hdr frag) key ftEntries + case mb of + -- abort packet processing here, as there's nothing left to do + Nothing -> escape + + -- return the reassembled packet + Just (hdr',body') -> return (hdr',body') +{-# INLINE processFragment #-} + + +-- Table Purging --------------------------------------------------------------- + +-- | Every second, purge the fragment table of entries that have expired. +purgeEntries :: NominalDiffTime -> Table -> IO () +purgeEntries lifetime entries = forever $ + do threadDelay halfLife + + now <- getCurrentTime + HT.filterHashTable (\_ Buffer { .. } -> bufExpire < now) entries + + where + halfLife = toUSeconds (lifetime / 2) + + +-- Fragment Operations --------------------------------------------------------- + +-- INVARIANT: When new fragments are inserted into bufFragments, they are merged +-- together when possible. This makes it easier to check the state of the whole +-- buffer. +data Buffer = Buffer { bufExpire :: !UTCTime + , bufSize :: !(Maybe Int) + , bufHeader :: !(Maybe IP4Header) + , bufFragments :: ![Fragment] + } + +data Fragment = Fragment { fragStart :: {-# UNPACK #-} !Int + , fragEnd :: {-# UNPACK #-} !Int + , fragPayload :: [S.ByteString] + } deriving (Show) + +mkKey :: IP4Header -> Key +mkKey IP4Header { .. } = (ip4SourceAddr,ip4DestAddr,ip4Protocol,ip4Ident) + + +mkFragment :: IP4Header -> S.ByteString -> Fragment +mkFragment hdr body = Fragment { .. } + where + fragStart = fromIntegral (view ip4FragmentOffset hdr) + fragEnd = fragStart + S.length body + fragPayload = [body] + + +-- | Create a buffer, given an expiration time, initial fragment, and +-- 'IP4Header' of that initial fragment. The initial header is included for the +-- case where the initial fragment is also the first fragment in the sequence. +mkBuffer :: UTCTime -> IP4Header -> Fragment -> Buffer +mkBuffer bufExpire hdr frag = + addFragment hdr frag + Buffer { bufHeader = Nothing + , bufSize = Nothing + , bufFragments = [] + , .. } + + +-- | For use with HT.alter. When the first element is 'Just', the second will +-- be 'Nothing', indicating that the entry in the table should be updated, and +-- there's no result yet. When the first element is 'Nothing', the second will +-- be 'Just', indicating that the entry should be removed from the table, and +-- that this is the final buffer. +updateBuffer :: UTCTime -> IP4Header -> Fragment -> Maybe Buffer + -> (Maybe Buffer,Maybe (IP4Header,S.ByteString)) + +-- the entry already exists in the table, removing it if it's full +updateBuffer _ hdr frag (Just buf) = + let buf' = addFragment hdr frag buf + in case bufFull buf' of + Just res -> (Nothing, Just res) + Nothing -> (Just buf', Nothing) + +-- create a new entry in the table +updateBuffer expire hdr frag Nothing = + let buf = mkBuffer expire hdr frag + in buf `seq` (Just buf, Nothing) + + +-- | When the buffer is full and all fragments are accounted for, reassemble it +-- into a new packet. +bufFull :: Buffer -> Maybe (IP4Header,S.ByteString) +bufFull Buffer { .. } + + | Just size <- bufSize + , Just hdr <- bufHeader + , [Fragment { .. }] <- bufFragments + , fragEnd == size = + Just (hdr, S.concat fragPayload) + + | otherwise = + Nothing + + +-- | Insert the fragment into the buffer. +addFragment :: IP4Header -> Fragment -> Buffer -> Buffer +addFragment hdr frag buf = + Buffer { bufExpire = bufExpire buf + , bufSize = size' + , bufHeader = case bufHeader buf of + Nothing | view ip4FragmentOffset hdr == 0 -> Just hdr + _ -> bufHeader buf + + , bufFragments = insertFragment (bufFragments buf) + } + + where + + size' | view ip4MoreFragments hdr = bufSize buf + | otherwise = Just $! fragEnd frag + + insertFragment frags@(f:fs) + | fragEnd frag == fragStart f = mergeFragment frag f : fs + | fragStart frag == fragEnd f = mergeFragment f frag : fs + | fragStart frag < fragStart f = frag : frags + | otherwise = f : insertFragment fs + + insertFragment [] = [frag] + + +mergeFragment :: Fragment -> Fragment -> Fragment +mergeFragment a b = + Fragment { fragStart = fragStart a + , fragEnd = fragEnd b + , fragPayload = fragPayload a ++ fragPayload b + } diff --git a/src/Hans/IP4/Icmp4.hs b/src/Hans/IP4/Icmp4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Icmp4.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.IP4.Icmp4 where + +import Hans.Checksum (computeChecksum) +import Hans.Device.Types (ChecksumOffload(..)) +import Hans.IP4.Packet (IP4,getIP4,putIP4) +import Hans.Serialize (runPutPacket) + +import Control.Monad (unless,when,replicateM,liftM2) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int (Int32) +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get + (Get,getWord8,getWord16be,getWord32be,getInt32be,label + ,getByteString,skip,remaining,isEmpty) +import Data.Serialize.Put + (Put,Putter,putWord8,putWord16be,putWord32be,putByteString) +import Data.Word (Word8,Word16,Word32) + + +-- General ICMP Packets -------------------------------------------------------- + +type Lifetime = Word16 + +getLifetime :: Get Lifetime +getLifetime = getWord16be + +putLifetime :: Putter Lifetime +putLifetime = putWord16be + + +data Icmp4Packet + -- RFC 792 - Internet Control Message Protocol + = 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 !S.ByteString + | ParameterProblem !Word8 !S.ByteString + | Timestamp !Identifier !SequenceNumber !Word32 !Word32 !Word32 + | TimestampReply !Identifier !SequenceNumber !Word32 !Word32 !Word32 + | Information !Identifier !SequenceNumber + | InformationReply !Identifier !SequenceNumber + + -- rfc 1393 - Traceroute Using an IP Option + | TraceRoute !TraceRouteCode !Identifier !Word16 !Word16 !Word32 !Word32 + + -- rfc 950 - Internet Standard Subnetting Procedure + | AddressMask !Identifier !SequenceNumber + | AddressMaskReply !Identifier !SequenceNumber !Word32 + deriving (Eq,Show) + +noCode :: String -> Get () +noCode str = do + code <- getWord8 + unless (code == 0) + (fail (str ++ " expects code 0")) + +getIcmp4Packet :: Get Icmp4Packet +getIcmp4Packet = label "ICMP" $ + do ty <- getWord8 + + let firstGet :: Serialize a => String -> (a -> Get b) -> Get b + firstGet labelString f = label labelString $ + do code <- get + skip 2 -- checksum + f code + + case ty of + 0 -> firstGet "Echo Reply" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + dat <- getByteString =<< remaining + return $! EchoReply ident seqNum dat + + 3 -> firstGet "DestinationUnreachable" $ \ code -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! DestinationUnreachable code dat + + 4 -> firstGet "Source Quence" $ \ NoCode -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! SourceQuench dat + + 5 -> firstGet "Redirect" $ \ code -> do + gateway <- getIP4 + dat <- getByteString =<< remaining + return $! Redirect code gateway dat + + 8 -> firstGet "Echo" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + dat <- getByteString =<< remaining + return $! Echo ident seqNum dat + + 9 -> firstGet "Router Advertisement" $ \ NoCode -> do + n <- getWord8 + sz <- getWord8 + unless (sz == 2) + (fail ("Expected size 2, got: " ++ show sz)) + lifetime <- getLifetime + addrs <- replicateM (fromIntegral n) get + return $! RouterAdvertisement lifetime addrs + + 10 -> firstGet "Router Solicitation" $ \ NoCode -> do + skip 4 -- reserved + return RouterSolicitation + + 11 -> firstGet "Time Exceeded" $ \ code -> do + skip 4 -- unused + dat <- getByteString =<< remaining + return $! TimeExceeded code dat + + 12 -> firstGet "Parameter Problem" $ \ NoCode -> do + ptr <- getWord8 + skip 3 -- unused + dat <- getByteString =<< remaining + return $! ParameterProblem ptr dat + + 13 -> firstGet "Timestamp" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + origTime <- getWord32be + recvTime <- getWord32be + tranTime <- getWord32be + return $! Timestamp ident seqNum origTime recvTime tranTime + + 14 -> firstGet "Timestamp Reply" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + origTime <- getWord32be + recvTime <- getWord32be + tranTime <- getWord32be + return $! TimestampReply ident seqNum origTime recvTime tranTime + + 15 -> firstGet "Information" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + return $! Information ident seqNum + + 16 -> firstGet "Information Reply" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + return $! InformationReply ident seqNum + + 17 -> firstGet "Address Mask" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + skip 4 -- address mask + return $! AddressMask ident seqNum + + 18 -> firstGet "Address Mask Reply" $ \ NoCode -> do + ident <- getIdentifier + seqNum <- getSequenceNumber + mask <- getWord32be + return $! AddressMaskReply ident seqNum mask + + 30 -> firstGet "Trace Route" $ \ code -> do + ident <- getIdentifier + skip 2 -- unused + outHop <- getWord16be + retHop <- getWord16be + speed <- getWord32be + mtu <- getWord32be + return $! TraceRoute code ident outHop retHop speed mtu + + _ -> fail ("Unknown type: " ++ show ty) + + +-- NOTE: we may want to parameterize this on the MTU of the device that will +-- send the message, as it could fragment. +renderIcmp4Packet :: ChecksumOffload -> Icmp4Packet -> L.ByteString +renderIcmp4Packet ChecksumOffload { .. } pkt + | coIcmp4 = bytes + | otherwise = L.take 2 bytes `L.append` + runPutPacket 2 100 (L.drop 4 bytes) (putWord16be cs) + + where + + -- best guess mtu + mtu = 1500 - 20 + + bytes = runPutPacket mtu mtu L.empty (putIcmp4Packet pkt) + cs = computeChecksum bytes + + +putIcmp4Packet :: Putter Icmp4Packet +putIcmp4Packet = put' + where + firstPut :: Serialize a => Word8 -> a -> Put + firstPut ty code + = do putWord8 ty + put code + putWord16be 0 + + put' (EchoReply ident seqNum dat) + = do firstPut 0 NoCode + putIdentifier ident + putSequenceNumber seqNum + putByteString dat + + put' (DestinationUnreachable code dat) + = do firstPut 3 code + putWord32be 0 -- unused + putByteString dat + + put' (SourceQuench dat) + = do firstPut 4 NoCode + putWord32be 0 -- unused + putByteString dat + + put' (Redirect code gateway dat) + = do firstPut 5 code + putIP4 gateway + putByteString dat + + put' (Echo ident seqNum dat) + = do firstPut 8 NoCode + putIdentifier ident + putSequenceNumber seqNum + putByteString dat + + put' (RouterAdvertisement lifetime addrs) + = do let len = length addrs + addrSize = 2 + + when (len > 255) + (fail "Too many routers in Router Advertisement") + + firstPut 9 NoCode + putWord8 (fromIntegral len) + putWord8 addrSize + putLifetime lifetime + mapM_ put addrs + + put' RouterSolicitation + = do firstPut 10 NoCode + putWord32be 0 -- RESERVED + + put' (TimeExceeded code dat) + = do firstPut 11 code + putWord32be 0 -- unused + putByteString dat + + put' (ParameterProblem ptr dat) + = do firstPut 12 NoCode + put ptr + putWord8 0 -- unused + putWord16be 0 -- unused + putByteString dat + + put' (Timestamp ident seqNum origTime recvTime tranTime) + = do firstPut 13 NoCode + putIdentifier ident + putSequenceNumber seqNum + putWord32be origTime + putWord32be recvTime + putWord32be tranTime + + put' (TimestampReply ident seqNum origTime recvTime tranTime) + = do firstPut 14 NoCode + putIdentifier ident + putSequenceNumber seqNum + putWord32be origTime + putWord32be recvTime + putWord32be tranTime + + put' (Information ident seqNum) + = do firstPut 15 NoCode + putIdentifier ident + putSequenceNumber seqNum + + put' (InformationReply ident seqNum) + = do firstPut 16 NoCode + putIdentifier ident + putSequenceNumber seqNum + + put' (AddressMask ident seqNum) + = do firstPut 17 NoCode + putIdentifier ident + putSequenceNumber seqNum + putWord32be 0 -- address mask + + put' (AddressMaskReply ident seqNum mask) + = do firstPut 18 NoCode + putIdentifier ident + putSequenceNumber seqNum + putWord32be mask + + put' (TraceRoute code ident outHop retHop speed mtu) + = do firstPut 30 code + putIdentifier ident + putWord16be 0 -- unused + putWord16be outHop + putWord16be retHop + putWord32be speed + putWord32be mtu + +data NoCode = NoCode + +instance Serialize NoCode where + get = do b <- getWord8 + unless (b == 0) + (fail ("Expected code 0, got code: " ++ show b)) + return NoCode + put NoCode = putWord8 0 + +data DestinationUnreachableCode + = NetUnreachable + | HostUnreachable + | ProtocolUnreachable + | PortUnreachable + | FragmentationUnreachable + | SourceRouteFailed + | 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 + 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 DestinationNetworkUnknown = putWord8 6 + put DestinationHostUnknown = putWord8 7 + put SourceHostIsolatedError = putWord8 8 + put AdministrativelyProhibited = putWord8 9 + put HostAdministrativelyProhibited = putWord8 10 + put NetworkUnreachableForTOS = putWord8 11 + put HostUnreachableForTOS = putWord8 12 + put CommunicationAdministrativelyProhibited = putWord8 13 + put HostPrecedenceViolation = putWord8 14 + put PrecedenceCutoffInEffect = putWord8 15 + +data TimeExceededCode + = TimeToLiveExceededInTransit + | FragmentReassemblyTimeExceeded + deriving (Eq,Show) + +instance Serialize TimeExceededCode where + get = do b <- getWord8 + case b of + 0 -> return TimeToLiveExceededInTransit + 1 -> return FragmentReassemblyTimeExceeded + _ -> fail "Invalid code for Time Exceeded" + + put TimeToLiveExceededInTransit = putWord8 0 + put FragmentReassemblyTimeExceeded = putWord8 1 + +data RedirectCode + = RedirectForNetwork + | RedirectForHost + | RedirectForTypeOfServiceAndNetwork + | RedirectForTypeOfServiceAndHost + deriving (Eq,Show) + +instance Serialize RedirectCode where + get = do b <- getWord8 + case b of + 0 -> return RedirectForNetwork + 1 -> return RedirectForHost + 2 -> return RedirectForTypeOfServiceAndNetwork + 3 -> return RedirectForTypeOfServiceAndHost + _ -> fail "Invalid code for Time Exceeded" + + put RedirectForNetwork = putWord8 0 + put RedirectForHost = putWord8 1 + put RedirectForTypeOfServiceAndNetwork = putWord8 2 + put RedirectForTypeOfServiceAndHost = putWord8 3 + +data TraceRouteCode + = TraceRouteForwarded + | TraceRouteDiscarded + deriving (Eq,Show) + +instance Serialize TraceRouteCode where + get = do b <- getWord8 + case b of + 0 -> return TraceRouteForwarded + 1 -> return TraceRouteDiscarded + _ -> fail "Invalid code for Trace Route" + + put TraceRouteForwarded = putWord8 0 + put TraceRouteDiscarded = putWord8 1 + +-- Router Discovery Data ------------------------------------------------------- + +type PreferenceLevel = Int32 + +data RouterAddress = RouterAddress { raAddr :: IP4 + , raPreferenceLevel :: PreferenceLevel + } deriving (Eq,Show) + +instance Serialize RouterAddress where + get = + do raAddr <- getIP4 + raPreferenceLevel <- getInt32be + return RouterAddress { .. } + + put RouterAddress { .. } = + do putIP4 raAddr + putWord32be (fromIntegral raPreferenceLevel) + +type Identifier = Word16 + +getIdentifier :: Get Identifier +getIdentifier = getWord16be +{-# INLINE getIdentifier #-} + +putIdentifier :: Putter Identifier +putIdentifier = putWord16be +{-# INLINE putIdentifier #-} + +type SequenceNumber = Word16 + +getSequenceNumber :: Get SequenceNumber +getSequenceNumber = getWord16be +{-# INLINE getSequenceNumber #-} + +putSequenceNumber :: Putter SequenceNumber +putSequenceNumber = putWord16be +{-# INLINE putSequenceNumber #-} + +getUntilDone :: Serialize a => Get [a] +getUntilDone = + do empty <- isEmpty + if empty then return [] + else liftM2 (:) get getUntilDone + diff --git a/src/Hans/IP4/Input.hs b/src/Hans/IP4/Input.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Input.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.IP4.Input ( + processArp, + processIP4, + handleIP4, + ) where + +import Hans.Checksum (computeChecksum) +import Hans.Device (Device(..),ChecksumOffload(..),rxOffload) +import Hans.Ethernet (Mac,pattern ETYPE_ARP,sendEthernet) +import Hans.IP4.ArpTable (addEntry,lookupEntry) +import Hans.IP4.Fragments (processFragment) +import Hans.IP4.Icmp4 (Icmp4Packet(..),getIcmp4Packet) +import Hans.IP4.Output (queueIcmp4,portUnreachable) +import Hans.IP4.Packet +import Hans.IP4.RoutingTable (Route(..)) +import Hans.Lens (view) +import Hans.Monad (Hans,io,dropPacket,escape,decode,decode') +import Hans.Network.Types +import Hans.Serialize (runPutPacket) +import Hans.Types +import Hans.Udp.Input (processUdp) +import Hans.Tcp.Input (processTcp) + +import Control.Monad (when,unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + + +-- Arp Processing -------------------------------------------------------------- + +-- | Handle incoming Arp packets. +processArp :: NetworkStack -> Device -> S.ByteString -> Hans () +processArp ns dev payload = + do ArpPacket { .. } <- decode (devStats dev) getArpPacket payload + + -- if the entry already exists in the arp table, update it + merge <- io (updateEntry ns arpSHA arpSPA) + + -- are we the target of the request? + mb <- io (isLocalAddr ns arpTPA) + dev' <- case mb of + Just route -> return (routeDevice route) + Nothing -> escape + let lha = devMac dev' + + -- add the entry if it didn't already exist + unless merge (io (addEntry (ip4ArpTable (view ip4State ns)) arpSPA arpSHA)) + + -- respond if the packet was a who-has request for our mac + when (arpOper == ArpRequest) + $ io + $ sendEthernet dev' arpSHA ETYPE_ARP + $ runPutPacket 28 100 L.empty + $ putArpPacket ArpPacket { arpSHA = lha, arpSPA = arpTPA + , arpTHA = arpSHA, arpTPA = arpSPA + , arpOper = ArpReply } + + +-- | Update an entry in the arp table, if it exists already. +updateEntry :: NetworkStack -> Mac -> IP4 -> IO Bool +updateEntry ns sha spa = + do mb <- lookupEntry (ip4ArpTable (view ip4State ns)) spa + case mb of + + Just _ -> do addEntry (ip4ArpTable (view ip4State ns)) spa sha + return True + + Nothing -> return False + + +-- IP4 Processing -------------------------------------------------------------- + +-- | Process a packet that has arrived from a device. +processIP4 :: NetworkStack -> Device -> S.ByteString -> Hans () +processIP4 ns dev payload = + do ((hdr,hdrLen,bodyLen),body) <- decode' (devStats dev) getIP4Packet payload + + -- only validate the checkum if the device hasn't done that already + let packetValid = coIP4 (view rxOffload dev) + || 0 == computeChecksum (S.take hdrLen payload) + unless packetValid (dropPacket (devStats dev)) + + -- Drop packets that weren't destined for an address that this device + -- holds. + -- XXX: if we ever want to use HaNS as a router, this would be where IP + -- routing would happen + checkDestination ns dev (ip4DestAddr hdr) + + handleIP4 ns dev (Just (hdrLen,payload)) hdr (S.take bodyLen body) + + +-- | The processing stage after the packet has been decoded and validated. It's +-- exposed here so that routing to an address that's managed by the network +-- stack can skip the device layer. +handleIP4 :: NetworkStack -> Device -> Maybe (Int,S.ByteString) + -> IP4Header -> S.ByteString -> Hans () +handleIP4 ns dev mbOrig hdr body = + do (IP4Header { .. },body') <- + processFragment (ip4Fragments (view ip4State ns)) hdr body + + case ip4Protocol of + PROT_ICMP4 -> processICMP ns dev ip4SourceAddr ip4DestAddr body' + + PROT_UDP -> + do routed <- processUdp ns dev ip4SourceAddr ip4DestAddr body' + case (routed,mbOrig) of + -- when we failed to route the datagram, and have the original + -- message handy, send a portUnreachable message. + (False,Just(ihl,orig)) -> io + $ portUnreachable ns dev (SourceIP4 ip4DestAddr) ip4SourceAddr + $ S.take (ihl + 8) orig + + -- otherwise, the packet was routed from an internal device, or a + -- destination actually existed. + _ -> return () + + PROT_TCP -> processTcp ns dev ip4SourceAddr ip4DestAddr body' + _ -> dropPacket (devStats dev) + + +-- | Validate the destination of this packet. +checkDestination :: NetworkStack -> Device -> IP4 -> Hans () + +-- always accept broadcast messages +checkDestination _ _ BroadcastIP4 = return () + +-- require that the input device has the destination address +checkDestination ns dev dest = + do mb <- io (isLocalAddr ns dest) + case mb of + Just Route { .. } + | routeDevice == dev -> return () + + -- A route was found, and it didn't involve the device the packet + -- arrived on + | otherwise -> escape + + -- No route was found. Check to see if there are any routes for this + -- device, and forward the packet on if there are none (in order to + -- support things like unicast DHCP). + Nothing -> + do routes <- io (routesForDev ns dev) + unless (null routes) escape + + + + +-- ICMP Processing ------------------------------------------------------------- + +-- | Process incoming ICMP packets. +processICMP :: NetworkStack -> Device -> IP4 -> IP4 -> S.ByteString -> Hans () + +processICMP ns dev src dst body = + do let packetValid = coIcmp4 (view rxOffload dev) || 0 == computeChecksum body + + unless packetValid (dropPacket (devStats dev)) + + msg <- decode (devStats dev) getIcmp4Packet body + + case msg of + + -- XXX: use the stats and config for the device that the message arrived + -- on. As it's probably going out the same device, this seems OK, but it + -- would be nice to confirm that. + Echo ident seqNum bytes -> + do io (queueIcmp4 ns dev (SourceIP4 dst) src (EchoReply ident seqNum bytes)) + escape + + + -- Drop all other messages for now + _ -> escape diff --git a/src/Hans/IP4/Output.hs b/src/Hans/IP4/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Output.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.IP4.Output ( + sendIP4, queueIP4, + prepareIP4, + primSendIP4, + responder, + + -- * ICMP4 Messages + queueIcmp4, + portUnreachable, + ) where + +import Hans.Checksum (computeChecksum) +import Hans.Config (config,Config(..)) +import Hans.Device + (Device(..),DeviceConfig(..),DeviceStats(..),updateError,statTX + ,ChecksumOffload(..),txOffload,deviceConfig) +import Hans.Ethernet + ( Mac,sendEthernet,pattern ETYPE_IPV4, pattern ETYPE_ARP + , pattern BroadcastMac) +import Hans.IP4.ArpTable + (lookupEntry,resolveAddr,QueryResult(..),markUnreachable + ,writeChanStrategy) +import Hans.IP4.Icmp4 + (Icmp4Packet(..),DestinationUnreachableCode(..),renderIcmp4Packet) +import Hans.IP4.Packet +import Hans.IP4.RoutingTable (Route(..),routeSource,routeNextHop) +import Hans.Lens +import Hans.Network.Types +import Hans.Serialize (runPutPacket) +import Hans.Threads (forkNamed) +import Hans.Types + +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.BoundedChan as BC +import Control.Monad (when,forever,unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Serialize.Put (putWord16be) + + + +responder :: NetworkStack -> IO () +responder ns = forever $ + do req <- BC.readChan (ip4ResponderQueue (view ip4State ns)) + case req of + + Send mbSrc dst df prot payload -> + do _ <- sendIP4 ns mbSrc dst df prot payload + return () + + Finish dev mac frames -> + sendIP4Frames dev mac frames + + +-- | Queue a message on the responder queue instead of attempting to send it +-- directly. +queueIP4 :: NetworkStack -> DeviceStats + -> SendSource -> IP4 -> Bool -> NetworkProtocol -> L.ByteString + -> IO () +queueIP4 ns stats mbSrc dst df prot payload = + do written <- BC.tryWriteChan (ip4ResponderQueue (view ip4State ns)) + (Send mbSrc dst df prot payload) + unless written (updateError statTX stats) + + +-- | Send an IP4 packet to the given destination. If it's not possible to find a +-- route to the destination, return False. +sendIP4 :: NetworkStack -> SendSource -> IP4 + -> Bool -> NetworkProtocol -> L.ByteString + -> IO Bool + +-- A special case for when the sender knows that this is the right device and +-- source address. The routing table is still queried to find the next hop, and +-- if the route found doesn't use the device provided, the packets aren't sent. +sendIP4 ns (SourceDev dev src) dst df prot payload = + do mbRoute <- lookupRoute4 ns dst + case mbRoute of + Just (_,next,dev') | devName dev == devName dev' -> + do primSendIP4 ns dev src dst next df prot payload + return True + + _ -> + do updateError statTX (devStats dev) + return False + +-- sending from a specific device +sendIP4 ns (SourceIP4 src) dst df prot payload = + do mbRoute <- isLocalAddr ns src + case mbRoute of + Just route -> + do primSendIP4 ns (routeDevice route) (routeSource route) + dst (routeNextHop dst route) df prot payload + return True + + Nothing -> + return False + +-- find the right path out +sendIP4 ns SourceAny dst df prot payload = + do mbRoute <- lookupRoute4 ns dst + case mbRoute of + Just (src,next,dev) -> do primSendIP4 ns dev src dst next df prot payload + return True + Nothing -> return False + + +prepareHeader :: NetworkStack -> IP4 -> IP4 -> Bool -> NetworkProtocol -> IO IP4Header +prepareHeader ns src dst df prot = + do ident <- nextIdent ns + return $! set ip4DontFragment df + emptyIP4Header { ip4Ident = ident + , ip4SourceAddr = src + , ip4DestAddr = dst + , ip4Protocol = prot + , ip4TimeToLive = cfgIP4InitialTTL (view config ns) + } + + +-- | Prepare IP4 fragments to be sent. +prepareIP4 :: NetworkStack -> Device -> IP4 -> IP4 -> Bool -> NetworkProtocol + -> L.ByteString + -> IO [L.ByteString] +prepareIP4 ns dev src dst df prot payload = + do hdr <- prepareHeader ns src dst df prot + + let DeviceConfig { .. } = devConfig dev + + return $ [ renderIP4Packet (view txOffload dev) h p + | (h,p) <- splitPacket (fromIntegral dcMtu) hdr payload ] + + +-- | Send an IP4 packet to the given destination. This assumes that routing has +-- already taken place, and that the source and destination addresses are +-- correct. +primSendIP4 :: NetworkStack -> Device -> IP4 -> IP4 -> IP4 -> Bool -> NetworkProtocol + -> L.ByteString -> IO () +primSendIP4 ns dev src dst next df prot payload + -- when the source and next hop are the same, re-queue in the network stack + -- after fragment reassembly + | src == next = + do hdr <- prepareHeader ns src dst df prot + _ <- BC.tryWriteChan (nsInput ns) $! FromIP4 dev hdr (L.toStrict payload) + -- don't write any stats for packets that skip the device layer + return () + + -- the packet is leaving the network stack so encode it and send + | otherwise = + do packets <- prepareIP4 ns dev src dst df prot payload + arpOutgoing ns dev src next packets + + +-- | Retrieve the outgoing address for this IP4 packet, and send along all +-- fragments. +arpOutgoing :: NetworkStack -> Device -> IP4 -> IP4 -> [L.ByteString] -> IO () +arpOutgoing _ dev _ BroadcastIP4 packets = + sendIP4Frames dev BroadcastMac packets + +arpOutgoing ns dev src next packets = + do res <- resolveAddr (ip4ArpTable (view ip4State ns)) next queueSend + case res of + Known dstMac -> + sendIP4Frames dev dstMac packets + + -- The mac wasn't present in the table. If this was the first request for + -- this address, start a request thread. + Unknown newRequest () -> + when newRequest $ do _ <- forkNamed "arpRequestThread" + (arpRequestThread ns dev src next) + return () + + where + + queueSend = + writeChanStrategy (Just (devStats dev)) mkFinish + (ip4ResponderQueue (view ip4State ns)) + + mkFinish mbMac = + do dstMac <- mbMac + return $! Finish dev dstMac packets + + +sendIP4Frames :: Device -> Mac -> [L.ByteString] -> IO () +sendIP4Frames dev dstMac packets = + mapM_ (sendEthernet dev dstMac ETYPE_IPV4) packets + + +-- | Make an Arp request for the given IP address, until the maximum retries +-- have been exhausted, or the entry made it into the table. +arpRequestThread :: NetworkStack -> Device -> IP4 -> IP4 -> IO () +arpRequestThread ns dev src dst = loop 0 + where + IP4State { ..} = view ip4State ns + + request = renderArpPacket ArpPacket { arpOper = ArpRequest + , arpSHA = devMac dev + , arpSPA = src + , arpTHA = BroadcastMac + , arpTPA = dst + } + + loop n = + do sendEthernet dev BroadcastMac ETYPE_ARP request + threadDelay ip4ArpRetryDelay + + mb <- lookupEntry ip4ArpTable dst + case mb of + Just{} -> return () + Nothing | n < ip4ArpRetry -> loop (n + 1) + | otherwise -> markUnreachable ip4ArpTable dst + + +-- | The final step to render an IP header and its payload out as a lazy +-- 'ByteString'. Compute the checksum over the packet with its checksum zeroed, +-- then reconstruct a new lazy 'ByteString' that contains chunks from the old +-- header, and the new checksum. +renderIP4Packet :: ChecksumOffload -> IP4Header -> L.ByteString -> L.ByteString +renderIP4Packet ChecksumOffload { .. } hdr pkt + | coIP4 = bytes `L.append` pkt + | otherwise = withChecksum + where + + pktlen = L.length pkt + + bytes = runPutPacket 20 40 pkt (putIP4Header hdr (fromIntegral pktlen)) + cs = computeChecksum (L.take (L.length bytes - pktlen) bytes) + + beforeCS = L.take 10 bytes + afterCS = L.drop 12 bytes + csBytes = runPutPacket 2 100 afterCS (putWord16be cs) + + withChecksum = beforeCS `L.append` csBytes + + +-- ICMP Messages --------------------------------------------------------------- + +queueIcmp4 :: NetworkStack -> Device -> SendSource -> IP4 -> Icmp4Packet + -> IO () +queueIcmp4 ns dev src dst pkt = + let msg = renderIcmp4Packet (view txOffload dev) pkt + df = fromIntegral (L.length msg) < dcMtu (view deviceConfig dev) - 20 + in queueIP4 ns (devStats dev) src dst df PROT_ICMP4 msg + +-- | Emit a destination unreachable ICMP message. This will always be queued via +-- the responder queue, as it is most likely coming from the fast path. The +-- bytestring argument is assumed to be the original IP4 datagram, trimmed to +-- IP4 header + 8 bytes of data. +portUnreachable :: NetworkStack -> Device -> SendSource -> IP4 -> S.ByteString + -> IO () +portUnreachable ns dev src dst chunk = + queueIcmp4 ns dev src dst (DestinationUnreachable PortUnreachable chunk) diff --git a/src/Hans/IP4/Packet.hs b/src/Hans/IP4/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/Packet.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Hans.IP4.Packet where + +import Hans.Checksum + (Checksum(..),PartialChecksum,Pair8(..),emptyPartialChecksum) +import Hans.Ethernet (Mac,getMac,putMac,pattern ETYPE_IPV4) +import Hans.Lens as L +import Hans.Network.Types (NetworkProtocol) +import Hans.Serialize (runPutPacket) + +import Control.Monad (unless,guard) +import Data.Bits as B + ((.|.),(.&.),testBit,shiftL,shiftR,bit,setBit,bit + ,complement) +import qualified Data.ByteString.Short as Sh +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import Data.Int (Int64) +import Data.Serialize + (Get,getWord8,getWord16be,getWord32be,getShortByteString + ,label,isolate,Serialize(..) + ,Putter,Put,putWord8,putWord16be,putWord32be + ,putLazyByteString,putShortByteString) +import Data.Typeable (Typeable) +import Data.Word (Word8,Word16,Word32) +import GHC.Generics (Generic) +import Numeric (readDec) + + +-- IP4 Addresses --------------------------------------------------------------- + +newtype IP4 = IP4 Word32 + deriving (Eq,Ord,Show,Read,Hashable,Checksum,Typeable,Generic) + +instance Serialize IP4 where + get = getIP4 + put = putIP4 + {-# INLINE get #-} + {-# INLINE put #-} + +getIP4 :: Get IP4 +getIP4 = + do w <- getWord32be + return (IP4 w) + +putIP4 :: Putter IP4 +putIP4 (IP4 w) = putWord32be w + +packIP4 :: Word8 -> Word8 -> Word8 -> Word8 -> IP4 +packIP4 a b c d = IP4 $! set (byte 3) a + $! set (byte 2) b + $! set (byte 1) c + $! set (byte 0) d 0 +{-# INLINE packIP4 #-} + + +unpackIP4 :: IP4 -> (Word8,Word8,Word8,Word8) +unpackIP4 (IP4 w) = ( view (byte 3) w + , view (byte 2) w + , view (byte 1) w + , view (byte 0) w + ) +{-# INLINE unpackIP4 #-} + +showIP4 :: IP4 -> ShowS +showIP4 ip4 = + let (a,b,c,d) = unpackIP4 ip4 + in shows a . showChar '.' . + shows b . showChar '.' . + shows c . showChar '.' . + shows d +{-# INLINE showIP4 #-} + +readIP4 :: ReadS IP4 +readIP4 str = + do (a,'.':rest1) <- readDec str + (b,'.':rest2) <- readDec rest1 + (c,'.':rest3) <- readDec rest2 + (d,rest4) <- readDec rest3 + return (packIP4 a b c d, rest4) +{-# INLINE readIP4 #-} + + +pattern BroadcastIP4 = IP4 0xffffffff + +pattern CurrentNetworkIP4 = IP4 0x0 + +pattern WildcardIP4 = IP4 0x0 + + +-- IP4 Masks ------------------------------------------------------------------- + +data IP4Mask = IP4Mask {-# UNPACK #-} !IP4 + {-# UNPACK #-} !Int -- ^ Between 0 and 32 + deriving (Show,Read) + +instance Eq IP4Mask where + m1 == m2 = maskBits m1 == maskBits m2 + && clearHostBits m1 == clearHostBits m2 + +hostmask :: Int -> Word32 +hostmask bits = B.bit (32 - bits) - 1 + +netmask :: Int -> Word32 +netmask bits = complement (hostmask bits) + +maskRange :: IP4Mask -> (IP4,IP4) +maskRange mask = (clearHostBits mask, setHostBits mask) + +maskBits :: IP4Mask -> Int +maskBits (IP4Mask _ bits) = bits + +maskAddr :: IP4Mask -> IP4 +maskAddr (IP4Mask addr _) = addr + +clearHostBits :: IP4Mask -> IP4 +clearHostBits (IP4Mask (IP4 addr) bits)= IP4 (addr .&. netmask bits) + +setHostBits :: IP4Mask -> IP4 +setHostBits (IP4Mask (IP4 addr) bits) = IP4 (addr .|. hostmask bits) + +broadcastAddress :: IP4Mask -> IP4 +broadcastAddress = setHostBits + +readIP4Mask :: ReadS IP4Mask +readIP4Mask str = + do (addr,'/':rest1) <- readIP4 str + (bits,rest2) <- readDec rest1 + return (IP4Mask addr bits, rest2) + +showIP4Mask :: IP4Mask -> ShowS +showIP4Mask (IP4Mask addr bits) = showIP4 addr . showChar '/' . shows bits + + +-- IP4 Pseudo Header ----------------------------------------------------------- + +-- 0 7 8 15 16 23 24 31 +-- +--------+--------+--------+--------+ +-- | source address | +-- +--------+--------+--------+--------+ +-- | destination address | +-- +--------+--------+--------+--------+ +-- | zero |protocol| length | +-- +--------+--------+--------+--------+ +ip4PseudoHeader :: IP4 -> IP4 -> NetworkProtocol -> Int -> PartialChecksum +ip4PseudoHeader src dst prot len = + extendChecksum (fromIntegral len :: Word16) $ + extendChecksum (Pair8 0 prot) $ + extendChecksum dst $ + extendChecksum src emptyPartialChecksum + + +-- IP4 Packets ----------------------------------------------------------------- + +type IP4Ident = Word16 + + +data IP4Header = IP4Header + { ip4TypeOfService :: {-# UNPACK #-} !Word8 + , ip4Ident :: {-# UNPACK #-} !IP4Ident + , ip4Fragment_ :: {-# UNPACK #-} !Word16 + -- ^ This includes the flags, and the fragment offset. + , ip4TimeToLive :: {-# UNPACK #-} !Word8 + , ip4Protocol :: {-# UNPACK #-} !NetworkProtocol + , ip4Checksum :: {-# UNPACK #-} !Word16 + , ip4SourceAddr :: {-# UNPACK #-} !IP4 + , ip4DestAddr :: {-# UNPACK #-} !IP4 + , ip4Options :: ![IP4Option] + } deriving (Eq,Show) + +emptyIP4Header :: IP4Header +emptyIP4Header = IP4Header + { ip4TypeOfService = 0 + , ip4Ident = 0 + , ip4Fragment_ = 0 + , ip4TimeToLive = 127 + , ip4Protocol = 0 + , ip4Checksum = 0 + , ip4SourceAddr = IP4 0 + , ip4DestAddr = IP4 0 + , ip4Options = [] + } + +ip4DCSP :: Lens' IP4Header Word8 +ip4DCSP f IP4Header { .. } = + fmap (\ w -> IP4Header { ip4TypeOfService = ip4TypeOfService .|. (w `shiftL` 2), .. }) + (f (ip4TypeOfService `shiftR` 2)) +{-# INLINE ip4DCSP #-} + +ip4ECN :: Lens' IP4Header Word8 +ip4ECN f IP4Header { .. } = + fmap (\ w -> IP4Header { ip4TypeOfService = ip4TypeOfService .|. (w .&. 0x3), .. }) + (f (ip4TypeOfService .&. 0x3)) +{-# INLINE ip4ECN #-} + +ip4Fragment :: Lens' IP4Header Word16 +ip4Fragment f IP4Header { .. } = + fmap (\flags' -> IP4Header { ip4Fragment_ = flags', .. }) (f ip4Fragment_) +{-# INLINE ip4Fragment #-} + +ip4DontFragment :: Lens' IP4Header Bool +ip4DontFragment = ip4Fragment . L.bit 14 +{-# INLINE ip4DontFragment #-} + +ip4MoreFragments :: Lens' IP4Header Bool +ip4MoreFragments = ip4Fragment . L.bit 13 +{-# INLINE ip4MoreFragments #-} + +-- | The fragment offset, in bytes. +ip4FragmentOffset :: Lens' IP4Header Word16 +ip4FragmentOffset = ip4Fragment . lens f g + where + f frag = (frag .&. 0x1fff) `shiftL` 3 + g frag len = (frag .&. complement 0x1fff) + .|. ((len `shiftR` 3) .&. 0x1fff) +{-# INLINE ip4FragmentOffset #-} + + +noMoreFragments :: IP4Header -> IP4Header +noMoreFragments = set ip4MoreFragments False + +moreFragments :: IP4Header -> IP4Header +moreFragments = set ip4MoreFragments True + +addOffset :: Word16 -> IP4Header -> IP4Header +addOffset off = over ip4FragmentOffset (+ off) + +setIdent :: IP4Ident -> IP4Header -> IP4Header +setIdent i hdr = hdr { ip4Ident = i } + + +-- | Calculate the size of an IP4 packet +ip4PacketSize :: IP4Header -> L.ByteString -> Int +ip4PacketSize hdr bs = + ip4HeaderSize hdr + fromIntegral (L.length bs) + +-- | Calculate the size of an IP4 header +ip4HeaderSize :: IP4Header -> Int +ip4HeaderSize hdr = 20 + sum (map ip4OptionSize (ip4Options hdr)) + + +-- | Fragment a single IP packet into one or more, given an MTU to fit into. +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 :: Int64 -> IP4Header -> L.ByteString + -> [(IP4Header,L.ByteString)] +fragmentPacket mtu0 hdr0 = loop hdr0 + where + mtu = mtu0 - fromIntegral (ip4HeaderSize hdr0) + + 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) + + +-- | Compute the value of the version/header length byte. +ip4VersionIHL :: Int -> Word8 +ip4VersionIHL ihl = 4 `shiftL` 4 .|. fromIntegral (ihl `shiftR` 2) + + +-- 0 1 2 3 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- |Version| IHL |Type of Service| Total Length | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Identification |Flags| Fragment Offset | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Time to Live | Protocol | Header Checksum | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Source Address | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Destination Address | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +getIP4Packet :: Get (IP4Header, Int, Int) +getIP4Packet = label "IP4 Header" $ do + do b0 <- getWord8 + let ver = b0 `shiftR` 4 + unless (ver == 4) (fail "Invalid version") + + let ihl = fromIntegral ((b0 .&. 0xf) * 4) + isolate (ihl - 1) $ + do ip4TypeOfService <- getWord8 + payloadLen <- getWord16be + ip4Ident <- getWord16be + ip4Fragment_ <- getWord16be + ip4TimeToLive <- getWord8 + ip4Protocol <- getWord8 + ip4Checksum <- getWord16be + ip4SourceAddr <- getIP4 + ip4DestAddr <- getIP4 + let optlen = ihl - 20 + ip4Options <- + label "IP4 Options" $ isolate optlen + $ getIP4Options optlen + + let hdr = IP4Header { .. } + hdr `seq` return (hdr, ihl, fromIntegral payloadLen - ihl) + +putIP4Header :: IP4Header -> Int -> Put +putIP4Header IP4Header { .. } pktlen = do + let (optbs,optlen) = renderIP4Options ip4Options + let ihl = 20 + optlen + putWord8 (ip4VersionIHL ihl) + putWord8 ip4TypeOfService + + putWord16be (fromIntegral (pktlen + ihl)) + putWord16be ip4Ident + putWord16be ip4Fragment_ + + putWord8 ip4TimeToLive + putWord8 ip4Protocol + putWord16be 0 -- checksum + + putIP4 ip4SourceAddr + putIP4 ip4DestAddr + + putLazyByteString optbs + + +-- IP4 Options ----------------------------------------------------------------- + +renderIP4Options :: [IP4Option] -> (L.ByteString,Int) +renderIP4Options [] = (L.empty,0) +renderIP4Options opts = + case optlen `mod` 4 of + 0 -> (optbs,optlen) + + -- pad with no-ops + n -> (optbs `L.append` L.replicate (fromIntegral n) 0x1, optlen + n) + where + optbs = runPutPacket 40 100 L.empty (mapM_ putIP4Option opts) + optlen = fromIntegral (L.length optbs) + + +getIP4Options :: Int -> Get [IP4Option] +getIP4Options len + | len <= 0 = return [] + | otherwise = do o <- getIP4Option + rest <- getIP4Options (len - ip4OptionSize o) + return $! (o : rest) + + +data IP4Option = IP4Option + { ip4OptionCopied :: !Bool + , ip4OptionClass :: {-# UNPACK #-} !Word8 + , ip4OptionNum :: {-# UNPACK #-} !Word8 + , ip4OptionData :: {-# UNPACK #-} !Sh.ShortByteString + } deriving (Eq,Show) + + +ip4OptionSize :: IP4Option -> Int +ip4OptionSize opt = case ip4OptionNum opt of + 0 -> 1 + 1 -> 1 + _ -> 2 + fromIntegral (Sh.length (ip4OptionData opt)) + + +getIP4Option :: Get IP4Option +getIP4Option = + do b <- getWord8 + let ip4OptionCopied = testBit b 7 + let ip4OptionClass = (b `shiftR` 5) .&. 0x3 + let ip4OptionNum = b .&. 0x1f + + ip4OptionData <- + if ip4OptionNum < 2 + then return Sh.empty + else do len <- getWord8 + unless (len >= 2) (fail "Option length parameter is to small") + getShortByteString (fromIntegral (len - 2)) + + return $! IP4Option { .. } + + +ip4OptionType :: Bool -> Word8 -> Word8 -> Word8 +ip4OptionType copied cls num = + copiedFlag ((cls .&. 0x3 `shiftL` 5) .|. (num .&. 0x1f)) + where + copiedFlag | copied = (`setBit` 7) + | otherwise = id + +putIP4Option :: Putter IP4Option +putIP4Option IP4Option { .. } = + do let copied | ip4OptionCopied = B.bit 7 + | otherwise = 0 + + putWord8 $ copied .|. ((ip4OptionClass .&. 0x3) `shiftL` 5) + .|. ip4OptionNum .&. 0x1f + + case ip4OptionNum of + 0 -> return () + 1 -> return () + _ -> do putWord8 (fromIntegral (Sh.length ip4OptionData + 2)) + putShortByteString ip4OptionData + + +-- Arp Packets ----------------------------------------------------------------- + +-- | Arp packets, specialized to IP4 and Mac addresses. +data ArpPacket = ArpPacket { arpOper :: {-# UNPACK #-} !ArpOper + , arpSHA :: !Mac + , arpSPA :: !IP4 + , arpTHA :: !Mac + , arpTPA :: !IP4 + } deriving (Eq,Show) + +-- | Parse an Arp packet, given a way to parse hardware and protocol addresses. +getArpPacket :: Get ArpPacket +getArpPacket = label "ArpPacket" $ + do hwtype <- getWord16be + ptype <- getWord16be + hwlen <- getWord8 + plen <- getWord8 + + -- make sure that this packet is specialized to IP4/Ethernet + guard $ hwtype == 0x1 && hwlen == 6 + && ptype == ETYPE_IPV4 && plen == 4 + + arpOper <- getArpOper + + arpSHA <- getMac + arpSPA <- getIP4 + + arpTHA <- getMac + arpTPA <- getIP4 + + return ArpPacket { .. } + + +renderArpPacket :: ArpPacket -> L.ByteString +renderArpPacket pkt = runPutPacket 28 100 L.empty (putArpPacket pkt) + +-- | Render an Arp packet, given a way to render hardware and protocol +-- addresses. +putArpPacket :: Putter ArpPacket +putArpPacket ArpPacket { .. } = + do putWord16be 0x1 + putWord16be ETYPE_IPV4 + putWord8 6 + putWord8 4 + + putArpOper arpOper + + putMac arpSHA + putIP4 arpSPA + + putMac arpTHA + putIP4 arpTPA + + +-- Arp Opcodes ----------------------------------------------------------------- + +type ArpOper = Word16 + +pattern ArpRequest = 0x1 +pattern ArpReply = 0x2 + +-- | Parse an Arp operation. +getArpOper :: Get ArpOper +getArpOper = + do w <- getWord16be + guard (w == ArpRequest || w == ArpReply) + return w +{-# INLINE getArpOper #-} + +-- | Render an Arp operation. +putArpOper :: Putter ArpOper +putArpOper = putWord16be +{-# INLINE putArpOper #-} diff --git a/src/Hans/IP4/RoutingTable.hs b/src/Hans/IP4/RoutingTable.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/RoutingTable.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.IP4.RoutingTable ( + Route(..), RouteType(..), + routeSource, routeNextHop, + RoutingTable, + empty, + addRule, + deleteRule, + lookupRoute, + isLocal, + getRoutes, + routesForDev, + ) where + +import Hans.Device.Types (Device) +import Hans.IP4.Packet + +import Control.Monad (guard) +import Data.Bits ((.&.)) +import Data.List (insertBy) +import Data.Maybe (mapMaybe) +import Data.Word (Word32) + + +data RouteType = Direct + | Indirect !IP4 + | Loopback + +data Route = Route { routeNetwork :: {-# UNPACK #-} !IP4Mask + , routeType :: !RouteType + , routeDevice :: !Device + } + +routeSource :: Route -> IP4 +routeSource Route { routeNetwork = IP4Mask addr _ } = addr + +routeNextHop :: IP4 -> Route -> IP4 +routeNextHop dest route = + case routeType route of + Direct -> dest + Indirect nextHop -> nextHop + Loopback -> routeSource route + + +data Rule = Rule { ruleMask :: {-# UNPACK #-} !Word32 + , rulePrefix :: {-# UNPACK #-} !Word32 + , ruleRoute :: !Route + } + +ruleMaskLen :: Rule -> Int +ruleMaskLen rule = maskBits (routeNetwork (ruleRoute rule)) + +ruleSource :: Rule -> IP4 +ruleSource rule = maskAddr (routeNetwork (ruleRoute rule)) + +ruleDevice :: Rule -> Device +ruleDevice rule = routeDevice (ruleRoute rule) + +mkRule :: Route -> Rule +mkRule ruleRoute = Rule { .. } + where + IP4Mask (IP4 w) bits = routeNetwork ruleRoute + + ruleMask = netmask bits + rulePrefix = ruleMask .&. w + +routesTo :: Rule -> IP4 -> Bool +routesTo Rule { .. } (IP4 addr) = addr .&. ruleMask == rulePrefix + +-- | Simple routing. +data RoutingTable = RoutingTable { rtRules :: [Rule] + -- ^ Insertions must keep this list ordered + -- by the network prefix length, descending. + + , rtDefault :: !(Maybe Route) + -- ^ Optional default route. + } + +empty :: RoutingTable +empty = RoutingTable { rtRules = [], rtDefault = Nothing } + +getRoutes :: RoutingTable -> [Route] +getRoutes RoutingTable { .. } = map ruleRoute rtRules + +addRule :: Bool -> Route -> RoutingTable -> RoutingTable +addRule isDefault route RoutingTable { .. } = + rule `seq` + RoutingTable { rtRules = insertBy maskLenDesc rule rtRules + , rtDefault = if isDefault + then Just route + else rtDefault + } + + where + + -- compare b to a, to get descending order + maskLenDesc a b = compare (ruleMaskLen b) (ruleMaskLen a) + + rule = mkRule route + +deleteRule :: IP4Mask -> RoutingTable -> RoutingTable +deleteRule mask RoutingTable { .. } = + rules' `seq` def' `seq` RoutingTable { rtRules = rules', rtDefault = def' } + + where + + rules' = + do rule <- rtRules + guard (routeNetwork (ruleRoute rule) /= mask) + return rule + + def' = + case rtDefault of + Just Route { .. } | routeNetwork == mask -> Nothing + _ -> rtDefault + +lookupRoute :: IP4 -> RoutingTable -> Maybe Route +lookupRoute dest RoutingTable { .. } = foldr findRoute rtDefault rtRules + where + findRoute rule continue + | rule `routesTo` dest = Just (ruleRoute rule) + | otherwise = continue + +-- | If the address given is the source address for a rule in the table, return +-- the associated 'Device'. +isLocal :: IP4 -> RoutingTable -> Maybe Route +isLocal addr RoutingTable { .. } = foldr hasSource Nothing rtRules + where + hasSource rule continue + | ruleSource rule == addr = Just (ruleRoute rule) + | otherwise = continue + +-- | Give back routes that involve this device. +routesForDev :: Device -> RoutingTable -> [Route] +routesForDev dev RoutingTable { .. } = mapMaybe usesDev rtRules + where + usesDev rule | ruleDevice rule == dev = Just (ruleRoute rule) + | otherwise = Nothing diff --git a/src/Hans/IP4/State.hs b/src/Hans/IP4/State.hs new file mode 100644 --- /dev/null +++ b/src/Hans/IP4/State.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.IP4.State ( + IP4State(..), + SendSource(..), + ResponderRequest(..), + newIP4State, + HasIP4State(..), + addRoute, + lookupRoute4, + isLocalAddr, + nextIdent, + routesForDev, + ) where + +import Hans.Config (Config(..)) +import Hans.Device.Types (Device(..)) +import Hans.Ethernet (Mac) +import Hans.IP4.ArpTable (ArpTable,newArpTable) +import Hans.IP4.Fragments (FragTable,newFragTable) +import Hans.IP4.Packet (IP4,IP4Ident) +import qualified Hans.IP4.RoutingTable as RT +import Hans.Lens +import Hans.Network.Types (NetworkProtocol) + + +import qualified Control.Concurrent.BoundedChan as BC +import qualified Data.ByteString.Lazy as L +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import System.Random (StdGen,newStdGen,Random(random)) + + +-- IP4 State ------------------------------------------------------------------- + +data SendSource = SourceAny + -- ^ Any interface that will route the message + + | SourceIP4 !IP4 + -- ^ The interface with this address + + | SourceDev !Device !IP4 + -- ^ This device with this source address + + +data ResponderRequest = Finish !Device !Mac [L.ByteString] + -- ^ Finish sending these IP4 packets + + | Send !SendSource !IP4 !Bool !NetworkProtocol L.ByteString + -- ^ Send this IP4 payload to this address + + +data IP4State = IP4State { ip4Routes :: !(IORef RT.RoutingTable) + -- ^ Addresses currently assigned to devices. + + , ip4ArpTable :: !ArpTable + -- ^ The ARP cache. + + , ip4Fragments :: !FragTable + -- ^ IP4 packet fragments + + , ip4ArpRetry :: {-# UNPACK #-} !Int + -- ^ Arp retry count + + , ip4ArpRetryDelay :: {-# UNPACK #-} !Int + + , ip4ResponderQueue :: !(BC.BoundedChan ResponderRequest) + + , ip4RandomSeed :: !(IORef StdGen) + } + +newIP4State :: Config -> IO IP4State +newIP4State cfg = + do ip4Routes <- newIORef RT.empty + ip4ArpTable <- newArpTable cfg + ip4Fragments <- newFragTable cfg + ip4ResponderQueue <- BC.newBoundedChan 32 + ip4RandomSeed <- newIORef =<< newStdGen + return IP4State { ip4ArpRetry = cfgArpRetry cfg + , ip4ArpRetryDelay = cfgArpRetryDelay cfg * 1000 + , .. } + +class HasIP4State state where + ip4State :: Getting r state IP4State + +instance HasIP4State IP4State where + ip4State = id + {-# INLINE ip4State #-} + + +addRoute :: HasIP4State state => state -> Bool -> RT.Route -> IO () +addRoute state = \ defRoute route -> + atomicModifyIORef' ip4Routes (\ table -> (RT.addRule defRoute route table, ())) + where + IP4State { .. } = view ip4State state + + +-- | Lookup the source address, as well as the next hop and device. +lookupRoute4 :: HasIP4State state => state -> IP4 -> IO (Maybe (IP4,IP4,Device)) +lookupRoute4 state = \ dest -> + do routes <- readIORef ip4Routes + case RT.lookupRoute dest routes of + Just route -> return (Just ( RT.routeSource route + , RT.routeNextHop dest route + , RT.routeDevice route)) + Nothing -> return Nothing + where + IP4State { .. } = view ip4State state + + +-- | Is this an address that's assigned to a device in the network stack? +isLocalAddr :: HasIP4State state => state -> IP4 -> IO (Maybe RT.Route) +isLocalAddr state = \ dst -> + do rt <- readIORef ip4Routes + return $! RT.isLocal dst rt + where + IP4State { .. } = view ip4State state + + +-- | Give back the result of using the 'random' function on the internal state. +nextIdent :: HasIP4State state => state -> IO IP4Ident +nextIdent state = + atomicModifyIORef' ip4RandomSeed (\g -> case random g of (a,g') -> (g',a) ) + where + IP4State { .. } = view ip4State state + + +-- | Give back the list of routing rules associated with this device. +routesForDev :: HasIP4State state => state -> Device -> IO [RT.Route] +routesForDev state dev = + do routes <- readIORef (ip4Routes (view ip4State state)) + return $! RT.routesForDev dev routes diff --git a/src/Hans/Input.hs b/src/Hans/Input.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Input.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Input where + +import Hans.Device (Device(..)) +import Hans.Ethernet +import Hans.IP4.Input (processArp,processIP4,handleIP4) +import Hans.Monad (Hans,runHans,dropPacket,io,escape,decode') +import Hans.Types (NetworkStack(..),InputPacket(..)) + +import Control.Concurrent.BoundedChan (readChan) +import Control.Monad (unless) +import qualified Data.ByteString as S + + +-- Incoming Packets ------------------------------------------------------------ + +-- | Handle incoming packets. +processPackets :: NetworkStack -> IO () +processPackets ns = runHans $ + do input <- io (readChan (nsInput ns)) + case input of + FromDevice dev pkt -> processEthernet ns dev pkt + FromIP4 dev hdr body -> handleIP4 ns dev Nothing hdr body + + +processEthernet :: NetworkStack -> Device -> S.ByteString -> Hans () +processEthernet ns dev bytes = + do (hdr,payload) <- decode' (devStats dev) getEthernetHeader bytes + + -- XXX at some point, we should extend this to support multicast + let validFrame = eDest hdr == BroadcastMac + || eDest hdr == devMac dev + + -- XXX should we increment a stat here? + unless validFrame escape + + case eType hdr of + + ETYPE_IPV4 -> + processIP4 ns dev payload + + ETYPE_ARP -> + processArp ns dev payload + + _ -> + dropPacket (devStats dev) diff --git a/src/Hans/Layer.hs b/src/Hans/Layer.hs deleted file mode 100644 --- a/src/Hans/Layer.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} - -module Hans.Layer where - -import Hans.Utils (just) - -import Control.Applicative (Applicative(..),Alternative(..)) -import Control.Monad (ap,MonadPlus(mzero,mplus)) -import Data.Monoid (Monoid(..)) -import Data.Time.Clock.POSIX -import MonadLib (StateM(get,set),BaseM(inBase)) -import qualified Control.Exception as X -import qualified Data.Map.Strict as Map - -data LayerState i = LayerState - { lsNow :: !POSIXTime - , lsState :: !i - } - -data Action = Nop | Action !(IO ()) - -instance Monoid Action where - mempty = Nop - - mappend (Action a) (Action b) = Action (a >> b) - mappend Nop b = b - mappend a _ = a - -runAction :: Action -> IO () -runAction Nop = return () -runAction (Action m) = m `X.catch` \ se -> print (se :: X.SomeException) - -data Result i a - = Error !Action - | Exit !(LayerState i) !Action - | Result !(LayerState i) !a !Action - --- | Early exit continuation -type Exit i r = LayerState i -> Action -> Result i r - --- | Failure continuation -type Failure i r = Action -> Result i r - --- | Success continuation -type Success a i r = a -> LayerState i -> Action -> Result i r - -newtype Layer i a = Layer - { 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 Exit Error success - where success a i o = Result i a o - -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 -> 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 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 x f k -> getLayer a i o x (\_ -> getLayer b i o x f k) k) - -instance Monad (Layer i) where - 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) - -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 = finish - -{-# INLINE time #-} -time :: Layer i POSIXTime -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 - -liftRight :: Either String b -> Layer i b -liftRight (Right b) = return b -liftRight (Left err) = do - output (putStrLn err) - dropPacket - - --- Handler Generalization ------------------------------------------------------ - -type Handlers k a = Map.Map k a - -emptyHandlers :: Handlers k a -emptyHandlers = Map.empty - - -class ProvidesHandlers i k a | i -> k a where - getHandlers :: i -> Handlers k a - setHandlers :: Handlers k a -> i -> i - - -getHandler :: (Ord k, ProvidesHandlers i k a) => k -> Layer i a -getHandler k = do - state <- get - just (Map.lookup k (getHandlers state)) - - -addHandler :: (Ord k, ProvidesHandlers i k a) => k -> a -> Layer i () -addHandler k a = do - state <- get - let hs' = Map.insert k a (getHandlers state) - hs' `seq` set (setHandlers hs' state) - - -removeHandler :: (Ord k, ProvidesHandlers i k a) => k -> Layer i () -removeHandler k = do - state <- get - let hs' = Map.delete k (getHandlers state) - hs' `seq` set (setHandlers hs' state) diff --git a/src/Hans/Layer/Arp.hs b/src/Hans/Layer/Arp.hs deleted file mode 100644 --- a/src/Hans/Layer/Arp.hs +++ /dev/null @@ -1,240 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - -module Hans.Layer.Arp ( - ArpHandle - , runArpLayer - - -- External Interface - , arpWhoHas - , arpIP4Packet - , addLocalAddress - ) where - -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.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 MonadLib (BaseM(inBase),set,get) -import qualified Data.ByteString.Lazy as L -import qualified Data.Map.Strict 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 -> IO () -runArpLayer h eth = do - addEthernetHandler eth (EtherType 0x0806) (send h . handleIncoming) - 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 - var <- newEmptyMVar - 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 -> 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) - - --- Message Handling ------------------------------------------------------------ - -type Arp = Layer ArpState - -data ArpState = ArpState - { arpTable :: !ArpTable - , arpAddrs :: !(Map.Map IP4 Mac) -- this layer's addresses - , arpWaiting :: !(Map.Map IP4 [Maybe Mac -> IO ()]) - , arpEthernet :: {-# UNPACK #-} !EthernetHandle - , arpSelf :: {-# UNPACK #-} !ArpHandle - } - -emptyArpState :: ArpHandle -> EthernetHandle -> ArpState -emptyArpState h eth = ArpState - { arpTable = Map.empty - , arpAddrs = Map.empty - , arpWaiting = Map.empty - , arpEthernet = eth - , arpSelf = h - } - -ethernetHandle :: Arp EthernetHandle -ethernetHandle = arpEthernet `fmap` get - -addEntry :: IP4 -> Mac -> Arp () -addEntry spa sha = do - state <- get - now <- time - let table' = addArpEntry now spa sha (arpTable state) - table' `seq` set state { arpTable = table' } - runWaiting spa (Just sha) - -addWaiter :: IP4 -> (Maybe Mac -> IO ()) -> Arp () -addWaiter addr cont = do - state <- get - set state { arpWaiting = Map.alter f addr (arpWaiting state) } - where - f Nothing = Just [cont] - f (Just ks) = Just (cont:ks) - -runWaiting :: IP4 -> Maybe Mac -> Arp () -runWaiting spa sha = do - state <- get - let (mb,waiting') = Map.updateLookupWithKey f spa (arpWaiting state) - where f _ _ = Nothing - -- run the callbacks associated with this protocol address - let run cb = output (cb sha) - mapM_ run (maybe [] reverse mb) - waiting' `seq` set state { arpWaiting = waiting' } - -updateExistingEntry :: IP4 -> Mac -> Arp Bool -updateExistingEntry spa sha = do - state <- get - let update = do - guard (spa `Map.member` arpTable state) - addEntry spa sha - return True - update `mplus` return False - -localHwAddress :: IP4 -> Arp Mac -localHwAddress pa = do - state <- get - just (Map.lookup pa (arpAddrs state)) - -sendArpPacket :: ArpPacket Mac IP4 -> Arp () -sendArpPacket msg = do - eth <- ethernetHandle - let frame = EthernetFrame - { etherSource = arpSHA msg - , etherDest = arpTHA msg - , etherType = 0x0806 - } - body = renderArpPacket renderMac renderIP4 msg - output (sendEthernet eth frame body) - -advanceArpTable :: Arp () -advanceArpTable = do - now <- time - state <- get - let (table', timedOut) = stepArpTable now (arpTable state) - set state { arpTable = table' } - forM_ timedOut $ \ x -> runWaiting x Nothing - --- | Handle a who-has request -whoHas :: IP4 -> (Maybe Mac -> IO ()) -> Arp () -whoHas ip k = (k' =<< localHwAddress ip) `mplus` query - where - k' addr = output (k (Just addr)) - - query = do - advanceArpTable - state <- get - case lookupArpEntry ip (arpTable state) of - KnownAddress mac -> k' mac - Pending -> addWaiter ip k - Unknown -> do - let addrs = Map.toList (arpAddrs state) - msg (spa,sha) = ArpPacket - { arpHwType = 0x1 - , arpPType = 0x0800 - , arpSHA = sha - , arpSPA = spa - , arpTHA = broadcastMac - , arpTPA = ip - , arpOper = ArpRequest - } - now <- time - let table' = addPending now ip (arpTable state) - set state { arpTable = table' } - addWaiter ip k - mapM_ (sendArpPacket . msg) addrs - output (delay_ 10000 (send (arpSelf state) advanceArpTable)) - --- | Process an incoming arp packet -handleIncoming :: S.ByteString -> Arp () -handleIncoming bs = do - 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] - -- ?Do I speak the protocol in ar$pro? - -- Yes: (This check is also enforced by the type system) - -- [optionally check the protocol length ar$pln] - -- Merge_flag := false - -- If the pair is - -- already in my translation table, update the sender - -- hardware address field of the entry with the new - -- information in the packet and set Merge_flag to true. - let sha = arpSHA msg - let spa = arpSPA msg - merge <- updateExistingEntry spa sha - -- ?Am I the target protocol address? - let tpa = arpTPA msg - lha <- localHwAddress tpa - -- Yes: - -- If Merge_flag is false, add the triplet to - -- the translation table. - unless merge (addEntry spa sha) - -- ?Is the opcode ares_op$REQUEST? (NOW look at the opcode!!) - -- Yes: - when (arpOper msg == ArpRequest) $ do - -- Swap hardware and protocol fields, putting the local - -- hardware and protocol addresses in the sender fields. - let msg' = msg { arpSHA = lha , arpSPA = tpa - , arpTHA = sha , arpTPA = spa - -- Set the ar$op field to ares_op$REPLY - , arpOper = ArpReply } - -- Send the packet to the (new) target hardware address on - -- the same hardware on which the request was received. - sendArpPacket msg' - - --- | Handle a request to associate an ip with a mac address for a local device -handleAddAddress :: IP4 -> Mac -> Arp () -handleAddAddress ip mac = do - state <- get - let addrs' = Map.insert ip mac (arpAddrs state) - addrs' `seq` set state { arpAddrs = addrs' } - - --- | Output a packet to the ethernet layer. -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 - } - whoHas dst $ \ res -> case res of - Nothing -> return () - Just dha -> sendEthernet eth (frame dha) body diff --git a/src/Hans/Layer/Arp/Table.hs b/src/Hans/Layer/Arp/Table.hs deleted file mode 100644 --- a/src/Hans/Layer/Arp/Table.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Hans.Layer.Arp.Table where - -import Hans.Address.Mac -import Hans.Address.IP4 - -import Control.Arrow (second) -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.Map.Strict as Map - - --- Arp Table ------------------------------------------------------------------- - -arpEntryTimeout :: POSIXTime -arpEntryTimeout = 60 - -data ArpEntry - = ArpEntry { arpMac :: {-# UNPACK #-} !Mac - , arpTimeout :: !POSIXTime - } - | ArpPending { arpTimeout :: !POSIXTime - } - deriving Show - -data ArpResult - = KnownAddress {-# UNPACK #-} !Mac - | Pending - | Unknown - -type ArpTable = Map.Map IP4 ArpEntry - -stepArpTable :: POSIXTime -> ArpTable -> (ArpTable, [IP4]) -stepArpTable now tab = second (Map.keys) (Map.partition p tab) - where - p ent = arpTimeout ent >= now - -addArpEntry :: POSIXTime -> IP4 -> Mac -> ArpTable -> ArpTable -addArpEntry now ip mac = Map.insert ip ent where - ent = ArpEntry - { arpMac = mac - , arpTimeout = now + arpEntryTimeout - } - --- | Assumption: there is not already a pending ARP query recorded in the --- ARP table for the given IP address. -addPending :: POSIXTime -> IP4 -> ArpTable -> ArpTable -addPending now ip = - Map.insert ip ArpPending - { arpTimeout = now + arpEntryTimeout -- FIXME: should queries stay longer? - } - --- | If the ARP table has a fully realized entry for the given IP address, --- then return it. Otherwise return Pending if we're waiting for this info, --- or Unknown if nothing is currently known about it. -lookupArpEntry :: IP4 -> ArpTable -> ArpResult -lookupArpEntry ip arp = - case Map.lookup ip arp of - Just (ArpEntry mac _) -> KnownAddress mac - Just (ArpPending _) -> Pending - _ -> Unknown diff --git a/src/Hans/Layer/Dns.hs b/src/Hans/Layer/Dns.hs deleted file mode 100644 --- a/src/Hans/Layer/Dns.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# 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.Strict 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 :: {-# UNPACK #-} !DnsHandle - , dnsUdpHandle :: {-# UNPACK #-} !UdpHandle - , dnsNameServers :: ![IP4] - , dnsReqId :: {-# UNPACK #-} !Word16 - , dnsQueries :: !(Map.Map Word16 DnsQuery) - , dnsTimeout :: {-# UNPACK #-} !Milliseconds - } - -emptyDnsState :: DnsHandle -> UdpHandle -> DnsState -emptyDnsState h udp = DnsState { dnsSelf = h - , dnsUdpHandle = udp - , dnsNameServers = [] - , dnsReqId = 1 - , dnsQueries = Map.empty - , dnsTimeout = 180000 -- 3 minutes - } - --- LFSR: x^16 + x^14 + x^13 + x^11 + 1 --- --- 0xB400 ~ bit 15 .|. bit 13 .|. bit 12 .|. bit 10 -stepReqId :: Word16 -> Word16 -stepReqId w = (w `shiftR` 1) .|. (negate (w .&. 0x1) .&. 0xB400) - --- | Register a fresh request, along with a timer to reap the request after --- 'dnsTimeout'. -registerRequest :: (Word16 -> DnsQuery) -> Dns Word16 -registerRequest mk = - do state <- get - let reqId = dnsReqId state - set state { dnsReqId = stepReqId reqId - , dnsQueries = Map.insert reqId (mk reqId) (dnsQueries state) - } - return reqId - -registerTimeout :: Word16 -> Timer -> Dns () -registerTimeout reqId timer = - do DnsState { .. } <- get - case Map.lookup reqId dnsQueries of - Just query -> updateRequest reqId query { qTimeout = Just timer } - Nothing -> output (cancel timer) - -updateRequest :: Word16 -> DnsQuery -> Dns () -updateRequest reqId query = - do state <- get - set state { dnsQueries = Map.insert reqId query (dnsQueries state) } - -lookupRequest :: Word16 -> Dns DnsQuery -lookupRequest reqId = - do DnsState { .. } <- get - case Map.lookup reqId dnsQueries of - Just query -> return query - Nothing -> mzero - -removeRequest :: Word16 -> Dns () -removeRequest reqId = - do state <- get - set state { dnsQueries = Map.delete reqId (dnsQueries state) } - - -data Source = FromHost HostName - | FromIP4 IP4 - deriving (Show) - -sourceQType :: Source -> [QType] -sourceQType FromHost{} = [QType A] -sourceQType FromIP4{} = [QType PTR] - -sourceHost :: Source -> Name -sourceHost (FromHost h) = toLabels h -sourceHost (FromIP4 (IP4 a b c d)) = let byte w = fromString (show w) - in map byte [d,c,b,a] ++ ["in-addr","arpa"] - -toLabels :: String -> Name -toLabels str = case break (== '.') str of - (as,_:bs) -> fromString as : toLabels bs - (as,_) -> [fromString as] - -getHostEntry :: DnsResult -> Source -> Dns () -getHostEntry res src = - do DnsState { .. } <- get - - -- make sure that there are name servers to work with - when (null dnsNameServers) $ - do output (putError res NoNameServers) - mzero - - -- register a upd handler on a fresh port, and query the name servers in - -- order - output $ - do port <- addUdpHandlerAnyPort dnsUdpHandle (serverResponse dnsSelf src) - send dnsSelf (createRequest res dnsNameServers src port) - - --- | Create the query packet, and register the request with the DNS layer. --- Then, send a request to the first name server. -createRequest :: DnsResult -> [IP4] -> Source -> UdpPort -> Dns () -createRequest res nss src port = - do DnsState { .. } <- get - reqId <- registerRequest (mkDnsQuery res nss port src) - sendRequest reqId - - --- | Send a request to the next name server in the queue. -sendRequest :: Word16 -> Dns () -sendRequest reqId = - do query <- lookupRequest reqId - - case qServers query of - - n:rest -> do updateRequest reqId query { qServers = rest - , qLastServer = Just n - } - sendQuery n (qUdpPort query) reqId (qRequest query) - - -- out of servers to try - [] -> do removeRequest reqId - output (putError (qResult query) OutOfServers) - -expireRequest :: Word16 -> Dns () -expireRequest reqId = - do DnsQuery { .. } <- lookupRequest reqId - removeRequest reqId - output (putError qResult OutOfServers) - --- | Handle the response from the server. -handleResponse :: Source -> IP4 -> UdpPort -> S.ByteString -> Dns () -handleResponse src srcIp srcPort bytes = - do guard (srcPort == 53) - - DNSPacket { .. } <- liftRight (parseDNSPacket bytes) - let DNSHeader { .. } = dnsHeader - DnsQuery { .. } <- lookupRequest dnsId - - -- require that the last name server we sent to was the one that responded, - -- and that it responded with a response, not a request. - guard (Just srcIp == qLastServer && not dnsQuery) - - if dnsRC == RespNoError - then output (putResult qResult (parseHostEntry src dnsAnswers)) - else output (putError qResult DnsRequestFailed) - - removeRequest dnsId - DnsState { .. } <- get - output $ do removeUdpHandler dnsUdpHandle qUdpPort - case qTimeout of - Just timeout -> cancel timeout - Nothing -> return () - -parseHostEntry :: Source -> [RR] -> HostEntry -parseHostEntry (FromHost host) = parseAddr host -parseHostEntry (FromIP4 addr) = parsePtr addr - --- | Parse the A and CNAME parts out of a response. -parseAddr :: HostName -> [RR] -> HostEntry -parseAddr host = foldl' processAnswer emptyHostEntry - where - - emptyHostEntry = HostEntry { hostName = host - , hostAliases = [] - , hostAddresses = [] } - - processAnswer he RR { .. } = case rrRData of - RDA ip -> he { hostAddresses = ip : hostAddresses he } - RDCNAME ns -> he { hostName = intercalate "." (map C8.unpack ns) - , hostAliases = hostName he : hostAliases he } - _ -> he - -parsePtr :: IP4 -> [RR] -> HostEntry -parsePtr addr = foldl' processAnswer emptyHostEntry - where - emptyHostEntry = HostEntry { hostName = "" - , hostAliases = [] - , hostAddresses = [addr] } - - processAnswer he RR { .. } = case rrRData of - RDPTR name -> he { hostName = intercalate "." (map C8.unpack name) } - _ -> he - - --- Query Management ------------------------------------------------------------ - -type DnsResult = MVar (Either DnsException HostEntry) - -putResult :: DnsResult -> HostEntry -> IO () -putResult var he = putMVar var (Right he) - -putError :: DnsResult -> DnsException -> IO () -putError var err = putMVar var (Left err) - -data DnsQuery = DnsQuery { qResult :: DnsResult - -- ^ The handle back to the thread waiting fo the - -- HostEntry - , qUdpPort :: !UdpPort - -- ^ The port this request is receiving on - , qRequest :: L.ByteString - -- ^ The packet to send - , qServers :: [IP4] - -- ^ Name servers left to try - , qLastServer :: Maybe IP4 - -- ^ The last server queried - , qTimeout :: Maybe Timer - -- ^ The timer for the current request - } - -mkDnsQuery :: DnsResult -> [IP4] -> UdpPort -> Source -> Word16 -> DnsQuery -mkDnsQuery res nss port src reqId = - DnsQuery { qResult = res - , qUdpPort = port - , qRequest = renderDNSPacket (mkDNSPacket host qs reqId) - , qServers = nss - , qLastServer = Nothing - , qTimeout = Nothing - } - where - host = sourceHost src - qs = sourceQType src - - -mkDNSPacket :: Name -> [QType] -> Word16 -> DNSPacket -mkDNSPacket name qs reqId = - DNSPacket { dnsHeader = hdr - , dnsQuestions = [ mkQuery q | q <- qs ] - , dnsAnswers = [] - , dnsAuthorityRecords = [] - , dnsAdditionalRecords = [] - } - where - hdr = DNSHeader { dnsId = reqId - , dnsQuery = True - , dnsOpCode = OpQuery - , dnsAA = False - , dnsTC = False - , dnsRD = True - , dnsRA = False - , dnsRC = RespNoError - } - - mkQuery qty = Query { qName = name - , qType = qty - , qClass = QClass IN - } - - --- UDP Interaction ------------------------------------------------------------- - --- | Send a UDP query to the server given -sendQuery :: IP4 -> UdpPort -> Word16 -> L.ByteString -> Dns () -sendQuery nameServer sp reqId bytes = - do DnsState { .. } <- get - output $ do sendUdp dnsUdpHandle nameServer (Just sp) 53 bytes - expire <- delay dnsTimeout (send dnsSelf (expireRequest reqId) `X.finally` putStrLn "KILLED") - send dnsSelf (registerTimeout reqId expire) - --- | Queue the packet into the DNS layer for processing. -serverResponse :: DnsHandle -> Source -> UdpPort -> Udp.Handler -serverResponse dns src _ srcIp srcPort bytes = - send dns (handleResponse src srcIp srcPort bytes) diff --git a/src/Hans/Layer/Ethernet.hs b/src/Hans/Layer/Ethernet.hs deleted file mode 100644 --- a/src/Hans/Layer/Ethernet.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module Hans.Layer.Ethernet ( - EthernetHandle - , runEthernetLayer - - -- * External Interface - , Tx - , Rx - , sendEthernet - , queueEthernet - , addEthernetDevice - , removeEthernetDevice - , addEthernetHandler - , removeEthernetHandler - , startEthernetDevice - , stopEthernetDevice - ) where - -import Hans.Address.Mac -import Hans.Channel -import Hans.Layer -import Hans.Message.EthernetFrame -import Hans.Utils (void,just) - -import Control.Concurrent (forkIO,ThreadId,killThread) -import Control.Monad (mplus) -import MonadLib (get,set) -import qualified Data.ByteString.Lazy as L -import qualified Data.Map.Strict as Map -import qualified Data.ByteString as S - - --- Ethernet Layer -------------------------------------------------------------- - -type Handler = S.ByteString -> IO () - -type Tx = L.ByteString -> IO () -type Rx = EthernetHandle -> IO () - -type EthernetHandle = Channel (Eth ()) - --- | Run the ethernet layer. -runEthernetLayer :: EthernetHandle -> IO () -runEthernetLayer h = - void (forkIO (loopLayer "ethernet" (emptyEthernetState h) (receive h) id)) - - --- 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 () -startEthernetDevice h !m = send h (startDevice m) - -stopEthernetDevice :: EthernetHandle -> Mac -> IO () -stopEthernetDevice h !m = send h (stopDevice m) - -addEthernetDevice :: EthernetHandle -> Mac -> Tx -> Rx -> IO () -addEthernetDevice h !mac tx rx = send h (addDevice mac tx rx) - -removeEthernetDevice :: EthernetHandle -> Mac -> IO () -removeEthernetDevice h !mac = send h (delDevice mac) - -addEthernetHandler :: EthernetHandle -> EtherType -> Handler -> IO () -addEthernetHandler h !et k = send h (addHandler et k) - -removeEthernetHandler :: EthernetHandle -> EtherType -> IO () -removeEthernetHandler h !et = send h (removeHandler et) - - --- Ethernet Message Monad ------------------------------------------------------ - -data EthernetDevice = EthernetDevice - { devTx :: Tx - , devRx :: IO () - , devUp :: Maybe ThreadId - } - -emptyDevice :: Tx -> IO () -> EthernetDevice -emptyDevice tx rx = EthernetDevice - { devTx = tx - , devRx = rx - , devUp = Nothing - } - - -type Eth = Layer EthernetState - -data EthernetState = EthernetState - { ethHandlers :: !(Handlers EtherType Handler) - , ethDevices :: !(Map.Map Mac EthernetDevice) - , ethHandle :: {-# UNPACK #-} !EthernetHandle - } - -instance ProvidesHandlers EthernetState EtherType Handler where - getHandlers = ethHandlers - setHandlers hs i = i { ethHandlers = hs } - -emptyEthernetState :: EthernetHandle -> EthernetState -emptyEthernetState h = EthernetState - { ethHandlers = emptyHandlers - , ethDevices = Map.empty - , ethHandle = h - } - -self :: Eth EthernetHandle -self = ethHandle `fmap` get - - --- Message Handling ------------------------------------------------------------ - --- | Handle an incoming packet, from a device. -handleIncoming :: S.ByteString -> Eth () -handleIncoming pkt = do - (hdr,body) <- liftRight (parseEthernetFrame pkt) - h <- getHandler (etherType hdr) - output (h body) - - --- | Get the device associated with a mac address. -getDevice :: Mac -> Eth EthernetDevice -getDevice mac = do - state <- get - just (Map.lookup mac (ethDevices state)) - - --- | Set the device associated with a mac address. -setDevice :: Mac -> EthernetDevice -> Eth () -setDevice mac dev = do - state <- get - let ds' = Map.insert mac dev (ethDevices state) - ds' `seq` set state { ethDevices = ds' } - - --- | Send an outgoing ethernet frame via the device that it's associated with. -handleOutgoing :: EthernetFrame -> L.ByteString -> Eth () -handleOutgoing frame body = do - dev <- getDevice (etherSource frame) - output (devTx dev (renderEthernetFrame frame body)) - - --- | Add an ethernet device to the state. -addDevice :: Mac -> Tx -> Rx -> Eth () -addDevice mac tx rx = do - stopDevice mac `mplus` return () - h <- self - setDevice mac (emptyDevice tx (rx h)) - - --- | Remove a device -delDevice :: Mac -> Eth () -delDevice mac = do - stopDevice mac - state <- get - let ds' = Map.delete mac (ethDevices state) - ds' `seq` set state { ethDevices = ds' } - - --- | Stop an ethernet device. -stopDevice :: Mac -> Eth () -stopDevice mac = do - dev <- getDevice mac - case devUp dev of - Nothing -> return () - Just tid -> do - output (killThread tid) - setDevice mac dev { devUp = Nothing } - - --- | Start an ethernet device. -startDevice :: Mac -> Eth () -startDevice mac = do - dev <- getDevice mac - case devUp dev of - Just _ -> return () - -- XXX: add functionality to pipe the threadid back into the layer state. - Nothing -> output (void (forkIO (devRx dev))) - --setDevice mac dev { devUp = Just tid } diff --git a/src/Hans/Layer/IP4.hs b/src/Hans/Layer/IP4.hs deleted file mode 100644 --- a/src/Hans/Layer/IP4.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Hans.Layer.IP4 ( - IP4Handle - , runIP4Layer - , Rule(..) - - -- * External Interface - , connectEthernet - , withIP4Source - , sendIP4Packet - , addIP4RoutingRule - , addIP4Handler, Handler - , removeIP4Handler - - , Mtu - ) where - -import Hans.Address -import Hans.Address.IP4 -import Hans.Channel -import Hans.Layer -import Hans.Layer.Arp -import Hans.Layer.Ethernet -import Hans.Layer.IP4.Fragmentation -import Hans.Layer.IP4.Routing -import Hans.Message.EthernetFrame -import Hans.Message.Ip4 -import Hans.Utils -import Hans.Utils.Checksum - -import Control.Concurrent (forkIO) -import Control.Monad (guard, (<=<)) -import MonadLib (get,set) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S - - -type Handler = IP4Header -> S.ByteString -> IO () - -type IP4Handle = Channel (IP ()) - -runIP4Layer :: IP4Handle -> ArpHandle -> EthernetHandle -> IO () -runIP4Layer h arp eth = do - void (forkIO (loopLayer "ip4" (emptyIP4State arp) (receive h) id)) - connectEthernet h eth - -connectEthernet :: IP4Handle -> EthernetHandle -> IO () -connectEthernet h eth = - addEthernetHandler eth (EtherType 0x0800) (send h . handleIncoming) - -withIP4Source :: IP4Handle -> IP4 -> (IP4 -> IO ()) -> IO () -withIP4Source h !dst k = send h (handleSource dst k) - -addIP4RoutingRule :: IP4Handle -> Rule IP4Mask IP4 -> IO () -addIP4RoutingRule h !rule = send h (handleAddRule rule) - -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) - -removeIP4Handler :: IP4Handle -> IP4Protocol -> IO () -removeIP4Handler h !prot = send h (removeHandler prot) - --- IP4 State ------------------------------------------------------------------- - -type IP = Layer IP4State - -data IP4State = IP4State - { ip4Fragments :: !(FragmentationTable IP4) - , ip4Routes :: !(RoutingTable IP4) - , ip4Handlers :: !(Handlers IP4Protocol Handler) - , ip4NextIdent :: {-# UNPACK #-} !Ident - , ip4ArpHandle :: {-# UNPACK #-} !ArpHandle - } - -instance ProvidesHandlers IP4State IP4Protocol Handler where - getHandlers = ip4Handlers - setHandlers hs i = i { ip4Handlers = hs } - - -emptyIP4State :: ArpHandle -> IP4State -emptyIP4State arp = IP4State - { ip4Fragments = emptyFragmentationTable - , ip4Routes = emptyRoutingTable - , ip4Handlers = emptyHandlers - , ip4NextIdent = 0 - , ip4ArpHandle = arp - } - - --- IP4 Utilities --------------------------------------------------------------- - -arpHandle :: IP ArpHandle -arpHandle = ip4ArpHandle `fmap` get - -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' :: IP4Header -> L.ByteString -> (IP4,IP4,Mtu) -> IP () -sendPacket' hdr body (src,dst,mtu) = do - arp <- arpHandle - output $ do - let frags = splitPacket mtu hdr body - mapM_ (arpIP4Packet arp src dst <=< uncurry renderIP4Packet) frags - - --- | Find a route to an address -findRoute :: IP4 -> IP (IP4,IP4,Mtu) -findRoute addr = do - state <- get - just (route addr (ip4Routes state)) - --- Route a packet that is forwardable. --- XXX Hide this facility behind configuration -_forward :: IP4Header -> L.ByteString -> IP () -_forward hdr body = do - rule@(src,_,_) <- findRoute (ip4DestAddr hdr) - guard (src /= ip4SourceAddr hdr) - sendPacket' hdr body rule - --- | Require that an address is local. -localAddress :: IP4 -> IP () -localAddress ip = do - state <- get - guard (ip `elem` localAddrs (ip4Routes state)) - -_findSourceMask :: IP4 -> IP IP4Mask -_findSourceMask ip = do - state <- get - just (sourceMask ip (ip4Routes state)) - -_broadcastDestination :: IP4 -> IP () -_broadcastDestination ip = do - mask <- _findSourceMask ip - guard (isBroadcast mask ip) - --- | Route a message to a local handler -routeLocal :: IP4Header -> S.ByteString -> IP () -routeLocal hdr body = do - let dest = ip4DestAddr hdr - localAddress dest - h <- getHandler (ip4Protocol hdr) - mb <- handleFragments hdr body - case mb of - Just bs -> output (h hdr (strict bs)) - Nothing -> return () - - -handleFragments :: IP4Header -> S.ByteString -> IP (Maybe L.ByteString) -handleFragments hdr body = do - state <- get - now <- time - let (table',mb) = processIP4Packet now (ip4Fragments state) hdr body - table' `seq` set state { ip4Fragments = table' } - return mb - -nextIdent :: IP Ident -nextIdent = do - state <- get - let i = ip4NextIdent state - set state { ip4NextIdent = i + 1 } - return i - --- Message Handling ------------------------------------------------------------ - --- | Incoming packet from the network -handleIncoming :: S.ByteString -> IP () -handleIncoming bs = do - (hdr,hlen,plen) <- liftRight (parseIP4Packet bs) - let (header,rest) = S.splitAt hlen bs - let checksum = computeChecksum 0 header - guard $ and - [ S.length bs >= 20 - , hlen >= 20 - , checksum == 0 - , ip4Version hdr == 4 - ] - - -- forward? - let payload = S.take (plen - hlen) rest - routeLocal hdr payload - -- XXX Hide this old router functionality behind a setting - -- `mplus` forward hdr (chunk payload) - - -handleAddRule :: Rule IP4Mask IP4 -> IP () -handleAddRule rule = do - state <- get - let routes' = addRule rule (ip4Routes state) - routes' `seq` set state { ip4Routes = routes' } - - -handleSource :: IP4 -> (IP4 -> IO ()) -> IP () -handleSource dst k = do - (s,_,_) <- findRoute dst - output (k s) diff --git a/src/Hans/Layer/IP4/Fragmentation.hs b/src/Hans/Layer/IP4/Fragmentation.hs deleted file mode 100644 --- a/src/Hans/Layer/IP4/Fragmentation.hs +++ /dev/null @@ -1,115 +0,0 @@ - -module Hans.Layer.IP4.Fragmentation where - -import Hans.Address -import Hans.Address.IP4 -import Hans.Message.Ip4 -import Hans.Utils (chunk) - -import Data.Ord (comparing) -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.ByteString.Lazy as L -import qualified Data.Map.Strict as Map -import qualified Data.ByteString as S - - -type FragmentationTable addr = Map.Map (Ident,addr,addr) Fragments - -emptyFragmentationTable :: FragmentationTable IP4 -emptyFragmentationTable = Map.empty - - -data Fragments = Fragments - { startTime :: !POSIXTime - , totalSize :: {-# UNPACK #-} !Int - , fragments :: ![Fragment] - } deriving Show - -data Fragment = Fragment - { fragmentOffset :: {-# UNPACK #-} !Int - , fragmentLength :: {-# UNPACK #-} !Int - , fragmentPayload :: !L.ByteString - } deriving (Eq,Show) - -instance Ord Fragment where - compare = comparing fragmentOffset - - --- | The end of a fragment. -fragmentEnd :: Fragment -> Int -fragmentEnd f = fragmentOffset f + fragmentLength f - --- | Check the ordering of two fragments. -comesBefore :: Fragment -> Fragment -> Bool -comesBefore f g = fragmentEnd f == fragmentOffset g - --- | Check the ordering of two fragments. -comesAfter :: Fragment -> Fragment -> Bool -comesAfter = flip comesBefore - --- | Merge two fragments. --- --- Note: This doesn't do a validity check to make sure that they're actually --- adjacent. -combineFragments :: Fragment -> Fragment -> Fragment -combineFragments f g = Fragment (fragmentOffset f) len pay - where - len = fragmentLength f + fragmentLength g - pay = fragmentPayload f `L.append` fragmentPayload g - - --- | Given a group of fragments, a new fragment, and a possible total size, --- create a new group of fragments that incorporates the new fragment. -expandGroup :: Fragments -> Fragment -> Int -> Fragments -expandGroup fs newfrag x = case totalSize fs of - -1 | x >= 0 -> expandGroup fs{ totalSize = x } newfrag x - _ -> fs { fragments = addFragment newfrag (fragments fs) } - - --- | Add a fragment to a list of fragments, in a position that is relative to --- its offset and length. -addFragment :: Fragment -> [Fragment] -> [Fragment] -addFragment f fs = case fs of - [] -> [f] - g:rest | f `comesBefore` g -> addFragment (combineFragments f g) rest - | f `comesAfter` g -> addFragment (combineFragments g f) rest - | f < g -> f:fs - | otherwise -> g:(addFragment f rest) - - --- | Process a packet fragment through the system, potentially returning a --- fully-processed packet if this fragment completes an existing packet or --- is itself a fully-complete packet. -processFragment :: Address addr - => POSIXTime -> FragmentationTable addr -> Bool -> Int - -> 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 = S.length bs - cur = Fragment off curlen (chunk bs) - newTotalLen | areMore = -1 - | otherwise = off + curlen - - -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) - ident = fromIntegral (ip4Ident hdr) - areMore = ip4MoreFragments hdr - src = ip4SourceAddr hdr - dest = ip4DestAddr hdr diff --git a/src/Hans/Layer/IP4/Routing.hs b/src/Hans/Layer/IP4/Routing.hs deleted file mode 100644 --- a/src/Hans/Layer/IP4/Routing.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Hans.Layer.IP4.Routing ( - -- * Routing Rules - Rule(..) - , Mtu - - -- * Routing Table - , RoutingTable - , emptyRoutingTable - , addRule - , route - , localAddrs - , sourceMask - ) where - -import Data.PrefixTree as PT -import Hans.Address.IP4 -import Hans.Address - -import Data.Maybe (mapMaybe) - - --- Routing Rules --------------------------------------------------------------- - -type Mtu = Int - -data Rule mask addr - = Direct mask addr Mtu - | Indirect mask addr - deriving Show - - --- Routing Table --------------------------------------------------------------- - -type RoutingTable addr = PrefixTree (Dest addr) - -data Dest addr - = NextHop addr - | Via addr Mtu - deriving Show - - -emptyRoutingTable :: Address addr => RoutingTable addr -emptyRoutingTable = PT.empty - - -{-# SPECIALIZE addRule :: Rule IP4Mask IP4 -> RoutingTable IP4 - -> RoutingTable IP4 #-} --- | Add a rule to the routing table. -addRule :: Mask mask addr - => Rule mask addr -> RoutingTable addr -> RoutingTable addr -addRule rule table = case rule of - Direct mask addr mtu -> k mask (Via addr mtu) - Indirect mask addr -> k mask (NextHop addr) - where - k m d = insert ks d table - where - (addr,bits) = getMaskComponents m - ks = take bits (toBits addr) - - -{-# SPECIALIZE route :: IP4 -> RoutingTable IP4 -> Maybe (IP4,IP4,Mtu) #-} --- | Discover the source and destination when trying to route an address. -route :: Address addr => addr -> RoutingTable addr -> Maybe (addr,addr,Mtu) -route addr t = do - r <- match (toBits addr) t - case r of - Via s mtu -> return (s,addr,mtu) - NextHop hop -> do - Via s mtu <- match (toBits hop) t - return (s,hop,mtu) - - -{-# SPECIALIZE sourceMask :: IP4 -> RoutingTable IP4 -> Maybe IP4Mask #-} --- | Find the mask that would be used to route an address. -sourceMask :: Mask mask addr => addr -> RoutingTable addr -> Maybe mask -sourceMask addr table = do - src <- key (toBits addr) table - let bits = fromIntegral (addrSize addr * 8) - length src - return (addr `withMask` bits) - - --- | Dump all local addresses. -localAddrs :: Address addr => RoutingTable addr -> [addr] -localAddrs table = mapMaybe p (PT.elems table) - where - p (Via s _) = Just s - p _ = Nothing diff --git a/src/Hans/Layer/Icmp4.hs b/src/Hans/Layer/Icmp4.hs deleted file mode 100644 --- a/src/Hans/Layer/Icmp4.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Hans.Layer.Icmp4 ( - Icmp4Handle - , runIcmp4Layer - , addIcmp4Handler - , destUnreachable - ) where - -import Hans.Address.IP4 (IP4,broadcastIP4) -import Hans.Channel -import Hans.Layer -import Hans.Message.Icmp4 -import Hans.Message.Ip4 -import Hans.Utils -import qualified Hans.Layer.IP4 as IP4 - -import Control.Concurrent (forkIO) -import Control.Monad (unless) -import Data.Serialize (runPut,putByteString) -import MonadLib (get,set) -import qualified Data.ByteString as S - -type Handler = Icmp4Packet -> IO () - -type Icmp4Handle = Channel (Icmp4 ()) - -icmpProtocol :: IP4Protocol -icmpProtocol = IP4Protocol 0x1 - -runIcmp4Layer :: Icmp4Handle -> IP4.IP4Handle -> IO () -runIcmp4Layer h ip4 = do - let handles = Icmp4Handles ip4 [] - IP4.addIP4Handler ip4 icmpProtocol - $ \ hdr bs -> send h (handleIncoming hdr bs) - void (forkIO (loopLayer "icmp4" handles (receive h) id)) - -data Icmp4Handles = Icmp4Handles - { icmpIp4 :: {-# UNPACK #-} !IP4.IP4Handle - , icmpHandlers :: ![Handler] - } - -type Icmp4 = Layer Icmp4Handles - -ip4Handle :: Icmp4 IP4.IP4Handle -ip4Handle = icmpIp4 `fmap` get - --- | 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 :: 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 hdr ident seqNum dat - _ty -> dropPacket - - --- | Add an icmp packet handler. -handleAdd :: Handler -> Icmp4 () -handleAdd k = do - s <- get - set s { icmpHandlers = k : icmpHandlers s } - - --- | Respond to an echo request -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. -matchHandlers :: Icmp4Packet -> Icmp4 () -matchHandlers pkt = do - s <- get - unless (null (icmpHandlers s)) (output (mapM_ ($ pkt) (icmpHandlers s))) diff --git a/src/Hans/Layer/Tcp.hs b/src/Hans/Layer/Tcp.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE BangPatterns #-} - -module Hans.Layer.Tcp ( - TcpHandle - , runTcpLayer - , queueTcp - ) where - -import Hans.Channel -import Hans.Layer -import Hans.Layer.IP4 -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 Control.Monad (when) -import Data.Time.Clock.POSIX (getPOSIXTime,POSIXTime) -import qualified Data.ByteString as S - - -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 - initTimers tcp - --- | Queue a tcp packet. -queueTcp :: TcpHandle -> IP4Header -> S.ByteString -> IO () -queueTcp tcp !hdr !bs = send tcp (handleIncomingTcp hdr bs) - --- | 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 - lastUpdate <- getLastUpdate - let diff = now - lastUpdate - -- increment the ISN at 128KHz - inc = round (isnRate * diff) - - when (inc > 0) $ - modifyHost_ $ \ host -> - host { hostLastUpdate = now - , hostInitialSeqNum = hostInitialSeqNum host + inc - } - - body diff --git a/src/Hans/Layer/Tcp/Handlers.hs b/src/Hans/Layer/Tcp/Handlers.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Handlers.hs +++ /dev/null @@ -1,506 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE PatternGuards #-} - -module Hans.Layer.Tcp.Handlers ( - handleIncomingTcp - , outputSegments - ) where - -import Hans.Address.IP4 -import Hans.Layer -import Hans.Layer.Tcp.Messages -import Hans.Layer.Tcp.Monad -import Hans.Layer.Tcp.Timers -import Hans.Layer.Tcp.Types -import Hans.Layer.Tcp.Window -import Hans.Message.Ip4 -import Hans.Message.Tcp - -import Control.Monad (guard,when,unless,join) -import Data.Bits (bit) -import Data.Int (Int64) -import Data.Maybe (fromMaybe,isJust) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.Foldable as F - - --- Incoming Packets ------------------------------------------------------------ - --- | Process a single incoming tcp packet. -handleIncomingTcp :: IP4Header -> S.ByteString -> Tcp () -handleIncomingTcp ip4 bytes = do - - let src = ip4SourceAddr ip4 - dst = ip4DestAddr ip4 - - guard (validateTcpChecksumIP4 src dst bytes) - (hdr,body) <- liftRight (parseTcpPacket bytes) - - withConnection' src hdr (segmentArrives src hdr body) - $ timeWaitConnection src hdr - $ noConnection src hdr body - -noConnection :: IP4 -> TcpHeader -> S.ByteString -> Tcp () -noConnection src hdr @ TcpHeader { .. } body = - do 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 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 - - shouldDrop <- modifyTcpSocket (updateTimestamp hdr) - when shouldDrop discardAndReturn - - 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 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, and advancing - -- RCV.NXT by one - , tcpIn = emptyLocalWindow (tcpSeqNum hdr + 1) 14600 0 - , tcpSack = sackSupported hdr - , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr) - } - - when (tcpAck hdr) $ - do -- advance SND.UNA - modifyTcpSocket_ $ \ sock -> sock - { tcpSndUna = tcpAckNum hdr } - - TcpSocket { .. } <- getTcpSocket - if tcpSndUna > tcpIss - then do ack - notify True - - setState Established - - -- 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 - - when (not (tcpSyn hdr || tcpRst hdr)) discardAndReturn - - -- 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 - whenStates [ SynReceived, Established, FinWait1, FinWait2 - , CloseWait, Closing, LastAck] $ - do notify False - 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 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 handleAck hdr - 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 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 = (inFins >> outFins,tcp') - where - - -- empty the outgoing buffer, notifying all waiting processes that the send - -- won't happen - (outFins,out') = flushWaiting (tcpOutBuffer tcp) - - -- empty the input buffer - (inFins, in') = flushWaiting (tcpInBuffer tcp) - - tcp' = tcp { tcpOutBuffer = out' - , tcpInBuffer = in' - } - - --- | 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 = (True, tcp) - | otherwise = (False,tcp { tcpTimestamp = ts' }) - where - -- when the timestamp check fails from an ack, that's not a syn,ack, mark this - -- packet as one to be dropped. - shouldDrop = not (tcpSyn hdr || tcpRst hdr) - && isJust (tcpTimestamp tcp) /= isJust ts' - ts' = do - ts <- tcpTimestamp tcp - OptTimestamp them echo <- findTcpOption OptTagTimestamp hdr - -- when this is an ack, the echo value should not be greater than the - -- current timestamp. this doesn't currently account for overflow, so - -- connections lasting >27 days will probably fail. - let rel = tsTimestamp ts - echo - isGreater = 0 < rel && rel < bit 31 - when (tcpAck hdr) (guard (tsTimestamp ts == echo || isGreater)) - return ts { tsLastTimestamp = them } - --- | Enqueue a new packet in the local window, attempting to place the bytes --- received in the user buffer as they complete a part of the stream. Bytes are --- ack'd as they complete the stream, and bytes that would cause the local --- buffer to overflow are dropped. -handleData :: TcpHeader -> S.ByteString -> TcpSocket - -> (Maybe Wakeup, TcpSocket) -handleData hdr body tcp0 = fromMaybe (Nothing,tcp) $ do - (wakeup,buf') <- putBytes bytes (tcpInBuffer tcp) - let tcp' = tcp - { tcpInBuffer = buf' - , tcpTimers = (tcpTimers tcp) - { ttDelayedAck = or [ not (L.null bytes) - , tcpSyn hdr - , tcpFin hdr ] - } - } - return (wakeup, tcp') - where - (segs,win') = incomingPacket hdr body (tcpIn tcp0) - tcp = tcp0 { tcpIn = win' } - bytes = L.fromChunks (map inBody (F.toList segs)) - - --- | Handle an ACK to a sent data segment. -handleAck :: TcpHeader -> Sock () -handleAck hdr = do - now <- inTcp time - modifyTcpSocket_ (updateAck now) - where - -- using Karns algorithm, only calibrate the RTO if the packet that was ack'd - -- has not yet been retransmitted. - updateAck now tcp = case receiveAck hdr (tcpOut tcp) of - Just (seg,out') -> - let calibrate | outFresh seg = calibrateRTO now (outTime seg) - | otherwise = id - in tcp { tcpOut = out' - , tcpSndUna = tcpAckNum hdr - , tcpTimers = calibrate (tcpTimers tcp) - } - Nothing -> tcp - --- | Setup the 2MSL timer, and enter the TIME_WAIT state. We only enter --- TimeWait if all of our sent data has been ACKed, so it's safe to clear out --- the retransmit queue here. -enterTimeWait :: Sock () -enterTimeWait = do - modifyTcpSocket_ $ \ tcp -> tcp { tcpOut = clearRetransmit (tcpOut tcp) } - set2MSL mslTimeout - setState TimeWait - -createConnection :: IP4 -> TcpHeader -> Sock TcpSocket -createConnection ip4 hdr = - do let parent = listenSocketId (tcpDestPort hdr) - isn <- inTcp initialSeqNum - tcp <- getTcpSocket - return (emptyTcpSocket (tcpWindow hdr) (windowScale hdr)) - { tcpParent = Just parent - , tcpSocketId = incomingSocketId ip4 hdr - , tcpState = SynReceived - , tcpIss = isn - , tcpSndNxt = isn - , tcpSndUna = isn - , tcpIn = emptyLocalWindow (tcpSeqNum hdr) 14600 0 - , tcpOutMSS = fromMaybe defaultMSS (getMSS hdr) - , tcpTimestamp = do - -- require that the parent had a timestamp - ts <- tcpTimestamp tcp - -- require that they have sent us a timestamp, before using them - OptTimestamp val _ <- findTcpOption OptTagTimestamp hdr - return ts { tsLastTimestamp = val } - , tcpSack = sackSupported hdr - , tcpWindowScale = isJust (findTcpOption OptTagWindowScaling hdr) - } - -establishConnection :: Sock () -establishConnection = - do mb <- inParent popAcceptor - case join mb of - Just k -> do sid <- tcpSocketId `fmap` getTcpSocket - outputS (k sid) - setState Established - - -- no one available to accept the connection, close it - Nothing -> do finAck - setState FinWait1 - done - - --- Buffer Delivery ------------------------------------------------------------- - --- | Fill up the remote window with segments. -outputSegments :: Sock () -outputSegments = do - now <- inTcp time - (ws,segs) <- modifyTcpSocket (genSegments now) - F.mapM_ outputSegment segs - unless (null ws) (outputS (F.traverse_ tryAgain ws)) - - --- Utilities ------------------------------------------------------------------- - --- | Extract the maximum segment size from a header, if the option is present. -getMSS :: TcpHeader -> Maybe Int64 -getMSS hdr = do - OptMaxSegmentSize n <- findTcpOption OptTagMaxSegmentSize hdr - return (fromIntegral n) - -windowScale :: TcpHeader -> Int -windowScale hdr = fromMaybe 0 $ do - OptWindowScaling n <- findTcpOption OptTagWindowScaling hdr - return (fromIntegral n) - -sackSupported :: TcpHeader -> Bool -sackSupported = isJust . findTcpOption OptTagSackPermitted diff --git a/src/Hans/Layer/Tcp/Messages.hs b/src/Hans/Layer/Tcp/Messages.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Messages.hs +++ /dev/null @@ -1,264 +0,0 @@ -module Hans.Layer.Tcp.Messages where - -import Hans.Layer ( time ) -import Hans.Layer.Tcp.Monad -import Hans.Layer.Tcp.Types -import Hans.Layer.Tcp.Window -import Hans.Message.Tcp - -import Data.Maybe ( fromMaybe ) -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.ByteString.Lazy as L -import qualified Data.Foldable as F -import qualified Data.Sequence as Seq - - --- Generic Packets ------------------------------------------------------------- - -mkSegment :: TcpSocket -> TcpHeader -mkSegment tcp = case tcpTimestamp tcp of - Just ts -> setTcpOption (mkTimestamp ts) hdr - Nothing -> hdr - where - hdr = emptyTcpHeader - { tcpDestPort = sidRemotePort (tcpSocketId tcp) - , tcpSourcePort = sidLocalPort (tcpSocketId tcp) - , tcpSeqNum = tcpSndNxt tcp - , tcpAckNum = tcpRcvNxt tcp - -- XXX this doesn't really reflect the right number - , tcpWindow = lwRcvWind (tcpIn tcp) - } - -mkAck :: TcpSocket -> TcpHeader -mkAck tcp = addSackOption tcp - $ (mkSegment tcp) - { tcpAck = True - } - - --- Options --------------------------------------------------------------------- - --- | Add the Sack option to a tcp packet. -addSackOption :: TcpSocket -> TcpHeader -> TcpHeader -addSackOption sock - | tcpSack sock && not (null bs) = setTcpOption (OptSack bs) - | otherwise = id - where - bs = F.toList (localWindowSackBlocks (tcpIn sock)) - --- | Add the sack permitted tcp option. -addSackPermitted :: TcpSocket -> TcpHeader -> TcpHeader -addSackPermitted sock - | tcpSack sock = setTcpOption OptSackPermitted - | otherwise = id - --- | Add the window scale option on the outgoing header. -addWindowScale :: TcpSocket -> TcpHeader -> TcpHeader -addWindowScale sock - | tcpWindowScale sock = setTcpOption - $ OptWindowScaling - $ fromIntegral - $ lwRcvWindScale - $ tcpIn sock - | otherwise = id - - --- Connection Refusal ---------------------------------------------------------- - --- | Given a tcp header, generate the next header in the sequence that --- corresponds to the RST ACK response. As this should only be used in --- situations in which an ACK was not received, this adds one plus the body --- length to the ack number. -mkRstAck :: TcpHeader -> Int -> TcpHeader -mkRstAck hdr len = emptyTcpHeader - { tcpSeqNum = 0 - , tcpAckNum = tcpSeqNum hdr + fromIntegral len + 1 -- to ack their message - , tcpRst = True - , tcpAck = True - , tcpDestPort = tcpSourcePort hdr - , tcpSourcePort = tcpDestPort hdr - } - -mkRst :: TcpHeader -> TcpHeader -mkRst hdr = emptyTcpHeader - { tcpSeqNum = tcpAckNum hdr - , tcpRst = True - , tcpDestPort = tcpSourcePort hdr - , tcpSourcePort = tcpDestPort hdr - } - - --- Connection Establishment ---------------------------------------------------- - -mkSyn :: TcpSocket -> TcpHeader -mkSyn tcp = addSackPermitted tcp - $ addWindowScale tcp - $ setTcpOption (mkMSS tcp) - $ (mkSegment tcp) - { tcpSyn = True - , tcpAckNum = 0 - } - --- | Construct a SYN ACK packet, in response to a SYN. -mkSynAck :: TcpSocket -> TcpHeader -mkSynAck tcp = addSackPermitted tcp - $ addWindowScale tcp - $ setTcpOption (mkMSS tcp) - $ (mkSegment tcp) - { tcpSyn = True - , tcpAck = True - } - - --- Connection Closing ---------------------------------------------------------- - --- | Construct a FIN packet. --- --- XXX should this include a sack option? -mkFinAck :: TcpSocket -> TcpHeader -mkFinAck tcp = (mkSegment tcp) - { tcpFin = True - , tcpAck = True - } - - --- Data Packets ---------------------------------------------------------------- - -mkData :: TcpSocket -> TcpHeader -mkData tcp = addSackOption tcp - $ (mkSegment tcp) - { tcpAck = True - , tcpPsh = True - } - - --- Socket Actions -------------------------------------------------------------- - -syn :: Sock () -syn = do - tcp <- getTcpSocket - tcpOutput (mkSyn tcp) L.empty - advanceSndNxt 1 - --- | Respond to a SYN message with a SYN ACK message. -synAck :: Sock () -synAck = do - advanceRcvNxt 1 - tcp <- getTcpSocket - tcpOutput (mkSynAck tcp) L.empty - advanceSndNxt 1 - --- | Send an ACK packet. -ack :: Sock () -ack = do - clearDelayedAck - tcp <- getTcpSocket - tcpOutput (mkAck tcp) L.empty - --- | Schedule a delayed ACK packet. -delayedAck :: Sock () -delayedAck = modifyTcpTimers_ (\tt -> tt { ttDelayedAck = True }) - --- | Unschedule a delayed ACK packet. -clearDelayedAck :: Sock () -clearDelayedAck = modifyTcpTimers_ (\tt -> tt { ttDelayedAck = False }) - --- | Queue an outgoing fin packet in the outgoing window, and send it. --- --- NOTE: This uses genSegments, which will pull data out of the waiti -finAck :: Sock () -finAck = do - now <- inTcp time - - seg <- modifyTcpSocket $ \ tcp -> - - let -- construct the outgoing FIN,ACK segment - hdr = mkFinAck tcp - finAckOutSeg = mkOutSegment now (ttRTO (tcpTimers tcp)) hdr L.empty - - -- push the FIN,ACK into the outgoing window - tcp' = tcp { tcpOut = addSegment finAckOutSeg (tcpOut tcp) - - -- advance SND.NXT over the FIN - , tcpSndNxt = tcpSndNxt tcp + 1 - } - - in (finAckOutSeg, tcp') - - outputSegment seg - clearDelayedAck - -rstAck :: TcpHeader -> Int -> Sock () -rstAck hdr len = tcpOutput (mkRstAck hdr len) L.empty - -rst :: TcpHeader -> Sock () -rst hdr = tcpOutput (mkRst hdr) L.empty - --- | Send a segment. -outputSegment :: OutSegment -> Sock () -outputSegment seg = do - clearDelayedAck - tcpOutput (outHeader seg) (outBody seg) - - --- Flag Tests ------------------------------------------------------------------ - -type SetFlag = TcpHeader -> Bool -type UnsetFlag = TcpHeader -> Bool - -testFlags :: [SetFlag] -> [UnsetFlag] -> TcpHeader -> Bool -testFlags sfs ufs hdr = all test sfs && all (not . test) ufs - where - test prj = prj hdr - -isSyn :: TcpHeader -> Bool -isSyn = testFlags [ tcpSyn ] - [ tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpFin ] - -isSynAck :: TcpHeader -> Bool -isSynAck = testFlags [ tcpSyn, tcpAck ] - [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpFin ] - -isRstAck :: TcpHeader -> Bool -isRstAck = testFlags [ tcpRst, tcpAck ] - [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpSyn, tcpFin ] - -isAck :: TcpHeader -> Bool -isAck = testFlags [ tcpAck ] - [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpSyn, tcpFin ] - -isFin :: TcpHeader -> Bool -isFin = testFlags [ tcpFin ] - [ tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpSyn ] - -isFinAck :: TcpHeader -> Bool -isFinAck = testFlags [ tcpFin, tcpAck ] - [ tcpCwr, tcpEce, tcpUrg, tcpPsh, tcpRst, tcpSyn ] - - --- Packet Output --------------------------------------------------------------- - --- | Take data from the output buffer, and turn it into segments. When data was --- freed from the output buffer, the wakeup actions for any threads currently --- blocked on writing to the output buffer will be returned. -genSegments :: POSIXTime -> TcpSocket -> (([Wakeup],OutSegments),TcpSocket) -genSegments now tcp0 = loop [] Seq.empty tcp0 - where - loop ws segs tcp - | rwAvailable (tcpOut tcp) <= 0 = result - | otherwise = fromMaybe result $ do - let len = nextSegSize tcp - (mbWakeup,body,bufOut) <- takeBytes len (tcpOutBuffer tcp) - let seg = mkOutSegment now (ttRTO (tcpTimers tcp)) (mkData tcp) body - tcp' = tcp { tcpSndNxt = outAckNum seg - , tcpOut = addSegment seg (tcpOut tcp) - , tcpOutBuffer = bufOut - } - - return (loop (addWakeup mbWakeup) (segs Seq.|> seg) tcp') - where - - addWakeup Nothing = ws - addWakeup (Just w) = w:ws - - result = ((ws,segs),tcp) diff --git a/src/Hans/Layer/Tcp/Monad.hs b/src/Hans/Layer/Tcp/Monad.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Monad.hs +++ /dev/null @@ -1,473 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiWayIf #-} - -module Hans.Layer.Tcp.Monad where - -import Hans.Address.IP4 -import Hans.Channel -import Hans.Layer -import Hans.Layer.IP4 -import Hans.Layer.Tcp.Types -import Hans.Layer.Tcp.Window -import Hans.Message.Ip4 -import Hans.Message.Tcp - -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 - - --- TCP Monad ------------------------------------------------------------------- - -type TcpHandle = Channel (Tcp ()) - -type Tcp = Layer TcpState - -data TcpState = TcpState - { tcpSelf :: {-# UNPACK #-} !TcpHandle - , tcpIP4 :: {-# UNPACK #-} !IP4Handle - , tcpHost :: !Host - } - -emptyTcpState :: TcpHandle -> IP4Handle -> POSIXTime -> TcpState -emptyTcpState tcp ip4 start = TcpState - { tcpSelf = tcp - , tcpIP4 = ip4 - , tcpHost = emptyHost start - } - --- | The handle to this layer. -self :: Tcp TcpHandle -self = tcpSelf `fmap` get - --- | Get the handle to the IP4 layer. -ip4Handle :: Tcp IP4Handle -ip4Handle = tcpIP4 `fmap` get - - --- Host Operations ------------------------------------------------------------- - -getHost :: Tcp Host -getHost = tcpHost `fmap` get - -getLastUpdate :: Tcp POSIXTime -getLastUpdate = hostLastUpdate `fmap` getHost - -setHost :: Host -> Tcp () -setHost host = do - rw <- get - host `seq` set rw { tcpHost = host } - -modifyHost_ :: (Host -> Host) -> Tcp () -modifyHost_ f = do - host <- getHost - setHost (f host) - -modifyHost :: (Host -> (a,Host)) -> Tcp a -modifyHost f = do - host <- getHost - let (a,host') = f host - setHost host' - return a - --- | Reset the 2MSL timer on the socket in TimeWait. -resetTimeWait2MSL :: SocketId -> Tcp () -resetTimeWait2MSL sid = modifyHost_ $ \ host -> - host { hostTimeWaits = Map.adjust twReset2MSL sid (hostTimeWaits host) } - -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) - -removeTimeWait :: SocketId -> Tcp () -removeTimeWait sid = - modifyHost_ $ \ host -> - host { hostTimeWaits = Map.delete sid (hostTimeWaits host) } - -getConnections :: Tcp Connections -getConnections = hostConnections `fmap` getHost - -takeConnections :: Tcp Connections -takeConnections = - modifyHost $ \ Host { .. } -> - (hostConnections, Host { hostConnections = Map.empty, .. }) - -setConnections :: Connections -> Tcp () -setConnections cons = modifyHost_ (\host -> host { hostConnections = cons }) - --- | 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) - --- | 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 - --- | 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) - } - - | 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 r - } - -type Escape r = TcpSocket -> Tcp r -type Next a r = TcpSocket -> a -> Tcp r - -instance Functor Sock where - fmap f m = Sock $ \s x k -> unSock m s x - $ \s' a -> k s' (f a) - {-# INLINE fmap #-} - -instance Applicative Sock where - {-# INLINE pure #-} - 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 - {-# INLINE (>>=) #-} - - m >> n = Sock $ \ s x k -> unSock m s x - $ \ s' _ -> unSock n s' x k - {-# INLINE (>>) #-} - -inTcp :: Tcp a -> Sock a -inTcp m = Sock $ \ s _ k -> do a <- m - k s a -{-# INLINE inTcp #-} - - --- | Finish early, with no result. -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 (Maybe a) -runSock tcp sm = - do (tcp',mb) <- runSock' tcp sm - setConnection (tcpSocketId tcp') $! tcp' - return mb - -seqMaybe :: Maybe a -> () -seqMaybe (Just a) = a `seq` () -seqMaybe Nothing = () - --- | Run the socket action, and increment its internal timestamp value. Do not --- add it back to the connections map. -runSock' :: TcpSocket -> Sock a -> Tcp (TcpSocket,Maybe a) -runSock' tcp sm = do - now <- time - let steppedTcp = tcp { tcpTimestamp = - let ts' = stepTimestamp now `fmap` tcpTimestamp tcp - in seqMaybe ts' `seq` ts' - } - res@(tcp',_) <- (unSock sm $! steppedTcp) escapeK nextK - tcp' `seq` return res - where - escapeK s = return (s,Nothing) - nextK s a = return (s,Just a) - --- | Iterate for each connection, rolling back to its previous state if the --- computation fails. -eachConnection :: Sock () -> Tcp () -eachConnection m = - do cs <- takeConnections - (cs',ws) <- sandbox [] [] (Map.elems cs) - - modifyHost_ $ \ Host { .. } -> - Host { hostConnections = cs' - , hostTimeWaits = Map.union ws hostTimeWaits - , .. - } - - where - - -- Prevent failure in the socket action from leaking out of this scope. When - -- failure is detected, just return the old TCB - sandbox active timeWait (tcp:rest) = - do tcp' <- fmap fst (runSock' tcp m) `mplus` return tcp - - if | tcpState tcp' == TimeWait -> sandbox active (tcp':timeWait) rest - | tcpState tcp' == Closed - && tcpUserClosed tcp' -> sandbox active timeWait rest - | otherwise -> sandbox (tcp':active) timeWait rest - - sandbox active timeWait [] = - return ( Map.fromList [ (tcpSocketId tcp, tcp) | tcp <- active ] - , Map.fromList [ (tcpSocketId tcp, mkTimeWait tcp) | tcp <- timeWait ]) - -withConnection :: IP4 -> TcpHeader -> Sock a -> Tcp () -withConnection remote hdr m = withConnection' remote hdr m mzero - -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) -{-# INLINE getTcpSocket #-} - -setTcpSocket :: TcpSocket -> Sock () -setTcpSocket tcp = Sock (\ _ _ k -> (k $! tcp) ()) -{-# INLINE setTcpSocket #-} - -getTcpTimers :: Sock TcpTimers -getTcpTimers = tcpTimers `fmap` getTcpSocket - -modifyTcpSocket :: (TcpSocket -> (a,TcpSocket)) -> Sock a -modifyTcpSocket f = Sock $ \ s _ k -> let (a,s') = f s - in (k $! s') a - -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) = flushWaiting (tcpOutBuffer tcp) - (wIn,bufIn) = flushWaiting (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 - -userClose :: Sock () -userClose = modifyTcpSocket_ (\tcp -> tcp { tcpUserClosed = True }) diff --git a/src/Hans/Layer/Tcp/Socket.hs b/src/Hans/Layer/Tcp/Socket.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Socket.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Hans.Layer.Tcp.Socket ( - Socket() - , 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.Layer.Tcp.Types -import Hans.Layer.Tcp.Window -import Hans.Message.Tcp - -import Control.Concurrent (MVar,newEmptyMVar,takeMVar,putMVar) -import Control.Exception (Exception,throwIO) -import Control.Monad (mplus) -import Data.Int (Int64) -import Data.Maybe (isJust) -import Data.Typeable (Typeable) -import qualified Data.ByteString.Lazy as L - - --- Socket Interface ------------------------------------------------------------ - -data Socket = Socket - { sockHandle :: !TcpHandle - , sockId :: !SocketId - } - --- | The remote host of a socket. -sockRemoteHost :: Socket -> IP4 -sockRemoteHost = sidRemoteHost . sockId - --- | The remote port of a socket. -sockRemotePort :: Socket -> TcpPort -sockRemotePort = sidRemotePort . sockId - --- | The local port of a socket. -sockLocalPort :: Socket -> TcpPort -sockLocalPort = sidLocalPort . sockId - -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 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 e -> throwIO e - - --- 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 + 1 - , tcpSndUna = isn - , tcpIss = 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 - - 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 - } - - Just _ -> output (putMVar res (socketError ListenError)) - - --- Accept ---------------------------------------------------------------------- - -data AcceptError = AcceptError - deriving (Show,Typeable) - -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 - } - - -- XXX need more descriptive errors - _ -> outputS (putMVar res (socketError AcceptError)) - - --- Close ----------------------------------------------------------------------- - -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 LastAck - 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) - - - --- 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 = ok - | tcpState tcp == CloseWait = ok - | tcpState tcp `elem` [ Closing, LastAck - , FinWait1, FinWait2 - , TimeWait ] = bad - | otherwise = bad - where - (mbWritten,bufOut) = writeBytes bytes wakeup (tcpOutBuffer tcp) - - -- normal response (add the data to the output buffer, or queue if there's no - -- space available) - ok = (mbWritten, tcp { tcpOutBuffer = bufOut }) - - -- the connection is closed, so return that no data was written, and don't - -- queue a wakeup action - bad = (Just 0, tcp) - - --- Reading --------------------------------------------------------------------- - --- | True when there are bytes queued to receive. -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 - | tcpState tcp == Established = ok - | tcpState tcp == CloseWait = if isJust mbRead - then ok - else bad - | tcpState tcp `elem` [ Closing, LastAck, TimeWait ] = bad - | otherwise = ok - - where - (mbRead,bufIn) = readBytes len wakeup (tcpInBuffer tcp) - - -- normal behavior (read buffered data, or queue) - ok = (mbRead, tcp { tcpInBuffer = bufIn }) - - -- return that there's no data to read, and don't queue a wakeup action - bad = (Just L.empty, tcp) diff --git a/src/Hans/Layer/Tcp/Timers.hs b/src/Hans/Layer/Tcp/Timers.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Timers.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Hans.Layer.Tcp.Timers ( - initTimers - - , resetIdle - , whenIdleFor - - , set2MSL - - , calibrateRTO - ) where - -import Hans.Channel -import Hans.Layer.Tcp.Messages -import Hans.Layer.Tcp.Monad -import Hans.Layer.Tcp.Types -import Hans.Layer.Tcp.Window - -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 the timers to run on the fast and slow intervals. -initTimers :: TcpHandle -> IO () -initTimers tcp = do - every 500 slowTimer - every 200 fastTimer - - where - - -- XXX we should investigate timing the time that body takes to run, and - -- making the decision about how long to delay based on that. - every n body = void $ forkIO $ forever $ - do threadDelay timeout - send tcp body - where - timeout = n * 1000 - --- | Fires every 500ms. -slowTimer :: Tcp () -slowTimer = - do -- first, handle active connections - eachConnection $ do - -- the slow timer is valid for all states but TimeWait; the check is done - -- here because the socket may have only just transitioned to TimeWait, - -- and hasn't been moved to hostTimeWaits yet. - TcpSocket { .. } <- getTcpSocket - unless (tcpState == TimeWait) handleRTO - handle2MSL - updateTimers - - -- second, decrement the 2MSL timer for sockets in the TimeWait state - modifyHost_ $ \ host -> - 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 - --- RTO ------------------------------------------------------------------------- - --- | Update segments in the outgoing window, decrementing their RTO timers, and --- retransmitting them if it expires. -handleRTO :: Sock () -handleRTO = do - s <- getState - when (s /= Closed) (F.mapM_ outputSegment =<< modifyTcpSocket update) - where - update tcp = (segs,tcp { tcpOut = win' }) - where - (segs,win') = genRetransmitSegments (tcpOut tcp) - --- | Calibrate the RTO timer, as specified by RFC-6298. -calibrateRTO :: POSIXTime -> POSIXTime -> TcpTimers -> TcpTimers -calibrateRTO sent ackd tt - | ttSRTT tt == 0 = initial - | otherwise = rolling - where - - -- round trip measurement - r = ackd - sent - - -- no data has been sent before, seed the RTO values. - initial = updateRTO tt - { ttSRTT = r - , ttRTTVar = r / 2 - } - - -- data has been sent, update based on previous values - alpha = 0.125 - beta = 0.25 - rttvar = (1 - beta) * ttRTTVar tt + beta * abs (ttSRTT tt * r) - srtt = (1 - alpha) * ttSRTT tt + alpha * r - rolling = updateRTO tt - { ttRTTVar = rttvar - , ttSRTT = srtt - } - - -- update the RTO timer length, bounding it at 64 seconds (128 ticks) - updateRTO tt' = tt' - { ttRTO = min 128 (ceiling (ttSRTT tt' + max 0.5 (2 * ttRTTVar tt'))) - } diff --git a/src/Hans/Layer/Tcp/Types.hs b/src/Hans/Layer/Tcp/Types.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Types.hs +++ /dev/null @@ -1,304 +0,0 @@ -{-# 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 :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !TcpPort - , sidRemotePort :: {-# UNPACK #-} !TcpPort - , sidRemoteHost :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !SlowTicks - -- ^ The current 2MSL value - , twInit2MSL :: {-# UNPACK #-} !SlowTicks - -- ^ The initial 2MSL value - , twSeqNum :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !SlowTicks - - -- retransmit timer - , ttRTO :: {-# UNPACK #-} !SlowTicks - , ttSRTT :: !POSIXTime - , ttRTTVar :: !POSIXTime - - -- idle timer - , ttMaxIdle :: {-# UNPACK #-} !SlowTicks - , ttIdle :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !Word32 - , tsLastTimestamp :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !SocketId - , tcpState :: !ConnState - , tcpAcceptors :: !(Seq.Seq Acceptor) - , tcpNotify :: !(Maybe Notify) - , tcpIss :: {-# UNPACK #-} !TcpSeqNum - , tcpSndNxt :: {-# UNPACK #-} !TcpSeqNum - , tcpSndUna :: {-# UNPACK #-} !TcpSeqNum - - , tcpUserClosed :: !Bool - , tcpOut :: !RemoteWindow - , tcpOutBuffer :: !(Buffer Outgoing) - , tcpOutMSS :: {-# UNPACK #-} !Int64 - , tcpIn :: !LocalWindow - , tcpInBuffer :: !(Buffer Incoming) - , tcpInMSS :: {-# UNPACK #-} !Int64 - - , tcpTimers :: {-# UNPACK #-} !TcpTimers - , tcpTimestamp :: !(Maybe Timestamp) - - , tcpSack :: !Bool - , tcpWindowScale :: !Bool - } - -emptyTcpSocket :: Word16 -> Int -> TcpSocket -emptyTcpSocket sendWindow sendScale = TcpSocket - { tcpParent = Nothing - , tcpSocketId = emptySocketId - , tcpState = Closed - , tcpAcceptors = Seq.empty - , tcpNotify = Nothing - , tcpIss = 0 - , tcpSndNxt = 0 - , tcpSndUna = 0 - - , tcpUserClosed = False - , tcpOut = emptyRemoteWindow sendWindow sendScale - , tcpOutBuffer = emptyBuffer 16384 - , tcpOutMSS = defaultMSS - , tcpIn = emptyLocalWindow 0 14600 0 - , tcpInBuffer = emptyBuffer 16384 - , tcpInMSS = defaultMSS - - , tcpTimers = emptyTcpTimers - , tcpTimestamp = Nothing - - , tcpSack = True - , tcpWindowScale = True - } - -defaultMSS :: Int64 -defaultMSS = 1460 - -nothingOutstanding :: TcpSocket -> Bool -nothingOutstanding TcpSocket { .. } = tcpSndUna == tcpSndNxt - -tcpRcvNxt :: TcpSocket -> TcpSeqNum -tcpRcvNxt = lwRcvNxt . tcpIn - -inRcvWnd :: TcpSeqNum -> TcpSocket -> Bool -inRcvWnd (TcpSeqNum sn) TcpSocket { .. } = - rcvNxt <= sn && sn < rcvNxt + fromIntegral (lwRcvWind tcpIn) - where - TcpSeqNum rcvNxt = lwRcvNxt tcpIn - -nextSegSize :: TcpSocket -> Int64 -nextSegSize tcp = - min (fromIntegral (rwAvailable (tcpOut tcp))) (tcpOutMSS tcp) - -isAccepting :: TcpSocket -> Bool -isAccepting = not . Seq.null . tcpAcceptors - -needsDelayedAck :: TcpSocket -> Bool -needsDelayedAck = ttDelayedAck . tcpTimers - -mkMSS :: TcpSocket -> TcpOption -mkMSS tcp = OptMaxSegmentSize (fromIntegral (tcpInMSS tcp)) - -data ConnState - = Closed - | Listen - | SynSent - | SynReceived - | Established - | CloseWait - | FinWait1 - | FinWait2 - | Closing - | LastAck - | TimeWait - deriving (Show,Eq,Ord) diff --git a/src/Hans/Layer/Tcp/WaitBuffer.hs b/src/Hans/Layer/Tcp/WaitBuffer.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/WaitBuffer.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} - -module Hans.Layer.Tcp.WaitBuffer ( - -- * Delayed work - Wakeup - , tryAgain - , abort - - -- * Directions - , Incoming, Outgoing - - -- * Directed Buffers - , Buffer - , emptyBuffer - , 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 :: {-# UNPACK #-} !Int64 - , bufAvailable :: {-# UNPACK #-} !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') - - --- Sending Buffer -------------------------------------------------------------- - --- | Queue bytes in an outgoing buffer. When there's no space available in the --- buffer, the wakeup action is queued. -writeBytes :: L.ByteString -> Wakeup -> Buffer Outgoing - -> (Maybe Int64,Buffer Outgoing) -writeBytes bytes wakeup buf = case queueBytes bytes buf of - (Nothing,buf') -> (Nothing,queueWaiting wakeup buf') - res -> res - --- | Take bytes off of a sending queue, making room new data. -takeBytes :: Int64 -> Buffer Outgoing - -> Maybe (Maybe Wakeup,L.ByteString,Buffer Outgoing) -takeBytes len buf = do - (bytes,buf') <- removeBytes len buf - case Seq.viewl (bufWaiting buf') of - Seq.EmptyL -> return (Nothing, bytes, buf') - w Seq.:< ws -> return (Just w, bytes, buf' { bufWaiting = ws }) - - --- Receiving Buffer ------------------------------------------------------------ - --- | Read bytes from an incoming buffer, queueing if there are no bytes to read. -readBytes :: Int64 -> Wakeup -> Buffer Incoming - -> (Maybe L.ByteString, Buffer Incoming) -readBytes len wakeup buf = - case removeBytes len buf of - Just (bytes,buf') -> (Just bytes, buf') - Nothing -> (Nothing, queueWaiting wakeup buf) - --- | Place bytes on the incoming buffer, provided that there is enough space for --- all of the bytes. -putBytes :: L.ByteString -> Buffer Incoming - -> Maybe (Maybe Wakeup,Buffer Incoming) -putBytes bytes buf = do - let needed = L.length bytes + L.length (bufBytes buf) - guard (needed < bufSize buf) - let buf' = buf { bufBytes = bufBytes buf `L.append` bytes } - case Seq.viewl (bufWaiting buf') of - Seq.EmptyL -> return (Nothing, buf') - w Seq.:< ws -> return (Just w, buf' { bufWaiting = ws }) diff --git a/src/Hans/Layer/Tcp/Window.hs b/src/Hans/Layer/Tcp/Window.hs deleted file mode 100644 --- a/src/Hans/Layer/Tcp/Window.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-# 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 :: {-# UNPACK #-} !Word32 - , rwSize :: {-# UNPACK #-} !Word32 - , rwSndWind :: {-# UNPACK #-} !Word16 - , rwSndWindScale :: {-# UNPACK #-} !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 :: {-# UNPACK #-} !TcpSeqNum - , outTime :: !POSIXTime - , outFresh :: !Bool -- ^ Whether or not this is a retransmission - , outRTO :: {-# UNPACK #-} !Int -- ^ Retransmit timer for this segment - , outHeader :: !TcpHeader - , outBody :: !L.ByteString - } deriving (Show) - -mkOutSegment :: POSIXTime -> Int -> TcpHeader -> L.ByteString -> OutSegment -mkOutSegment created rto hdr body = - OutSegment { outAckNum = tcpSeqNum hdr + outSize' hdr body - , outTime = created - , outFresh = True - , outRTO = rto - , outHeader = hdr - , outBody = body - } - -ctlLength :: Num len => Bool -> len -ctlLength True = 1 -ctlLength False = 0 - -outSize :: Num a => OutSegment -> a -outSize OutSegment { .. } = outSize' outHeader outBody - --- | The size of a segment body. -outSize' :: Num a => TcpHeader -> L.ByteString -> a -outSize' TcpHeader { .. } body = fromIntegral (L.length body) - + ctlLength tcpSyn - + ctlLength tcpFin - - --- | Decrement the RTO value on a segment by the timer granularity (500ms). --- Once the RTO value dips below 1, mark the segment as no longer fresh. -decrementRTO :: OutSegment -> OutSegment -decrementRTO seg - | outRTO seg' <= 0 = seg' { outFresh = False } - | otherwise = seg' - where - seg' = seg { outRTO = outRTO seg - 1 } - - --- Local Window ---------------------------------------------------------------- - --- | Local window, containing a buffer of incoming packets, indexed by their --- sequence number, relative to RCV.NXT. --- --- XXX make this respect the values of size and available -data LocalWindow = LocalWindow - { lwBuffer :: Seq.Seq InSegment - , lwRcvNxt :: !TcpSeqNum - , lwAvailable :: !Word32 - , lwSize :: !Word32 - , lwRcvWind :: !Word16 - , lwRcvWindScale :: !Int - } deriving (Show) - --- | Empty local buffer, with an initial sequence number as the next expected --- sequence number. -emptyLocalWindow :: TcpSeqNum -> Word16 -> Int -> LocalWindow -emptyLocalWindow sn size scale = refreshLocalWindow $! LocalWindow - { lwBuffer = Seq.empty - , lwRcvNxt = sn - , lwAvailable = 0 - , lwSize = 0 - , lwRcvWind = size - , lwRcvWindScale = scale - } - --- | Produce a sequence of blocks for the sack option. -localWindowSackBlocks :: LocalWindow -> Seq.Seq SackBlock -localWindowSackBlocks lw = case Seq.viewl (fmap mkSackBlock (lwBuffer lw)) of - b Seq.:< rest -> uncurry (Seq.|>) (F.foldl step (Seq.empty,b) rest) - Seq.EmptyL -> Seq.empty - where - step (bs,b) b' - | sbRight b == sbLeft b' = (bs,b { sbRight = sbRight b' }) - | otherwise = (bs Seq.|> b, b') - --- | Recalculate internal constants. -refreshLocalWindow :: LocalWindow -> LocalWindow -refreshLocalWindow lw = lw - { lwSize = fromIntegral (lwRcvWind lw) `shiftL` lwRcvWindScale lw - } - --- | Update the size of the remote window. -setRcvNxt :: TcpSeqNum -> LocalWindow -> LocalWindow -setRcvNxt sn lw = lw { lwRcvNxt = sn } - --- | Add a sequence number to the value of Rcv.Nxt. -addRcvNxt :: TcpSeqNum -> LocalWindow -> LocalWindow -addRcvNxt sn win = win { lwRcvNxt = lwRcvNxt win + sn } - --- | Set the Rcv.Wind variable for the local window. -setRcvWind :: Word16 -> LocalWindow -> LocalWindow -setRcvWind size lw = refreshLocalWindow $! lw - { lwRcvWind = size - } - --- | Set the Rcv.Wind.Scale variable in the local window. -setRcvWindScale :: Int -> LocalWindow -> LocalWindow -setRcvWindScale scale lw = refreshLocalWindow $! lw - { lwRcvWindScale = scale - } - --- | Process an incoming packet that needs to pass through the incoming queue. -incomingPacket :: TcpHeader -> S.ByteString -> LocalWindow - -> (Seq.Seq InSegment, LocalWindow) -incomingPacket hdr body win = stepWindow (addInSegment hdr body win) - --- | Queue an incoming packet in the incoming window. -addInSegment :: TcpHeader -> S.ByteString -> LocalWindow -> LocalWindow -addInSegment hdr body win = win { lwBuffer = insert (lwBuffer win) } - where - seg = mkInSegment (lwRcvNxt win) hdr body - insert buf = case Seq.viewl buf of - a Seq.:< rest -> case compare (inRelSeqNum a) (inRelSeqNum seg) of - LT -> a Seq.<| insert rest - EQ -> seg Seq.<| rest - GT -> seg Seq.<| buf - Seq.EmptyL -> Seq.singleton seg - --- | Advance the window, if there are packets available to be returned. -stepWindow :: LocalWindow -> (Seq.Seq InSegment, LocalWindow) -stepWindow = loop 0 Seq.empty - where - loop expect segs win = case Seq.viewl (lwBuffer win) of - a Seq.:< rest | inRelSeqNum a == expect -> keep a segs rest win - | otherwise -> finalize segs win - Seq.EmptyL -> finalize segs win - - keep seg segs rest win = loop (inRelSeqNum seg + len) (segs Seq.|> seg) win - { lwBuffer = rest - , lwRcvNxt = lwRcvNxt win + len - } - where - len = fromIntegral (S.length (inBody seg)) - - finalize segs win = (segs,win { lwBuffer = update `fmap` lwBuffer win }) - where - len = F.sum (inLength `fmap` segs) - update is = is { inRelSeqNum = inRelSeqNum is - len } - -data InSegment = InSegment - { inRelSeqNum :: !TcpSeqNum - , inHeader :: !TcpHeader - , inBody :: !S.ByteString - } deriving (Show) - -inSeqNum :: InSegment -> TcpSeqNum -inSeqNum = tcpSeqNum . inHeader - -inLength :: Num a => InSegment -> a -inLength = fromIntegral . S.length . inBody - --- | Generate an incoming segment, relative to the value of RCV.NXT -mkInSegment :: TcpSeqNum -> TcpHeader -> S.ByteString -> InSegment -mkInSegment rcvNxt hdr body = InSegment - { inRelSeqNum = rel - , inHeader = hdr - , inBody = body - } - where - -- calculate the index, relative to RCV.NXT, taking sequence number wrap into - -- account - rel | tcpSeqNum hdr < rcvNxt = maxBound - rcvNxt + tcpSeqNum hdr + 1 - | otherwise = tcpSeqNum hdr - rcvNxt - -mkSackBlock :: InSegment -> SackBlock -mkSackBlock is = SackBlock - { sbLeft = sn - , sbRight = sn + fromIntegral (S.length (inBody is)) - } - where - sn = tcpSeqNum (inHeader is) diff --git a/src/Hans/Layer/Udp.hs b/src/Hans/Layer/Udp.hs deleted file mode 100644 --- a/src/Hans/Layer/Udp.hs +++ /dev/null @@ -1,211 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# 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.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,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 -> S.ByteString -> IO () - -type UdpHandle = Channel (Udp ()) - -data UdpException = NoPortsAvailable - | PortInUse UdpPort - deriving (Show,Typeable) - -instance X.Exception UdpException - -runUdpLayer :: UdpHandle -> IP4.IP4Handle -> Icmp4.Icmp4Handle -> IO () -runUdpLayer h ip4 icmp4 = do - IP4.addIP4Handler ip4 udpProtocol (queueUdp h) - void (forkIO (loopLayer "udp" (emptyUdp4State ip4 icmp4) (receive h) id)) - --- | 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 - - 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 = 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 $ do freePort sp - removeHandler sp - - --- Udp State ------------------------------------------------------------------- - -type Udp = Layer UdpState - -data UdpState = UdpState - { udpPorts :: !(PortManager UdpPort) - , udpHandlers :: !(Handlers UdpPort Handler) - , udpIp4Handle :: {-# UNPACK #-} !IP4.IP4Handle - , udpIcmp4Handle :: {-# UNPACK #-} !Icmp4.Icmp4Handle - } - -emptyUdp4State :: IP4.IP4Handle -> Icmp4.Icmp4Handle -> UdpState -emptyUdp4State ip4 icmp4 = UdpState - { udpPorts = emptyPortManager [maxBound, maxBound - 1 .. 1 ] - , udpHandlers = emptyHandlers - , udpIp4Handle = ip4 - , udpIcmp4Handle = icmp4 - } - -instance ProvidesHandlers UdpState UdpPort Handler where - getHandlers = udpHandlers - setHandlers hs s = s { udpHandlers = hs } - - --- Utilities ------------------------------------------------------------------- - -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 Icmp4.Icmp4Handle -icmp4Handle = udpIcmp4Handle `fmap` get - -allocPort :: Udp (Either UdpException UdpPort) -allocPort = modifyPortManager $ \pm -> - case nextPort pm of - Just (p,pm') -> (Right p,pm') - Nothing -> (Left NoPortsAvailable,pm) - -reservePort :: UdpPort -> Udp (Maybe UdpException) -reservePort sp = modifyPortManager $ \ pm -> - case reserve sp pm of - Just pm' -> (Nothing,pm') - Nothing -> (Just (PortInUse sp), pm) - -freePort :: UdpPort -> Udp () -freePort sp = modifyPortManager $ \ pm -> - case unreserve sp pm of - Just pm' -> ((), pm') - Nothing -> ((), pm ) - - --- Message Handling ------------------------------------------------------------ - -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 () - --- | 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 hdr = UdpHeader sp dp 0 - output $ IP4.withIP4Source ip4 dst $ \ src -> do - let ip4Hdr = emptyIP4Header - { ip4DestAddr = dst - , ip4Protocol = udpProtocol - , ip4DontFragment = False - } - pkt <- renderUdpPacket hdr bs (mkIP4PseudoHeader src dst udpProtocol) - IP4.sendIP4Packet ip4 ip4Hdr pkt diff --git a/src/Hans/Lens.hs b/src/Hans/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Lens.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveFunctor #-} + +module Hans.Lens ( + + -- * Lenses + Lens, Lens', + lens, + + -- ** Getters + Getting, + Getter, + view, + to, + + -- ** Setters + ASetter, ASetter', + set, + over, + modify, + + -- * Utility Lenses + bit, + byte, + + ) where + +import qualified Control.Applicative as A +import qualified Data.Bits as B +import Data.Word (Word8) +import MonadLib (Id,runId) + + +-- Lenses ---------------------------------------------------------------------- + +-- | General lenses that allow for the type of the inner field to change. +type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t) + +-- | Lenses that don't change type. +type Lens' s a = Lens s s a a + +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens get upd = \ f s -> upd s `fmap` f (get s) +{-# INLINE lens #-} + + +-- Getters --------------------------------------------------------------------- + +type Getting r s a = (a -> Const r a) -> (s -> Const r s) + +type Getter s a = forall r. Getting r s a + +newtype Const r a = Const { runConst :: r } deriving Functor + +-- | This is just a handy way of not exposing a Contrafunctor class, as we only +-- really need it for the definition of `to`. +castConst' :: (b -> a) -> Const r a -> Const r b +castConst' _ (Const r) = Const r +{-# INLINE castConst' #-} + +-- NOTE: the @(s -> a)@ part could be generalized to @ReaderM m s@. +view :: Getting a s a -> s -> a +view l = \ s -> runConst (l Const s) +{-# INLINE view #-} + +to :: (s -> a) -> Getting r s a +to f = \ l s -> castConst' f (l (f s)) +{-# INLINE to #-} + + +-- Setters --------------------------------------------------------------------- + +type ASetter s t a b = (a -> Id b) -> (s -> Id t) + +type ASetter' s a = ASetter s s a a + +set :: Lens s t a b -> b -> s -> t +set l b = \ s -> runId (l (\ _ -> A.pure b) s) +{-# INLINE set #-} + +over :: ASetter s t a b -> (a -> b) -> (s -> t) +over l f = \ s -> runId (l (A.pure . f) s) +{-# INLINE over #-} + +newtype Modify r a = Modify { runModify :: (a,r) } + +instance Functor (Modify r) where + fmap f = \ (Modify (a,r)) -> Modify (f a, r) + {-# INLINE fmap #-} + +modify :: Lens s t a b -> (a -> (b,r)) -> (s -> (t,r)) +modify l f = \ s -> runModify (l (\ a -> Modify (f a)) s) +{-# INLINE modify #-} + + +-- Utility Lenses -------------------------------------------------------------- + +-- NOTE: successive uses of 'bit' with 'set' will cause terms like this to build +-- up: +-- +-- > or# (or# .. (or# val (__word m1)) .. (__word mi)) (__word mj) +-- +-- This can be fixed with a rewrite rule that associates all uses of or# to the +-- right, but this seems like it might block other simplifications that would +-- have fired if it was associated to the left. +-- +-- The real problem here is that GHC isn't reorganizing the uses of or# to group +-- together constants, which would allow only one final use of or# after +-- simplification. +bit :: B.Bits a => Int -> Lens' a Bool +bit n = lens get upd + where + get a = B.testBit a n + + upd a True = B.setBit a n + upd a False = B.clearBit a n + + +byte :: (Integral a, B.Bits a) => Int -> Lens' a Word8 +byte n = lens get upd + where + sh = n * 8 + + get a = fromIntegral (a `B.shiftR` sh) + + upd a b = a B..|. (fromIntegral b `B.shiftL` sh) diff --git a/src/Hans/Message/Arp.hs b/src/Hans/Message/Arp.hs deleted file mode 100644 --- a/src/Hans/Message/Arp.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Hans.Message.Arp where - -import Hans.Address (Address(addrSize)) -import Hans.Utils (chunk) - -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 ----------------------------------------------------------------- - -data ArpPacket hw p = ArpPacket - { arpHwType :: !Word16 - , arpPType :: !Word16 - , arpOper :: ArpOper - , arpSHA :: hw - , arpSPA :: p - , arpTHA :: hw - , arpTPA :: p - } deriving (Show) - --- | 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 - --- | 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 (Show,Eq) - --- | Parse an Arp operation. -parseArpOper :: Get ArpOper -parseArpOper = do - b <- getWord16be - case b of - 0x1 -> return ArpRequest - 0x2 -> return ArpReply - _ -> fail "invalid Arp opcode" - --- | Render an Arp operation. -renderArpOper :: Putter ArpOper -renderArpOper op = case op of - ArpRequest -> putWord16be 0x1 - ArpReply -> putWord16be 0x2 diff --git a/src/Hans/Message/Dhcp4.hs b/src/Hans/Message/Dhcp4.hs deleted file mode 100644 --- a/src/Hans/Message/Dhcp4.hs +++ /dev/null @@ -1,575 +0,0 @@ -{- | The 'Hans.Message.Dhcp4' module defines the various messages and - transitions used in the DHCPv4 protocol. This module provides both - a high-level view of the message types as well as a low-level - intermediate form which is closely tied to the binary format. - - References: - RFC 2131 - Dynamic Host Configuration Protocol - http://www.faqs.org/rfcs/rfc2131.html --} -module Hans.Message.Dhcp4 - ( - -- ** High-level client types - RequestMessage(..) - , Request(..) - , Discover(..) - - -- ** High-level server types - , ServerSettings(..) - , ReplyMessage(..) - , Ack(..) - , Offer(..) - - -- ** Low-level message types - , Dhcp4Message(..) - , Xid(..) - - -- ** Server message transition logic - , requestToAck - , discoverToOffer - - -- ** Client message transition logic - , mkDiscover - , offerToRequest - - -- ** Convert high-level message types to low-level format - , requestToMessage - , ackToMessage - , offerToMessage - , discoverToMessage - - -- ** Convert low-level message type to high-level format - , parseDhcpMessage - - -- ** Convert low-level message type to binary format - , getDhcp4Message - , putDhcp4Message - - ) where - -import Hans.Address.IP4 (IP4(..)) -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, 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 --------------------------------------------- - --- |'ServerSettings' define all of the information that would be needed to --- act as a DHCP server for one client. The server is defined to be able to --- issue a single "lease" whose parameters are defined below. -data ServerSettings = Settings - { staticServerAddr :: IP4 -- ^ The IPv4 address of the DHCP server - , staticTimeOffset :: Word32 -- ^ Lease: timezone offset in seconds from UTC - , staticClientAddr :: IP4 -- ^ Lease: client IPv4 address on network - , staticLeaseTime :: Word32 -- ^ Lease: duration in seconds - , staticSubnet :: SubnetMask -- ^ Lease: subnet mask on network - , staticBroadcast :: IP4 -- ^ Lease: broadcast address on network - , staticRouters :: [IP4] -- ^ Lease: gateway routers on network - , staticDomainName :: String -- ^ Lease: client's assigned domain name - , staticDNS :: [IP4] -- ^ Lease: network DNS servers - } - deriving (Show) - --- Structured DHCP Messages ------------------------------------------------ - --- |'RequestMessage' is a sum of the client request messages. -data RequestMessage = RequestMessage Request - | DiscoverMessage Discover - deriving (Show) - --- |'ReplyMessage' is a sum of the server response messages. -data ReplyMessage = AckMessage Ack - | OfferMessage Offer - deriving (Show) - --- |'Request' is used by the client to accept an offered lease. -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 - } - deriving (Show) - --- |'Discover' is used by the client to discover what servers are available. --- This message is sent to the IPv4 broadcast. -data Discover = Discover - { discoverXid :: Xid -- ^ Transaction ID of this and subsequent messages - , discoverBroadcast :: Bool -- ^ Set 'True' to instruct the server to send to broadcast hardware address - , discoverClientHardwareAddr :: Mac -- ^ Hardware address of the client - , discoverParameters :: [Dhcp4OptionTag]-- ^ Used to specify the information that client needs in the offers - } - deriving (Show) - --- |'Ack' is sent by the DHCPv4 server to acknowledge a sucessful 'Request' --- message. Upon receiving this message the client has completed the --- exchange and has successfully obtained a lease. -data Ack = Ack - { ackHops :: Word8 -- ^ The maximum number of relays this message can use. - , ackXid :: Xid -- ^ Transaction ID for this exchange - , ackYourAddr :: IP4 -- ^ Lease: assigned client address - , ackServerAddr :: IP4 -- ^ DHCP server's IPv4 address - , ackRelayAddr :: IP4 -- ^ DHCP relay server's address - , ackClientHardwareAddr :: Mac -- ^ Client's hardware address - , ackLeaseTime :: Word32 -- ^ Lease: duration of lease in seconds - , ackOptions :: [Dhcp4Option] -- ^ Subset of information requested in previous 'Request' - } - deriving (Show) - --- |'Offer' is sent by the DHCPv4 server in response to a 'Discover'. --- This offer is only valid for a short period of time as the client --- might receive many offers. The client must next request a lease --- from a specific server using the information in that server's offer. -data Offer = Offer - { offerHops :: Word8 -- ^ The maximum number of relays this message can use. - , offerXid :: Xid -- ^ Transaction ID of this exchange - , offerYourAddr :: IP4 -- ^ The IPv4 address that this server is willing to lease - , offerServerAddr :: IP4 -- ^ The IPv4 address of the DHCPv4 server - , offerRelayAddr :: IP4 -- ^ The IPv4 address of the DHCPv4 relay server - , offerClientHardwareAddr :: Mac -- ^ The hardware address of the client - , offerOptions :: [Dhcp4Option] -- ^ The options that this server would include in a lease - } - deriving (Show) - --- |'requestToAck' creates 'Ack' messages suitable for responding to 'Request' --- messages given a static 'ServerSettings' configuration. -requestToAck :: ServerSettings -- ^ DHCPv4 server settings - -> Request -- ^ Client's request message - -> Ack -requestToAck settings request = Ack - { ackHops = 1 - , ackXid = requestXid request - , ackYourAddr = staticClientAddr settings - , ackServerAddr = staticServerAddr settings - , ackRelayAddr = staticServerAddr settings - , ackClientHardwareAddr = requestClientHardwareAddress request - , ackLeaseTime = staticLeaseTime settings - , ackOptions = mapMaybe lookupOption (requestParameters request) - } - where - lookupOption tag = case tag of - OptTagSubnetMask - -> Just (OptSubnetMask (staticSubnet settings)) - OptTagBroadcastAddress - -> Just (OptBroadcastAddress (staticBroadcast settings)) - OptTagTimeOffset - -> Just (OptTimeOffset (staticTimeOffset settings)) - OptTagRouters - -> Just (OptRouters (staticRouters settings)) - OptTagDomainName - -> Just (OptDomainName (NVTAsciiString (staticDomainName settings))) - OptTagNameServers - -> Just (OptNameServers (staticDNS settings)) - _ -> Nothing - --- |'discoverToOffer' creates a suitable 'Offer' in response to a client's --- 'Discover' message using the configuration settings specified in the --- given 'ServerSettings'. -discoverToOffer :: ServerSettings -- ^ DHCPv4 server settings - -> Discover -- ^ Client's discover message - -> Offer -discoverToOffer settings discover = Offer - { offerHops = 1 - , offerXid = discoverXid discover - , offerYourAddr = staticClientAddr settings - , offerServerAddr = staticServerAddr settings - , offerRelayAddr = staticServerAddr settings - , offerClientHardwareAddr = discoverClientHardwareAddr discover - , offerOptions = mapMaybe lookupOption (discoverParameters discover) - } - where - lookupOption tag = case tag of - OptTagSubnetMask - -> Just (OptSubnetMask (staticSubnet settings)) - OptTagBroadcastAddress - -> Just (OptBroadcastAddress (staticBroadcast settings)) - OptTagTimeOffset - -> Just (OptTimeOffset (staticTimeOffset settings)) - OptTagRouters - -> Just (OptRouters (staticRouters settings)) - OptTagDomainName - -> Just (OptDomainName (NVTAsciiString (staticDomainName settings))) - OptTagNameServers - -> Just (OptNameServers (staticDNS settings)) - _ -> Nothing - --- Unstructured DHCP Message ----------------------------------------------- - --- |'Dhcp4Message' is a low-level message container that is very close to --- the binary representation of DHCPv4 message. It is suitable for containing --- any DHCPv4 message. Values of this type should only be created using the --- publicly exported functions. -data Dhcp4Message = Dhcp4Message - { dhcp4Op :: Dhcp4Op -- ^ Message op code / message type. 1 = BOOTREQUEST, 2 = BOOTREPLY - , dhcp4Hops :: Word8 -- ^ Client sets to zero, optionally used by relay agents when booting via a relay agent. - , dhcp4Xid :: Xid -- ^ Transaction ID, a random number chosen by the client, used by the client and server to associate messages and responses between a client and a server. - , dhcp4Secs :: Word16 -- ^ Filled in by client, seconds elapsed since client began address acquisition or renewal process. - , dhcp4Broadcast :: Bool -- ^ Client requests messages be sent to hardware broadcast address - , dhcp4ClientAddr :: IP4 -- ^ Client IP address; only filled in if client is in BOUND, RENEW or REBINDING state and can respond to ARP requests. - , dhcp4YourAddr :: IP4 -- ^ 'your' (client) address - , dhcp4ServerAddr :: IP4 -- ^ IP address of next server to use in bootstrap; returned in DHCPOFFER, DHCPACK by server - , dhcp4RelayAddr :: IP4 -- ^ Relay agent IP address, used in booting via a relay agent - , dhcp4ClientHardwareAddr :: Mac -- ^ Client hardware address - , dhcp4ServerHostname :: String -- ^ Optional server host name, null terminated string - , dhcp4BootFilename :: String -- ^ Boot file name, full terminated string; "generic" name of null in DHCPDISCOVER, fully qualified directory-path name in DHCPOFFER - , dhcp4Options :: [Dhcp4Option] -- ^ Optional parameters field. - } deriving (Eq,Show) - --- |'getDhcp4Message' is the binary decoder for parsing 'Dhcp4Message' values. -getDhcp4Message :: BS.ByteString -> Either String Dhcp4Message -getDhcp4Message = runGet $ do - op <- getAtom - hwtype <- getAtom - len <- getAtom - unless (len == hardwareTypeAddressLength hwtype) - (fail "Hardware address length does not match hardware type.") - hops <- label "hops" getAtom - xid <- label "xid" getAtom - secs <- label "secs" getAtom - flags <- label "flags" getAtom - ciaddr <- label "ciaddr" getAtom - yiaddr <- label "yiaddr" getAtom - siaddr <- label "siaddr" getAtom - giaddr <- label "giaddr" getAtom - chaddr <- label "chaddr" $ isolate 16 $ getAtom <* (skip =<< remaining) - snameBytes <- label "sname field" (getByteString 64) - fileBytes <- label "file field" (getByteString 128) - (sname, file, opts) <- getDhcp4Options snameBytes fileBytes - return $! Dhcp4Message - { dhcp4Op = op - , dhcp4Hops = hops - , dhcp4Xid = xid - , dhcp4Secs = secs - , dhcp4Broadcast = broadcastFlag flags - , dhcp4ClientAddr = ciaddr - , dhcp4YourAddr = yiaddr - , dhcp4ServerAddr = siaddr - , dhcp4RelayAddr = giaddr - , dhcp4ClientHardwareAddr = chaddr - , dhcp4ServerHostname = sname - , dhcp4BootFilename = file - , dhcp4Options = opts - } - --- |'getDhcp4Message' is the binary encoder for rendering 'Dhcp4Message' values. -putDhcp4Message :: Dhcp4Message -> L.ByteString -putDhcp4Message dhcp = chunk $ runPut $ do - putAtom (dhcp4Op dhcp) - let hwType = Ethernet - putAtom hwType - putAtom (hardwareTypeAddressLength hwType) - putAtom (dhcp4Hops dhcp) - putAtom (dhcp4Xid dhcp) - putAtom (dhcp4Secs dhcp) - putAtom Flags { broadcastFlag = dhcp4Broadcast dhcp } - putAtom (dhcp4ClientAddr dhcp) - putAtom (dhcp4YourAddr dhcp) - putAtom (dhcp4ServerAddr dhcp) - putAtom (dhcp4RelayAddr dhcp) - putAtom (dhcp4ClientHardwareAddr dhcp) - putByteString $ BS.replicate (16 {- chaddr field length -} - - fromIntegral (hardwareTypeAddressLength hwType)) 0 - putPaddedByteString 64 (BS8.pack (dhcp4ServerHostname dhcp)) - putPaddedByteString 128 (BS8.pack (dhcp4BootFilename dhcp)) - putDhcp4Options (dhcp4Options dhcp) - --- Transaction ID -------------------------------------------------------------- - --- |'Xid' is a Transaction ID, a random number chosen by the client, --- used by the client and server to associate messages and responses between a --- client and a server. -newtype Xid = Xid Word32 - deriving (Eq, Show) - -instance CodecAtom Xid where - getAtom = Xid <$> getAtom - putAtom (Xid xid) = putAtom xid - atomSize _ = atomSize (0 :: Word32) - --- Opcodes --------------------------------------------------------------------- - -data Dhcp4Op - = BootRequest - | BootReply - deriving (Eq,Show) - -instance CodecAtom Dhcp4Op where - getAtom = do - b <- getAtom - case b :: Word8 of - 1 -> return BootRequest - 2 -> return BootReply - _ -> fail ("Unknown DHCP op 0x" ++ showHex b "") - - putAtom BootRequest = putAtom (0x1 :: Word8) - putAtom BootReply = putAtom (0x2 :: Word8) - - atomSize _ = atomSize (0 :: Word8) - --- | HardwareType is an enumeration of the supported hardware types as assigned --- in the ARP RFC http://www.iana.org/assignments/arp-parameters/ -data HardwareType - = Ethernet - deriving (Eq, Show) - -instance CodecAtom HardwareType where - getAtom = getAtom >>= \ b -> case b :: Word8 of - 1 -> return Ethernet - _ -> fail ("Unsupported hardware type 0x" ++ showHex b "") - - putAtom Ethernet = putAtom (1 :: Word8) - - atomSize _ = atomSize (1 :: Word8) - -hardwareTypeAddressLength :: HardwareType -> Word8 -hardwareTypeAddressLength Ethernet = 6 - --- RFC 2131, Section 2, Page 11: --- 1 1 1 1 1 1 --- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- |B| MBZ | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- B: BROADCAST flag --- MBZ: MUST BE ZERO (reserved for future use) --- Figure 2: Format of the ’flags’ field - -data Flags = Flags { broadcastFlag :: Bool } - deriving (Show, Eq) - -instance CodecAtom Flags where - getAtom = do - b <- getAtom :: Get Word16 - return Flags { broadcastFlag = testBit b 15 } - - putAtom flags = putAtom $ if broadcastFlag flags then bit 15 :: Word16 - else 0 - - atomSize _ = atomSize (0 :: Word16) - -putPaddedByteString :: Int -> BS.ByteString -> Put -putPaddedByteString n bs = do - putByteString $ BS.take n bs - putByteString $ BS.replicate (n - BS.length bs) 0 - - -selectKnownTags :: [OptionTagOrError] -> [Dhcp4OptionTag] -selectKnownTags = mapMaybe aux - where - aux (KnownTag t) = Just t - aux _ = Nothing - --- --- Unstructured to Structured logic --- --- |'parseDhcpMessage' attempts to find a valid high-level message --- contained in a low-level message. The 'Dhcp4Message' is a large --- type and can encode invalid combinations of options. -parseDhcpMessage :: Dhcp4Message -> Maybe (Either RequestMessage ReplyMessage) -parseDhcpMessage msg = do - messageType <- lookupMessageType (dhcp4Options msg) - case dhcp4Op msg of - - BootRequest -> Left <$> case messageType of - - Dhcp4Request -> RequestMessage <$> do - params <- lookupParams (dhcp4Options msg) - let params' = selectKnownTags params - let addr = lookupRequestAddr (dhcp4Options msg) - return Request - { requestXid = dhcp4Xid msg - , requestBroadcast = dhcp4Broadcast msg - , requestServerAddr = dhcp4ServerAddr msg - , requestClientHardwareAddress = dhcp4ClientHardwareAddr msg - , requestParameters = params' - , requestAddress = addr - } - - Dhcp4Discover -> DiscoverMessage <$> do - params <- lookupParams (dhcp4Options msg) - let params' = selectKnownTags params - return Discover - { discoverXid = dhcp4Xid msg - , discoverBroadcast = dhcp4Broadcast msg - , discoverClientHardwareAddr = dhcp4ClientHardwareAddr msg - , discoverParameters = params' - } - - _ -> Nothing - - BootReply -> Right <$> case messageType of - - Dhcp4Ack -> AckMessage <$> do - leaseTime <- lookupLeaseTime (dhcp4Options msg) - return Ack - { ackHops = dhcp4Hops msg - , ackXid = dhcp4Xid msg - , ackYourAddr = dhcp4YourAddr msg - , ackServerAddr = dhcp4ServerAddr msg - , ackRelayAddr = dhcp4RelayAddr msg - , ackClientHardwareAddr = dhcp4ClientHardwareAddr msg - , ackLeaseTime = leaseTime - , ackOptions = dhcp4Options msg - } - - Dhcp4Offer -> OfferMessage <$> do - return Offer - { offerHops = dhcp4Hops msg - , offerXid = dhcp4Xid msg - , offerYourAddr = dhcp4YourAddr msg - , offerServerAddr = dhcp4ServerAddr msg - , offerRelayAddr = dhcp4RelayAddr msg - , offerClientHardwareAddr = dhcp4ClientHardwareAddr msg - , offerOptions = dhcp4Options msg - } - - _ -> Nothing - --- --- Structured to unstrucured logic --- --- |'discoverToMessage' embeds 'Discover' messages in the low-level --- 'Dhcp4Message' type, typically for the purpose of serialization. -discoverToMessage :: Discover -> Dhcp4Message -discoverToMessage discover = Dhcp4Message - { dhcp4Op = BootRequest - , dhcp4Hops = 0 - , dhcp4Xid = discoverXid discover - , dhcp4Secs = 0 - , dhcp4Broadcast = False - , dhcp4ClientAddr = IP4 0 0 0 0 - , dhcp4YourAddr = IP4 0 0 0 0 - , dhcp4ServerAddr = IP4 0 0 0 0 - , dhcp4RelayAddr = IP4 0 0 0 0 - , dhcp4ClientHardwareAddr = discoverClientHardwareAddr discover - , dhcp4ServerHostname = "" - , dhcp4BootFilename = "" - , dhcp4Options = [ OptMessageType Dhcp4Discover - , OptParameterRequestList - $ map KnownTag - $ discoverParameters discover - ] - } - --- |'ackToMessage' embeds 'Ack' messages in the low-level --- 'Dhcp4Message' type, typically for the purpose of serialization. -ackToMessage :: Ack -> Dhcp4Message -ackToMessage ack = Dhcp4Message - { dhcp4Op = BootReply - , dhcp4Hops = ackHops ack - , dhcp4Xid = ackXid ack - , dhcp4Secs = 0 - , dhcp4Broadcast = False - , dhcp4ClientAddr = IP4 0 0 0 0 - , dhcp4YourAddr = ackYourAddr ack - , dhcp4ServerAddr = ackServerAddr ack - , dhcp4RelayAddr = ackRelayAddr ack - , dhcp4ClientHardwareAddr = ackClientHardwareAddr ack - , dhcp4ServerHostname = "" - , dhcp4BootFilename = "" - , dhcp4Options = OptMessageType Dhcp4Ack - : OptServerIdentifier (ackServerAddr ack) - : OptIPAddressLeaseTime (ackLeaseTime ack) - : ackOptions ack - } - --- |'offerToMessage' embeds 'Offer' messages in the low-level --- 'Dhcp4Message' type, typically for the purpose of serialization. -offerToMessage :: Offer -> Dhcp4Message -offerToMessage offer = Dhcp4Message - { dhcp4Op = BootReply - , dhcp4Hops = offerHops offer - , dhcp4Xid = offerXid offer - , dhcp4Secs = 0 - , dhcp4Broadcast = False - , dhcp4ClientAddr = IP4 0 0 0 0 - , dhcp4YourAddr = offerYourAddr offer - , dhcp4ServerAddr = offerServerAddr offer - , dhcp4RelayAddr = offerRelayAddr offer - , dhcp4ClientHardwareAddr = offerClientHardwareAddr offer - , dhcp4ServerHostname = "" - , dhcp4BootFilename = "" - , dhcp4Options = OptMessageType Dhcp4Offer - : OptServerIdentifier (offerServerAddr offer) - : offerOptions offer - } - --- |'requestToMessage' embeds 'Request' messages in the low-level --- 'Dhcp4Message' type, typically for the purpose of serialization. -requestToMessage :: Request -> Dhcp4Message -requestToMessage request = Dhcp4Message - { dhcp4Op = BootRequest - , dhcp4Hops = 0 - , dhcp4Xid = requestXid request - , dhcp4Secs = 0 - , dhcp4Broadcast = requestBroadcast request - , dhcp4ClientAddr = IP4 0 0 0 0 - , dhcp4YourAddr = IP4 0 0 0 0 - , dhcp4ServerAddr = IP4 0 0 0 0 - , dhcp4RelayAddr = IP4 0 0 0 0 - , dhcp4ClientHardwareAddr = requestClientHardwareAddress request - , dhcp4ServerHostname = "" - , dhcp4BootFilename = "" - , dhcp4Options = [ OptMessageType Dhcp4Request - , OptServerIdentifier (requestServerAddr request) - , OptParameterRequestList - $ map KnownTag - $ requestParameters request - ] ++ maybe [] (\x -> [OptRequestIPAddress x]) - (requestAddress request) - } - --- |'mkDiscover' creates a new 'Discover' message with a set --- of options suitable for configuring a basic network stack. -mkDiscover :: Xid -- ^ New randomly generated transaction ID - -> Mac -- ^ The client's hardware address - -> Discover -mkDiscover xid mac = Discover - { discoverXid = xid - , discoverBroadcast = False - , discoverClientHardwareAddr = mac - , discoverParameters = [ OptTagSubnetMask - , OptTagBroadcastAddress - , OptTagTimeOffset - , OptTagRouters - , OptTagDomainName - , OptTagNameServers - , OptTagHostName - ] - } - --- |'offerToRequest' creates a 'Request' message suitable for accepting --- an 'Offer' from the DHCPv4 server. -offerToRequest :: Offer -- ^ The offer as received from the server - -> Request -offerToRequest offer = Request - { requestXid = offerXid offer - , requestBroadcast = False - , requestServerAddr = offerServerAddr offer - , requestClientHardwareAddress = offerClientHardwareAddr offer - , requestParameters = [ OptTagSubnetMask - , OptTagBroadcastAddress - , OptTagTimeOffset - , OptTagRouters - , OptTagDomainName - , OptTagNameServers - , OptTagHostName - ] - , requestAddress = Just (offerYourAddr offer) - } diff --git a/src/Hans/Message/Dhcp4Codec.hs b/src/Hans/Message/Dhcp4Codec.hs deleted file mode 100644 --- a/src/Hans/Message/Dhcp4Codec.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Hans.Message.Dhcp4Codec where - -import Control.Applicative -import Data.List (find) -import qualified Data.Serialize -import Data.Serialize.Get -import Data.Serialize.Put -import Data.Word (Word8, Word16, Word32) - -import Hans.Address.IP4 (IP4,IP4Mask) -import Hans.Address.Mac (Mac) -import Hans.Address (Mask(..)) - -class CodecAtom a where - getAtom :: Get a - putAtom :: a -> Put - atomSize :: a -> Int - -instance (CodecAtom a, CodecAtom b) => CodecAtom (a,b) where - getAtom = (,) <$> getAtom <*> getAtom - putAtom (a,b) = putAtom a *> putAtom b - atomSize (a,b)= atomSize a + atomSize b - -instance CodecAtom Word8 where - getAtom = getWord8 - putAtom n = putWord8 n - atomSize _ = 1 - -instance CodecAtom Word16 where - getAtom = getWord16be - putAtom n = putWord16be n - atomSize _ = 2 - -instance CodecAtom Word32 where - getAtom = getWord32be - putAtom n = putWord32be n - atomSize _ = 4 - -instance CodecAtom Bool where - getAtom = do b <- getWord8 - case b of - 0 -> return False - 1 -> return True - _ -> fail "Expected 0/1 in boolean option" - putAtom False = putWord8 0 - putAtom True = putWord8 1 - atomSize _ = 1 - -instance CodecAtom IP4 where - getAtom = Data.Serialize.get - putAtom = Data.Serialize.put - atomSize _ = 4 - -instance CodecAtom IP4Mask where - getAtom = withMask <$> getAtom <*> (unmask <$> getAtom) - putAtom ip4mask = putAtom addr *> putAtom (SubnetMask mask) - where (addr, mask) = getMaskComponents ip4mask - atomSize _ = atomSize (undefined :: IP4) - + atomSize (undefined :: SubnetMask) - -instance CodecAtom Mac where - getAtom = Data.Serialize.get - putAtom = Data.Serialize.put - atomSize _ = 6 - ------------------------------------------------------------------------ --- Subnet parser/unparser operations ---------------------------------- ------------------------------------------------------------------------ - -newtype SubnetMask = SubnetMask { unmask :: Int} - deriving (Show, Eq) - -word32ToSubnetMask :: Word32 -> Maybe SubnetMask -word32ToSubnetMask mask = - SubnetMask <$> find (\ i -> computeMask i == mask) [0..32] - -subnetMaskToWord32 :: SubnetMask -> Word32 -subnetMaskToWord32 (SubnetMask n) = computeMask n - -computeMask :: Int -> Word32 -computeMask n = 0-2^(32-n) - -instance CodecAtom SubnetMask where - getAtom = do x <- getAtom - case word32ToSubnetMask x of - Just mask -> return mask - Nothing -> fail "Invalid subnet mask" - putAtom = putAtom . subnetMaskToWord32 - atomSize _ = atomSize (undefined :: Word32) diff --git a/src/Hans/Message/Dhcp4Options.hs b/src/Hans/Message/Dhcp4Options.hs deleted file mode 100644 --- a/src/Hans/Message/Dhcp4Options.hs +++ /dev/null @@ -1,869 +0,0 @@ -module Hans.Message.Dhcp4Options where - -import Control.Monad (unless) -import Control.Applicative -import Data.Maybe (fromMaybe) -import Data.Foldable (traverse_) -import Data.Traversable (sequenceA) -import Data.Word (Word8, Word16, Word32) -import Data.Serialize.Get -import Data.Serialize.Put -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Numeric (showHex) - -import Hans.Address.IP4 (IP4,IP4Mask) -import Hans.Message.Dhcp4Codec - ------------------------------------------------------------------------ --- Magic constants ---------------------------------------------------- ------------------------------------------------------------------------ - -data MagicCookie = MagicCookie - -dhcp4MagicCookie :: Word32 -dhcp4MagicCookie = 0x63825363 - -instance CodecAtom MagicCookie where - getAtom = do cookie <- getAtom - unless (cookie == dhcp4MagicCookie) - (fail "Incorrect magic cookie.") - return MagicCookie - putAtom MagicCookie = putAtom dhcp4MagicCookie - atomSize MagicCookie = atomSize dhcp4MagicCookie - - ------------------------------------------------------------------------ --- DHCP option type and operations ------------------------------------ ------------------------------------------------------------------------ - -data Dhcp4Option - = OptSubnetMask SubnetMask - | OptTimeOffset Word32 - | OptRouters [IP4] - | OptTimeServers [IP4] - | OptIEN116NameServers [IP4] - | OptNameServers [IP4] - | OptLogServers [IP4] - | OptCookieServers [IP4] - | OptLPRServers [IP4] - | OptImpressServers [IP4] - | OptResourceLocationServers [IP4] - | OptHostName NVTAsciiString - | OptBootFileSize Word16 - | OptMeritDumpFile NVTAsciiString - | OptDomainName NVTAsciiString - | OptSwapServer IP4 - | OptRootPath NVTAsciiString - | OptExtensionsPath NVTAsciiString - | OptEnableIPForwarding Bool - | OptEnableNonLocalSourceRouting Bool - | OptPolicyFilters [IP4Mask] - | OptMaximumDatagramReassemblySize Word16 - | OptDefaultTTL Word8 - | OptPathMTUAgingTimeout Word32 - | OptPathMTUPlateauTable [Word16] - | OptInterfaceMTU Word16 - | OptAllSubnetsAreLocal Bool - | OptBroadcastAddress IP4 - | OptPerformMaskDiscovery Bool - | OptShouldSupplyMasks Bool - | OptShouldPerformRouterDiscovery Bool - | OptRouterSolicitationAddress IP4 - | OptStaticRoutes [(IP4,IP4)] - | OptShouldNegotiateArpTrailers Bool - | OptArpCacheTimeout Word32 - | OptUseRFC1042EthernetEncapsulation Bool - | OptTcpDefaultTTL Word8 - | OptTcpKeepaliveInterval Word32 - | OptTcpKeepaliveUseGarbage Bool - | OptNisDomainName NVTAsciiString - | OptNisServers [IP4] - | OptNtpServers [IP4] - | OptVendorSpecific ByteString - | OptNetBiosNameServers [IP4] - | OptNetBiosDistributionServers [IP4] - | OptNetBiosNodeType NetBiosNodeType - | OptNetBiosScope NVTAsciiString - | OptXWindowsFontServer [IP4] - | OptXWindowsDisplayManagers [IP4] - | OptNisPlusDomain NVTAsciiString - | OptNisPlusServers [IP4] - | OptSmtpServers [IP4] - | OptPopServers [IP4] - | OptNntpServers [IP4] - | OptWwwServers [IP4] - | OptFingerServers [IP4] - | OptIrcServers [IP4] - | OptStreetTalkServers [IP4] - | OptStreetTalkDirectoryAssistanceServers [IP4] - | OptFQDN NVTAsciiString -- RFC 4702 - | OptRequestIPAddress IP4 - | OptIPAddressLeaseTime Word32 - | OptOverload OverloadOption - | OptTftpServer NVTAsciiString - | OptBootfileName NVTAsciiString - | OptMessageType Dhcp4MessageType - | OptServerIdentifier IP4 - | OptParameterRequestList [OptionTagOrError] - | OptErrorMessage NVTAsciiString - | OptMaxDHCPMessageSize Word16 - | OptRenewalTime Word32 - | OptRebindingTime Word32 - | OptVendorClass NVTAsciiString - | OptClientIdentifier ByteString - | OptNetWareDomainName NVTAsciiString -- RFC 2242 - | OptNetWareInfo ByteString -- RFC 2242 - | OptAutoconfiguration Bool -- RFC 2563 - deriving (Show,Eq) - -getDhcp4Option :: Get (Either ControlTag Dhcp4Option) -getDhcp4Option = do - mb_tag <- getOptionTag - case mb_tag of - UnknownTag t -> do xs <- getBytes =<< remaining - fail ("getDhcp4Option failed tag (" ++ show t ++ ") " ++ show xs) - KnownTag tag -> do - let r con = Right . con <$> getOption - case tag of - OptTagPad -> Left <$> pure ControlPad - OptTagEnd -> Left <$> pure ControlEnd - OptTagSubnetMask -> r OptSubnetMask - OptTagTimeOffset -> r OptTimeOffset - OptTagRouters -> r OptRouters - OptTagTimeServers -> r OptTimeServers - OptTagIEN116NameServers -> r OptIEN116NameServers - OptTagNameServers -> r OptNameServers - OptTagLogServers -> r OptLogServers - OptTagCookieServers -> r OptCookieServers - OptTagLPRServers -> r OptLPRServers - OptTagImpressServers -> r OptImpressServers - OptTagResourceLocationServers -> r OptResourceLocationServers - OptTagHostName -> r OptHostName - OptTagBootFileSize -> r OptBootFileSize - OptTagMeritDumpFile -> r OptMeritDumpFile - OptTagDomainName -> r OptDomainName - OptTagSwapServer -> r OptSwapServer - OptTagRootPath -> r OptRootPath - OptTagExtensionsPath -> r OptExtensionsPath - OptTagEnableIPForwarding -> r OptEnableIPForwarding - OptTagEnableNonLocalSourceRouting -> r OptEnableNonLocalSourceRouting - OptTagPolicyFilters -> r OptPolicyFilters - OptTagMaximumDatagramReassemblySize -> r OptMaximumDatagramReassemblySize - OptTagDefaultTTL -> r OptDefaultTTL - OptTagPathMTUAgingTimeout -> r OptPathMTUAgingTimeout - OptTagPathMTUPlateauTable -> r OptPathMTUPlateauTable - OptTagInterfaceMTU -> r OptInterfaceMTU - OptTagAllSubnetsAreLocal -> r OptAllSubnetsAreLocal - OptTagBroadcastAddress -> r OptBroadcastAddress - OptTagPerformMaskDiscovery -> r OptPerformMaskDiscovery - OptTagShouldSupplyMasks -> r OptShouldSupplyMasks - OptTagShouldPerformRouterDiscovery -> r OptShouldPerformRouterDiscovery - OptTagRouterSolicitationAddress -> r OptRouterSolicitationAddress - OptTagStaticRoutes -> r OptStaticRoutes - OptTagShouldNegotiateArpTrailers -> r OptShouldNegotiateArpTrailers - OptTagArpCacheTimeout -> r OptArpCacheTimeout - OptTagUseRFC1042EthernetEncapsulation -> r OptUseRFC1042EthernetEncapsulation - OptTagTcpDefaultTTL -> r OptTcpDefaultTTL - OptTagTcpKeepaliveInterval -> r OptTcpKeepaliveInterval - OptTagTcpKeepaliveUseGarbage -> r OptTcpKeepaliveUseGarbage - OptTagNisDomainName -> r OptNisDomainName - OptTagNisServers -> r OptNisServers - OptTagNtpServers -> r OptNtpServers - OptTagVendorSpecific -> r OptVendorSpecific - OptTagNetBiosNameServers -> r OptNetBiosNameServers - OptTagNetBiosDistributionServers -> r OptNetBiosDistributionServers - OptTagNetBiosNodeType -> r OptNetBiosNodeType - OptTagNetBiosScope -> r OptNetBiosScope - OptTagXWindowsFontServer -> r OptXWindowsFontServer - OptTagXWindowsDisplayManagers -> r OptXWindowsDisplayManagers - OptTagNisPlusDomain -> r OptNisPlusDomain - OptTagNisPlusServers -> r OptNisPlusServers - OptTagSmtpServers -> r OptSmtpServers - OptTagPopServers -> r OptPopServers - OptTagNntpServers -> r OptNntpServers - OptTagWwwServers -> r OptWwwServers - OptTagFingerServers -> r OptFingerServers - OptTagIrcServers -> r OptIrcServers - OptTagStreetTalkServers -> r OptStreetTalkServers - OptTagStreetTalkDirectoryAssistanceServers -> r OptStreetTalkDirectoryAssistanceServers - OptTagFQDN -> r OptFQDN - OptTagRequestIPAddress -> r OptRequestIPAddress - OptTagIPAddressLeaseTime -> r OptIPAddressLeaseTime - OptTagOverload -> r OptOverload - OptTagTftpServer -> r OptTftpServer - OptTagBootfileName -> r OptBootfileName - OptTagMessageType -> r OptMessageType - OptTagServerIdentifier -> r OptServerIdentifier - OptTagParameterRequestList -> r OptParameterRequestList - OptTagErrorMessage -> r OptErrorMessage - OptTagMaxDHCPMessageSize -> r OptMaxDHCPMessageSize - OptTagRenewalTime -> r OptRenewalTime - OptTagRebindingTime -> r OptRebindingTime - OptTagVendorClass -> r OptVendorClass - OptTagClientIdentifier -> r OptClientIdentifier - OptTagNetWareDomainName -> r OptNetWareDomainName - OptTagNetWareInfo -> r OptNetWareInfo - OptTagAutoconfiguration -> r OptAutoconfiguration - -putDhcp4Option :: Dhcp4Option -> Put -putDhcp4Option opt = - let p tag val = putAtom (KnownTag tag) *> putOption val in - case opt of - OptSubnetMask mask -> p OptTagSubnetMask mask - OptTimeOffset offset -> p OptTagTimeOffset offset - OptRouters routers -> p OptTagRouters routers - OptTimeServers servers -> p OptTagTimeServers servers - OptIEN116NameServers servers -> p OptTagIEN116NameServers servers - OptNameServers servers -> p OptTagNameServers servers - OptLogServers servers -> p OptTagLogServers servers - OptCookieServers servers -> p OptTagCookieServers servers - OptLPRServers servers -> p OptTagLPRServers servers - OptImpressServers servers -> p OptTagImpressServers servers - OptResourceLocationServers servers -> p OptTagResourceLocationServers servers - OptHostName hostname -> p OptTagHostName hostname - OptBootFileSize sz -> p OptTagBootFileSize sz - OptMeritDumpFile file -> p OptTagMeritDumpFile file - OptDomainName domainname -> p OptTagDomainName domainname - OptSwapServer server -> p OptTagSwapServer server - OptRootPath path -> p OptTagRootPath path - OptExtensionsPath path -> p OptTagExtensionsPath path - OptEnableIPForwarding enabled -> p OptTagEnableIPForwarding enabled - OptEnableNonLocalSourceRouting enab -> p OptTagEnableNonLocalSourceRouting enab - OptPolicyFilters filters -> p OptTagPolicyFilters filters - OptMaximumDatagramReassemblySize n -> p OptTagMaximumDatagramReassemblySize n - OptDefaultTTL ttl -> p OptTagDefaultTTL ttl - OptPathMTUAgingTimeout timeout -> p OptTagPathMTUAgingTimeout timeout - OptPathMTUPlateauTable mtus -> p OptTagPathMTUPlateauTable mtus - OptInterfaceMTU mtu -> p OptTagInterfaceMTU mtu - OptAllSubnetsAreLocal arelocal -> p OptTagAllSubnetsAreLocal arelocal - OptBroadcastAddress addr -> p OptTagBroadcastAddress addr - OptPerformMaskDiscovery perform -> p OptTagPerformMaskDiscovery perform - OptShouldSupplyMasks should -> p OptTagShouldSupplyMasks should - OptShouldPerformRouterDiscovery b -> p OptTagShouldPerformRouterDiscovery b - OptRouterSolicitationAddress addr -> p OptTagRouterSolicitationAddress addr - OptStaticRoutes routes -> p OptTagStaticRoutes routes - OptShouldNegotiateArpTrailers b -> p OptTagShouldNegotiateArpTrailers b - OptArpCacheTimeout timeout -> p OptTagArpCacheTimeout timeout - OptUseRFC1042EthernetEncapsulation b-> p OptTagUseRFC1042EthernetEncapsulation b - OptTcpDefaultTTL ttl -> p OptTagTcpDefaultTTL ttl - OptTcpKeepaliveInterval interval -> p OptTagTcpKeepaliveInterval interval - OptTcpKeepaliveUseGarbage use -> p OptTagTcpKeepaliveUseGarbage use - OptNisDomainName domainname -> p OptTagNisDomainName domainname - OptNisServers servers -> p OptTagNisServers servers - OptNtpServers servers -> p OptTagNtpServers servers - OptVendorSpecific bs -> p OptTagVendorSpecific bs - OptNetBiosNameServers servers -> p OptTagNetBiosNameServers servers - OptNetBiosDistributionServers srvs -> p OptTagNetBiosDistributionServers srvs - OptNetBiosNodeType node -> p OptTagNetBiosNodeType node - OptNetBiosScope scope -> p OptTagNetBiosScope scope - OptXWindowsFontServer servers -> p OptTagXWindowsFontServer servers - OptXWindowsDisplayManagers servers -> p OptTagXWindowsDisplayManagers servers - OptNisPlusDomain domain -> p OptTagNisPlusDomain domain - OptNisPlusServers servers -> p OptTagNisPlusServers servers - OptSmtpServers servers -> p OptTagSmtpServers servers - OptPopServers servers -> p OptTagPopServers servers - OptNntpServers servers -> p OptTagNntpServers servers - OptWwwServers servers -> p OptTagWwwServers servers - OptFingerServers servers -> p OptTagFingerServers servers - OptIrcServers servers -> p OptTagIrcServers servers - OptStreetTalkServers servers -> p OptTagStreetTalkServers servers - OptStreetTalkDirectoryAssistanceServers servers -> p OptTagStreetTalkDirectoryAssistanceServers servers - OptFQDN fqdn -> p OptTagFQDN fqdn - OptRequestIPAddress addr -> p OptTagRequestIPAddress addr - OptIPAddressLeaseTime time -> p OptTagIPAddressLeaseTime time - OptOverload overload -> p OptTagOverload overload - OptTftpServer server -> p OptTagTftpServer server - OptBootfileName filename -> p OptTagBootfileName filename - OptMessageType t -> p OptTagMessageType t - OptServerIdentifier server -> p OptTagServerIdentifier server - OptParameterRequestList ps -> p OptTagParameterRequestList ps - OptErrorMessage msg -> p OptTagErrorMessage msg - OptMaxDHCPMessageSize maxsz -> p OptTagMaxDHCPMessageSize maxsz - OptRenewalTime time -> p OptTagRenewalTime time - OptRebindingTime time -> p OptTagRebindingTime time - OptVendorClass str -> p OptTagVendorClass str - OptClientIdentifier client -> p OptTagClientIdentifier client - OptNetWareDomainName name -> p OptTagNetWareDomainName name - OptNetWareInfo info -> p OptTagNetWareInfo info - OptAutoconfiguration autoconf -> p OptTagAutoconfiguration autoconf - ------------------------------------------------------------------------ --- Message Type type and operations ----------------------------------- ------------------------------------------------------------------------ - -data Dhcp4MessageType - = Dhcp4Discover - | Dhcp4Offer - | Dhcp4Request - | Dhcp4Decline - | Dhcp4Ack - | Dhcp4Nak - | Dhcp4Release - | Dhcp4Inform - deriving (Eq,Show) - -instance Option Dhcp4MessageType where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption - -instance CodecAtom Dhcp4MessageType where - getAtom = do - b <- getAtom - case b :: Word8 of - 1 -> return Dhcp4Discover - 2 -> return Dhcp4Offer - 3 -> return Dhcp4Request - 4 -> return Dhcp4Decline - 5 -> return Dhcp4Ack - 6 -> return Dhcp4Nak - 7 -> return Dhcp4Release - 8 -> return Dhcp4Inform - _ -> fail ("Unknown DHCP Message Type 0x" ++ showHex b "") - - putAtom t = putAtom $ case t of - Dhcp4Discover -> 1 :: Word8 - Dhcp4Offer -> 2 - Dhcp4Request -> 3 - Dhcp4Decline -> 4 - Dhcp4Ack -> 5 - Dhcp4Nak -> 6 - Dhcp4Release -> 7 - Dhcp4Inform -> 8 - - atomSize _ = 1 - ------------------------------------------------------------------------ --- Control tag type and operations ------------------------------------ ------------------------------------------------------------------------ - -data ControlTag - = ControlPad - | ControlEnd - deriving (Eq, Show) - -putControlOption :: ControlTag -> Put -putControlOption opt = case opt of - ControlPad -> putAtom (KnownTag OptTagPad) - ControlEnd -> putAtom (KnownTag OptTagEnd) - ------------------------------------------------------------------------ --- Option tag type and operations ------------------------------------- ------------------------------------------------------------------------ - -data Dhcp4OptionTag - = OptTagPad - | OptTagEnd - | OptTagSubnetMask - | OptTagTimeOffset - | OptTagRouters - | OptTagTimeServers - | OptTagIEN116NameServers - | OptTagNameServers - | OptTagLogServers - | OptTagCookieServers - | OptTagLPRServers - | OptTagImpressServers - | OptTagResourceLocationServers - | OptTagHostName - | OptTagBootFileSize - | OptTagMeritDumpFile - | OptTagDomainName - | OptTagSwapServer - | OptTagRootPath - | OptTagExtensionsPath - | OptTagEnableIPForwarding - | OptTagEnableNonLocalSourceRouting - | OptTagPolicyFilters - | OptTagMaximumDatagramReassemblySize - | OptTagDefaultTTL - | OptTagPathMTUAgingTimeout - | OptTagPathMTUPlateauTable - | OptTagInterfaceMTU - | OptTagAllSubnetsAreLocal - | OptTagBroadcastAddress - | OptTagPerformMaskDiscovery - | OptTagShouldSupplyMasks - | OptTagShouldPerformRouterDiscovery - | OptTagRouterSolicitationAddress - | OptTagStaticRoutes - | OptTagShouldNegotiateArpTrailers - | OptTagArpCacheTimeout - | OptTagUseRFC1042EthernetEncapsulation - | OptTagTcpDefaultTTL - | OptTagTcpKeepaliveInterval - | OptTagTcpKeepaliveUseGarbage - | OptTagNisDomainName - | OptTagNisServers - | OptTagNtpServers - | OptTagVendorSpecific - | OptTagNetBiosNameServers - | OptTagNetBiosDistributionServers - | OptTagNetBiosNodeType - | OptTagNetBiosScope - | OptTagXWindowsFontServer - | OptTagXWindowsDisplayManagers - | OptTagNisPlusDomain - | OptTagNisPlusServers - | OptTagSmtpServers - | OptTagPopServers - | OptTagNntpServers - | OptTagWwwServers - | OptTagFingerServers - | OptTagIrcServers - | OptTagStreetTalkServers - | OptTagStreetTalkDirectoryAssistanceServers - | OptTagFQDN - | OptTagRequestIPAddress - | OptTagIPAddressLeaseTime - | OptTagOverload - | OptTagTftpServer - | OptTagBootfileName - | OptTagMessageType - | OptTagServerIdentifier - | OptTagParameterRequestList - | OptTagErrorMessage - | OptTagMaxDHCPMessageSize - | OptTagRenewalTime - | OptTagRebindingTime - | OptTagVendorClass - | OptTagClientIdentifier - | OptTagNetWareDomainName - | OptTagNetWareInfo - | OptTagAutoconfiguration - deriving (Show,Eq) - -data OptionTagOrError = UnknownTag Word8 | KnownTag Dhcp4OptionTag - deriving (Show,Eq) - -getOptionTag :: Get OptionTagOrError -getOptionTag = f =<< getWord8 - where - r = return . KnownTag - f 0 = r OptTagPad - f 1 = r OptTagSubnetMask - f 2 = r OptTagTimeOffset - f 3 = r OptTagRouters - f 4 = r OptTagTimeServers - f 5 = r OptTagIEN116NameServers - f 6 = r OptTagNameServers - f 7 = r OptTagLogServers - f 8 = r OptTagCookieServers - f 9 = r OptTagLPRServers - f 10 = r OptTagImpressServers - f 11 = r OptTagResourceLocationServers - f 12 = r OptTagHostName - f 13 = r OptTagBootFileSize - f 14 = r OptTagMeritDumpFile - f 15 = r OptTagDomainName - f 16 = r OptTagSwapServer - f 17 = r OptTagRootPath - f 18 = r OptTagExtensionsPath - f 19 = r OptTagEnableIPForwarding - f 20 = r OptTagEnableNonLocalSourceRouting - f 21 = r OptTagPolicyFilters - f 22 = r OptTagMaximumDatagramReassemblySize - f 23 = r OptTagDefaultTTL - f 24 = r OptTagPathMTUAgingTimeout - f 25 = r OptTagPathMTUPlateauTable - f 26 = r OptTagInterfaceMTU - f 27 = r OptTagAllSubnetsAreLocal - f 28 = r OptTagBroadcastAddress - f 29 = r OptTagPerformMaskDiscovery - f 30 = r OptTagShouldSupplyMasks - f 31 = r OptTagShouldPerformRouterDiscovery - f 32 = r OptTagRouterSolicitationAddress - f 33 = r OptTagStaticRoutes - f 34 = r OptTagShouldNegotiateArpTrailers - f 35 = r OptTagArpCacheTimeout - f 36 = r OptTagUseRFC1042EthernetEncapsulation - f 37 = r OptTagTcpDefaultTTL - f 38 = r OptTagTcpKeepaliveInterval - f 39 = r OptTagTcpKeepaliveUseGarbage - f 40 = r OptTagNisDomainName - f 41 = r OptTagNisServers - f 42 = r OptTagNtpServers - f 43 = r OptTagVendorSpecific - f 44 = r OptTagNetBiosNameServers - f 45 = r OptTagNetBiosDistributionServers - f 46 = r OptTagNetBiosNodeType - f 47 = r OptTagNetBiosScope - f 48 = r OptTagXWindowsFontServer - f 49 = r OptTagXWindowsDisplayManagers - f 50 = r OptTagRequestIPAddress - f 51 = r OptTagIPAddressLeaseTime - f 52 = r OptTagOverload - f 53 = r OptTagMessageType - f 54 = r OptTagServerIdentifier - f 55 = r OptTagParameterRequestList - f 56 = r OptTagErrorMessage - f 57 = r OptTagMaxDHCPMessageSize - f 58 = r OptTagRenewalTime - f 59 = r OptTagRebindingTime - f 60 = r OptTagVendorClass - f 61 = r OptTagClientIdentifier - f 62 = r OptTagNetWareDomainName - f 63 = r OptTagNetWareInfo - f 64 = r OptTagNisPlusDomain - f 65 = r OptTagNisPlusServers - f 66 = r OptTagTftpServer - f 67 = r OptTagBootfileName - f 69 = r OptTagSmtpServers - f 70 = r OptTagPopServers - f 71 = r OptTagNntpServers - f 72 = r OptTagWwwServers - f 73 = r OptTagFingerServers - f 74 = r OptTagIrcServers - f 75 = r OptTagStreetTalkServers - f 76 = r OptTagStreetTalkDirectoryAssistanceServers - f 81 = r OptTagFQDN - f 116 = r OptTagAutoconfiguration - f 255 = r OptTagEnd - f t = return (UnknownTag t) - -putOptionTag :: OptionTagOrError -> Put -putOptionTag (UnknownTag t) = putAtom t -putOptionTag (KnownTag t) = putAtom (f t) - where - f :: Dhcp4OptionTag -> Word8 - f OptTagPad = 0 - f OptTagEnd = 255 - f OptTagSubnetMask = 1 - f OptTagTimeOffset = 2 - f OptTagRouters = 3 - f OptTagTimeServers = 4 - f OptTagIEN116NameServers = 5 - f OptTagNameServers = 6 - f OptTagLogServers = 7 - f OptTagCookieServers = 8 - f OptTagLPRServers = 9 - f OptTagImpressServers = 10 - f OptTagResourceLocationServers = 11 - f OptTagHostName = 12 - f OptTagBootFileSize = 13 - f OptTagMeritDumpFile = 14 - f OptTagDomainName = 15 - f OptTagSwapServer = 16 - f OptTagRootPath = 17 - f OptTagExtensionsPath = 18 - f OptTagEnableIPForwarding = 19 - f OptTagEnableNonLocalSourceRouting = 20 - f OptTagPolicyFilters = 21 - f OptTagMaximumDatagramReassemblySize = 22 - f OptTagDefaultTTL = 23 - f OptTagPathMTUAgingTimeout = 24 - f OptTagPathMTUPlateauTable = 25 - f OptTagInterfaceMTU = 26 - f OptTagAllSubnetsAreLocal = 27 - f OptTagBroadcastAddress = 28 - f OptTagPerformMaskDiscovery = 29 - f OptTagShouldSupplyMasks = 30 - f OptTagShouldPerformRouterDiscovery = 31 - f OptTagRouterSolicitationAddress = 32 - f OptTagStaticRoutes = 33 - f OptTagShouldNegotiateArpTrailers = 34 - f OptTagArpCacheTimeout = 35 - f OptTagUseRFC1042EthernetEncapsulation = 36 - f OptTagTcpDefaultTTL = 37 - f OptTagTcpKeepaliveInterval = 38 - f OptTagTcpKeepaliveUseGarbage = 39 - f OptTagNisDomainName = 40 - f OptTagNisServers = 41 - f OptTagNtpServers = 42 - f OptTagVendorSpecific = 43 - f OptTagNetBiosNameServers = 44 - f OptTagNetBiosDistributionServers = 45 - f OptTagNetBiosNodeType = 46 - f OptTagNetBiosScope = 47 - f OptTagXWindowsFontServer = 48 - f OptTagXWindowsDisplayManagers = 49 - f OptTagRequestIPAddress = 50 - f OptTagIPAddressLeaseTime = 51 - f OptTagOverload = 52 - f OptTagMessageType = 53 - f OptTagServerIdentifier = 54 - f OptTagParameterRequestList = 55 - f OptTagErrorMessage = 56 - f OptTagMaxDHCPMessageSize = 57 - f OptTagRenewalTime = 58 - f OptTagRebindingTime = 59 - f OptTagVendorClass = 60 - f OptTagClientIdentifier = 61 - f OptTagNetWareDomainName = 62 - f OptTagNetWareInfo = 63 - f OptTagNisPlusDomain = 64 - f OptTagNisPlusServers = 65 - f OptTagTftpServer = 66 - f OptTagBootfileName = 67 - f OptTagSmtpServers = 69 - f OptTagPopServers = 70 - f OptTagNntpServers = 71 - f OptTagWwwServers = 72 - f OptTagFingerServers = 73 - f OptTagIrcServers = 74 - f OptTagStreetTalkServers = 75 - f OptTagStreetTalkDirectoryAssistanceServers = 76 - f OptTagFQDN = 81 - f OptTagAutoconfiguration = 116 - ------------------------------------------------------------------------ --- NetBIOS node type and operations ----------------------------------- ------------------------------------------------------------------------ - -data NetBiosNodeType - = BNode - | PNode - | MNode - | HNode - deriving (Show,Eq) - -instance Option NetBiosNodeType where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption - -instance CodecAtom NetBiosNodeType where - getAtom = do - b <- getAtom - case b :: Word8 of - 0x1 -> return BNode - 0x2 -> return PNode - 0x4 -> return MNode - 0x8 -> return HNode - _ -> fail "Unknown NetBIOS node type" - - putAtom t = putAtom $ case t of - BNode -> 0x1 :: Word8 - PNode -> 0x2 - MNode -> 0x4 - HNode -> 0x8 - - atomSize _ = 1 - ------------------------------------------------------------------------ --- Overload option type and operations -------------------------------- ------------------------------------------------------------------------ - -data OverloadOption - = UsedFileField - | UsedSNameField - | UsedBothFields - deriving (Show, Eq) - -instance Option OverloadOption where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption - -instance CodecAtom OverloadOption where - getAtom = do b <- getAtom - case b :: Word8 of - 1 -> return UsedFileField - 2 -> return UsedSNameField - 3 -> return UsedBothFields - _ -> fail ("Bad overload value 0x" ++ showHex b "") - putAtom t = putAtom $ case t of - UsedFileField -> 1 :: Word8 - UsedSNameField -> 2 - UsedBothFields -> 3 - - atomSize _ = atomSize (undefined :: Word8) - ------------------------------------------------------------------------ --- Options list operations -------------------------------------------- ------------------------------------------------------------------------ - -getDhcp4Options :: ByteString -> ByteString - -> Get (String, String, [Dhcp4Option]) -getDhcp4Options sname file = do - MagicCookie <- getAtom - options0 <- remainingAsOptions - case lookupOverload options0 of - Nothing -> return (nullTerminated sname, nullTerminated file, options0) - - Just UsedFileField -> do - options1 <- localParse file remainingAsOptions - let options = options0 ++ options1 - NVTAsciiString fileString - = fromMaybe (NVTAsciiString "") (lookupFile options) - return (nullTerminated sname, fileString, options) - - Just UsedSNameField -> do - options1 <- localParse sname remainingAsOptions - let options = options0 ++ options1 - NVTAsciiString snameString - = fromMaybe (NVTAsciiString "") (lookupSname options) - return (snameString, nullTerminated file, options) - - Just UsedBothFields -> do - - -- The file field MUST be interpreted for options before the sname field. - -- RFC 2131, Section 4.1, Page 24 - options1 <- localParse file remainingAsOptions - options2 <- localParse sname remainingAsOptions - let options = options0 ++ options1 ++ options2 - NVTAsciiString snameString - = fromMaybe (NVTAsciiString "") (lookupSname options) - NVTAsciiString fileString - = fromMaybe (NVTAsciiString "") (lookupFile options) - return (snameString, fileString, options) - - where - remainingAsOptions = scrubControls =<< repeatedly getDhcp4Option - - localParse bs m = case runGet m bs of - Right x -> return x - Left err -> fail err - - -putDhcp4Options :: [Dhcp4Option] -> Put -putDhcp4Options opts = putAtom MagicCookie - *> traverse_ putDhcp4Option opts - *> putControlOption ControlEnd - -scrubControls :: (Applicative m, Monad m) - => [Either ControlTag Dhcp4Option] -> m [Dhcp4Option] -scrubControls [] = fail "No END option found" -scrubControls (Left ControlPad : xs) = scrubControls xs -scrubControls (Left ControlEnd : xs) = [] <$ traverse_ eatPad xs -scrubControls (Right o : xs) = (o :) <$> scrubControls xs - --- | 'eatPad' fails on any non 'ControlPad' option with an error message. -eatPad :: Monad m => Either ControlTag Dhcp4Option -> m () -eatPad (Left ControlPad) = return () -eatPad _ = fail "Unexpected option after END option" - -replicateA :: Applicative f => Int -> f a -> f [a] -replicateA n f = sequenceA (replicate n f) - -repeatedly :: Get a -> Get [a] -repeatedly m = do - done <- isEmpty - if done then return [] - else (:) <$> m <*> repeatedly m - -nullTerminated :: ByteString -> String -nullTerminated = takeWhile (/= '\NUL') . BS8.unpack - -lookupOverload :: [Dhcp4Option] -> Maybe OverloadOption -lookupOverload = foldr f Nothing - where f (OptOverload o) _ = Just o - f _ a = a - -lookupFile :: [Dhcp4Option] -> Maybe NVTAsciiString -lookupFile = foldr f Nothing - where f (OptBootfileName fn) _ = Just fn - f _ a = a - -lookupSname :: [Dhcp4Option] -> Maybe NVTAsciiString -lookupSname = foldr f Nothing - where f (OptTftpServer n) _ = Just n - f _ a = a - -lookupParams :: [Dhcp4Option] -> Maybe [OptionTagOrError] -lookupParams = foldr f Nothing - where f (OptParameterRequestList n) _ = Just n - f _ a = a - -lookupMessageType :: [Dhcp4Option] -> Maybe Dhcp4MessageType -lookupMessageType = foldr f Nothing - where f (OptMessageType n) _ = Just n - f _ a = a - -lookupRequestAddr :: [Dhcp4Option] -> Maybe IP4 -lookupRequestAddr = foldr f Nothing - where f (OptRequestIPAddress n) _ = Just n - f _ a = a - -lookupLeaseTime :: [Dhcp4Option] -> Maybe Word32 -lookupLeaseTime = foldr f Nothing - where f (OptIPAddressLeaseTime t) _ = Just t - f _ a = a - ------------------------------------------------------------------------ --- Protected parser and unparser monad -------------------------------- ------------------------------------------------------------------------ - -class Option a where - getOption :: Get a - putOption :: a -> Put - -instance CodecAtom a => Option [a] where - getOption = do - let (n, m) = getRecord - len <- getLen - let (count, remainder) = divMod len n - unless (remainder == 0) (fail ("Length was not a multiple of " ++ show n)) - unless (count > 0) (fail "Minimum length not met") - replicateA count $ label "List of fixed-length values" $ isolate n m - putOption xs = do putLen (atomSize (head xs) * length xs) - traverse_ putAtom xs - -instance (CodecAtom a, CodecAtom b) => Option (a,b) where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option Bool where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option Word8 where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option Word16 where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option Word32 where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option IP4 where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option SubnetMask where - getOption = defaultFixedGetOption - putOption = defaultFixedPutOption -instance Option ByteString where - getOption = do len <- getLen - getByteString len - putOption bs = do putLen (BS.length bs) - putByteString bs - -defaultFixedGetOption :: CodecAtom a => Get a -defaultFixedGetOption = fixedLen n m - where (n,m) = getRecord - -defaultFixedPutOption :: CodecAtom a => a -> Put -defaultFixedPutOption x = do - putLen (atomSize x) - putAtom x - -fixedLen :: Int -> Get a -> Get a -fixedLen expectedLen m = do - len <- getLen - unless (len == expectedLen) (fail "Bad length on \"fixed-length\" option.") - label "Fixed length field" (isolate expectedLen m) - -getRecord :: CodecAtom a => (Int, Get a) -getRecord = (atomSize undef, m) - where - (undef, m) = (undefined, getAtom) :: CodecAtom a => (a, Get a) - - -instance CodecAtom OptionTagOrError where - getAtom = getOptionTag - putAtom x = putOptionTag x - atomSize _ = 1 - -newtype NVTAsciiString = NVTAsciiString String - deriving (Eq, Show) - -instance Option NVTAsciiString where - getOption = do len <- getLen - bs <- getByteString len - return (NVTAsciiString (nullTerminated bs)) - putOption (NVTAsciiString str) = do - putLen (length str) - putByteString (BS8.pack str) - -getLen :: Get Int -getLen = fromIntegral <$> getWord8 - -putLen :: Int -> Put -putLen n = putWord8 $ fromIntegral n diff --git a/src/Hans/Message/Dns.hs b/src/Hans/Message/Dns.hs deleted file mode 100644 --- a/src/Hans/Message/Dns.hs +++ /dev/null @@ -1,601 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE MultiWayIf #-} - -module Hans.Message.Dns ( - DNSPacket(..) - , DNSHeader(..) - , OpCode(..) - , RespCode(..) - , Query(..) - , QClass(..) - , QType(..) - , RR(..) - , Type(..) - , Class(..) - , RData(..) - , Name - - , parseDNSPacket, getDNSPacket - , renderDNSPacket, putDNSPacket - ) where - -import Hans.Address.IP4 -import Hans.Utils (chunk) - -import Control.Monad -import Data.Bits -import Data.Foldable ( traverse_, foldMap ) -import Data.Int -import Data.Serialize ( Putter, runPut, putWord8, putWord16be, putWord32be - , putByteString ) -import Data.Word -import MonadLib ( lift, StateT, runStateT, get, set ) -import Numeric ( showHex ) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import qualified Data.Map.Strict as Map -import qualified Data.Serialize.Get as C - - --- DNS Packets ----------------------------------------------------------------- - -data DNSPacket = DNSPacket { dnsHeader :: DNSHeader - , dnsQuestions :: [Query] - , dnsAnswers :: [RR] - , dnsAuthorityRecords :: [RR] - , dnsAdditionalRecords :: [RR] - } deriving (Show) - -data DNSHeader = DNSHeader { dnsId :: !Word16 - , dnsQuery :: Bool - , dnsOpCode :: OpCode - , dnsAA :: Bool - , dnsTC :: Bool - , dnsRD :: Bool - , dnsRA :: Bool - , dnsRC :: RespCode - } deriving (Show) - -data OpCode = OpQuery - | OpIQuery - | OpStatus - | OpReserved !Word16 - deriving (Show) - -data RespCode = RespNoError - | RespFormatError - | RespServerFailure - | RespNameError - | RespNotImplemented - | RespRefused - | RespReserved !Word16 - deriving (Eq,Show) - -type Name = [S.ByteString] - -data Query = Query { qName :: Name - , qType :: QType - , qClass :: QClass - } deriving (Show) - -data RR = RR { rrName :: Name - , rrClass :: Class - , rrTTL :: !Int32 - , rrRData :: RData - } deriving (Show) - -data QType = QType Type - | AFXR - | MAILB - | MAILA - | QTAny - deriving (Show) - -data Type = A - | NS - | MD - | MF - | CNAME - | SOA - | MB - | MG - | MR - | NULL - | PTR - | HINFO - | MINFO - | MX - | AAAA - deriving (Show) - -data QClass = QClass Class - | QAnyClass - deriving (Show) - -data Class = IN | CS | CH | HS - deriving (Show,Eq) - -data RData = RDA IP4 - | RDNS Name - | RDMD Name - | RDMF Name - | RDCNAME Name - | RDSOA Name Name !Word32 !Int32 !Int32 !Int32 !Word32 - | RDMB Name - | RDMG Name - | RDMR Name - | RDPTR Name - | RDHINFO S.ByteString S.ByteString - | RDMINFO Name Name - | RDMX !Word16 Name - | RDNULL S.ByteString - | RDUnknown Type S.ByteString - deriving (Show) - - --- Cereal With Label Compression ----------------------------------------------- - -data RW = RW { rwOffset :: !Int - , rwLabels :: Map.Map Int Name - } deriving (Show) - -type Get = StateT RW C.Get - -{-# INLINE unGet #-} -unGet :: Get a -> C.Get a -unGet m = - do (a,_) <- runStateT RW { rwOffset = 0, rwLabels = Map.empty } m - return a - -getOffset :: Get Int -getOffset = rwOffset `fmap` get - -addOffset :: Int -> Get () -addOffset off = - do rw <- get - set $! rw { rwOffset = rwOffset rw + off } - -lookupPtr :: Int -> Get Name -lookupPtr off = - do rw <- get - when (off >= rwOffset rw) (fail "Invalid offset in pointer") - case Map.lookup off (rwLabels rw) of - Just ls -> return ls - Nothing -> fail $ "Unknown label for offset: " ++ showHex off "\n" - ++ show (rwLabels rw) - -data Label = Label Int S.ByteString - | Ptr Int Name - deriving (Show) - -labelsToName :: [Label] -> Name -labelsToName = foldMap toName - where - toName (Label _ l) = [l] - toName (Ptr _ n) = n - -addLabels :: [Label] -> Get () -addLabels labels = - do rw <- get - set $! rw { rwLabels = Map.fromList newLabels `Map.union` rwLabels rw } - where - newLabels = go labels (labelsToName labels) - - go (Label off _ : rest) name@(_ : ns) = (off,name) : go rest ns - go (Ptr off _ : _) name = [(off,name)] - go _ _ = [] - - -{-# INLINE liftGet #-} -liftGet :: Int -> C.Get a -> Get a -liftGet n m = do addOffset n - lift m - - -{-# INLINE getWord8 #-} -getWord8 :: Get Word8 -getWord8 = liftGet 1 C.getWord8 - -{-# INLINE getWord16be #-} -getWord16be :: Get Word16 -getWord16be = liftGet 2 C.getWord16be - -{-# INLINE getWord32be #-} -getWord32be :: Get Word32 -getWord32be = liftGet 4 C.getWord32be - -{-# INLINE getInt32be #-} -getInt32be :: Get Int32 -getInt32be = fromIntegral `fmap` liftGet 4 C.getWord32be - -{-# INLINE getBytes #-} -getBytes :: Int -> Get S.ByteString -getBytes n = liftGet n (C.getBytes n) - -isolate :: Int -> Get a -> Get a -isolate n body = - do off <- get - (a,off') <- lift (C.isolate n (runStateT off body)) - set off' - return a - -label :: String -> Get a -> Get a -label str m = - do off <- get - (a,off') <- lift (C.label str (runStateT off m)) - set off' - return a - - -{-# INLINE putInt32be #-} -putInt32be :: Putter Int32 -putInt32be i = putWord32be (fromIntegral i) - --- Parsing --------------------------------------------------------------------- - -parseDNSPacket :: S.ByteString -> Either String DNSPacket -parseDNSPacket = C.runGet getDNSPacket - -getDNSPacket :: C.Get DNSPacket -getDNSPacket = unGet $ label "DNSPacket" $ - do dnsHeader <- getDNSHeader - qdCount <- getWord16be - anCount <- getWord16be - nsCount <- getWord16be - arCount <- getWord16be - - let blockOf c l m = label l (replicateM (fromIntegral c) m) - dnsQuestions <- blockOf qdCount "Questions" getQuery - dnsAnswers <- blockOf anCount "Answers" getRR - dnsAuthorityRecords <- blockOf nsCount "Authority Records" getRR - dnsAdditionalRecords <- blockOf arCount "Additional Records" getRR - - return DNSPacket { .. } - --- 1 1 1 1 1 1 --- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | ID | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- |QR| Opcode |AA|TC|RD|RA| Z | RCODE | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | QDCOUNT | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | ANCOUNT | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | NSCOUNT | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | ARCOUNT | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ -getDNSHeader :: Get DNSHeader -getDNSHeader = label "DNS Header" $ - do dnsId <- getWord16be - flags <- getWord16be - let dnsQuery = not (flags `testBit` 15) - dnsOpCode = parseOpCode (flags `shiftR` 11) - dnsAA = flags `testBit` 10 - dnsTC = flags `testBit` 9 - dnsRD = flags `testBit` 8 - dnsRA = flags `testBit` 7 - dnsZ = (flags `shiftR` 4) .&. 0x7 - dnsRC = parseRespCode (flags .&. 0xf) - - unless (dnsZ == 0) (fail ("Z not zero")) - - return DNSHeader { .. } - - -parseOpCode :: Word16 -> OpCode -parseOpCode 0 = OpQuery -parseOpCode 1 = OpIQuery -parseOpCode 2 = OpStatus -parseOpCode c = OpReserved (c .&. 0xf) - -parseRespCode :: Word16 -> RespCode -parseRespCode 0 = RespNoError -parseRespCode 1 = RespFormatError -parseRespCode 2 = RespServerFailure -parseRespCode 3 = RespNameError -parseRespCode 4 = RespNotImplemented -parseRespCode 5 = RespRefused -parseRespCode c = RespReserved (c .&. 0xf) - -getQuery :: Get Query -getQuery = label "Question" $ - do qName <- getName - qType <- label "QTYPE" getQType - qClass <- label "QCLASS" getQClass - return Query { .. } - --- 1 1 1 1 1 1 --- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | | --- / / --- / NAME / --- | | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | TYPE | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | CLASS | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | TTL | --- | | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ --- | RDLENGTH | --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--| --- / RDATA / --- / / --- +--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+ -getRR :: Get RR -getRR = label "RR" $ - do rrName <- getName - ty <- getType - rrClass <- getClass - rrTTL <- getInt32be - rrRData <- getRData ty - return RR { .. } - - -getType :: Get Type -getType = - do qt <- getQType - case qt of - QType ty -> return ty - _ -> fail ("Invalid TYPE: " ++ show qt) - -getQType :: Get QType -getQType = - do tag <- getWord16be - case tag of - 1 -> return (QType A) - 2 -> return (QType NS) - 3 -> return (QType MD) - 4 -> return (QType MF) - 5 -> return (QType CNAME) - 6 -> return (QType SOA) - 7 -> return (QType MB) - 8 -> return (QType MG) - 9 -> return (QType MR) - 10 -> return (QType NULL) - 12 -> return (QType PTR) - 13 -> return (QType HINFO) - 14 -> return (QType MINFO) - 15 -> return (QType MX) - 28 -> return (QType AAAA) - 252 -> return AFXR - 253 -> return MAILB - 254 -> return MAILA - 255 -> return QTAny - _ -> fail ("Invalid TYPE: " ++ show tag) - - -getQClass :: Get QClass -getQClass = - do tag <- getWord16be - case tag of - 1 -> return (QClass IN) - 2 -> return (QClass CS) - 3 -> return (QClass CH) - 4 -> return (QClass HS) - 255 -> return QAnyClass - _ -> fail ("Invalid CLASS: " ++ show tag) - -getName :: Get Name -getName = - do labels <- go - addLabels labels - return (labelsToName labels) - where - go = do off <- getOffset - len <- getWord8 - if | len .&. 0xc0 == 0xc0 -> - do l <- getWord8 - let ptr = fromIntegral ((0x3f .&. len) `shiftL` 8) - + fromIntegral l - ns <- lookupPtr ptr - return [Ptr off ns] - - | len == 0 -> - return [] - - | otherwise -> - do l <- getBytes (fromIntegral len) - ls <- go - return (Label off l:ls) - -getClass :: Get Class -getClass = label "CLASS" $ - do qc <- getQClass - case qc of - QClass c -> return c - QAnyClass -> fail "Invalid CLASS" - -getRData :: Type -> Get RData -getRData ty = label (show ty) $ - do len <- getWord16be - isolate (fromIntegral len) $ case ty of - A -> RDA `fmap` liftGet 4 parseIP4 - NS -> RDNS `fmap` getName - MD -> RDMD `fmap` getName - MF -> RDMF `fmap` getName - CNAME -> RDCNAME `fmap` getName - SOA -> do mname <- getName - rname <- getName - serial <- getWord32be - refresh <- getInt32be - retry <- getInt32be - expire <- getInt32be - minTTL <- getWord32be - return (RDSOA mname rname serial refresh retry expire minTTL) - MB -> RDMB `fmap` getName - MG -> RDMG `fmap` getName - MR -> RDMR `fmap` getName - NULL -> RDNULL `fmap` (getBytes =<< lift C.remaining) - PTR -> RDPTR `fmap` getName - - HINFO -> do cpuLen <- getWord8 - cpu <- getBytes (fromIntegral cpuLen) - osLen <- getWord8 - os <- getBytes (fromIntegral osLen) - return (RDHINFO cpu os) - - MINFO -> do rmailBx <- getName - emailBx <- getName - return (RDMINFO rmailBx emailBx) - - MX -> do pref <- getWord16be - ex <- getName - return (RDMX pref ex) - - _ -> RDUnknown ty `fmap` (getBytes =<< lift C.remaining) - - --- Rendering ------------------------------------------------------------------- - -renderDNSPacket :: DNSPacket -> L.ByteString -renderDNSPacket pkt = chunk (runPut (putDNSPacket pkt)) - -putDNSPacket :: Putter DNSPacket -putDNSPacket DNSPacket{ .. } = - do putDNSHeader dnsHeader - - putWord16be (fromIntegral (length dnsQuestions)) - putWord16be (fromIntegral (length dnsAnswers)) - putWord16be (fromIntegral (length dnsAuthorityRecords)) - putWord16be (fromIntegral (length dnsAdditionalRecords)) - - traverse_ putQuery dnsQuestions - traverse_ putRR dnsAnswers - traverse_ putRR dnsAuthorityRecords - traverse_ putRR dnsAdditionalRecords - -putDNSHeader :: Putter DNSHeader -putDNSHeader DNSHeader { .. } = - do putWord16be dnsId - let flag i b w | b = setBit w i - | otherwise = clearBit w i - flags = flag 15 (not dnsQuery) - $ flag 10 dnsAA - $ flag 9 dnsTC - $ flag 8 dnsRD - $ flag 7 dnsRA - $ flag 4 False -- dnsZ - $ (renderOpCode dnsOpCode `shiftL` 11) .|. renderRespCode dnsRC - putWord16be flags - -renderOpCode :: OpCode -> Word16 -renderOpCode OpQuery = 0 -renderOpCode OpIQuery = 1 -renderOpCode OpStatus = 2 -renderOpCode (OpReserved c) = c .&. 0xf - -renderRespCode :: RespCode -> Word16 -renderRespCode RespNoError = 0 -renderRespCode RespFormatError = 1 -renderRespCode RespServerFailure = 2 -renderRespCode RespNameError = 3 -renderRespCode RespNotImplemented = 4 -renderRespCode RespRefused = 5 -renderRespCode (RespReserved c) = c .&. 0xf - -putName :: Putter Name -putName = go - where - go (l:ls) - | S.null l = putWord8 0 - | S.length l > 63 = error "Label too big" - | otherwise = do putWord8 (fromIntegral len) - putByteString l - go ls - where - len = S.length l - - go [] = putWord8 0 - -putQuery :: Putter Query -putQuery Query { .. } = - do putName qName - putQType qType - putQClass qClass - -putType :: Putter Type -putType A = putWord16be 1 -putType NS = putWord16be 2 -putType MD = putWord16be 3 -putType MF = putWord16be 4 -putType CNAME = putWord16be 5 -putType SOA = putWord16be 6 -putType MB = putWord16be 7 -putType MG = putWord16be 8 -putType MR = putWord16be 9 -putType NULL = putWord16be 10 -putType PTR = putWord16be 12 -putType HINFO = putWord16be 13 -putType MINFO = putWord16be 14 -putType MX = putWord16be 15 -putType AAAA = putWord16be 28 - -putQType :: Putter QType -putQType (QType ty) = putType ty -putQType AFXR = putWord16be 252 -putQType MAILB = putWord16be 253 -putQType MAILA = putWord16be 254 -putQType QTAny = putWord16be 255 - -putQClass :: Putter QClass -putQClass (QClass c) = putClass c -putQClass QAnyClass = putWord16be 255 - -putRR :: Putter RR -putRR RR { .. } = - do putName rrName - let (ty,rdata) = putRData rrRData - putType ty - putClass rrClass - putWord32be (fromIntegral rrTTL) - putWord16be (fromIntegral (S.length rdata)) - putByteString rdata - -putClass :: Putter Class -putClass IN = putWord16be 1 -putClass CS = putWord16be 2 -putClass CH = putWord16be 3 -putClass HS = putWord16be 4 - -putRData :: RData -> (Type,S.ByteString) -putRData rd = case rd of - RDA addr -> rdata A (renderIP4 addr) - RDNS name -> rdata NS (putName name) - RDMD name -> rdata MD (putName name) - RDMF name -> rdata MF (putName name) - RDCNAME name -> rdata CNAME (putName name) - RDSOA m r s f t ex ttl -> - rdata SOA $ do putName m - putName r - putWord32be s - putInt32be f - putInt32be t - putInt32be ex - putWord32be ttl - - RDMB name -> rdata MB (putName name) - RDMG name -> rdata MG (putName name) - RDMR name -> rdata MR (putName name) - RDNULL bytes -> rdata NULL $ do putWord8 (fromIntegral (S.length bytes)) - putByteString bytes - RDPTR name -> rdata PTR (putName name) - RDHINFO cpu os -> rdata HINFO $ do putWord8 (fromIntegral (S.length cpu)) - putByteString cpu - putWord8 (fromIntegral (S.length os)) - putByteString os - RDMINFO rm em -> rdata MINFO $ do putName rm - putName em - RDMX pref ex -> rdata MX $ do putWord16be pref - putName ex - RDUnknown ty bytes -> (ty,bytes) - where - rdata tag m = (tag,runPut m) diff --git a/src/Hans/Message/EthernetFrame.hs b/src/Hans/Message/EthernetFrame.hs deleted file mode 100644 --- a/src/Hans/Message/EthernetFrame.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hans.Message.EthernetFrame ( - EtherType(..) - , parseEtherType, renderEtherType - - , EthernetFrame(..) - , parseEthernetFrame, renderEthernetFrame - ) where - -import Hans.Address.Mac (Mac,parseMac,renderMac) -import Hans.Utils (chunk) - -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) - -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 - } deriving (Eq,Show) - -parseEthernetFrame :: S.ByteString -> Either String (EthernetFrame,S.ByteString) -parseEthernetFrame = runGet ((,) <$> header <*> (getBytes =<< remaining)) - where - header = EthernetFrame - <$> parseMac - <*> parseMac - <*> parseEtherType - -renderEthernetFrame :: EthernetFrame -> L.ByteString -> L.ByteString -renderEthernetFrame frame body = chunk hdr `L.append` body - where - hdr = runPut $ do - renderMac (etherDest frame) - renderMac (etherSource frame) - renderEtherType (etherType frame) diff --git a/src/Hans/Message/Icmp4.hs b/src/Hans/Message/Icmp4.hs deleted file mode 100644 --- a/src/Hans/Message/Icmp4.hs +++ /dev/null @@ -1,442 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hans.Message.Icmp4 where - -import Hans.Address.IP4 (IP4) -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, 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 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 S.ByteString - | ParameterProblem Word8 S.ByteString - | Timestamp Identifier SequenceNumber Word32 Word32 Word32 - | TimestampReply Identifier SequenceNumber Word32 Word32 Word32 - | Information Identifier SequenceNumber - | InformationReply Identifier SequenceNumber - - -- rfc 1393 - Traceroute Using an IP Option - | TraceRoute TraceRouteCode Identifier Word16 Word16 Word32 Word32 - - -- rfc 950 - Internet Standard Subnetting Procedure - | AddressMask Identifier SequenceNumber - | AddressMaskReply Identifier SequenceNumber Word32 - deriving (Eq,Show) - -noCode :: String -> Get () -noCode str = do - code <- getWord8 - unless (code == 0) - (fail (str ++ " expects code 0")) - -{-# INLINE parseIcmp4Packet #-} -parseIcmp4Packet :: S.ByteString -> Either String Icmp4Packet -parseIcmp4Packet = runGet $ do - rest <- lookAhead (getBytes =<< remaining) - unless (computeChecksum 0 rest == 0) - (fail "Bad checksum") - getIcmp4Packet - -getIcmp4Packet :: Get Icmp4Packet -getIcmp4Packet = label "ICMP" $ do - - ty <- get - - let firstGet :: Serialize a => String -> (a -> Get b) -> Get b - firstGet labelString f = label labelString $ do - code <- get - skip 2 -- checksum - f code - - case (ty :: Word8) of - 0 -> firstGet "Echo Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - dat <- getByteString =<< remaining - return $! EchoReply ident seqNum dat - - 3 -> firstGet "DestinationUnreachable" $ \ code -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! DestinationUnreachable code dat - - 4 -> firstGet "Source Quence" $ \ NoCode -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! SourceQuench dat - - 5 -> firstGet "Redirect" $ \ code -> do - gateway <- get - dat <- getByteString =<< remaining - return $! Redirect code gateway dat - - 8 -> firstGet "Echo" $ \ NoCode -> do - ident <- get - seqNum <- get - dat <- getByteString =<< remaining - return $! Echo ident seqNum 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 - - 10 -> firstGet "Router Solicitation" $ \ NoCode -> do - skip 4 -- reserved - return RouterSolicitation - - 11 -> firstGet "Time Exceeded" $ \ code -> do - skip 4 -- unused - dat <- getByteString =<< remaining - return $! TimeExceeded code dat - - 12 -> firstGet "Parameter Problem" $ \ NoCode -> do - ptr <- getWord8 - skip 3 -- unused - dat <- getByteString =<< remaining - return $! ParameterProblem ptr dat - - 13 -> firstGet "Timestamp" $ \ NoCode -> do - ident <- get - seqNum <- get - origTime <- get - recvTime <- get - tranTime <- get - return $! Timestamp ident seqNum origTime recvTime tranTime - - 14 -> firstGet "Timestamp Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - origTime <- get - recvTime <- get - tranTime <- get - return $! TimestampReply ident seqNum origTime recvTime tranTime - - 15 -> firstGet "Information" $ \ NoCode -> do - ident <- get - seqNum <- get - return $! Information ident seqNum - - 16 -> firstGet "Information Reply" $ \ NoCode -> do - ident <- get - seqNum <- get - return $! InformationReply ident seqNum - - 17 -> firstGet "Address Mask" $ \ NoCode -> do - ident <- get - seqNum <- get - skip 4 -- address mask - return $! AddressMask ident seqNum - - 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 - - _ -> fail ("Unknown type: " ++ show ty) - - -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 - -putIcmp4Packet :: Putter Icmp4Packet -putIcmp4Packet = put' - where - 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 - - put' (DestinationUnreachable code dat) - = do firstPut 3 code - put (0 :: Word32) -- unused - putByteString dat - - put' (SourceQuench dat) - = do firstPut 4 NoCode - put (0 :: Word32) -- unused - putByteString dat - - put' (Redirect code gateway dat) - = do firstPut 5 code - put gateway - putByteString dat - - put' (Echo ident seqNum dat) - = do firstPut 8 NoCode - put ident - put seqNum - putByteString dat - - put' (RouterAdvertisement lifetime addrs) - = do let len = length addrs - addrSize :: Word8 - addrSize = 2 - - when (len > 255) - (fail "Too many routers in Router Advertisement") - - firstPut 9 NoCode - put (fromIntegral len :: Word8) - put addrSize - renderLifetime lifetime - mapM_ put addrs - - put' RouterSolicitation - = do firstPut 10 NoCode - put (0 :: Word32) -- RESERVED - - put' (TimeExceeded code dat) - = do firstPut 11 code - put (0 :: Word32) -- unused - putByteString dat - - put' (ParameterProblem ptr dat) - = do firstPut 12 NoCode - put ptr - put (0 :: Word8) -- unused - put (0 :: Word16) -- unused - putByteString dat - - put' (Timestamp ident seqNum origTime recvTime tranTime) - = do firstPut 13 NoCode - put ident - put seqNum - put origTime - put recvTime - put tranTime - - put' (TimestampReply ident seqNum origTime recvTime tranTime) - = do firstPut 14 NoCode - put ident - put seqNum - put origTime - put recvTime - put tranTime - - put' (Information ident seqNum) - = do firstPut 15 NoCode - put ident - put seqNum - - put' (InformationReply ident seqNum) - = do firstPut 16 NoCode - put ident - put seqNum - - 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 - get = do b <- getWord8 - unless (b == 0) - (fail ("Expected code 0, got code: " ++ show b)) - return NoCode - put NoCode = putWord8 0 - -data DestinationUnreachableCode - = NetUnreachable - | HostUnreachable - | ProtocolUnreachable - | PortUnreachable - | FragmentationUnreachable - | SourceRouteFailed - | 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 - 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 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 (Eq,Show) - -instance Serialize TimeExceededCode where - get = do b <- getWord8 - case b of - 0 -> return TimeToLiveExceededInTransit - 1 -> return FragmentReassemblyTimeExceeded - _ -> fail "Invalid code for Time Exceeded" - - put TimeToLiveExceededInTransit = putWord8 0 - put FragmentReassemblyTimeExceeded = putWord8 1 - -data RedirectCode - = RedirectForNetwork - | RedirectForHost - | RedirectForTypeOfServiceAndNetwork - | RedirectForTypeOfServiceAndHost - deriving (Eq,Show) - -instance Serialize RedirectCode where - get = do b <- getWord8 - case b of - 0 -> return RedirectForNetwork - 1 -> return RedirectForHost - 2 -> return RedirectForTypeOfServiceAndNetwork - 3 -> return RedirectForTypeOfServiceAndHost - _ -> fail "Invalid code for Time Exceeded" - - put RedirectForNetwork = putWord8 0 - put RedirectForHost = putWord8 1 - put RedirectForTypeOfServiceAndNetwork = putWord8 2 - put RedirectForTypeOfServiceAndHost = putWord8 3 - -data TraceRouteCode - = TraceRouteForwarded - | TraceRouteDiscarded - deriving (Eq,Show) - -instance Serialize TraceRouteCode where - get = do b <- getWord8 - case b of - 0 -> return TraceRouteForwarded - 1 -> return TraceRouteDiscarded - _ -> fail "Invalid code for Trace Route" - - put TraceRouteForwarded = putWord8 0 - put TraceRouteDiscarded = putWord8 1 - --- Router Discovery Data ------------------------------------------------------- - -newtype PreferenceLevel = PreferenceLevel Int32 - deriving (Show,Eq,Ord,Num,Serialize) - -data RouterAddress = RouterAddress - { raAddr :: IP4 - , raPreferenceLevel :: PreferenceLevel - } deriving (Eq,Show) - -instance Serialize RouterAddress where - get = liftM2 RouterAddress get get - - put ra = do - put (raAddr ra) - put (raPreferenceLevel ra) - -newtype Identifier = Identifier Word16 - deriving (Show, Eq, Ord, Num, Serialize) - -newtype SequenceNumber = SequenceNumber Word16 - deriving (Show, Eq, Ord, Num, Serialize) - -getUntilDone :: Serialize a => Get [a] -getUntilDone = do - empty <- isEmpty - if empty then return [] - else liftM2 (:) get getUntilDone diff --git a/src/Hans/Message/Ip4.hs b/src/Hans/Message/Ip4.hs deleted file mode 100644 --- a/src/Hans/Message/Ip4.hs +++ /dev/null @@ -1,288 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hans.Message.Ip4 where - -import Hans.Address.IP4 (IP4(..)) -import Hans.Utils -import Hans.Utils.Checksum - -import Control.Monad (unless) -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 ----------------------------------------------------------- - --- 0 7 8 15 16 23 24 31 --- +--------+--------+--------+--------+ --- | source address | --- +--------+--------+--------+--------+ --- | destination address | --- +--------+--------+--------+--------+ --- | zero |protocol| length | --- +--------+--------+--------+--------+ -mkIP4PseudoHeader :: IP4 -> IP4 -> IP4Protocol -> MkPseudoHeader -mkIP4PseudoHeader src dst prot len = runPut $ do - put src - put dst - putWord8 0 >> put prot >> putWord16be (fromIntegral len) - - --- IP4 Packets ----------------------------------------------------------------- - -newtype Ident = Ident { getIdent :: Word16 } - deriving (Eq,Ord,Num,Show,Serialize,Integral,Real,Enum) - -newtype IP4Protocol = IP4Protocol { getIP4Protocol :: Word8 } - deriving (Eq,Ord,Num,Show,Serialize) - -data IP4Header = IP4Header - { ip4Version :: !Word8 - , ip4TypeOfService :: !Word8 - , ip4Ident :: !Ident - , ip4DontFragment :: Bool - , ip4MoreFragments :: Bool - , ip4FragmentOffset :: !Word16 - , ip4TimeToLive :: !Word8 - , ip4Protocol :: !IP4Protocol - , ip4Checksum :: !Word16 - , ip4SourceAddr :: !IP4 - , ip4DestAddr :: !IP4 - , ip4Options :: [IP4Option] - } deriving (Eq,Show) - -emptyIP4Header :: IP4Header -emptyIP4Header = IP4Header - { ip4Version = 4 - , ip4TypeOfService = 0 - , ip4Ident = 0 - , ip4DontFragment = False - , ip4MoreFragments = False - , ip4FragmentOffset = 0 - , ip4TimeToLive = 127 - , ip4Protocol = IP4Protocol 0 - , ip4Checksum = 0 - , ip4SourceAddr = IP4 0 0 0 0 - , ip4DestAddr = IP4 0 0 0 0 - , ip4Options = [] - } - - -noMoreFragments :: IP4Header -> IP4Header -noMoreFragments hdr = hdr { ip4MoreFragments = False } - -moreFragments :: IP4Header -> IP4Header -moreFragments hdr = hdr { ip4MoreFragments = True } - -addOffset :: Word16 -> IP4Header -> IP4Header -addOffset off hdr = hdr { ip4FragmentOffset = ip4FragmentOffset hdr + off } - -setIdent :: Ident -> IP4Header -> IP4Header -setIdent i hdr = hdr { ip4Ident = i } - - --- | Calculate the size of an IP4 packet -ip4PacketSize :: IP4Header -> L.ByteString -> Int -ip4PacketSize hdr bs = - ip4HeaderSize hdr + fromIntegral (L.length bs) - --- | Calculate the size of an IP4 header -ip4HeaderSize :: IP4Header -> Int -ip4HeaderSize hdr = 20 + sum (map ip4OptionSize (ip4Options hdr)) - - --- | Fragment a single IP packet into one or more, given an MTU to fit into. -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 :: Int64 -> IP4Header -> L.ByteString - -> [(IP4Header,L.ByteString)] -fragmentPacket mtu = loop - where - 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 --- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- |Version| IHL |Type of Service| Total Length | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Identification |Flags| Fragment Offset | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Time to Live | Protocol | Header Checksum | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Source Address | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Destination Address | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -getIP4Packet :: Get (IP4Header, Int, Int) -getIP4Packet = do - b0 <- getWord8 - let ver = b0 `shiftR` 4 - let ihl = fromIntegral ((b0 .&. 0xf) * 4) - label "IP4 Header" $ isolate (ihl - 1) $ do - tos <- getWord8 - len <- getWord16be - ident <- get - b1 <- getWord16be - let flags = b1 `shiftR` 13 - let off = b1 .&. 0x1fff - ttl <- getWord8 - prot <- get - cs <- getWord16be - source <- get - dest <- get - let optlen = ihl - 20 - opts <- label "IP4 Options" - $ isolate optlen - $ getOptions - $ fromIntegral optlen - let hdr = IP4Header - { ip4Version = ver - , ip4TypeOfService = tos - , ip4Ident = ident - , ip4DontFragment = flags `testBit` 1 - , ip4MoreFragments = flags `testBit` 0 - , ip4FragmentOffset = off * 8 - , ip4TimeToLive = ttl - , ip4Protocol = prot - , ip4Checksum = cs - , ip4SourceAddr = source - , ip4DestAddr = dest - , ip4Options = opts - } - return (hdr, fromIntegral ihl, fromIntegral len) - -{-# INLINE parseIP4Packet #-} -parseIP4Packet :: S.ByteString -> Either String (IP4Header, Int, Int) -parseIP4Packet bytes = runGet getIP4Packet bytes - -{-# INLINE renderIP4Header #-} -renderIP4Header :: IP4Header -> Int -> S.ByteString -renderIP4Header hdr pktlen = runPut (putIP4Header hdr pktlen) - -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 -- checksum - - put (ip4SourceAddr hdr) - - put (ip4DestAddr hdr) - - putByteString optbs - - --- | 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) -renderOptions opts = case optlen `mod` 4 of - 0 -> (optbs,fromIntegral optlen) - -- pad with no-ops - n -> (optbs `S.append` S.replicate n 0x1, fromIntegral (optlen + n)) - where - optbs = runPut (mapM_ put opts) - optlen = S.length optbs - - -getOptions :: Int -> Get [IP4Option] -getOptions len - | len <= 0 = return [] - | otherwise = do - o <- get - rest <- getOptions (len - ip4OptionSize o) - return $! (o : rest) - - -data IP4Option = IP4Option - { ip4OptionCopied :: !Bool - , ip4OptionClass :: !Word8 - , ip4OptionNum :: !Word8 - , ip4OptionData :: S.ByteString - } deriving (Eq,Show) - - -ip4OptionSize :: IP4Option -> Int -ip4OptionSize opt = case ip4OptionNum opt of - 0 -> 1 - 1 -> 1 - _ -> 2 + fromIntegral (S.length (ip4OptionData opt)) - - -instance Serialize IP4Option where - get = do - b <- getWord8 - let optCopied = testBit b 7 - let optClass = (b `shiftR` 5) .&. 0x3 - let optNum = b .&. 0x1f - bs <- case optNum of - 0 -> return S.empty - 1 -> return S.empty - _ -> do - len <- getWord8 - unless (len >= 2) (fail "Option length parameter is to small") - getByteString (fromIntegral (len - 2)) - return $! IP4Option - { ip4OptionCopied = optCopied - , ip4OptionClass = optClass - , ip4OptionNum = optNum - , ip4OptionData = bs - } - put opt = do - let copied | ip4OptionCopied opt = bit 7 - | otherwise = 0 - putWord8 (copied .|. ((ip4OptionClass opt .&. 0x3) `shiftL` 5) - .|. ip4OptionNum opt .&. 0x1f) - case ip4OptionNum opt of - 0 -> return () - 1 -> return () - _ -> do - putWord8 (fromIntegral (S.length (ip4OptionData opt))) - putByteString (ip4OptionData opt) diff --git a/src/Hans/Message/Tcp.hs b/src/Hans/Message/Tcp.hs deleted file mode 100644 --- a/src/Hans/Message/Tcp.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hans.Message.Tcp where - -import Hans.Address.IP4 (IP4) -import Hans.Message.Ip4 (mkIP4PseudoHeader,IP4Protocol(..)) -import Hans.Utils (chunk) -import Hans.Utils.Checksum - -import Control.Monad (unless,ap,replicateM_,replicateM) -import Data.Bits ((.&.),setBit,testBit,shiftL,shiftR) -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,runGet,runPut - ,putLazyByteString) -import Data.Word (Word8,Word16,Word32) -import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S -import qualified Data.Foldable as F - - --- Tcp Support Types ----------------------------------------------------------- - -tcpProtocol :: IP4Protocol -tcpProtocol = IP4Protocol 0x6 - -newtype TcpPort = TcpPort - { getPort :: Word16 - } deriving (Eq,Ord,Read,Show,Num,Enum,Bounded) - -putTcpPort :: Putter TcpPort -putTcpPort (TcpPort w16) = putWord16be w16 - -getTcpPort :: Get TcpPort -getTcpPort = TcpPort `fmap` getWord16be - - -newtype TcpSeqNum = TcpSeqNum - { getSeqNum :: Word32 - } deriving (Eq,Ord,Show,Num,Bounded,Enum,Real,Integral) - -instance Monoid TcpSeqNum where - mempty = 0 - mappend = (+) - -putTcpSeqNum :: Putter TcpSeqNum -putTcpSeqNum (TcpSeqNum w32) = putWord32be w32 - -getTcpSeqNum :: Get TcpSeqNum -getTcpSeqNum = TcpSeqNum `fmap` getWord32be - - --- | An alias to TcpSeqNum, as these two are used in the same role. -type TcpAckNum = TcpSeqNum - -putTcpAckNum :: Putter TcpAckNum -putTcpAckNum = putTcpSeqNum - -getTcpAckNum :: Get TcpAckNum -getTcpAckNum = getTcpSeqNum - - --- Tcp Header ------------------------------------------------------------------ - --- 0 1 2 3 --- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Source Port | Destination Port | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Sequence Number | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Acknowledgment Number | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Data | |C|E|U|A|P|R|S|F| | --- | Offset| Res. |W|C|R|C|S|S|Y|I| Window | --- | | |R|E|G|K|H|T|N|N| | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Checksum | Urgent Pointer | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | Options | Padding | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ --- | data | --- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -data TcpHeader = TcpHeader - { tcpSourcePort :: !TcpPort - , tcpDestPort :: !TcpPort - , tcpSeqNum :: !TcpSeqNum - , tcpAckNum :: !TcpAckNum - , tcpCwr :: !Bool - , tcpEce :: !Bool - , tcpUrg :: !Bool - , tcpAck :: !Bool - , tcpPsh :: !Bool - , tcpRst :: !Bool - , tcpSyn :: !Bool - , tcpFin :: !Bool - , tcpWindow :: !Word16 - , tcpChecksum :: !Word16 - , tcpUrgentPointer :: !Word16 - , tcpOptions :: [TcpOption] - } deriving (Eq,Show) - -instance HasTcpOptions TcpHeader where - findTcpOption tag hdr = findTcpOption tag (tcpOptions hdr) - setTcpOption opt hdr = hdr { tcpOptions = setTcpOption opt (tcpOptions hdr) } - -emptyTcpHeader :: TcpHeader -emptyTcpHeader = TcpHeader - { tcpSourcePort = TcpPort 0 - , tcpDestPort = TcpPort 0 - , tcpSeqNum = 0 - , tcpAckNum = 0 - , tcpCwr = False - , tcpEce = False - , tcpUrg = False - , tcpAck = False - , tcpPsh = False - , tcpRst = False - , tcpSyn = False - , tcpFin = False - , tcpWindow = 0 - , tcpChecksum = 0 - , tcpUrgentPointer = 0 - , tcpOptions = [] - } - --- | The length of the fixed part of the TcpHeader, in 4-byte octets. -tcpFixedHeaderLength :: Int -tcpFixedHeaderLength = 5 - --- | Render a TcpHeader. The checksum value is never rendered, as it is --- expected to be calculated and poked in afterwords. -putTcpHeader :: Putter TcpHeader -putTcpHeader hdr = do - putTcpPort (tcpSourcePort hdr) - putTcpPort (tcpDestPort hdr) - putTcpSeqNum (tcpSeqNum hdr) - putTcpAckNum (tcpAckNum hdr) - let (optLen,padding) = tcpOptionsLength (tcpOptions hdr) - putWord8 (fromIntegral ((tcpFixedHeaderLength + optLen) `shiftL` 4)) - putTcpControl hdr - putWord16be (tcpWindow hdr) - putWord16be 0 - putWord16be (tcpUrgentPointer 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 = label "TcpHeader" $ do - src <- getTcpPort - dst <- getTcpPort - seqNum <- getTcpSeqNum - ackNum <- getTcpAckNum - b <- getWord8 - let len = fromIntegral ((b `shiftR` 4) .&. 0xf) - cont <- getWord8 - win <- getWord16be - cs <- getWord16be - urgent <- getWord16be - let optsLen = len - tcpFixedHeaderLength - opts <- label "options" (isolate (optsLen `shiftL` 2) getTcpOptions) - let hdr = setTcpControl cont emptyTcpHeader - { tcpSourcePort = src - , tcpDestPort = dst - , tcpSeqNum = seqNum - , tcpAckNum = ackNum - , tcpWindow = win - , tcpChecksum = cs - , tcpUrgentPointer = urgent - , tcpOptions = filter (/= OptEndOfOptions) opts - } - return (hdr,len * 4) - --- | Render out the @Word8@ that contains the Control field of the TcpHeader. -putTcpControl :: Putter TcpHeader -putTcpControl c = - putWord8 $ putBit 7 tcpCwr - $ putBit 6 tcpEce - $ putBit 5 tcpUrg - $ putBit 4 tcpAck - $ putBit 3 tcpPsh - $ putBit 2 tcpRst - $ putBit 1 tcpSyn - $ putBit 0 tcpFin - 0 - where - putBit n prj w | prj c = setBit w n - | otherwise = w - --- | Parse out the control flags from the octet that contains them. -setTcpControl :: Word8 -> TcpHeader -> TcpHeader -setTcpControl w hdr = hdr - { tcpCwr = testBit w 7 - , tcpEce = testBit w 6 - , tcpUrg = testBit w 5 - , tcpAck = testBit w 4 - , tcpPsh = testBit w 3 - , tcpRst = testBit w 2 - , tcpSyn = testBit w 1 - , tcpFin = testBit w 0 - } - - --- Tcp Options ----------------------------------------------------------------- - -class HasTcpOptions a where - 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) - -getTcpOptionTag :: Get TcpOptionTag -getTcpOptionTag = do - ty <- getWord8 - return $! case ty of - 0 -> OptTagEndOfOptions - 1 -> OptTagNoOption - 2 -> OptTagMaxSegmentSize - 3 -> OptTagWindowScaling - 4 -> OptTagSackPermitted - 5 -> OptTagSack - 8 -> OptTagTimestamp - _ -> OptTagUnknown ty - -putTcpOptionTag :: Putter TcpOptionTag -putTcpOptionTag tag = - putWord8 $ case tag of - OptTagEndOfOptions -> 0 - OptTagNoOption -> 1 - OptTagMaxSegmentSize -> 2 - OptTagWindowScaling -> 3 - OptTagSackPermitted -> 4 - OptTagSack -> 5 - OptTagTimestamp -> 8 - OptTagUnknown ty -> ty - -instance HasTcpOptions [TcpOption] where - findTcpOption tag = find p - where - p opt = tag == tcpOptionTag opt - - setTcpOption opt = loop - where - tag = tcpOptionTag opt - loop [] = [opt] - loop (o:opts) - | tcpOptionTag o == tag = opt : opts - | otherwise = o : loop opts - - -data TcpOption - = OptEndOfOptions - | OptNoOption - | OptMaxSegmentSize !Word16 - | OptWindowScaling !Word8 - | OptSackPermitted - | OptSack [SackBlock] - | OptTimestamp !Word32 !Word32 - | OptUnknown !Word8 !Word8 !S.ByteString - 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 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,0) - | otherwise = (len + 1,4 - left) - where - (len,left) = F.sum (fmap tcpOptionLength opts) `quotRem` 4 - -tcpOptionLength :: TcpOption -> Int -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 - - -putTcpOption :: Putter TcpOption -putTcpOption opt = do - putTcpOptionTag (tcpOptionTag opt) - case opt of - 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 _ len bs -> putUnknown len bs - --- | Parse in known tcp options. -getTcpOptions :: Get [TcpOption] -getTcpOptions = label "Tcp Options" loop - where - loop = do - left <- remaining - if left > 0 then body else return [] - - body = do - opt <- getTcpOption - case opt of - - OptEndOfOptions -> do - skip =<< remaining - return [] - - _ -> do - rest <- loop - return (opt:rest) - -getTcpOption :: Get TcpOption -getTcpOption = do - tag <- getTcpOptionTag - case tag of - OptTagEndOfOptions -> return OptEndOfOptions - OptTagNoOption -> return OptNoOption - OptTagMaxSegmentSize -> getMaxSegmentSize - OptTagWindowScaling -> getWindowScaling - OptTagSackPermitted -> getSackPermitted - OptTagSack -> getSack - OptTagTimestamp -> getTimestamp - OptTagUnknown ty -> getUnknown ty - -getMaxSegmentSize :: Get TcpOption -getMaxSegmentSize = label "Max Segment Size" $ isolate 3 $ do - len <- getWord8 - unless (len == 4) (fail ("Unexpected length: " ++ show len)) - OptMaxSegmentSize `fmap` getWord16be - -putMaxSegmentSize :: Putter Word16 -putMaxSegmentSize w16 = do - 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 - unless (len == 3) (fail ("Unexpected length: " ++ show len)) - OptWindowScaling `fmap` getWord8 - -putWindowScaling :: Putter Word8 -putWindowScaling w = do - putWord8 3 - putWord8 w - -getTimestamp :: Get TcpOption -getTimestamp = label "Timestamp" $ isolate 9 $ do - len <- getWord8 - unless (len == 10) (fail ("Unexpected length: " ++ show len)) - OptTimestamp `fmap` getWord32be `ap` getWord32be - -putTimestamp :: Word32 -> Word32 -> Put -putTimestamp v r = do - putWord8 10 - putWord32be v - putWord32be r - -getUnknown :: Word8 -> Get TcpOption -getUnknown ty = do - len <- getWord8 - body <- isolate (fromIntegral len - 2) (getBytes =<< remaining) - return (OptUnknown ty len body) - -putUnknown :: Word8 -> S.ByteString -> Put -putUnknown len body = do - putWord8 len - putByteString body - - --- Tcp Packet ------------------------------------------------------------------ - -{-# INLINE parseTcpPacket #-} -parseTcpPacket :: S.ByteString -> Either String (TcpHeader,S.ByteString) -parseTcpPacket bytes = runGet getTcpPacket bytes - --- | Parse a TcpPacket. -getTcpPacket :: Get (TcpHeader,S.ByteString) -getTcpPacket = do - pktLen <- remaining - (hdr,hdrLen) <- getTcpHeader - body <- getBytes (pktLen - hdrLen) - return (hdr,body) - --- | Render out a TcpPacket, without calculating its checksum. -putTcpPacket :: TcpHeader -> L.ByteString -> Put -putTcpPacket hdr body = do - putTcpHeader hdr - putLazyByteString body - --- | Calculate the checksum of a TcpHeader, and its body. -renderWithTcpChecksumIP4 :: IP4 -> IP4 -> TcpHeader -> L.ByteString - -> L.ByteString -renderWithTcpChecksumIP4 src dst hdr body = chunk hdrbs `L.append` body - where - (hdrbs,_) = computeTcpChecksumIP4 src dst hdr body - --- | Calculate the checksum of a tcp packet, and return its rendered header. -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 - phcs = computePartialChecksum emptyPartialChecksum - $ mkIP4PseudoHeader src dst tcpProtocol - $ S.length hdrbs + fromIntegral (L.length body) - hdrbs = runPut (putTcpHeader hdr { tcpChecksum = 0 }) - hdrcs = computePartialChecksum phcs hdrbs - cs = finalizeChecksum (computePartialChecksumLazy hdrcs body) - --- | Re-create the checksum, minimizing duplication of the original, rendered --- TCP packet. -validateTcpChecksumIP4 :: IP4 -> IP4 -> S.ByteString -> Bool -validateTcpChecksumIP4 src dst bytes = - finalizeChecksum (computePartialChecksum phcs bytes) == 0 - where - phcs = computePartialChecksum emptyPartialChecksum - $ mkIP4PseudoHeader src dst tcpProtocol - $ S.length bytes - diff --git a/src/Hans/Message/Types.hs b/src/Hans/Message/Types.hs deleted file mode 100644 --- a/src/Hans/Message/Types.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Hans.Message.Types where - -import Control.Applicative ((<$>)) -import Data.Serialize.Get (Get,getWord16be) -import Data.Serialize.Put (Putter,putWord16be) -import Data.Word (Word16) - -newtype Lifetime = Lifetime { getLifetime :: Word16 } - deriving (Show,Eq,Ord,Num) - -parseLifetime :: Get Lifetime -parseLifetime = Lifetime <$> getWord16be - -renderLifetime :: Putter Lifetime -renderLifetime = putWord16be . getLifetime diff --git a/src/Hans/Message/Udp.hs b/src/Hans/Message/Udp.hs deleted file mode 100644 --- a/src/Hans/Message/Udp.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# 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 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.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,Read,Show,Enum,Bounded,Typeable) - -parseUdpPort :: Get UdpPort -parseUdpPort = UdpPort <$> getWord16be - -renderUdpPort :: Putter UdpPort -renderUdpPort = putWord16be . getUdpPort - - --- Udp Header ------------------------------------------------------------------ - -data UdpHeader = UdpHeader - { udpSourcePort :: !UdpPort - , udpDestPort :: !UdpPort - , udpChecksum :: !Word16 - } deriving (Eq,Show) - -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 - (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 :: UdpHeader -> L.ByteString -> MkPseudoHeader - -> IO L.ByteString -renderUdpPacket hdr body mk = do - -- the checksum is 6 bytes into the rendered packet - hdrBytes' <- pokeChecksum cs hdrBytes 6 - return (L.fromChunks [hdrBytes'] `L.append` body) - where - -- pseudo header - bodyLen = fromIntegral (L.length body) - ph = mk (bodyLen + udpHeaderSize) - pcs = computePartialChecksum emptyPartialChecksum ph - - -- real header - hdrBytes = runPut (renderUdpHeader (hdr { udpChecksum = 0 }) bodyLen) - - -- body, and final checksum - hcs = computePartialChecksum pcs hdrBytes - cs = finalizeChecksum (computePartialChecksumLazy hcs body) - --- | Recreate the UDP checksum, given a rendered packet, and the source and --- destination. -validateUdpChecksum :: IP4 -> IP4 -> S.ByteString -> Bool -validateUdpChecksum src dst bytes = - finalizeChecksum (computePartialChecksum phcs bytes) == 0 - where - phcs = computePartialChecksum emptyPartialChecksum - $ mkIP4PseudoHeader src dst udpProtocol - $ S.length bytes diff --git a/src/Hans/Monad.hs b/src/Hans/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Monad.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Hans.Monad ( + Hans() + , runHans, runHansOnce + , setEscape, escape, dropPacket + , callCC + , io + , decode, decode' + ) where + +import Hans.Device.Types (DeviceStats(),updateDropped,statRX) + +import qualified Control.Applicative as A +import qualified Data.ByteString as S +import Data.IORef (newIORef,writeIORef,readIORef) +import Data.Serialize.Get (runGet,runGetState,Get) +import MonadLib (BaseM(..)) + + +newtype Hans a = Hans { unHans :: IO () -> (a -> IO ()) -> IO () } + +instance Functor Hans where + fmap f m = Hans (\ e k -> unHans m e (k . f)) + {-# INLINE fmap #-} + +instance A.Applicative Hans where + pure x = Hans (\ _ k -> k x) + + f <*> x = Hans $ \ e k -> unHans f e + $ \ g -> unHans x e + $ \ y -> k (g y) + + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + +instance Monad Hans where + return = A.pure + + m >>= f = Hans $ \ e k -> unHans m e + $ \ a -> unHans (f a) e k + + {-# INLINE return #-} + {-# INLINE (>>=) #-} + +instance BaseM Hans IO where + inBase = io + {-# INLINE inBase #-} + + +-- | Run only one iteration of the Hans monad. +runHansOnce :: Hans a -> IO (Maybe a) +runHansOnce (Hans f) = + do res <- newIORef Nothing + f (writeIORef res Nothing) (\x -> writeIORef res (Just x)) + readIORef res + + +-- | Loop forever, running the underlying operation. +runHans :: Hans () -> IO () +runHans (Hans m) = loop () + where + loop () = m (loop ()) loop +{-# INLINE runHans #-} + +-- | Set the escape continuation to the current position, within the operation +-- given, so that control flow always restores back through this point. +setEscape :: Hans () -> Hans () +setEscape m = Hans (\ _ k -> unHans m (k ()) k) +{-# INLINE setEscape #-} + +-- | Invoke the escape continuation. +escape :: Hans a +escape = Hans (\ e _ -> e) +{-# INLINE escape #-} + +-- | Call-cc. NOTE: the continuation will inherit the escape point of the +-- calling context. +callCC :: ((b -> Hans a) -> Hans b) -> Hans b +callCC f = Hans (\e k -> unHans (f (\b -> Hans (\_ _ -> k b))) e k) +{-# INLINE callCC #-} + +-- | Synonym for 'escape' that also updates device statistics. +dropPacket :: DeviceStats -> Hans a +dropPacket stats = + do io (updateDropped statRX stats) + escape +{-# INLINE dropPacket #-} + +-- | Lift an 'IO' operation into 'Hans'. +io :: IO a -> Hans a +io m = Hans (\ _ k -> m >>= k ) +{-# INLINE io #-} + +-- | Run a Get action in the context of the Hans monad, +decode :: DeviceStats -> Get a -> S.ByteString -> Hans a +decode dev m bytes = + case runGet m bytes of + Right a -> return a + Left _ -> dropPacket dev +{-# INLINE decode #-} + +-- | Run a Get action in the context of the Hans monad, returning any unconsumed +-- input. +decode' :: DeviceStats -> Get a -> S.ByteString -> Hans (a,S.ByteString) +decode' dev m bytes = + case runGetState m bytes 0 of + Right a -> return a + Left _ -> dropPacket dev diff --git a/src/Hans/Nat.hs b/src/Hans/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Nat.hs @@ -0,0 +1,55 @@ +module Hans.Nat where + +import Hans.Addr (toAddr) +import qualified Hans.Nat.State as Nat +import Hans.Network (Network) +import Hans.Tcp.Packet (TcpPort) +import Hans.Types +import Hans.Udp.Packet (UdpPort) + + +-- | Add a TCP port-forwarding rule. +forwardTcpPort :: Network addr + => NetworkStack + -> addr -- ^ Local address (can be wildcard) + -> TcpPort -- ^ Local port + -> addr -- ^ Remote address + -> TcpPort -- ^ Remote port + -> IO () +forwardTcpPort ns src srcPort dest destPort = + Nat.addTcpPortForward ns + Nat.PortForward { pfSourceAddr = toAddr src + , pfSourcePort = srcPort + , pfDestAddr = toAddr dest + , pfDestPort = destPort } + +-- | Remove a TCP port-forwarding rule. +removeTcpPortForward :: Network addr + => NetworkStack + -> addr -- ^ Local address (can be wildcard) + -> TcpPort -- ^ Local port + -> IO () +removeTcpPortForward ns src port = Nat.removeTcpPortForward ns (toAddr src) port + +-- | Add a UDP port-forwarding rule. +forwardUdpPort :: Network addr + => NetworkStack + -> addr -- ^ Local address (can be wildcard) + -> UdpPort -- ^ Local port + -> addr -- ^ Remote address + -> UdpPort -- ^ Remote port + -> IO () +forwardUdpPort ns src srcPort dest destPort = + Nat.addUdpPortForward ns + Nat.PortForward { pfSourceAddr = toAddr src + , pfSourcePort = srcPort + , pfDestAddr = toAddr dest + , pfDestPort = destPort } + +-- | Remove a UDP port-forwarding rule. +removeUdpPortForward :: Network addr + => NetworkStack + -> addr -- ^ Local address (can be wildcard) + -> UdpPort -- ^ Local port + -> IO () +removeUdpPortForward ns src port = Nat.removeUdpPortForward ns (toAddr src) port diff --git a/src/Hans/Nat/Forward.hs b/src/Hans/Nat/Forward.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Nat/Forward.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Nat.Forward ( tryForwardUdp, tryForwardTcp ) where + +import Hans.Addr.Types (Addr) +import Hans.Lens (view) +import Hans.Network (lookupRoute,RouteInfo(..)) +import Hans.Tcp.Packet (TcpHeader(..),tcpSyn) +import Hans.Types +import Hans.Udp.Packet (UdpHeader(..)) + + +-- TCP ------------------------------------------------------------------------- + +-- | Try to produce a new TCP packet that should be forwarded. Returns 'Nothing' +-- if the packet was destined for the local machine. +tryForwardTcp :: NetworkStack + -> Addr -- ^ Local addr + -> Addr -- ^ Remote addr + -> TcpHeader + -> IO (Maybe (RouteInfo Addr,Addr,TcpHeader)) +tryForwardTcp ns local remote hdr = + do let key = Flow local (tcpDestPort hdr) remote (tcpSourcePort hdr) + mbEntry <- tcpForwardingActive ns key + case mbEntry of + + -- forwarding is already established, rewrite the packet + Just entry -> return $! rewrite key entry + + -- No forwarding entry exists. If it's a syn packet and there's a rule, start a + -- new session. + Nothing + | view tcpSyn hdr -> + do mbRule <- shouldForwardTcp ns key + case mbRule of + Nothing -> return Nothing + + -- add an entry to the table, and rewrite the packet + Just rule -> + do mbSess <- newSession ns key rule + case mbSess of + Just entry -> do addTcpSession ns entry + return $! rewrite key entry + + Nothing -> return Nothing + + | otherwise -> + return Nothing + + where + + -- rewrite the source and destination in the header + rewrite key entry = + let other = otherSide key entry + hdr' = hdr { tcpSourcePort = flowLocalPort other + , tcpDestPort = flowRemotePort other + , tcpChecksum = 0 } + + in hdr' `seq` Just (flowLocal other, flowRemote other, hdr') + + +-- UDP ------------------------------------------------------------------------- + +-- | Try to produce a new TCP packet that should be forwarded. Returns 'Nothing' +-- if the packet was destined for the local machine. +tryForwardUdp :: NetworkStack + -> Addr -- ^ Local addr + -> Addr -- ^ Remote addr + -> UdpHeader + -> IO (Maybe (RouteInfo Addr,Addr,UdpHeader)) +tryForwardUdp ns local remote hdr = + do let key = Flow local (udpDestPort hdr) remote (udpSourcePort hdr) + mbEntry <- udpForwardingActive ns key + case mbEntry of + + -- forwarding is already established, rewrite the packet + Just entry -> return $! rewrite key entry + + -- No forwarding entry exists. If a rule exists, add it to the table. + Nothing -> + do mbRule <- shouldForwardUdp ns key + case mbRule of + + Nothing -> return Nothing + + -- add an entry to the table, and rewrite the packet + Just rule -> + do mbSess <- newSession ns key rule + case mbSess of + Just entry -> do addUdpSession ns entry + return $! rewrite key entry + Nothing -> return Nothing + + where + + rewrite key entry = + let other = otherSide key entry + hdr' = hdr { udpSourcePort = flowLocalPort other + , udpDestPort = flowRemotePort other + , udpChecksum = 0 } + + in hdr' `seq` Just (flowLocal other, flowRemote other, hdr') + + +newSession :: NetworkStack -> Flow Addr -> PortForward -> IO (Maybe Session) +newSession ns flow rule = + do l <- lookupRoute ns (flowRemote flow) + r <- lookupRoute ns (pfDestAddr rule) + p <- nextTcpPort ns (flowLocal flow) (pfDestAddr rule) (pfDestPort rule) + + case (l,r,p) of + (Just riLeft, Just riRight, Just rightPort) -> + return $ Just + $ Session { sessLeft = flow { flowLocal = riLeft } + , sessRight = Flow { flowLocal = riRight + , flowLocalPort = rightPort + , flowRemote = pfDestAddr rule + , flowRemotePort = pfDestPort rule } } + + _ -> return Nothing diff --git a/src/Hans/Nat/State.hs b/src/Hans/Nat/State.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Nat/State.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} + +module Hans.Nat.State ( + NatState(), HasNatState(..), + newNatState, + Flow(..), + Session(..), + + otherSide, + + PortForward(..), + + -- ** Rules + addUdpPortForward, removeUdpPortForward, + addTcpPortForward, removeTcpPortForward, + + -- ** Queries + udpForwardingActive, addUdpSession, shouldForwardUdp, + tcpForwardingActive, addTcpSession, shouldForwardTcp, + ) where + +import Hans.Addr (Addr,isWildcardAddr) +import Hans.Config (Config(..)) +import Hans.Lens (Getting,view) +import Hans.Network.Types (RouteInfo(..)) +import Hans.Tcp.Packet (TcpPort) +import Hans.Threads (forkNamed) +import Hans.Udp.Packet (UdpPort) + +import Control.Concurrent (ThreadId,threadDelay) +import Control.Monad (forever) +import Data.HashPSQ as Q +import Data.Hashable (Hashable) +import Data.IORef (IORef,newIORef,readIORef,atomicModifyIORef') +import Data.List (find) +import Data.Time.Clock + (UTCTime,getCurrentTime,NominalDiffTime,addUTCTime) +import Data.Word (Word16) +import GHC.Generics (Generic) + + +-- State ----------------------------------------------------------------------- + +-- | NOTE: as TcpPort and UdpPort are both type aliases to Word16, Flow isn't +-- parameterized on the port type. +data Flow local = Flow { flowLocal :: !local + , flowLocalPort :: !Word16 + , flowRemote :: !Addr + , flowRemotePort :: !Word16 + } deriving (Functor,Eq,Ord,Generic,Show) + +instance Hashable remote => Hashable (Flow remote) + + +data NatState = + NatState { natTcpTable_ :: !NatTable + -- ^ Active TCP flows + + , natTcpRules_ :: !(IORef [PortForward]) + -- ^ Ports that have been forwarded in the TCP layer + + , natUdpTable_ :: !NatTable + -- ^ Active UDP flows + + , natUdpRules_ :: !(IORef [PortForward]) + -- ^ Ports that have been forwarded in the UDP layer + + , natReaper_ :: !ThreadId + -- ^ When flows are active, this is the id of the reaping thread + } + +class HasNatState state where + natState :: Getting r state NatState + +instance HasNatState NatState where + natState = id + +data PortForward = PortForward { pfSourceAddr :: !Addr + -- ^ Local address to listen on + + , pfSourcePort :: !Word16 + -- ^ The port on this network stack to + -- forward + + , pfDestAddr :: !Addr + -- ^ Destination machine to forward to + + , pfDestPort :: !Word16 + -- ^ Destination port to forward to + } + + +newNatState :: Config -> IO NatState +newNatState cfg = + do natTcpTable_ <- newNatTable cfg + natTcpRules_ <- newIORef [] + natUdpTable_ <- newNatTable cfg + natUdpRules_ <- newIORef [] + natReaper_ <- forkNamed "Nat.reaper" (reaper natTcpTable_ natUdpTable_) + return NatState { .. } + + +-- Nat Tables ------------------------------------------------------------------ + +data Session = Session { sessLeft, sessRight :: !(Flow (RouteInfo Addr)) } + +-- | Gives back the other end of the session. +otherSide :: Flow Addr -> Session -> Flow (RouteInfo Addr) +otherSide flow Session { .. } = + if flowRemote flow == flowRemote sessLeft + && flowRemotePort flow == flowRemotePort sessLeft + then sessRight else sessLeft + +sessionFlows :: Session -> (Flow Addr, Flow Addr) +sessionFlows Session { .. } = (fmap riSource sessLeft, fmap riSource sessRight) + + +type Sessions = Q.HashPSQ (Flow Addr) UTCTime Session + +addSession :: UTCTime -> Session -> Sessions -> Sessions +addSession age a q = + let (l,r) = sessionFlows a + in Q.insert l age a (Q.insert r age a q) + +removeOldest :: Sessions -> Sessions +removeOldest q = + case Q.minView q of + Just (k,_,a,q') -> Q.delete (fmap riSource (otherSide k a)) q' + Nothing -> q + +removeSession :: Flow Addr -> Sessions -> Maybe (Session,Sessions) +removeSession flow q = + case Q.deleteView flow q of + Just (_,a,q') -> Just (a,Q.delete (fmap riSource (otherSide flow a)) q') + Nothing -> Nothing + + +data NatTable = NatTable { natConfig :: Config + , natTable :: !(IORef Sessions) + } + +newNatTable :: Config -> IO NatTable +newNatTable natConfig = + do natTable <- newIORef Q.empty + return NatTable { .. } + +-- | Insert an entry into the NAT table. +insertNatTable :: Session -> NatTable -> IO () +insertNatTable sess NatTable { .. } = + do now <- getCurrentTime + atomicModifyIORef' natTable $ \ q -> + let q' = addSession now sess q + in if Q.size q' > cfgNatMaxEntries natConfig + then (removeOldest q', ()) + else (q', ()) + +-- | Remove entries from the NAT table, decrementing the size by the number of +-- entries that were removed. +expireEntries :: UTCTime -> NatTable -> IO () +expireEntries now NatTable { .. } = + atomicModifyIORef' natTable go + where + now' = addUTCTime (negate fourMinutes) now + + -- remove entries that are older than four minutes + go q = + case Q.minView q of + Just (k,p,a,q') + | p < now' -> go (Q.delete (fmap riSource (otherSide k a)) q') + | otherwise -> (q, ()) + + Nothing -> (Q.empty, ()) + +-- | Lookup and touch an entry in the NAT table. +lookupNatTable :: Flow Addr -> NatTable -> IO (Maybe Session) +lookupNatTable key NatTable { .. } = + do now <- getCurrentTime + atomicModifyIORef' natTable $ \ q -> + case removeSession key q of + Just (a,q') -> (addSession now a q', Just a) + Nothing -> (q, Nothing) + + +-- Table Reaping --------------------------------------------------------------- + +-- | Every two minutes, reap old entries from the TCP and UDP NAT tables. +reaper :: NatTable -> NatTable -> IO () +reaper tcp udp = forever $ + do threadDelay (2 * 60 * 1000000) -- delay for two minutes + + now <- getCurrentTime + expireEntries now tcp + expireEntries now udp + +fourMinutes :: NominalDiffTime +fourMinutes = 4 * 60.0 + + +-- Rules ----------------------------------------------------------------------- + +addTcpPortForward :: HasNatState state => state -> PortForward -> IO () +addTcpPortForward state rule = + do let NatState { .. } = view natState state + atomicModifyIORef' natTcpRules_ (\rs -> (rule : rs, ())) + +-- | Remove port forwarding for UDP based on source address and port number. +removeTcpPortForward :: HasNatState state => state -> Addr -> TcpPort -> IO () +removeTcpPortForward state addr port = + do let NatState { .. } = view natState state + atomicModifyIORef' natTcpRules_ (\rs -> (filter keepRule rs, ())) + where + keepRule PortForward { .. } = pfSourceAddr /= addr || pfSourcePort /= port + +addUdpPortForward :: HasNatState state => state -> PortForward -> IO () +addUdpPortForward state rule = + do let NatState { .. } = view natState state + atomicModifyIORef' natUdpRules_ (\rs -> (rule : rs, ())) + +-- | Remove port forwarding for UDP based on source address and port number. +removeUdpPortForward :: HasNatState state => state -> Addr -> UdpPort -> IO () +removeUdpPortForward state addr port = + do let NatState { .. } = view natState state + atomicModifyIORef' natUdpRules_ (\rs -> (filter keepRule rs, ())) + where + keepRule PortForward { .. } = pfSourceAddr /= addr || pfSourcePort /= port + + +-- Queries --------------------------------------------------------------------- + +-- | Lookup information about an active forwarding session. +tcpForwardingActive :: HasNatState state + => state -> Flow Addr -> IO (Maybe Session) +tcpForwardingActive state key = + do let NatState { .. } = view natState state + lookupNatTable key natTcpTable_ + + +-- | Lookup information about an active forwarding session. +udpForwardingActive :: HasNatState state + => state -> Flow Addr -> IO (Maybe Session) +udpForwardingActive state key = + do let NatState { .. } = view natState state + lookupNatTable key natUdpTable_ + + +-- | Insert a TCP forwarding entry into the NAT state. +addTcpSession :: HasNatState state => state -> Session -> IO () +addTcpSession state sess = + do let NatState { .. } = view natState state + insertNatTable sess natTcpTable_ + + +-- | Insert a UDP forwarding entry into the NAT state. +addUdpSession :: HasNatState state => state -> Session -> IO () +addUdpSession state sess = + do let NatState { .. } = view natState state + insertNatTable sess natUdpTable_ + +ruleApplies :: Flow Addr -> PortForward -> Bool +ruleApplies Flow { .. } = \ PortForward { .. } -> + flowLocalPort == pfSourcePort && + (flowLocal == pfSourceAddr || isWildcardAddr pfSourceAddr) + + +-- | Returns the forwarding rule to use, if this connection should be forwarded. +shouldForwardTcp :: HasNatState state + => state -> Flow Addr -> IO (Maybe PortForward) +shouldForwardTcp state flow = + do let NatState { .. } = view natState state + rules <- readIORef natTcpRules_ + return $! find (ruleApplies flow) rules + + +-- | Returns the forwarding rule to use, if this session should be forwarded +shouldForwardUdp :: HasNatState state + => state -> Flow Addr -> IO (Maybe PortForward) +shouldForwardUdp state flow = + do let NatState { .. } = view natState state + rules <- readIORef natUdpRules_ + return $! find (ruleApplies flow) rules diff --git a/src/Hans/Network.hs b/src/Hans/Network.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Network.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Network ( + module Hans.Network, + module Hans.Network.Types + ) where + +import Hans.Addr (NetworkAddr) +import Hans.Addr.Types (Addr(..)) +import Hans.Checksum (PartialChecksum) +import Hans.Device.Types (Device) +import qualified Hans.IP4 as IP4 +import qualified Hans.IP4.State as IP4 +import Hans.Lens +import Hans.Network.Types +import Hans.Types + +import qualified Data.ByteString.Lazy as L + + +-- | Interaction with routing and message delivery for a network layer. +class NetworkAddr addr => Network addr where + -- | Calculate the pseudo-header for checksumming a packet at this layer of + -- the network. + pseudoHeader :: addr -> addr -> NetworkProtocol -> Int -> PartialChecksum + + -- | Lookup a route to reach this destination address. + lookupRoute :: HasNetworkStack ns => ns -> addr -> IO (Maybe (RouteInfo addr)) + + -- | Send a single datagram to a destination. + sendDatagram' :: HasNetworkStack ns + => ns + -> Device + -> addr -- ^ Source + -> addr -- ^ Destination + -> addr -- ^ Next-hop + -> Bool -- ^ Don't fragment + -> NetworkProtocol + -> L.ByteString + -> IO () + + +sendDatagram :: (HasNetworkStack ns, Network addr) + => ns -> RouteInfo addr -> addr + -> Bool -> NetworkProtocol -> L.ByteString + -> IO () +sendDatagram ns RouteInfo { .. } = \ dst -> + sendDatagram' ns riDev riSource dst riNext +{-# INLINE sendDatagram #-} + + + +-- | Send a datagram and lookup routing information at the same time. Returns +-- 'False' if no route to the destination was known. +routeDatagram :: (HasNetworkStack ns, Network addr) + => ns -> addr -> Bool -> NetworkProtocol -> L.ByteString -> IO Bool +routeDatagram ns dst df prot bytes = + do mbRoute <- lookupRoute ns dst + case mbRoute of + Just route -> do sendDatagram ns route dst df prot bytes + return True + + Nothing -> return False + + +findNextHop :: (HasNetworkStack ns, Network addr) + => ns + -> Maybe Device -- ^ Desired output device + -> Maybe addr -- ^ Desired source address + -> addr -- ^ Destination + -> IO (Maybe (RouteInfo addr)) +findNextHop ns mbDev mbSrc dst = + + -- XXX it might be nice to have lookupRoute return a list of possible routes. + -- is it unreasonable to think that there may be multiple valid routes for a + -- datagram? + do mbRoute <- lookupRoute ns dst + case mbRoute of + Just ri | maybe True (== riDev ri) mbDev + && maybe True (== riSource ri) mbSrc -> return (Just ri) + + _ -> return Nothing + + +-- Generic --------------------------------------------------------------------- + +instance Network Addr where + pseudoHeader (Addr4 src) (Addr4 dst) = \ prot len -> pseudoHeader src dst prot len + {-# INLINE pseudoHeader #-} + + lookupRoute ns (Addr4 dst) = + do ri <- lookupRoute ns dst + return (fmap (fmap Addr4) ri) + {-# INLINE lookupRoute #-} + + sendDatagram' ns dev (Addr4 src) (Addr4 dst) (Addr4 next) = + sendDatagram' ns dev src dst next + {-# INLINE sendDatagram' #-} + + + +-- IP4 ------------------------------------------------------------------------- + +instance Network IP4.IP4 where + pseudoHeader = IP4.ip4PseudoHeader + {-# INLINE pseudoHeader #-} + + lookupRoute ns ip4 = + do mb <- IP4.lookupRoute4 (view networkStack ns) ip4 + case mb of + Just (riSource,riNext,riDev) -> return $! Just RouteInfo { .. } + Nothing -> return Nothing + {-# INLINE lookupRoute #-} + + sendDatagram' ns dev src dst df next = + IP4.primSendIP4 (view networkStack ns) dev src dst df next + {-# INLINE sendDatagram' #-} diff --git a/src/Hans/Network/Types.hs b/src/Hans/Network/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Network/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Network.Types where + +import Hans.Device.Types (Device,HasDeviceConfig(..)) +import Hans.Lens + +import Data.Serialize (Get,Put,getWord8,putWord8) +import Data.Word (Word8) + + +type NetworkProtocol = Word8 + +pattern PROT_ICMP4 = 0x1 +pattern PROT_TCP = 0x6 +pattern PROT_UDP = 0x11 + +getNetworkProtocol :: Get NetworkProtocol +getNetworkProtocol = getWord8 + +putNetworkProtocol :: NetworkProtocol -> Put +putNetworkProtocol = putWord8 + + +-- | Information about how to reach a specific destination address (source and +-- next-hop addresses, and device to use). +data RouteInfo addr = RouteInfo { riSource :: !addr + -- ^ The source address to use when sending + , riNext :: !addr + -- ^ The next-hop in the route + , riDev :: !Device + -- ^ The device used for delivery + } deriving (Eq,Functor) + +instance HasDeviceConfig (RouteInfo addr) where + deviceConfig = to riDev . deviceConfig diff --git a/src/Hans/NetworkStack.hs b/src/Hans/NetworkStack.hs deleted file mode 100644 --- a/src/Hans/NetworkStack.hs +++ /dev/null @@ -1,251 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} - -module Hans.NetworkStack ( - module Hans.NetworkStack - - -- * Re-exported Types - , UdpPort - , TcpPort - - -- * DNS - , Dns.HostName - , Dns.HostEntry(..) - - -- * Sockets - , Tcp.Socket() - - -- ** Socket Functions - , Tcp.sockRemoteHost - , Tcp.sockRemotePort - , Tcp.sockLocalPort - , Tcp.accept - , Tcp.close - , Tcp.sendBytes - , Tcp.recvBytes - - -- ** Socket Exceptions - , Tcp.AcceptError(..) - , Tcp.CloseError(..) - , Tcp.ConnectError(..) - , Tcp.ListenError(..) - ) where - -import Hans.Address (getMaskComponents) -import Hans.Address.IP4 (IP4Mask,IP4) -import Hans.Address.Mac (Mac) -import Hans.Channel (newChannel) -import Hans.Message.Ip4 (IP4Protocol,IP4Header) -import Hans.Message.Tcp (TcpPort) -import Hans.Message.Udp (UdpPort) -import qualified Hans.Layer.Arp as Arp -import qualified Hans.Layer.Ethernet as Eth -import qualified Hans.Layer.Dns as Dns -import qualified Hans.Layer.Icmp4 as Icmp4 -import qualified Hans.Layer.IP4 as IP4 -import qualified Hans.Layer.Tcp as Tcp -import qualified Hans.Layer.Tcp.Socket as Tcp -import qualified Hans.Layer.Udp as Udp - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - - --- Generic Network Stack ------------------------------------------------------- - --- | An example implementation of the whole network stack. -data NetworkStack = NetworkStack - { nsArp :: Arp.ArpHandle - , nsEthernet :: Eth.EthernetHandle - , nsIp4 :: IP4.IP4Handle - , nsIcmp4 :: Icmp4.Icmp4Handle - , nsUdp :: Udp.UdpHandle - , nsTcp :: Tcp.TcpHandle - , nsDns :: Dns.DnsHandle - } - -instance HasArp NetworkStack where arpHandle = nsArp -instance HasEthernet NetworkStack where ethernetHandle = nsEthernet -instance HasIP4 NetworkStack where ip4Handle = nsIp4 -instance HasIcmp4 NetworkStack where icmp4Handle = nsIcmp4 -instance HasTcp NetworkStack where tcpHandle = nsTcp -instance HasUdp NetworkStack where udpHandle = nsUdp -instance HasDns NetworkStack where dnsHandle = nsDns - -newNetworkStack :: IO NetworkStack -newNetworkStack = do - nsEthernet <- newChannel - nsArp <- newChannel - nsIp4 <- newChannel - nsIcmp4 <- newChannel - nsUdp <- newChannel - nsTcp <- newChannel - nsDns <- newChannel - - let ns = NetworkStack { .. } - - startEthernetLayer ns - startArpLayer ns - startIcmp4Layer ns - startIP4Layer ns - startUdpLayer ns - startTcpLayer ns - startDnsLayer ns - - return ns - - - --- Ethernet Layer Interface ---------------------------------------------------- - -class HasEthernet stack where - ethernetHandle :: stack -> Eth.EthernetHandle - --- | Start the ethernet layer in a network stack. -startEthernetLayer :: HasEthernet stack => stack -> IO () -startEthernetLayer stack = - Eth.runEthernetLayer (ethernetHandle stack) - --- | Add an ethernet device to the ethernet layer. -addDevice :: HasEthernet stack => stack -> Mac -> Eth.Tx -> Eth.Rx -> IO () -addDevice stack = Eth.addEthernetDevice (ethernetHandle stack) - --- | Remove a device from the ethernet layer. -removeDevice :: HasEthernet stack => stack -> Mac -> IO () -removeDevice stack = Eth.removeEthernetDevice (ethernetHandle stack) - --- | Bring an ethernet device in the ethernet layer up. -deviceUp :: HasEthernet stack => stack -> Mac -> IO () -deviceUp stack = Eth.startEthernetDevice (ethernetHandle stack) - --- | Bring an ethernet device in the ethernet layer down. -deviceDown :: HasEthernet stack => stack -> Mac -> IO () -deviceDown stack = Eth.stopEthernetDevice (ethernetHandle stack) - - --- Arp Layer Interface --------------------------------------------------------- - -class HasArp stack where - arpHandle :: stack -> Arp.ArpHandle - --- | Start the arp layer in a network stack. -startArpLayer :: (HasEthernet stack, HasArp stack) => stack -> IO () -startArpLayer stack = - Arp.runArpLayer (arpHandle stack) (ethernetHandle stack) - - --- Icmp4 Layer Interface ------------------------------------------------------- - -class HasIcmp4 stack where - icmp4Handle :: stack -> Icmp4.Icmp4Handle - --- | Start the icmp4 layer in a network stack.. -startIcmp4Layer :: (HasIcmp4 stack, HasIP4 stack) => stack -> IO () -startIcmp4Layer stack = - Icmp4.runIcmp4Layer (icmp4Handle stack) (ip4Handle stack) - - --- IP4 Layer Interface --------------------------------------------------------- - -class HasIP4 stack where - ip4Handle :: stack -> IP4.IP4Handle - --- | Start the IP4 layer in a network stack. -startIP4Layer :: (HasArp stack, HasEthernet stack, HasIP4 stack) - => stack -> IO () -startIP4Layer stack = - IP4.runIP4Layer (ip4Handle stack) (arpHandle stack) (ethernetHandle stack) - -type Mtu = Int - --- | Add an IP4 address to a network stack. -addIP4Addr :: (HasArp stack, HasIP4 stack) - => stack -> IP4Mask -> Mac -> Mtu -> IO () -addIP4Addr stack mask mac mtu = do - let (addr,_) = getMaskComponents mask - Arp.addLocalAddress (arpHandle stack) addr mac - IP4.addIP4RoutingRule (ip4Handle stack) (IP4.Direct mask addr mtu) - --- | Add a route for a network, via an address. -routeVia :: HasIP4 stack => stack -> IP4Mask -> IP4 -> IO () -routeVia stack mask addr = - IP4.addIP4RoutingRule (ip4Handle stack) (IP4.Indirect mask addr) - --- | Register a handler for an IP4 protocol -listenIP4Protocol :: HasIP4 stack - => stack -> IP4Protocol -> IP4.Handler -> IO () -listenIP4Protocol stack = IP4.addIP4Handler (ip4Handle stack) - --- | Register a handler for an IP4 protocol -ignoreIP4Protocol :: HasIP4 stack => stack -> IP4Protocol -> IO () -ignoreIP4Protocol stack = IP4.removeIP4Handler (ip4Handle stack) - - --- Udp Layer Interface --------------------------------------------------------- - -class HasUdp stack where - udpHandle :: stack -> Udp.UdpHandle - --- | Start the UDP layer of a network stack. -startUdpLayer :: (HasIP4 stack, HasIcmp4 stack, HasUdp stack) => stack -> IO () -startUdpLayer stack = - Udp.runUdpLayer (udpHandle stack) (ip4Handle stack) (icmp4Handle stack) - --- | Add a handler for a UDP port. -addUdpHandler :: HasUdp stack => stack -> UdpPort -> Udp.Handler -> IO () -addUdpHandler stack = Udp.addUdpHandler (udpHandle stack) - --- | Remove a handler for a UDP port. -removeUdpHandler :: HasUdp stack => stack -> UdpPort -> IO () -removeUdpHandler stack = Udp.removeUdpHandler (udpHandle stack) - --- | Inject a packet into the UDP layer. -queueUdp :: HasUdp stack => stack -> IP4Header -> S.ByteString -> IO () -queueUdp stack = Udp.queueUdp (udpHandle stack) - --- | Send a UDP packet. -sendUdp :: HasUdp stack - => stack -> IP4 -> Maybe UdpPort -> UdpPort -> L.ByteString -> IO () -sendUdp stack = Udp.sendUdp (udpHandle stack) - - --- Tcp Layer Interface --------------------------------------------------------- - -class HasIP4 stack => HasTcp stack where - tcpHandle :: stack -> Tcp.TcpHandle - --- | Start the TCP layer of a network stack. -startTcpLayer :: HasTcp stack => stack -> IO () -startTcpLayer stack = - Tcp.runTcpLayer (tcpHandle stack) (ip4Handle stack) - --- | Listen for incoming connections. -listen :: HasTcp stack => stack -> IP4 -> TcpPort -> IO Tcp.Socket -listen stack = Tcp.listen (tcpHandle stack) - --- | Make a remote connection. -connect :: HasTcp stack => stack -> IP4 -> TcpPort -> Maybe TcpPort -> IO Tcp.Socket -connect stack = Tcp.connect (tcpHandle stack) - - --- Dns Layer Interface --------------------------------------------------------- - -class HasUdp stack => HasDns stack where - dnsHandle :: stack -> Dns.DnsHandle - -startDnsLayer :: HasDns stack => stack -> IO () -startDnsLayer stack = - Dns.runDnsLayer (dnsHandle stack) (udpHandle stack) - -addNameServer :: HasDns stack => stack -> IP4 -> IO () -addNameServer stack = Dns.addNameServer (dnsHandle stack) - -removeNameServer :: HasDns stack => stack -> IP4 -> IO () -removeNameServer stack = Dns.removeNameServer (dnsHandle stack) - -getHostByName :: HasDns stack => stack -> Dns.HostName -> IO Dns.HostEntry -getHostByName stack = Dns.getHostByName (dnsHandle stack) - -getHostByAddr :: HasDns stack => stack -> IP4 -> IO Dns.HostEntry -getHostByAddr stack = Dns.getHostByAddr (dnsHandle stack) diff --git a/src/Hans/Ports.hs b/src/Hans/Ports.hs deleted file mode 100644 --- a/src/Hans/Ports.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - -module Hans.Ports ( - -- * Port Management - PortManager - , emptyPortManager - , isUsed - , reserve - , unreserve - , nextPort - ) where - -import Control.Monad (guard) -import qualified Data.Set as Set - - --- Port Management ------------------------------------------------------------- - -data PortManager i = PortManager - { portNext :: [i] - , portReserved :: Set.Set i - , portActive :: Set.Set i - } - -instance Show i => Show (PortManager i) where - show pm = "" - -emptyPortManager :: [i] -> PortManager i -emptyPortManager range = PortManager - { portNext = range - , portReserved = Set.empty - , portActive = Set.empty - } - -isUsed :: (Eq i, Ord i) => i -> PortManager i -> Bool -isUsed i PortManager { .. } = i `Set.member` portActive - || i `Set.member` portReserved - -reserve :: (Eq i, Ord i, Show i) => i -> PortManager i -> Maybe (PortManager i) -reserve i pm = do - guard (not (isUsed i pm)) - return $! pm - { portReserved = Set.insert i (portReserved 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 :: (Eq i, Ord i, Show i) => PortManager i -> Maybe (i, PortManager i) -nextPort pm = case span (`isUsed` pm) (portNext pm) of - - (_,i:rest) -> return (i, pm { portNext = rest - , portActive = Set.insert i (portActive pm) }) - - _ -> Nothing diff --git a/src/Hans/Serialize.hs b/src/Hans/Serialize.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Serialize.hs @@ -0,0 +1,15 @@ +module Hans.Serialize where + +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Lazy as L +import Data.Serialize (Put,execPut) + + +-- | A specialized version of 'runPut' that allows the initial and successive +-- buffer sizes for the 'Builder' to be defined. For example, if you're +-- rendering an IP4 packet, you might give the first parameter as 20 (the size +-- of the fixed header), and the second as 40 (the maximum additional length for +-- options). +runPutPacket :: Int -> Int -> L.ByteString -> Put -> L.ByteString +runPutPacket isz ssz tl m = + B.toLazyByteStringWith (B.untrimmedStrategy isz ssz) tl (execPut m) diff --git a/src/Hans/Simple.hs b/src/Hans/Simple.hs deleted file mode 100644 --- a/src/Hans/Simple.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Hans.Simple ( - -- * UDP Messages - renderUdp - , renderIp4 - - -- * Ident - , Ident - , newIdent - , nextIdent - ) where - -import Hans.Address.IP4 (IP4) -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.Lazy as L - -newtype Ident = Ident (MVar IP4.Ident) - -newIdent :: IO Ident -newIdent = Ident `fmap` newMVar 0 - -nextIdent :: Ident -> IO IP4.Ident -nextIdent (Ident var) = modifyMVar var (\i -> return (i+1, i)) - -type MTU = Word16 - -fromMTU :: Maybe MTU -> Int -fromMTU = maybe ip4Max (min ip4Max . fromIntegral) - where ip4Max = 0xffff - --- | Render a UDP message to an unfragmented IP4 packet. -renderUdp :: Ident -> Maybe MTU -> IP4 -> IP4 -> UdpPort -> UdpPort - -> L.ByteString - -> IO [L.ByteString] -renderUdp i mb source dest srcPort destPort payload = do - let prot = IP4Protocol 0x11 - let mk = mkIP4PseudoHeader source dest prot - let hdr = UdpHeader - { udpSourcePort = srcPort - , udpDestPort = destPort - , udpChecksum = 0 - } - udp <- renderUdpPacket hdr payload mk - renderIp4 i mb prot source dest udp - - --- | Render an IP4 packet. -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 - { ip4Protocol = prot - , ip4SourceAddr = source - , ip4DestAddr = dest - , ip4Ident = i - } - mapM (uncurry renderIP4Packet) (splitPacket (fromMTU mb) hdr payload) diff --git a/src/Hans/Socket.hs b/src/Hans/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Socket.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Hans.Socket ( + -- * Abstract Sockets + Socket(..), + ListenSocket(..), + DataSocket(..), + SocketConfig(..), defaultSocketConfig, + SockPort, + + -- ** UDP Sockets + UdpSocket(), + newUdpSocket, + sendto, + recvfrom, + recvfrom', + + -- ** TCP Sockets + TcpSocket(), + TcpListenSocket(), + + tcpRemoteAddr, + tcpRemotePort, + tcpLocalAddr, + tcpLocalPort, + + -- ** Exceptions + ConnectionException, + ListenException, + RoutingException + + ) where + +import Hans.Socket.Udp +import Hans.Socket.Tcp +import Hans.Socket.Types diff --git a/src/Hans/Socket/Handle.hs b/src/Hans/Socket/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Socket/Handle.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Hans.Socket.Handle(makeHansHandle) where + +import Control.Concurrent(threadDelay) +import Control.Exception(throwIO) +import qualified Data.ByteString as BSS +import qualified Data.ByteString.Lazy as BS +import Data.Typeable(Typeable) +import Foreign.Ptr(Ptr, castPtr, plusPtr) +import GHC.IO.Buffer(newByteBuffer) +import GHC.IO.BufferedIO(BufferedIO(..), + readBuf, readBufNonBlocking, + writeBuf, writeBufNonBlocking) +import GHC.IO.Device(IODevice(..), RawIO(..), IODeviceType(..)) +import GHC.IO.Handle(mkFileHandle, noNewlineTranslation) +import Hans.Network(Network(..)) +import Hans.Socket(Socket(..), DataSocket(..)) +import Prelude hiding (read) +import System.IO(Handle, IOMode) + + +instance (Socket sock, DataSocket sock, Network addr) => + IODevice (sock addr) where + ready dev forWrite msecs = + do let tester = if forWrite then sCanWrite else sCanRead + canDo <- tester dev + if | canDo -> return True + | msecs <= 0 -> return False + | otherwise -> do let delay = min msecs 100 + threadDelay (delay * 1000) + ready dev forWrite (msecs - delay) + close bs = sClose bs + isTerminal _ = return False + isSeekable _ = return False + seek _ _ _ = throwIO (userError "Seek on HaNS socket.") + tell _ = throwIO (userError "Tell on HaNS socket.") + getSize _ = throwIO (userError "getSize on HaNS socket.") + setSize _ _ = throwIO (userError "setSize on HaNS socket.") + setEcho _ _ = throwIO (userError "setEcho on HaNS socket.") + getEcho _ = throwIO (userError "getEcho on HaNS socket.") + setRaw _ _ = return () + devType _ = return Stream + dup _ = throwIO (userError "dup on HaNS socket.") + dup2 _ _ = throwIO (userError "dup2 on HaNS socket.") + +instance (Socket sock, DataSocket sock, Network addr) => + RawIO (sock addr) where + read sock dptr sz = + do bstr <- sRead sock (fromIntegral sz) + copyToPtr dptr sz bstr + readNonBlocking sock dptr sz = + do mbstr <- sTryRead sock (fromIntegral sz) + case mbstr of + Nothing -> return Nothing + Just bstr -> Just `fmap` copyToPtr dptr sz bstr + write sock ptr sz = + do bstr <- BSS.packCStringLen (castPtr ptr, sz) + sendAll (BS.fromStrict bstr) + where + sendAll bstr + | BS.null bstr = return () + | otherwise = do num <- sWrite sock bstr + sendAll (BS.drop (fromIntegral num) bstr) + writeNonBlocking sock ptr sz = + do bstr <- BSS.packCStringLen (castPtr ptr, sz) + num <- sWrite sock (BS.fromStrict bstr) + return (fromIntegral num) + +instance (Socket sock, DataSocket sock, Network addr) => + BufferedIO (sock addr) where + newBuffer _ = newByteBuffer (64 * 1024) + fillReadBuffer = readBuf + fillReadBuffer0 = readBufNonBlocking + flushWriteBuffer = writeBuf + flushWriteBuffer0 = writeBufNonBlocking + +-- |Make a GHC Handle from a Hans handle. +makeHansHandle :: (Socket sock, DataSocket sock, Network addr, Typeable sock) => + sock addr -> IOMode -> IO Handle +makeHansHandle socket mode = + mkFileHandle socket "" mode Nothing noNewlineTranslation + +copyToPtr :: Num a => Ptr b -> Int -> BS.ByteString -> IO a +copyToPtr ptr sz bstr + | BS.length bstr == 0 = return 0 + | BS.length bstr > fromIntegral sz = fail "Too big a chunk for copy!" + | otherwise = + do copyBS (BS.toChunks bstr) ptr sz + return (fromIntegral (BS.length bstr)) + +copyBS :: [BSS.ByteString] -> Ptr a -> Int -> IO () +copyBS [] _ _ = return () +copyBS (f:rest) sptr szLeft + | BSS.null f = copyBS rest sptr szLeft + | szLeft <= 0 = return () + | otherwise = + do let (chunk1, chunk2) = BSS.splitAt szLeft f + amt = fromIntegral (BSS.length chunk1) + BSS.useAsCString chunk1 $ \ dptr -> memcpy dptr sptr amt + copyBS (chunk2 : rest) (sptr `plusPtr` amt) (szLeft - amt) + +foreign import ccall unsafe "string.h memcpy" + memcpy :: Ptr a -> Ptr b -> Int -> IO () diff --git a/src/Hans/Socket/Tcp.hs b/src/Hans/Socket/Tcp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Socket/Tcp.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Hans.Socket.Tcp where + +import Hans.Addr +import qualified Hans.Buffer.Stream as Stream +import qualified Hans.HashTable as HT +import Hans.Lens (Getting,view,to) +import Hans.Network +import Hans.Socket.Types +import Hans.Tcp.Tcb +import Hans.Tcp.Message +import Hans.Tcp.Output +import qualified Hans.Tcp.SendWindow as Send +import Hans.Types + +import Control.Concurrent (newEmptyMVar,tryPutMVar,takeMVar,yield) +import Control.Exception (throwIO, handle) +import Control.Monad (unless,when) +import qualified Data.ByteString.Lazy as L +import Data.IORef (readIORef) +import Data.Time.Clock (getCurrentTime) +import Data.Typeable(Typeable) +import System.CPUTime (getCPUTime) + + +-- TCP Sockets ----------------------------------------------------------------- + +data TcpSocket addr = TcpSocket { tcpNS :: !NetworkStack + , tcpTcb :: !Tcb + } + deriving (Typeable) + +instance HasNetworkStack (TcpSocket addr) where + networkStack = to tcpNS + +-- | Routing information for this socket. +tcpRoute :: NetworkAddr addr => Getting r (TcpSocket addr) (RouteInfo addr) +tcpRoute = to (\ TcpSocket { tcpTcb = Tcb { .. } } -> cast tcbRouteInfo) + where + cast RouteInfo { .. } = + case (fromAddr riSource, fromAddr riNext) of + (Just a,Just b) -> RouteInfo { riSource = a, riNext = b, .. } + _ -> error "tcpRoute: invalid address combination" + +-- | The source address of this socket. +tcpLocalAddr :: NetworkAddr addr => Getting r (TcpSocket addr) addr +tcpLocalAddr = tcpRoute . to riSource + +-- | The local port for this socket. +tcpLocalPort :: Getting r (TcpSocket addr) SockPort +tcpLocalPort = to (\ TcpSocket { tcpTcb = Tcb { .. } } -> tcbLocalPort ) + +-- | The remote address of this socket. +tcpRemoteAddr :: NetworkAddr addr => Getting r (TcpSocket addr) addr +tcpRemoteAddr = to (\ TcpSocket { tcpTcb = Tcb { .. } } -> cast tcbRemote) + where + cast addr = + case fromAddr addr of + Just a -> a + Nothing -> error "tcpRemoteHost: invalid remote address" + +-- | The remote port of this socket. +tcpRemotePort :: Getting r (TcpSocket addr) SockPort +tcpRemotePort = to (\ TcpSocket { tcpTcb = Tcb { .. } } -> tcbRemotePort) + + +-- | Add a new active connection to the TCP state. The connection will initially +-- be in the 'SynSent' state, as a Syn will be sent when the 'Tcb' is created. +activeOpen :: Network addr + => NetworkStack -> RouteInfo addr -> SockPort -> addr -> SockPort + -> IO Tcb +activeOpen ns ri srcPort dst dstPort = + do let ri' = toAddr `fmap` ri + dst' = toAddr dst + + done <- newEmptyMVar + + now <- getCurrentTime + tsval <- getCPUTime + let tsc = Send.initialTSClock (fromInteger tsval) now + + iss <- nextIss (view tcpState ns) (riSource ri') srcPort dst' dstPort + tcb <- newTcb ns Nothing iss ri' srcPort dst' dstPort Closed tsc + (\_ _ -> tryPutMVar done True >> return ()) + (\_ _ -> tryPutMVar done False >> return ()) + + let update Nothing = (Just tcb, True) + update Just{} = (Nothing, False) + success <- HT.alter update (view tcbKey tcb) (view tcpActive ns) + if success + then + do syn <- mkSyn tcb + _ <- sendWithTcb ns tcb syn L.empty + setState tcb SynSent + + established <- takeMVar done + if established + then return tcb + else throwIO ConnectionRefused + + else throwIO AlreadyConnected + + +instance Socket TcpSocket where + + sClose TcpSocket { .. } = + do state <- readIORef (tcbState tcpTcb) + case state of + + -- the remote side closed the connection, so we just need to cleanup. + CloseWait -> + do sendFin tcpNS tcpTcb + setState tcpTcb LastAck + + Established -> + do sendFin tcpNS tcpTcb + setState tcpTcb FinWait1 + + -- SynSent, Listen, Closed, Closing, LastAck + _ -> return () + + +-- | Guard an action that will use the send window. +guardSend :: Tcb -> IO r -> IO r +guardSend tcb send = + do st <- getState tcb + case st of + Closed -> throwIO NoConnection + + Listen -> error "guardSend: Listen state for active tcb" + + -- the send window should queue these + SynReceived -> send + SynSent -> send + + Established -> send + CloseWait -> send + + -- FinWait1, FinWait2, Closing, LastAck, TimeWait + _ -> throwIO ConnectionClosing + + +-- | Guard an action that will use the receive buffer. +guardRecv :: Tcb -> IO r -> IO r +guardRecv tcb recv = + do st <- getState tcb + case st of + Closed -> throwIO NoConnection + + -- these three cases will block until data is available + Listen -> recv + SynSent -> recv + SynReceived -> recv + + -- the common case + Established -> recv + FinWait1 -> recv + FinWait2 -> recv + + -- XXX: is this enough? + CloseWait -> do avail <- Stream.bytesAvailable (tcbRecvBuffer tcb) + if avail + then recv + else throwIO ConnectionClosing + + Closing -> throwIO ConnectionClosing + LastAck -> throwIO ConnectionClosing + TimeWait -> throwIO ConnectionClosing + + + +instance DataSocket TcpSocket where + + sConnect ns SocketConfig { .. } mbDev src mbSrcPort dst dstPort = + do let tcpNS = view networkStack ns + + ri <- route tcpNS mbDev src dst + + srcPort <- case mbSrcPort of + Just port -> return port + Nothing -> + do mb <- nextTcpPort tcpNS (toAddr (riSource ri)) (toAddr dst) dstPort + case mb of + Just port -> return port + Nothing -> throwIO NoPortAvailable + + -- activeOpen will start the connection for us, sending a SYN to the + -- remote end of the connection. + tcpTcb <- activeOpen tcpNS ri srcPort dst dstPort + return TcpSocket { .. } + + sCanWrite TcpSocket { .. } = + handle ((\ _ -> return False) :: (ConnectionException -> IO Bool)) $ + guardSend tcpTcb (canSend tcpTcb) + + -- segmentize the bytes, and return to the user the number of bytes that have + -- been moved into the send window + sWrite TcpSocket { .. } bytes = + guardSend tcpTcb $ do len <- sendData tcpNS tcpTcb bytes + + when (len < L.length bytes) yield + + return $! fromIntegral len + + sCanRead TcpSocket { .. } = guardRecv tcpTcb (haveBytesAvail tcpTcb) + sRead TcpSocket { .. } len = guardRecv tcpTcb (receiveBytes len tcpTcb) + sTryRead TcpSocket { .. } len = guardRecv tcpTcb (tryReceiveBytes len tcpTcb) + + +data TcpListenSocket addr = TcpListenSocket { tlNS :: !NetworkStack + , tlTcb :: !ListenTcb + } + + +instance Socket TcpListenSocket where + + -- NOTE: as listen sockets are always in the Listen state, we don't need to + -- consider any of the other cases on page 60 of RFC 793. + sClose TcpListenSocket { .. } = deleteListening tlNS tlTcb + {-# INLINE sClose #-} + + +instance ListenSocket TcpListenSocket where + + type Client TcpListenSocket = TcpSocket + + sListen ns SocketConfig { .. } src srcPort backlog = + do let tlNS = view networkStack ns + tlTcb <- newListenTcb (toAddr src) srcPort backlog + + created <- registerListening tlNS tlTcb + unless created (throwIO AlreadyListening) + + return $! TcpListenSocket { .. } + + sAccept TcpListenSocket { .. } = + do tcpTcb <- acceptTcb tlTcb + return $! TcpSocket { tcpNS = tlNS, .. } diff --git a/src/Hans/Socket/Types.hs b/src/Hans/Socket/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Socket/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Hans.Socket.Types where + +import Hans.Addr (isWildcardAddr) +import Hans.Device.Types (Device) +import Hans.Network (Network(..),RouteInfo(..)) +import Hans.Types (HasNetworkStack,NetworkStack) + +import Control.Exception (Exception,throwIO) +import qualified Data.ByteString.Lazy as L +import Data.Typeable (Typeable) +import Data.Word (Word16) + + +-- Socket Addresses ------------------------------------------------------------ + +type SockPort = Word16 + + +-- Generic Socket Operations --------------------------------------------------- + +data SocketConfig = SocketConfig { scRecvBufferSize :: !Int + -- ^ Bytes to buffer + } deriving (Show) + +defaultSocketConfig :: SocketConfig +defaultSocketConfig = SocketConfig { scRecvBufferSize = 4096 } + +class Socket sock where + + -- | Close an open socket. + sClose :: Network addr => sock addr -> IO () + + +class (DataSocket (Client sock), Socket sock) => ListenSocket sock where + + type Client sock :: * -> * + + -- | Create a listening socket, with a backlog of n. + sListen :: (HasNetworkStack ns, Network addr) + => ns -> SocketConfig -> addr -> SockPort -> Int -> IO (sock addr) + + sAccept :: Network addr => sock addr -> IO (Client sock addr) + + +class Socket sock => DataSocket sock where + + -- | Connect this socket to one on a remote machine. + sConnect :: (HasNetworkStack ns, Network addr) + => ns + -> SocketConfig + -> Maybe Device + -> addr -- ^ Local address + -> Maybe SockPort -- ^ Local port + -> addr -- ^ Remote host + -> SockPort -- ^ Remote port + -> IO (sock addr) + + -- | Returns True iff there is currently space in the buffer to accept a + -- write. Note, this is probably a bad thing to count on in a concurrent + -- system ... + sCanWrite :: Network addr => sock addr -> IO Bool + + -- | Send a chunk of data on a socket. + sWrite :: Network addr => sock addr -> L.ByteString -> IO Int + + -- | Returns True iff there is data in the buffer that can be read. + -- Note, this is probably a bad thing to count on in a concurrent + -- system ... + sCanRead :: Network addr => sock addr -> IO Bool + + -- | Read a chunk of data from a socket. Reading an empty result indicates + -- that the socket has closed. + sRead :: Network addr => sock addr -> Int -> IO L.ByteString + + -- | Non-blocking read from a socket. Reading an empty result means that the + -- socket has closed, while reading a 'Nothing' result indicates that there + -- was no data available. + sTryRead :: Network addr => sock addr -> Int -> IO (Maybe L.ByteString) + + +-- Exceptions ------------------------------------------------------------------ + +data ConnectionException = AlreadyConnected + -- ^ This connection already exists. + + | NoConnection + -- ^ No information about the other end of the + -- socket was present. + + | NoPortAvailable + -- ^ All ports are in use. + + | ConnectionRefused + + | ConnectionClosing + + | DoesNotExist + -- ^ The connection is already closed. + deriving (Show,Typeable) + +data ListenException = AlreadyListening + -- ^ Something is already listening on this + -- host/port combination. + deriving (Show,Typeable) + +data RoutingException = NoRouteToHost + -- ^ It's not possible to reach this host from this + -- source address. + deriving (Show,Typeable) + +instance Exception ConnectionException +instance Exception ListenException +instance Exception RoutingException + + +-- Utilities ------------------------------------------------------------------- + +-- | Raise an exception when no route can be found to the destination. +route :: Network addr + => NetworkStack -> Maybe Device -> addr -> addr -> IO (RouteInfo addr) + +route ns mbDev src dst = + do mbRoute <- route' ns mbDev src dst + case mbRoute of + Just ri -> return ri + Nothing -> throwIO NoRouteToHost + + +-- | Return source routing information, when a route exists to the destination. +route' :: Network addr + => NetworkStack -> Maybe Device -> addr -> addr + -> IO (Maybe (RouteInfo addr)) + +route' ns mbDev src dst = + do mbRoute <- lookupRoute ns dst + case mbRoute of + Just ri | maybe True (riDev ri ==) mbDev + && (src == riSource ri || isWildcardAddr src) -> + return (Just ri) + + _ -> return Nothing diff --git a/src/Hans/Socket/Udp.hs b/src/Hans/Socket/Udp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Socket/Udp.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +module Hans.Socket.Udp where + +import Hans.Addr (toAddr,fromAddr,isBroadcastAddr) +import qualified Hans.Buffer.Datagram as DGram +import Hans.Device.Types (Device) +import Hans.Lens (view,to) +import Hans.Network (Network,RouteInfo(..)) +import Hans.Socket.Types +import Hans.Types +import Hans.Udp.Output (primSendUdp) + +import Control.Exception (throwIO) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.IORef (IORef,newIORef,readIORef) + + +-- UDP Sockets ----------------------------------------------------------------- + +data SockState addr = KnownRoute !(RouteInfo addr) !addr !SockPort !SockPort + -- ^ Cached route, and port information + + | KnownSource !(Maybe Device) !addr !SockPort + -- ^ Known source only. + + +data UdpSocket addr = UdpSocket { udpNS :: !NetworkStack + , udpBuffer :: !UdpBuffer + , udpSockState :: !(IORef (SockState addr)) + , udpClose :: !(IO ()) + } + +instance HasNetworkStack (UdpSocket addr) where + networkStack = to udpNS + {-# INLINE networkStack #-} + +instance Socket UdpSocket where + + sClose UdpSocket { .. } = udpClose + {-# INLINE sClose #-} + + +newUdpSocket :: (HasNetworkStack ns, Network addr) + => ns + -> SocketConfig + -> Maybe Device + -> addr + -> Maybe SockPort + -> IO (UdpSocket addr) + +newUdpSocket ns SocketConfig { .. } mbDev src mbSrcPort = + do let udpNS = view networkStack ns + + srcPort <- case mbSrcPort of + Nothing -> do mb <- nextUdpPort udpNS (toAddr src) + case mb of + Just port -> return port + Nothing -> throwIO NoPortAvailable + + Just p -> return p + + udpSockState <- newIORef (KnownSource mbDev src srcPort) + + udpBuffer <- DGram.newBuffer scRecvBufferSize + + -- XXX: Need some SocketError exceptions: this only happens if there's + -- already something listening + mbClose <- registerRecv udpNS (toAddr src) srcPort udpBuffer + udpClose <- case mbClose of + Just unreg -> return unreg + Nothing -> throwIO AlreadyListening + + return $! UdpSocket { .. } + + +instance DataSocket UdpSocket where + + -- Always lookup the route before modifying the state of the socket, so that + -- the state can be manipulated atomically. + sConnect ns SocketConfig { .. } mbDev src mbPort dst dstPort = + do let udpNS = view networkStack ns + + ri <- route udpNS mbDev src dst + + srcPort <- case mbPort of + Just p -> return p + Nothing -> do mb <- nextUdpPort udpNS (toAddr (riSource ri)) + case mb of + Just port -> return port + Nothing -> throwIO NoPortAvailable + + udpSockState <- newIORef (KnownRoute ri dst srcPort dstPort) + + udpBuffer <- DGram.newBuffer scRecvBufferSize + + mbClose <- registerRecv udpNS (toAddr src) srcPort udpBuffer + udpClose <- case mbClose of + Just unreg -> return unreg + Nothing -> throwIO AlreadyConnected + + return UdpSocket { .. } + + sCanWrite UdpSocket { .. } = + do path <- readIORef udpSockState + case path of + KnownRoute _ _ _ _ -> return True + KnownSource{} -> return False + + sWrite UdpSocket { .. } bytes = + do path <- readIORef udpSockState + case path of + + KnownRoute ri dst srcPort dstPort -> + do sent <- primSendUdp udpNS ri dst srcPort dstPort bytes + if sent + then return (fromIntegral (L.length bytes)) + else return (-1) + + KnownSource{} -> + throwIO NoConnection + + sCanRead UdpSocket { .. } = + not `fmap` DGram.isEmptyBuffer udpBuffer + + sRead UdpSocket { .. } len = + do (_,buf) <- DGram.readChunk udpBuffer + return (L.fromStrict (S.take len buf)) + + sTryRead UdpSocket { .. } len = + do mb <- DGram.tryReadChunk udpBuffer + case mb of + Just (_,buf) -> return $! Just $! L.fromStrict $! S.take len buf + Nothing -> return Nothing + +-- | Receive, with information about who sent this datagram. +recvfrom :: Network addr + => UdpSocket addr -> IO (Device,addr,SockPort,L.ByteString) +recvfrom sock = do + (dev,srcAddr,srcPort,_,msg) <- recvfrom' sock + return (dev,srcAddr,srcPort,msg) +{-# INLINE recvfrom #-} + +recvfrom' :: Network addr + => UdpSocket addr -> IO (Device,addr,SockPort,addr,L.ByteString) +recvfrom' UdpSocket { .. } = loop + where + + -- NOTE: this loop shouldn't run more than one time, as it's very unlikely + -- that we receive a packet destined for a different protocol address + loop = + do ((dev,srcAddr,srcPort,dstAddr,_), chunk) <- DGram.readChunk udpBuffer + case (fromAddr srcAddr, fromAddr dstAddr) of + (Just srcAddr', Just dstAddr') -> + return (dev,srcAddr',srcPort,dstAddr',L.fromStrict chunk) + _ -> loop +{-# INLINE recvfrom' #-} + + +-- | Send to a specific end host. +sendto :: Network addr + => UdpSocket addr -> addr -> SockPort -> L.ByteString -> IO () +sendto UdpSocket { .. } = \ dst dstPort bytes -> + do state <- readIORef udpSockState + case state of + + KnownSource mbDev src srcPort -> + do mbRoute <- route' udpNS mbDev src dst + case mbRoute of + + Just ri -> + do _ <- primSendUdp udpNS ri dst srcPort dstPort bytes + return () + + -- no route found, but we're broadcasting using a known device + Nothing + | Just dev <- mbDev, isBroadcastAddr dst -> + do let ri = RouteInfo { riSource = src + , riNext = dst + , riDev = dev } + _ <- primSendUdp udpNS ri dst srcPort dstPort bytes + return () + + _ -> + throwIO NoRouteToHost + + -- we can't use sendto if sConnect has been used already + KnownRoute{} -> + throwIO AlreadyConnected +{-# INLINE sendto #-} + + diff --git a/src/Hans/Tcp/Input.hs b/src/Hans/Tcp/Input.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Input.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.Tcp.Input ( + processTcp + ) where + +import Hans.Addr (Addr,NetworkAddr(..)) +import Hans.Checksum (finalizeChecksum,extendChecksum) +import Hans.Config (config) +import Hans.Device.Types (Device(..),ChecksumOffload(..),rxOffload) +import Hans.Lens (view,set) +import Hans.Monad (Hans,escape,decode',dropPacket,io) +import Hans.Nat.Forward (tryForwardTcp) +import Hans.Network +import Hans.Tcp.Message +import Hans.Tcp.Output (routeTcp,queueTcp,queueAck,queueWithTcb,queueTcp) +import Hans.Tcp.Packet +import Hans.Tcp.RecvWindow + (sequenceNumberValid,recvSegment) +import Hans.Tcp.SendWindow (ackSegment,nullWindow) +import Hans.Tcp.Tcb +import Hans.Types + +import Control.Monad (unless,when) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.IORef (atomicModifyIORef',atomicWriteIORef,readIORef) +import Data.Maybe (isJust) +import Data.Time.Clock (UTCTime,NominalDiffTime,getCurrentTime) + + +-- | Process incoming tcp segments. +processTcp :: Network addr + => NetworkStack -> Device -> addr -> addr -> S.ByteString -> Hans () +processTcp ns dev src dst bytes = + do -- make sure that the checksum is valid + let checksum = finalizeChecksum $ extendChecksum bytes + $ pseudoHeader src dst PROT_TCP + $ S.length bytes + unless (coTcp (view rxOffload dev) || checksum == 0) + (dropPacket (devStats dev)) + + (hdr,payload) <- decode' (devStats dev) getTcpHeader bytes + + let remote = toAddr src + let local = toAddr dst + + tryActive ns dev remote local hdr payload + +-- | A single case for an incoming segment. +type InputCase = NetworkStack -> Device -> Addr -> Addr -> TcpHeader + -> S.ByteString -> Hans () + +-- | Process incoming segments that are destined for an active connection. +tryActive :: InputCase +tryActive ns dev src dst hdr payload = + do mbActive <- io (lookupActive ns src (tcpSourcePort hdr) dst (tcpDestPort hdr)) + case mbActive of + Just tcb -> handleActive ns dev hdr payload tcb + Nothing -> tryListening ns dev src dst hdr payload +{-# INLINE tryActive #-} + + +-- | Process incoming segments that are destined for a listening connection. +tryListening :: InputCase +tryListening ns dev src dst hdr payload = + do mbListening <- io (lookupListening ns dst (tcpDestPort hdr)) + case mbListening of + Just tcb -> handleListening ns dev src dst hdr payload tcb + Nothing -> tryTimeWait ns dev src dst hdr payload +{-# INLINE tryListening #-} + + +-- | Process incoming segments that are destined for a connection in TimeWait. +tryTimeWait :: InputCase +tryTimeWait ns dev remote local hdr payload = + do mbTimeWait <- io (lookupTimeWait ns remote (tcpSourcePort hdr) local (tcpDestPort hdr)) + case mbTimeWait of + Just tcb -> handleTimeWait ns hdr payload tcb + Nothing -> tryForward ns dev remote local hdr payload +{-# INLINE tryTimeWait #-} + + +-- | Process incoming segments to a forwarded port. +tryForward :: InputCase +tryForward ns dev remote local hdr payload = + do mbHdr <- io (tryForwardTcp ns local remote hdr) + case mbHdr of + + Just (ri,dst,hdr') -> io $ + do _ <- queueTcp ns ri dst hdr' (L.fromStrict payload) + return () + + Nothing -> handleClosed ns dev remote local hdr payload +{-# INLINE tryForward #-} + + + +-- Active Connections ---------------------------------------------------------- + +handleActive :: NetworkStack + -> Device -> TcpHeader -> S.ByteString -> Tcb -> Hans () + +handleActive ns dev hdr payload tcb = + -- XXX it would be nice to add header prediction here + do updateTimestamp tcb hdr payload + + whenState tcb SynSent (handleSynSent ns dev hdr payload tcb) + + -- page 69 + -- check sequence numbers + mbSegs <- io (atomicModifyIORef' (tcbRecvWindow tcb) (recvSegment hdr payload)) + case mbSegs of + + Nothing -> + do unless (view tcpRst hdr) $ io $ + do _ <- queueWithTcb ns tcb (set tcpAck True emptyTcpHeader) L.empty + return () + + Just segs -> + do now <- io getCurrentTime + handleActiveSegs ns tcb now segs + + escape + + +-- | Update the internal timestamp. This follows the algorithm described on +-- pages 15 and 16 of RFC-1323. +updateTimestamp :: Tcb -> TcpHeader -> S.ByteString -> Hans () +updateTimestamp Tcb { .. } hdr payload = + do TcbConfig { .. } <- io (readIORef tcbConfig) + + when tcUseTimestamp $ + case findTcpOption OptTagTimestamp hdr of + + -- update TS.recent when Last.ACK.sent falls within the segment, and + -- there isn't an outstanding delayed ack registered. + Just (OptTimestamp val _) -> + do lastAckSent <- io (readIORef tcbLastAckSent) + delayed <- io (readIORef tcbNeedsDelayedAck) + let end = tcpSegNextAckNum hdr (S.length payload) + when (not delayed && withinWindow (tcpSeqNum hdr) end lastAckSent) + (io (atomicWriteIORef tcbTSRecent val)) + + -- when the timestamp is missing, but we're using timestamps, drop the + -- segment, unless it was an RST + _ | view tcpRst hdr -> return () + | otherwise -> escape + + +-- | At this point, the list of segments is contiguous, and starts at the old +-- value of RCV.NXT. RCV.NXT has been advanced to point at the end of the +-- segment list. +handleActiveSegs :: NetworkStack -> Tcb -> UTCTime -> [(TcpHeader,S.ByteString)] + -> Hans () +handleActiveSegs ns tcb now = go + where + go [] = return () + go ((hdr,payload):segs) = + do -- page 70 and page 71 + -- check RST/check SYN + when (view tcpRst hdr || view tcpSyn hdr) $ + do io $ do when (view tcpSyn hdr) $ + do let rst = set tcpRst True emptyTcpHeader + _ <- queueWithTcb ns tcb rst L.empty + return () + + -- when the tcb was passively opened, this will free its + -- accept queue slot. + setState tcb Closed + + closeActive ns tcb + + escape + + -- page 71 + -- skipping security/precedence + + -- page 72 + -- check ACK + -- NOTE: processing ends here if ack is not present, which is why the + -- remainder of packet processing is underneath this `when`. + when (view tcpAck hdr) $ + do -- Reset idle timeout + io $ atomicModifyIORef' (tcbTimers tcb) resetIdleTimer + + -- update the send window + mbAck <- io $ + do mbAck <- atomicModifyIORef' (tcbSendWindow tcb) + (ackSegment (view config ns) now (tcpAckNum hdr)) + handleRTTMeasurement tcb mbAck + + state <- io (getState tcb) + case state of + + SynReceived -> + case mbAck of + Just True -> io (setState tcb Established) + Just False -> return () + Nothing -> do let rst = set tcpRst True emptyTcpHeader + _ <- io (queueWithTcb ns tcb rst L.empty) + return () + + FinWait1 -> + case mbAck of + Just True -> + do io (setState tcb FinWait2) + io (processFinWait2 ns tcb) + + _ -> return () + + FinWait2 -> + case mbAck of + Just True -> io (processFinWait2 ns tcb) + _ -> return () + + Closing -> + case mbAck of + Just True -> enterTimeWait ns tcb + _ -> return () + + LastAck -> + case mbAck of + Just True -> + do io (setState tcb Closed) + io (closeActive ns tcb) + escape + + _ -> return () + + -- TimeWait processing is done in handleTimeWait + + -- CloseWait | Established + _ -> return () + + -- page 73 + -- check URG + + -- page 74 + -- process the segment text + -- XXX: we're ignoring PSH for now, just making the data immediately + -- available + unless (S.null payload) $ io $ + do signalDelayedAck tcb + queueBytes payload tcb + + -- page 75 + -- check FIN + when (view tcpFin hdr) $ + do -- send an ACK to the FIN + _ <- io (queueAck ns tcb) + + state' <- io (getState tcb) + case state' of + + SynReceived -> io (setState tcb CloseWait) + Established -> io (setState tcb CloseWait) + + FinWait1 -> + case mbAck of + Just True -> enterTimeWait ns tcb + _ -> io (setState tcb Closing) + + FinWait2 -> enterTimeWait ns tcb + + _ -> return () + + go segs + + +-- | Processing for the FinWait2 state, when the retransmit queue is known to be +-- empty. (Page 73 of RFC-793) +processFinWait2 :: NetworkStack -> Tcb -> IO () +processFinWait2 _ns Tcb { .. } = + do win <- readIORef tcbSendWindow + + when (nullWindow win) $ + do -- XXX acknowledge the user's close request + return () + + +-- | Invalidate, and remove the active 'Tcb', replacing it with a 'TimeWaitTcb' +-- that was derived from it. +enterTimeWait :: NetworkStack -> Tcb -> Hans () +enterTimeWait ns tcb = + do tw <- io (mkTimeWaitTcb tcb) + io (closeActive ns tcb) + io (registerTimeWait ns tw) + escape + + +-- | Apply an RTT measurement to the timers in a tcb, and return the relevant +-- information about the state of the send queue. +handleRTTMeasurement :: Tcb -> Maybe (Bool, Maybe NominalDiffTime) + -> IO (Maybe Bool) +handleRTTMeasurement Tcb { .. } mb = + case mb of + Just (b, Just rtt) -> + do atomicModifyIORef' tcbTimers (calibrateRTO rtt) + return (Just b) + + Just (b,_) -> + return (Just b) + + Nothing -> + return Nothing + + +-- Half-open Connections ------------------------------------------------------- + +-- | Handle incoming packets destined for a tcb that's in the SYN-SENT state. +handleSynSent :: NetworkStack -> Device -> TcpHeader -> S.ByteString -> Tcb + -> Hans () +handleSynSent ns _dev hdr _payload tcb = + do -- page 66 + iss <- io (readIORef (tcbIss tcb)) + when (view tcpAck hdr) $ + do sndNxt <- getSndNxt tcb + + when (tcpAckNum hdr <= iss || tcpAckNum hdr > sndNxt) $ + do when (view tcpRst hdr) escape + + rst <- io (mkRst hdr) + _ <- io (queueTcp ns (tcbRouteInfo tcb) (tcbRemote tcb) rst L.empty) + escape + + -- page 66/67 + when (view tcpRst hdr) $ + do when (view tcpAck hdr) $ io $ + -- NOTE: the ACK must have been acceptable at this point, as we + -- would have not made it this far otherwise. + do setState tcb Closed + deleteActive ns tcb + + escape + + -- no security/precedence currently + + -- page 67/68 + when (view tcpSyn hdr) $ + do let rcvNxt = tcpSeqNum hdr + 1 + + res <- io (setRcvNxt rcvNxt tcb) + -- should never happen, but if a segment was queued in the receive + -- window, mucking about with RCV.NXT will cause processing to abort + -- + -- XXX: maybe there's a better way to encode advancing RCV.NXT over + -- the SYN? + unless res escape + + io (atomicWriteIORef (tcbIrs tcb) (tcpSeqNum hdr)) + + sndUna <- io $ + if view tcpAck hdr + then do now <- getCurrentTime + mb <- atomicModifyIORef' (tcbSendWindow tcb) + (ackSegment (view config ns) now (tcpAckNum hdr)) + _ <- handleRTTMeasurement tcb mb + return (tcpAckNum hdr) + + else getSndUna tcb + + when (sndUna > iss) $ + do -- XXX: include any queued data/controls + _ <- io (queueAck ns tcb) + io (setState tcb Established) + + -- XXX: not processing additional data/controls from the ack + escape + + io (setState tcb SynReceived) + let synAck = set tcpSyn True + $ set tcpAck True emptyTcpHeader + _ <- io (queueWithTcb ns tcb synAck L.empty) + + -- XXX: not queueing any additional data + escape + + -- page 68 + -- at this point, neither syn or rst were set, so drop the segment + escape + + +-- Listening Connections ------------------------------------------------------- + +-- | Respond to a segment directed at a socket in the Listen state. This +-- implements the LISTEN case from pages 64-67 of RFC793. +handleListening :: NetworkStack + -> Device -> Addr -> Addr -> TcpHeader -> S.ByteString + -> ListenTcb -> Hans () + +handleListening ns dev remote local hdr _payload tcb = + -- ignore all incoming RST packets (page 64) + do when (view tcpRst hdr) + escape + + -- send a RST for incoming ACK packets (page 64) + when (view tcpAck hdr) $ + do hdr' <- io (mkRst hdr) + _ <- io (routeTcp ns dev local remote hdr' L.empty) + escape + + -- we don't enforce security in HaNS (page 65) + -- XXX should we be managing precedence? + -- XXX we're not queueing any other control/data that arrived + when (view tcpSyn hdr) $ + do canAccept <- io (decrSynBacklog ns) + unless canAccept (rejectSyn ns dev remote local hdr) + + createChildTcb ns dev remote local hdr tcb + escape + + -- drop anything else that made it this far (page 65) + escape + + +-- | Create a child TCB from a listening one. +createChildTcb :: NetworkStack -> Device -> Addr -> Addr -> TcpHeader -> ListenTcb + -> Hans () +createChildTcb ns dev remote local hdr parent = + + -- cache routing information for the child, and fail if there's no valid + -- route + do mbRoute <- io (findNextHop ns (Just dev) (Just local) remote) + ri <- case mbRoute of + Just ri -> return ri + Nothing -> rejectSyn ns dev remote local hdr + + -- reserve a spot in the accept queue + canAccept <- io (reserveSlot parent) + unless canAccept (rejectSyn ns dev remote local hdr) + + -- construct a new tcb, and initialize it as specified on (page 65) + (added,child) <- io $ + do iss <- nextIss ns local (tcpDestPort hdr) remote (tcpSourcePort hdr) + child <- createChild ns iss parent ri remote hdr + (\_ _ -> incrSynBacklog ns) + (\_ s -> when (s == SynReceived) (incrSynBacklog ns)) + added <- registerActive ns child + return (added,child) + + -- if we couldn't add the entry to the active connections, reject it + unless added $ + do io (releaseSlot parent) + rejectSyn ns dev remote local hdr + + -- queueing a SYN/ACK in the send window will advance SND.NXT + -- automatically + io (processSynOptions child hdr) + let synAck = set tcpSyn True + $ set tcpAck True emptyTcpHeader + _ <- io (queueWithTcb ns child synAck L.empty) + + return () + + +-- | Determine which options should be sent in the SYN,ACK response. +processSynOptions :: Tcb -> TcpHeader -> IO () +processSynOptions Tcb { .. } hdr = + do case findTcpOption OptTagTimestamp hdr of + + -- the timestamp option is requested by the remote side + Just (OptTimestamp val 0) -> + do atomicModifyIORef' tcbConfig $ \ TcbConfig { .. } -> + (TcbConfig { tcUseTimestamp = True, .. }, ()) + atomicWriteIORef tcbTSRecent val + + -- no timestamp option, disable timestamps + _ -> atomicModifyIORef' tcbConfig $ \ TcbConfig { .. } -> + (TcbConfig { tcUseTimestamp = False, .. }, ()) + + -- XXX: in the future, enable SACK here + -- XXX: in the future, enable Window Scale here + + return () + + +-- | Reject the SYN by sending an RST, drop the segment and return. +rejectSyn :: NetworkStack -> Device -> Addr -> Addr -> TcpHeader -> Hans a +rejectSyn ns dev remote local hdr = + do hdr' <- io (mkRst hdr) + _ <- io (routeTcp ns dev local remote hdr' L.empty) + escape + + +-- TimeWait Connections -------------------------------------------------------- + +handleTimeWait :: NetworkStack -> TcpHeader -> S.ByteString -> TimeWaitTcb -> Hans () +handleTimeWait ns hdr payload tcb = + -- page 69 + do (rcvNxt,rcvRight) <- getRecvWindow tcb + unless (isJust (sequenceNumberValid rcvNxt rcvRight hdr payload)) $ + do unless (view tcpRst hdr) $ io $ + do ack <- mkAck (twSndNxt tcb) rcvNxt (tcpDestPort hdr) (tcpSourcePort hdr) + _ <- queueTcp ns (twRouteInfo tcb) (twRemote tcb) ack L.empty + return () + escape + + -- page 70 + when (view tcpRst hdr) $ + do io (deleteTimeWait ns tcb) + escape + + -- page 71 + when (view tcpSyn hdr) $ + do rst <- io (mkRst hdr) + _ <- io (queueTcp ns (twRouteInfo tcb) (twRemote tcb) rst L.empty) + io (deleteTimeWait ns tcb) + escape + + -- page 73 + when (not (view tcpAck hdr)) escape + + -- page 74 + -- ignore the URG bit + + -- page 75 + -- ignore the segment text + + -- page 75/76 + -- process the FIN bit + when (view tcpFin hdr) $ + do rcvNxt' <- io $ + atomicModifyIORef' (twRcvNxt tcb) $ \ i -> + let i' = i + 1 + fromIntegral (S.length payload) + in (i', i') + + ack <- io (mkAck (twSndNxt tcb) rcvNxt' (tcpDestPort hdr) (tcpSourcePort hdr)) + _ <- io (queueTcp ns (twRouteInfo tcb) (twRemote tcb) ack L.empty) + + io (resetTimeWait ns tcb) + escape + + escape + + +-- Closed Connections ---------------------------------------------------------- + +-- | Respond to a segment that was directed at a closed port. This implements +-- the CLOSED case on page 64 of RFC793 +handleClosed :: NetworkStack + -> Device -> Addr -> Addr -> TcpHeader -> S.ByteString -> Hans () +handleClosed ns dev remote local hdr payload = + do when (view tcpRst hdr) escape + + rst <- io $ if view tcpAck hdr then mkRst hdr + else mkRstAck hdr payload + _ <- io (routeTcp ns dev local remote rst L.empty) + escape diff --git a/src/Hans/Tcp/Message.hs b/src/Hans/Tcp/Message.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Message.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Tcp.Message where + +import Hans.Lens +import Hans.Tcp.Packet +import Hans.Tcp.Tcb + +import qualified Data.ByteString as S +import Data.IORef (readIORef) + + +-- | @@ +mkRst :: TcpHeader -> IO TcpHeader +mkRst TcpHeader { .. } = + return $ set tcpRst True + $ emptyTcpHeader { tcpSourcePort = tcpDestPort + , tcpDestPort = tcpSourcePort + , tcpSeqNum = tcpAckNum + } +{-# INLINE mkRst #-} + + +-- | @@ +mkRstAck :: TcpHeader -> S.ByteString -> IO TcpHeader +mkRstAck hdr @ TcpHeader { .. } payload = + return $ set tcpRst True + $ set tcpAck True + $ emptyTcpHeader { tcpSourcePort = tcpDestPort + , tcpDestPort = tcpSourcePort + , tcpSeqNum = 0 + , tcpAckNum = tcpSegNextAckNum hdr (S.length payload) + } +{-# INLINE mkRstAck #-} + + +mkSyn :: Tcb -> IO TcpHeader +mkSyn Tcb { .. } = + do iss <- readIORef tcbIss + return $ set tcpSyn True + $ emptyTcpHeader { tcpSourcePort = tcbRemotePort + , tcpDestPort = tcbLocalPort + , tcpSeqNum = iss + , tcpAckNum = 0 + } +{-# INLINE mkSyn #-} + + +-- | @@ +mkSynAck :: Tcb -> TcpHeader -> IO TcpHeader +mkSynAck Tcb { .. } TcpHeader { .. } = + do iss <- readIORef tcbIss + ack <- getRcvNxt tcbRecvWindow + + return $ set tcpSyn True + $ set tcpAck True + $ emptyTcpHeader { tcpSourcePort = tcpDestPort + , tcpDestPort = tcpSourcePort + , tcpSeqNum = iss + , tcpAckNum = ack + } +{-# INLINE mkSynAck #-} + + +mkAck :: TcpSeqNum -- ^ SEG.SEQ + -> TcpSeqNum -- ^ SEG.ACK + -> TcpPort -- ^ Local port + -> TcpPort -- ^ Remote port + -> IO TcpHeader +mkAck segSeq segAck local remote = + return $ set tcpAck True + $ emptyTcpHeader { tcpSourcePort = local + , tcpDestPort = remote + , tcpSeqNum = segSeq + , tcpAckNum = segAck + } +{-# INLINE mkAck #-} diff --git a/src/Hans/Tcp/Output.hs b/src/Hans/Tcp/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Output.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.Tcp.Output ( + -- * Output + routeTcp, + sendTcp, + + -- ** With a TCB + sendWithTcb, + sendAck, + sendFin, + sendData, + canSend, + + -- ** From the fast-path + queueTcp, + queueWithTcb, + queueAck, + responder, + + -- $notes + ) where + +import Hans.Addr.Types (Addr) +import Hans.Config (config) +import Hans.Checksum (finalizeChecksum,extendChecksum) +import Hans.Device.Types (Device(..),ChecksumOffload(..),txOffload) +import Hans.Lens (view,set) +import Hans.Network +import Hans.Serialize (runPutPacket) +import Hans.Tcp.Packet + (TcpHeader(..),putTcpHeader,emptyTcpHeader,tcpAck,tcpFin + ,tcpPsh,TcpOption(..),setTcpOption) +import qualified Hans.Tcp.RecvWindow as Recv +import qualified Hans.Tcp.SendWindow as Send +import Hans.Tcp.Tcb +import Hans.Types + +import qualified Control.Concurrent.BoundedChan as BC +import Control.Monad (when,forever) +import qualified Data.ByteString.Lazy as L +import Data.IORef (readIORef,atomicModifyIORef',atomicWriteIORef) +import Data.Int (Int64) +import Data.Serialize.Put (putWord16be) +import Data.Time.Clock (getCurrentTime) +import Data.Word (Word32) + + +-- Sending with a TCB ---------------------------------------------------------- + +-- | Send a single ACK immediately. +sendAck :: NetworkStack -> Tcb -> IO () +sendAck ns tcb = + do _ <- sendWithTcb ns tcb (set tcpAck True emptyTcpHeader) L.empty + return () + +-- | Send a single FIN packet. +sendFin :: NetworkStack -> Tcb -> IO () +sendFin ns tcb = + do let hdr = set tcpFin True + $ set tcpAck True emptyTcpHeader + _ <- sendWithTcb ns tcb hdr L.empty + return () + +-- | Send a data segment, potentially sending multiple packets if the send +-- window allows, and the payload is larger than MSS. When the remote window is +-- full, this returns 0. +sendData :: NetworkStack -> Tcb -> L.ByteString -> IO Int64 +sendData ns tcb = go 0 + where + -- technically the MSS could change between sends, so this ensures that we + -- would pick up that change. + go acc bytes + | L.null bytes = + return acc + + | otherwise = + do mss <- fromIntegral `fmap` readIORef (tcbMss tcb) + mb <- sendWithTcb ns tcb hdr (L.take mss bytes) + case mb of + + -- when the amount sent was less than mss, we've filled the send + -- window, and won't be able to send any more. + Just len | len < mss -> return $! acc + len + | otherwise -> let acc' = acc + len + in acc' `seq` go acc' (L.drop len bytes) + + -- the send window is full, return the accumulator + Nothing -> return acc + + hdr = set tcpAck True + $ set tcpPsh True + emptyTcpHeader + + +-- | Determine if there is any room in the remote window for us to send +-- data. +canSend :: Tcb -> IO Bool +canSend Tcb { .. } = + (not . Send.fullWindow) `fmap` readIORef tcbSendWindow + +-- | Send a segment and queue it in the remote window. The number of bytes that +-- were sent is returned. +sendWithTcb :: NetworkStack -> Tcb -> TcpHeader -> L.ByteString -> IO (Maybe Int64) +sendWithTcb ns Tcb { .. } hdr body = + do TcbConfig { .. } <- readIORef tcbConfig + + recvWindow <- readIORef tcbRecvWindow + + mbTSecr <- if tcUseTimestamp + then Just `fmap` readIORef tcbTSRecent + else return Nothing + + let mkHdr tsVal seqNum = + addTimestamp tsVal mbTSecr + hdr { tcpSeqNum = seqNum + , tcpAckNum = if view tcpAck hdr + then view Recv.rcvNxt recvWindow + else 0 + , tcpDestPort = tcbRemotePort + , tcpSourcePort = tcbLocalPort + , tcpWindow = view Recv.rcvWnd recvWindow + } + + -- only enter the retransmit queue if the segment contains data + now <- getCurrentTime + mbRes <- atomicModifyIORef' tcbSendWindow + (Send.queueSegment (view config ns) now mkHdr body) + case mbRes of + + Just (startRT,hdr',body') -> + do -- clear the delayed ack flag and update Last.ACK.sent, when an ack + -- is present + when (view tcpAck hdr') $ + do atomicWriteIORef tcbNeedsDelayedAck False + atomicWriteIORef tcbLastAckSent (tcpAckNum hdr') + + -- reset the retransmit timer, if the retransmit queue is now + -- non-empty + when startRT (atomicModifyIORef' tcbTimers resetRetransmit) + + -- send the frame + _ <- sendTcp ns tcbRouteInfo tcbRemote hdr' body' + + -- return how much of the segment was actually delivered + return (Just (L.length body')) + + Nothing -> + return Nothing + + +-- | The presence of a tracked TSecr value controls whether or not we send the +-- timestamp option. +addTimestamp :: Word32 -> Maybe Word32 -> TcpHeader -> TcpHeader +addTimestamp tsVal (Just tsEcr) hdr = setTcpOption (OptTimestamp tsVal tsEcr) hdr +addTimestamp _ _ hdr = hdr + + +-- Fast-path Sending ----------------------------------------------------------- + +-- | Responder thread for messages generated in the fast-path. +responder :: NetworkStack -> IO () +responder ns = forever $ + do msg <- BC.readChan chan + case msg of + SendSegment ri dst hdr body -> + do _ <- sendTcp ns ri dst hdr body + return () + + SendWithTcb tcb hdr body -> + do _ <- sendWithTcb ns tcb hdr body + return () + + where + chan = view tcpQueue ns + + +-- | Queue an outgoing TCP segment from the fast-path. +-- +-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue"). +queueTcp :: NetworkStack + -> RouteInfo Addr -> Addr -> TcpHeader -> L.ByteString -> IO Bool +queueTcp ns ri dst hdr body = + BC.tryWriteChan (view tcpQueue ns) $! SendSegment ri dst hdr body + + +-- | Queue an outgoing TCP segment from the fast-path. +queueWithTcb :: NetworkStack -> Tcb -> TcpHeader -> L.ByteString -> IO Bool +queueWithTcb ns tcb hdr body = + BC.tryWriteChan (view tcpQueue ns) $! SendWithTcb tcb hdr body + + +-- | Queue an ACK from the fast-path. +queueAck :: NetworkStack -> Tcb -> IO Bool +queueAck ns tcb = queueWithTcb ns tcb (set tcpAck True emptyTcpHeader) L.empty + + +-- Primitive Send -------------------------------------------------------------- + +-- | Send outgoing tcp segments, with a route calculation. +-- +-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue"). +routeTcp :: Network addr + => NetworkStack -> Device + -> addr -> addr -> TcpHeader -> L.ByteString -> IO Bool +routeTcp ns dev src dst hdr payload + | L.length payload > fromIntegral (maxBound :: Word32) = + return False + + | otherwise = + do mbRoute <- findNextHop ns (Just dev) (Just src) dst + case mbRoute of + + Just ri -> + do let bytes = renderTcpPacket (view txOffload dev) src dst hdr payload + sendDatagram ns ri dst False PROT_TCP bytes + return True + + Nothing -> + return False + + +-- | Lowest-level output function for TCP. +-- +-- See note "No Retransmit Queue" ("Hans.Tcp.Output#no-retransmit-queue"). +sendTcp :: Network addr + => NetworkStack + -> RouteInfo addr -> addr -> TcpHeader -> L.ByteString -> IO Bool +sendTcp ns ri dst hdr payload + | L.length payload >= fromIntegral (maxBound :: Word32) = + return False + + | otherwise = + do let bytes = renderTcpPacket (view txOffload ri) (riSource ri) dst hdr payload + sendDatagram ns ri dst False PROT_TCP bytes + + return True + + +-- | Render out a tcp packet, calculating the checksum when the device requires +-- it. +renderTcpPacket :: Network addr + => ChecksumOffload -> addr -> addr -> TcpHeader -> L.ByteString + -> L.ByteString +renderTcpPacket ChecksumOffload { .. } src dst hdr body + | coTcp = bytes + | otherwise = beforeCS `L.append` csBytes + where + bytes = runPutPacket 20 40 body (putTcpHeader hdr) + + cs = finalizeChecksum + $ extendChecksum bytes + $ pseudoHeader src dst PROT_TCP (fromIntegral (L.length bytes)) + + beforeCS = L.take 16 bytes + csBytes = runPutPacket 2 0 (L.drop 18 bytes) (putWord16be cs) + + +-- $notes +-- #no-retransmit-queue# +-- +-- = No Retransmit Queue +-- This function will not record entries in the retransmit queue, and is +-- responsible only for output to a lower layer. diff --git a/src/Hans/Tcp/Packet.hs b/src/Hans/Tcp/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Packet.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hans.Tcp.Packet ( + + -- * Header + TcpHeader(..), + TcpPort, putTcpPort, + emptyTcpHeader, + tcpHeaderSize, + + -- ** Sequence Numbers + TcpSeqNum, TcpAckNum, + withinWindow, + fromTcpSeqNum, + + -- ** Header Flags + tcpNs, tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpSyn, + tcpFin, + + -- ** Serialization + getTcpHeader, putTcpHeader, + + -- ** Options + HasTcpOptions(..), + findTcpOption, + setTcpOption, + setTcpOptions, + TcpOption(..), + TcpOptionTag(..), tcpOptionTag, + SackBlock(..), + tcpOptionsSize, + tcpOptionSize, + + -- * Segment Operations + tcpSegLen, + tcpSegLastSeqNum, + tcpSegNextAckNum, + ) where + +import Hans.Lens + +import Control.Monad (replicateM,replicateM_,unless) +import Data.Bits ((.|.),(.&.),shiftL,shiftR) +import qualified Data.ByteString as S +import qualified Data.Foldable as F +import Data.Int (Int32) +import Data.List (find) +import Data.Serialize.Get + (Get,getWord8,getWord16be,getWord32be,label,isolate + ,getBytes,remaining,skip) +import Data.Serialize.Put + (Putter,Put,putWord8,putWord16be,putWord32be,putByteString) +import Data.Word (Word8,Word16,Word32) + + +-- Tcp Support Types ----------------------------------------------------------- + +type TcpPort = Word16 + +putTcpPort :: Putter TcpPort +putTcpPort = putWord16be + +getTcpPort :: Get TcpPort +getTcpPort = getWord16be + + +newtype TcpSeqNum = TcpSeqNum Word32 + deriving (Num,Eq,Show) + +fromTcpSeqNum :: Num a => TcpSeqNum -> a +fromTcpSeqNum (TcpSeqNum a) = fromIntegral a + +instance Ord TcpSeqNum where + compare (TcpSeqNum a) (TcpSeqNum b) = + compare (fromIntegral (a - b) :: Int32) 0 + + TcpSeqNum a < TcpSeqNum b = (fromIntegral (a - b) :: Int32) < 0 + TcpSeqNum a <= TcpSeqNum b = (fromIntegral (a - b) :: Int32) <= 0 + TcpSeqNum a > TcpSeqNum b = (fromIntegral (a - b) :: Int32) > 0 + TcpSeqNum a >= TcpSeqNum b = (fromIntegral (a - b) :: Int32) >= 0 + + {-# INLINE compare #-} + {-# INLINE (<) #-} + {-# INLINE (<=) #-} + {-# INLINE (>) #-} + {-# INLINE (>=) #-} + +withinWindow :: TcpSeqNum -> TcpSeqNum -> TcpSeqNum -> Bool +withinWindow l r = \x -> l <= x && x < r +{-# INLINE withinWindow #-} + +putTcpSeqNum :: Putter TcpSeqNum +putTcpSeqNum (TcpSeqNum w) = putWord32be w + +getTcpSeqNum :: Get TcpSeqNum +getTcpSeqNum = + do w <- getWord32be + return (TcpSeqNum w) + + +-- | An alias to TcpSeqNum, as these two are used in the same role. +type TcpAckNum = TcpSeqNum + +putTcpAckNum :: Putter TcpAckNum +putTcpAckNum = putTcpSeqNum + +getTcpAckNum :: Get TcpAckNum +getTcpAckNum = getTcpSeqNum + + +-- Tcp Header ------------------------------------------------------------------ + +-- 0 1 2 3 +-- 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Source Port | Destination Port | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Sequence Number | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Acknowledgment Number | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Data | |N|C|E|U|A|P|R|S|F| | +-- | Offset| Res.|S|W|C|R|C|S|S|Y|I| Window | +-- | | | |R|E|G|K|H|T|N|N| | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Checksum | Urgent Pointer | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | Options | Padding | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +-- | data | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +data TcpHeader = TcpHeader { tcpSourcePort :: !TcpPort + , tcpDestPort :: !TcpPort + , tcpSeqNum :: !TcpSeqNum + , tcpAckNum :: !TcpAckNum + , tcpFlags_ :: !Word16 + , tcpWindow :: !Word16 + , tcpChecksum :: !Word16 + , tcpUrgentPointer :: !Word16 + , tcpOptions_ :: [TcpOption] + } deriving (Eq,Show) + +emptyTcpHeader :: TcpHeader +emptyTcpHeader = TcpHeader { tcpSourcePort = 0 + , tcpDestPort = 0 + , tcpSeqNum = 0 + , tcpAckNum = 0 + , tcpFlags_ = 0 + , tcpWindow = 0 + , tcpChecksum = 0 + , tcpUrgentPointer = 0 + , tcpOptions_ = [] + } + +tcpFlags :: Lens' TcpHeader Word16 +tcpFlags f hdr = + fmap (\flags' -> hdr { tcpFlags_ = flags' }) (f (tcpFlags_ hdr)) +{-# INLINE tcpFlags #-} + +tcpNs, tcpCwr, tcpEce, tcpUrg, tcpAck, tcpPsh, tcpRst, tcpSyn, + tcpFin :: Lens' TcpHeader Bool +tcpNs = tcpFlags . bit 8 +tcpCwr = tcpFlags . bit 7 +tcpEce = tcpFlags . bit 6 +tcpUrg = tcpFlags . bit 5 +tcpAck = tcpFlags . bit 4 +tcpPsh = tcpFlags . bit 3 +tcpRst = tcpFlags . bit 2 +tcpSyn = tcpFlags . bit 1 +tcpFin = tcpFlags . bit 0 +{-# INLINE tcpNs #-} +{-# INLINE tcpCwr #-} +{-# INLINE tcpEce #-} +{-# INLINE tcpUrg #-} +{-# INLINE tcpAck #-} +{-# INLINE tcpPsh #-} +{-# INLINE tcpRst #-} +{-# INLINE tcpSyn #-} +{-# INLINE tcpFin #-} + + +-- | The length of the fixed part of the TcpHeader, in 4-byte octets. +tcpFixedHeaderSize :: Int +tcpFixedHeaderSize = 5 + +-- | The encoded size of a header. +tcpHeaderSize :: TcpHeader -> Int +tcpHeaderSize TcpHeader { .. } = + let (size,padding) = tcpOptionsSize tcpOptions_ + in size + padding + tcpFixedHeaderSize + +-- | Render a TcpHeader. The checksum value is never rendered, as it is +-- expected to be calculated and poked in afterwords. +putTcpHeader :: Putter TcpHeader +putTcpHeader TcpHeader { .. } = + do putTcpPort tcpSourcePort + putTcpPort tcpDestPort + putTcpSeqNum tcpSeqNum + putTcpAckNum tcpAckNum + let (optLen,padding) = tcpOptionsSize tcpOptions_ + putTcpControl (tcpFixedHeaderSize + optLen) tcpFlags_ + putWord16be tcpWindow + putWord16be 0 + putWord16be tcpUrgentPointer + mapM_ putTcpOption tcpOptions_ + replicateM_ padding (putTcpOptionTag OptTagEndOfOptions) + +-- | Parse a TcpHeader. +getTcpHeader :: Get TcpHeader +getTcpHeader = label "TcpHeader" $ + do tcpSourcePort <- getTcpPort + tcpDestPort <- getTcpPort + tcpSeqNum <- getTcpSeqNum + tcpAckNum <- getTcpAckNum + + -- data offset and flags + tcpFlags_ <- getWord16be + let dataOff = fromIntegral ((tcpFlags_ `shiftR` 12) .&. 0xf) + + tcpWindow <- getWord16be + tcpChecksum <- getWord16be + tcpUrgentPointer <- getWord16be + + -- options, not including the end-of-list option + let optsLen = dataOff - tcpFixedHeaderSize + opts <- label "options" (isolate (optsLen `shiftL` 2) getTcpOptions) + let tcpOptions_ = filter (/= OptEndOfOptions) opts + + return $! TcpHeader { .. } + +-- | Render out the @Word8@ that contains the Control field of the TcpHeader. +putTcpControl :: Int -> Word16 -> Put +putTcpControl hdrLenWords flags = + putWord16be (fromIntegral (hdrLenWords) `shiftL` 12 .|. (flags .&. 0x1ff)) + + +-- Tcp Options ----------------------------------------------------------------- + +class HasTcpOptions a where + tcpOptions :: Lens' a [TcpOption] + +instance HasTcpOptions TcpHeader where + tcpOptions f TcpHeader { .. } = + fmap (\opts -> TcpHeader { tcpOptions_ = opts, .. }) (f tcpOptions_) + +instance HasTcpOptions [TcpOption] where + tcpOptions = id + +findTcpOption :: HasTcpOptions opts => TcpOptionTag -> opts -> Maybe TcpOption +findTcpOption tag opts = find p (view tcpOptions opts) + where + p opt = tag == tcpOptionTag opt + +setTcpOption :: HasTcpOptions opts => TcpOption -> opts -> opts +setTcpOption opt = over tcpOptions loop + where + tag = tcpOptionTag opt + + loop [] = [opt] + loop (o:opts) + | tcpOptionTag o == tag = opt : opts + | otherwise = o : loop opts + +setTcpOptions :: HasTcpOptions opts => [TcpOption] -> opts -> opts +setTcpOptions opts a = foldr setTcpOption a opts + +data TcpOptionTag = OptTagEndOfOptions + | OptTagNoOption + | OptTagMaxSegmentSize + | OptTagWindowScaling + | OptTagSackPermitted + | OptTagSack + | OptTagTimestamp + | OptTagUnknown !Word8 + deriving (Eq,Show) + +getTcpOptionTag :: Get TcpOptionTag +getTcpOptionTag = + do ty <- getWord8 + return $! case ty of + 0 -> OptTagEndOfOptions + 1 -> OptTagNoOption + 2 -> OptTagMaxSegmentSize + 3 -> OptTagWindowScaling + 4 -> OptTagSackPermitted + 5 -> OptTagSack + 8 -> OptTagTimestamp + _ -> OptTagUnknown ty + +putTcpOptionTag :: Putter TcpOptionTag +putTcpOptionTag tag = + putWord8 $! case tag of + OptTagEndOfOptions -> 0 + OptTagNoOption -> 1 + OptTagMaxSegmentSize -> 2 + OptTagWindowScaling -> 3 + OptTagSackPermitted -> 4 + OptTagSack -> 5 + OptTagTimestamp -> 8 + OptTagUnknown ty -> ty + + + +data TcpOption = OptEndOfOptions + | OptNoOption + | OptMaxSegmentSize !Word16 + | OptWindowScaling !Word8 + | OptSackPermitted + | OptSack [SackBlock] + | OptTimestamp !Word32 !Word32 + | OptUnknown !Word8 !Word8 !S.ByteString + deriving (Show,Eq) + +data SackBlock = SackBlock { sbLeft :: !TcpSeqNum + , sbRight :: !TcpSeqNum + } deriving (Show,Eq) + +tcpOptionTag :: TcpOption -> TcpOptionTag +tcpOptionTag OptEndOfOptions{} = OptTagEndOfOptions +tcpOptionTag OptNoOption{} = OptTagNoOption +tcpOptionTag OptMaxSegmentSize{} = OptTagMaxSegmentSize +tcpOptionTag OptSackPermitted{} = OptTagSackPermitted +tcpOptionTag OptSack{} = OptTagSack +tcpOptionTag OptWindowScaling{} = OptTagWindowScaling +tcpOptionTag OptTimestamp{} = OptTagTimestamp +tcpOptionTag (OptUnknown ty _ _) = OptTagUnknown ty + +-- | 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. +tcpOptionsSize :: [TcpOption] -> (Int,Int) +tcpOptionsSize opts + | left == 0 = (len,0) + | otherwise = (len + 1,4 - left) + where + (len,left) = F.foldl' (\acc o -> acc + tcpOptionSize o) 0 opts `quotRem` 4 + + +tcpOptionSize :: TcpOption -> Int +tcpOptionSize OptEndOfOptions{} = 1 +tcpOptionSize OptNoOption{} = 1 +tcpOptionSize OptMaxSegmentSize{} = 4 +tcpOptionSize OptWindowScaling{} = 3 +tcpOptionSize OptSackPermitted{} = 2 +tcpOptionSize (OptSack bs) = sackLength bs +tcpOptionSize OptTimestamp{} = 10 +tcpOptionSize (OptUnknown _ len _) = fromIntegral len + + +putTcpOption :: Putter TcpOption +putTcpOption opt = + do putTcpOptionTag (tcpOptionTag opt) + case opt of + 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 _ len bs -> putUnknown len bs + +-- | Parse in known tcp options. +getTcpOptions :: Get [TcpOption] +getTcpOptions = label "Tcp Options" loop + where + loop = + do left <- remaining + if left > 0 + then body + else return [] + + body = + do opt <- getTcpOption + case opt of + + OptEndOfOptions -> + do skip =<< remaining + return [] + + _ -> + do rest <- loop + return (opt:rest) + +getTcpOption :: Get TcpOption +getTcpOption = + do tag <- getTcpOptionTag + case tag of + OptTagEndOfOptions -> return OptEndOfOptions + OptTagNoOption -> return OptNoOption + OptTagMaxSegmentSize -> getMaxSegmentSize + OptTagWindowScaling -> getWindowScaling + OptTagSackPermitted -> getSackPermitted + OptTagSack -> getSack + OptTagTimestamp -> getTimestamp + OptTagUnknown ty -> getUnknown ty + +getMaxSegmentSize :: Get TcpOption +getMaxSegmentSize = label "Max Segment Size" $ isolate 3 $ + do len <- getWord8 + unless (len == 4) (fail ("Unexpected length: " ++ show len)) + OptMaxSegmentSize `fmap` getWord16be + +putMaxSegmentSize :: Putter Word16 +putMaxSegmentSize w16 = + do 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 = putWord8 2 + +getSack :: Get TcpOption +getSack = label "Sack" $ + do len <- getWord8 + let edgeLen = fromIntegral len - 2 + bs <- isolate edgeLen (replicateM (edgeLen `shiftR` 3) getSackBlock) + return $! OptSack bs + +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 + unless (len == 3) (fail ("Unexpected length: " ++ show len)) + OptWindowScaling `fmap` getWord8 + +putWindowScaling :: Putter Word8 +putWindowScaling w = + do putWord8 3 + putWord8 w + +getTimestamp :: Get TcpOption +getTimestamp = label "Timestamp" $ isolate 9 $ + do len <- getWord8 + unless (len == 10) (fail ("Unexpected length: " ++ show len)) + a <- getWord32be + b <- getWord32be + return $! OptTimestamp a b + +putTimestamp :: Word32 -> Word32 -> Put +putTimestamp v r = + do putWord8 10 + putWord32be v + putWord32be r + +getUnknown :: Word8 -> Get TcpOption +getUnknown ty = + do len <- getWord8 + body <- isolate (fromIntegral len - 2) (getBytes =<< remaining) + return (OptUnknown ty len body) + +putUnknown :: Word8 -> S.ByteString -> Put +putUnknown len body = + do putWord8 len + putByteString body + + +-- Tcp Packet ------------------------------------------------------------------ + +-- | The length of the data segment, including Syn and Fin. +tcpSegLen :: TcpHeader -> Int -> Int +tcpSegLen hdr len = len + flagVal tcpSyn + flagVal tcpFin + where + flagVal l | view l hdr = 1 + | otherwise = 0 + +-- | The last sequence number used in a segment. +tcpSegLastSeqNum :: TcpHeader -> Int -> TcpSeqNum +tcpSegLastSeqNum hdr len = tcpSeqNum hdr + fromIntegral (tcpSegLen hdr len) - 1 + +-- | The ack number for this segment. +tcpSegNextAckNum :: TcpHeader -> Int -> TcpAckNum +tcpSegNextAckNum hdr len = tcpSeqNum hdr + fromIntegral (tcpSegLen hdr len) diff --git a/src/Hans/Tcp/RecvWindow.hs b/src/Hans/Tcp/RecvWindow.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/RecvWindow.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE MultiWayIf #-} + +module Hans.Tcp.RecvWindow ( + -- * Receive Window + Window(), + emptyWindow, + recvSegment, + rcvWnd, + rcvNxt, setRcvNxt, + rcvRight, + moveRcvRight, + + + -- ** Sequence Numbers + sequenceNumberValid, + ) where + +import Hans.Lens +import Hans.Tcp.Packet + +import qualified Data.ByteString as S +import Data.Word (Word16) + + +-- Segments -------------------------------------------------------------------- + +data Segment = Segment { segStart :: !TcpSeqNum + -- ^ The first byte occupied by this segment + + , segEnd :: !TcpSeqNum + -- ^ The last byte occupied by this segment + + , segHdr :: !TcpHeader + , segBody :: !S.ByteString + } deriving (Show) + +mkSegment :: TcpHeader -> S.ByteString -> Segment +mkSegment segHdr segBody = + Segment { segStart = tcpSeqNum segHdr + , segEnd = tcpSegLastSeqNum segHdr (S.length segBody) + , .. } + +-- | The next segment number, directly after this one. +segNext :: Segment -> TcpSeqNum +segNext Segment { .. } = segEnd + 1 + +-- | Drop data off of the front of this segment. +trimSeg :: Int -> Segment -> Maybe Segment +trimSeg len seg@Segment { .. } + | len' <= 0 = + Just seg + + | len' >= S.length segBody = + Nothing + + | otherwise = + Just $! Segment { segStart = segStart + fromIntegral len' + , segHdr = segHdr { tcpSeqNum = tcpSeqNum segHdr + + fromIntegral len } + , segBody = S.drop len segBody + , .. } + + where + + flag l | view l segHdr = 1 + | otherwise = 0 + + -- adjust the length to account for syn/fin + len' = len - flag tcpSyn - flag tcpFin + +-- | Resolve overlap between two segments. It's assumed that the two segments do +-- actually overlap. Overlap is resolved by trimming the front of the later +-- packet. +resolveOverlap :: Segment -> Segment -> [Segment] +resolveOverlap a b = + case trimSeg (fromTcpSeqNum (segEnd x - segStart y)) y of + Just y' -> [x,y'] + Nothing -> error "resolveOverlap: invariant violated" + where + (x,y) | segStart a < segStart b = (a,b) -- a overlaps b + | otherwise = (b,a) -- b overlaps a + + +-- Receive Window -------------------------------------------------------------- + +-- | The receive window. +-- +-- INVARIANTS: +-- +-- 1. All segments in rwSegments are within the window defined by rwRcvNxt and +-- rwRcvWnd +-- 2. The segments in rwSegments should not overlap +-- +data Window = Window { wSegments :: ![Segment] + -- ^ Out of order segments. + + , wRcvNxt :: !TcpSeqNum + -- ^ Left-edge of the receive window + + , wRcvRight :: !TcpSeqNum + -- ^ Right-edge of the receive window + + , wMax :: !TcpSeqNum + -- ^ Maximum size of the receive window + } deriving (Show) + +emptyWindow :: TcpSeqNum -> Int -> Window +emptyWindow wRcvNxt maxWin = + Window { wSegments = [] + , wRcvRight = wRcvNxt + wMax + , .. } + where + wMax = fromIntegral maxWin + +-- | The value of RCV.WND. +rcvWnd :: Lens' Window Word16 +rcvWnd f Window { .. } = + fmap (\ wnd -> Window { wRcvRight = wRcvNxt + fromIntegral wnd, .. }) + (f (fromTcpSeqNum (wRcvRight - wRcvNxt))) + +-- | The left edge of the receive window. +rcvNxt :: Getting r Window TcpSeqNum +rcvNxt = to wRcvNxt + +-- | The right edge of the receive window, RCV.NXT + RCV.WND. +rcvRight :: Getting r Window TcpSeqNum +rcvRight = to wRcvRight + +-- | Only sets RCV.NXT when the segment queue is empty. Returns 'True' when the +-- value has been successfully changed. +setRcvNxt :: TcpSeqNum -> Window -> (Window,Bool) +setRcvNxt nxt win + | null (wSegments win) = (win { wRcvNxt = nxt, wRcvRight = nxt + wMax win }, True) + | otherwise = (win, False) + + +-- | Check an incoming segment, and queue it in the receive window. When the +-- segment received was valid 'Just' is returned, including segments in the +-- receive window were unblocked by it. +-- +-- NOTE: when Just[] is returned, this should be a signal to issue a duplicate +-- ACK, as we've receive something out of sequence (fast retransmit). +recvSegment :: TcpHeader -> S.ByteString -> Window + -> (Window, Maybe [(TcpHeader,S.ByteString)]) +recvSegment hdr body win + + -- add the trimmed frame to the receive queue + | Just seg <- sequenceNumberValid (wRcvNxt win) (wRcvRight win) hdr body = + let (win', segs) = addSegment seg win + in (win', Just [ (segHdr,segBody) | Segment { .. } <- segs ]) + + -- drop the invalid frame + | otherwise = + (win, Nothing) + + +-- | Increase the right edge of the window by n, clamping at the maximum window +-- size. +moveRcvRight :: Int -> Window -> (Window, ()) +moveRcvRight n = \ win -> + let rcvRight' = view rcvRight win + min (max 0 (fromIntegral n)) (wMax win) + in (win { wRcvRight = rcvRight' }, ()) +{-# INLINE moveRcvRight #-} + + +-- | Add a validated segment to the receive window, and return +addSegment :: Segment -> Window -> (Window, [Segment]) +addSegment seg win + + -- The new segment falls right at the beginning of the receive window. Move + -- RCV.NXT and put the segment into the receive buffer. Don't modify + -- RCV.WND until the segment has been removed from the receive buffer. + | segStart seg == wRcvNxt win = + advanceLeft seg win + + -- As addSegment should only be called with the results of + -- sequenceNumberValid, the only remaining case to consider is that the + -- segment falls somewhere else within the window. + | otherwise = + (insertOutOfOrder seg win, []) + + +-- | Use this segment to advance the window, which may unblock zero or more out +-- of order segments. The list returned is always non-empty, as it includes the +-- segment that's given. +advanceLeft :: Segment -> Window -> (Window, [Segment]) +advanceLeft seg win + + -- there were no other segments that might be unblocked by this one + | null (wSegments win) = + ( win { wRcvNxt = segNext seg }, [seg]) + + -- see if this segment unblocks any others + | otherwise = + let win' = insertOutOfOrder seg win -- to resolve overlap + (nxt,valid,rest) = splitContiguous (wSegments win') + in (win' { wSegments = rest, wRcvNxt = nxt }, valid) + + +-- | Insert a new segment into the receive window. NOTE: we don't need to worry +-- about trimming the segment to fit the window, as that's already been done by +-- sequenceNumberValid. +insertOutOfOrder :: Segment -> Window -> Window +insertOutOfOrder seg Window { .. } = Window { wSegments = segs', .. } + where + segs' = loop seg wSegments + + loop new segs@(x:xs) + + -- new segment ends before x starts + | segEnd new < segStart x = new : segs + + -- new segment starts after x + | segStart new > segEnd x = + x : loop new segs + + -- segments overlap + | otherwise = resolveOverlap new x ++ xs + + loop new [] = [new] + + +-- | Split out contiguous segments, and out of order segments. NOTE: this +-- assumes that the segment list given does not contain any overlapping +-- segments, and is ordered. +-- +-- NOTE: this should never be called with an empty list. +splitContiguous :: [Segment] -> (TcpSeqNum,[Segment],[Segment]) + +splitContiguous (seg:segs) = loop [seg] (segNext seg) segs + where + loop acc from (x:xs) | segStart x == from = loop (x:acc) (segNext seg) xs + loop acc from xs = (from, reverse acc, xs) + +splitContiguous [] = error "splitContiguous: empty list" + + +-- Window Checks --------------------------------------------------------------- + +-- | This is the check described on page 68 of RFC793, which checks that data +-- falls within the expected receive window. When the check is successful, the +-- segment returned is one that has been trimmed to fit in the window (if +-- necessary). +-- +-- When this produces a segment, the segment has these properties: +-- +-- 1. The sequence number is within the window +-- 2. The segment body falls within the window +-- 3. The segment has been copied from the original bytestring +-- +-- The reason for point 3 is that when frames are allocated by devices, they are +-- likely allocated to the full MTU, and not resized. Copying here frees up some +-- memory. +sequenceNumberValid :: TcpSeqNum -- ^ RCV.NXT + -> TcpSeqNum -- ^ RCV.NXT + RCV.WND + -> TcpHeader + -> S.ByteString + -> Maybe Segment + +sequenceNumberValid nxt wnd hdr@TcpHeader { .. } payload + + | payloadLen == 0 = + if nullWindow + -- test 1 + then if tcpSeqNum == nxt then Just (mkSegment hdr S.empty) else Nothing + + -- test 2 + else if seqNumInWindow then Just (mkSegment hdr S.empty) else Nothing + + | otherwise = + if nullWindow + -- test 3 + then Nothing + + -- test 4 + else if | seqNumInWindow -> Just (mkSegment hdr seg') + | dataEndInWindow -> Just (mkSegment hdr' seg') + | otherwise -> Nothing + + where + + nullWindow = nxt == wnd + payloadLen = tcpSegLen hdr (fromIntegral (S.length payload)) + segEnd = tcpSeqNum + fromIntegral (payloadLen - 1) + + -- adjusted header for when the payload spans RCV.NXT + hdr' = hdr { tcpSeqNum = nxt } + + -- XXX: this doesn't account for syn/fin at the moment + -- trim the payload to fit in the window + seg' = S.copy $ S.drop (fromTcpSeqNum (nxt - tcpSeqNum)) + $ S.take (fromTcpSeqNum (segEnd - wnd)) payload + + seqNumInWindow = nxt <= tcpSeqNum && tcpSeqNum < wnd + dataEndInWindow = nxt <= segEnd && segEnd < wnd diff --git a/src/Hans/Tcp/SendWindow.hs b/src/Hans/Tcp/SendWindow.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/SendWindow.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} + +module Hans.Tcp.SendWindow ( + -- * Remote Window + Window(), + emptyWindow, + sndNxt, setSndNxt, + sndUna, + sndWnd, + nullWindow, + fullWindow, + flushWindow, + + -- ** Timestamp Clock + TSClock(), + initialTSClock, + updateTSClock, + tsVal, + + -- ** Packet Processing + queueSegment, + retransmitTimeout, + ackSegment, + + -- ** Selective Ack + handleSack, + ) where + +import Hans.Config +import Hans.Lens +import Hans.Tcp.Packet + +import Control.Monad (guard) +import qualified Data.ByteString.Lazy as L +import Data.List (sortBy) +import Data.Maybe (isJust) +import Data.Ord (comparing) +import Data.Time.Clock (UTCTime,NominalDiffTime,diffUTCTime) +import Data.Word (Word32) + + +-- Segments -------------------------------------------------------------------- + +data Segment = Segment { segHeader :: !TcpHeader + , segRightEdge :: !TcpSeqNum -- ^ Cached right edge + , segBody :: !L.ByteString + , segSentAt :: !(Maybe UTCTime) + , segSACK :: !Bool + } + +segHeaderL :: Lens' Segment TcpHeader +segHeaderL f Segment { .. } = + fmap (\h -> Segment { segHeader = h, .. }) (f segHeader) + +instance HasTcpOptions Segment where + tcpOptions = segHeaderL . tcpOptions + +mkSegment :: TcpHeader -> L.ByteString -> UTCTime -> Segment +mkSegment segHeader segBody now = + Segment { segRightEdge = tcpSegNextAckNum segHeader (fromIntegral (L.length segBody)) + , segSACK = False + , segSentAt = Just now + , .. } + +-- | The sequence number of the frame. +-- +-- INVARIANT: the sequence number must always be greater than or equal to the +-- current sequence number, and less than the value of the right edge of the +-- segment. +leftEdge :: Lens' Segment TcpSeqNum +leftEdge f seg@Segment { segHeader = hdr@TcpHeader { .. }, .. } = + fmap update (f tcpSeqNum) + where + + update sn + -- only update if the sequence number can actually trim the packet + | sn <= tcpSeqNum = seg + | otherwise = + -- account syn counting for one + let len = fromTcpSeqNum (sn - tcpSeqNum) + (hdr',len') | view tcpSyn hdr = (set tcpSyn False hdr,len - 1) + | otherwise = (hdr,len) + + -- NOTE: the header gets the unmodified sequence number, but the data gets + -- the adjusted version, as the adjusted + in Segment { segHeader = hdr' { tcpSeqNum = sn } -- NOTE: use old sn here + , segBody = L.drop len' segBody + , .. } +{-# INLINE leftEdge #-} + + +-- | The sequence number of the first byte AFTER this segment. +-- +-- INVARIANT: the sequence number must always be less than or equal to the +-- current right edge sequence number, and greater than or equal to the left +-- edge. +rightEdge :: Getting r Segment TcpSeqNum +rightEdge = to segRightEdge +{-# INLINE rightEdge #-} + + +-- | The SACK flag for this segment. This flag is turned TRUE when the segment +-- has been wholly acknowledged through the SACK option on an incoming ACK. +sack :: Lens' Segment Bool +sack f seg@Segment { .. } = + fmap update (f segSACK) + where + update b | b == segSACK = seg + | otherwise = Segment { segSACK = b, .. } + + +-- Timestamp Clock ------------------------------------------------------------- + +data TSClock = TSClock { tscVal :: !Word32, tscLastUpdate :: !UTCTime } + +-- | Create a 'TSClock'. +initialTSClock :: Word32 -> UTCTime -> TSClock +initialTSClock tscVal tscLastUpdate = TSClock { .. } + +-- | Update the timestamp clock, and return the new value of TSval. +updateTSClock :: Config -> UTCTime -> TSClock -> TSClock +updateTSClock Config { .. } now TSClock { .. } = + let diff = truncate (diffUTCTime now tscLastUpdate * cfgTcpTSClockFrequency) + in TSClock { tscVal = tscVal + diff, tscLastUpdate = now } + +-- | The current value of the TS clock. +tsVal :: Getting r TSClock Word32 +tsVal = to tscVal + +-- | Given an echo'd timestamp, generate an RTT measurement. +measureRTT :: Config -> Word32 -> TSClock -> NominalDiffTime +measureRTT Config { .. } ecr clk = + fromIntegral (view tsVal clk - ecr) / cfgTcpTSClockFrequency + + +-- Send Window ----------------------------------------------------------------- + +type Segments = [Segment] + +-- | This structure holds bookkeeping variables for the remote end's receive +-- window, as well as the retransmit queue. +data Window = Window { wRetransmitQueue :: !Segments + -- ^ The retransmit queue contains segments that fall + -- between SND.UNA and SND.NXT + + , wSndAvail :: !Int + -- ^ The effective window + + , wSndNxt :: !TcpSeqNum + , wSndWnd :: !TcpSeqNum + + , wTSClock :: !TSClock + } + + +emptyWindow :: TcpSeqNum -- ^ SND.NXT + -> TcpSeqNum -- ^ SND.WND + -> TSClock + -> Window +emptyWindow wSndNxt wSndWnd wTSClock = + Window { wRetransmitQueue = [] + , wSndAvail = fromTcpSeqNum wSndWnd + , .. } + + +-- | Remove everything from the remote window. +flushWindow :: Window -> (Window, ()) +flushWindow Window { .. } = (Window { wRetransmitQueue = [], .. }, ()) + + +-- | True when the window is empty. +nullWindow :: Window -> Bool +nullWindow Window { .. } = null wRetransmitQueue + +-- | True when the window is full. +fullWindow :: Window -> Bool +fullWindow Window { .. } = wSndAvail == 0 + +-- | The value of SND.NXT. +-- +-- NOTE: SND.UNA <= SND.NXT < SND.UNA + SND.WND +sndNxt :: Getting r Window TcpSeqNum +sndNxt = to wSndNxt + + +-- | Only sets the value of SND.NXT when the retransmit queue is empty. +setSndNxt :: TcpSeqNum -> Window -> (Window, Bool) +setSndNxt nxt win + | null (wRetransmitQueue win) = (win { wSndNxt = nxt }, True) + | otherwise = (win, False) + + +-- | The value of SND.WND. +sndWnd :: Lens' Window TcpSeqNum +sndWnd f Window { .. } = + fmap (\ wnd -> Window { wSndWnd = wnd + , wSndAvail = wSndAvail + fromTcpSeqNum (wnd - wSndWnd) + , .. }) + (f wSndWnd) + + +-- | The value of SND.UNA -- the left-edge of the send window. +sndUna :: Getting r Window TcpSeqNum +sndUna = to $ \ Window { .. } -> + case wRetransmitQueue of + seg : _ -> view leftEdge seg + [] -> wSndNxt + + +-- | Returns the new send window, as well as boolean indicating whether or not +-- the retransmit timer needs to be started. +queueSegment :: Config -> UTCTime -> (Word32 -> TcpSeqNum -> TcpHeader) -> L.ByteString + -> Window -> (Window,Maybe (Bool,TcpHeader,L.ByteString)) +queueSegment cfg now mkHdr body win + | size == 0 = (win, Just (False,hdr,L.empty)) + | wSndAvail win == 0 = (win,Nothing) + | otherwise = (win',Just (startRTO,hdr,trimmedBody)) + where + + clock' = updateTSClock cfg now (wTSClock win) + hdr = mkHdr (view tsVal clock') (wSndNxt win) + + trimmedBody = L.take (fromIntegral (wSndAvail win)) body + seg = mkSegment hdr trimmedBody now + + size = tcpSegLen hdr (fromIntegral (L.length trimmedBody)) + + win' = win { wRetransmitQueue = wRetransmitQueue win ++ [seg] + , wSndAvail = wSndAvail win - size + , wSndNxt = wSndNxt win + fromIntegral size + , wTSClock = clock' + } + + -- start the retransmit timer when the queue was empty + startRTO = null (wRetransmitQueue win) + + +-- | A retransmit timer has gone off: reset the sack bit on all segments in the +-- queue; if the left-edge exists, mark it as having been retransmitted, and +-- return it back to be sent. +-- +-- XXX: does this need to update the TS clock? +retransmitTimeout :: Window -> (Window,Maybe (TcpHeader,L.ByteString)) +retransmitTimeout win = (win { wRetransmitQueue = queue' }, mbSeg) + where + + (mbSeg,queue') = + case wRetransmitQueue win of + Segment { .. } : rest -> + ( Just (segHeader,segBody) + , map (set sack False) (Segment { segSentAt = Nothing, .. } : rest ) ) + + [] -> (Nothing,[]) + + +-- | Remove all segments of the send window that occur before this sequence +-- number, and increase the size of the available window. When the segment +-- doesn't acknowledge anything in the window, 'Nothing' as the second +-- parameter. Otherwise, return a boolean that is 'True' when there are no +-- outstanding segments, and a measurement of the RTT when the segment has not +-- been retransmitted. +ackSegment :: Config -> UTCTime -> TcpSeqNum -> Window + -> (Window, Maybe (Bool,Maybe NominalDiffTime)) +ackSegment cfg now ack win + | view sndUna win <= ack && ack <= view sndNxt win = + ( win', Just (null (wRetransmitQueue win'), mbMeasurement) ) + + | otherwise = + ( win, Nothing ) + where + win' = win { wRetransmitQueue = queue' + , wSndAvail = wSndAvail win + fromTcpSeqNum (ack - view sndUna win) + , wTSClock = updateTSClock cfg now (wTSClock win) + } + + -- zip down the send queue, partitioning it into (reversed) acknowledged + -- packets, and outstanding packets. + go acks segs@(seg : rest) + | view rightEdge seg <= ack = go (seg:acks) rest + | view leftEdge seg <= ack = (seg:acks, set leftEdge ack seg : rest) + | otherwise = (acks,segs) + + go acks [] = (acks,[]) + + -- partition packets that have been acknowledged + (ackd,queue') = go [] (wRetransmitQueue win) + + -- generate a measurement. If the timestamp option is available, that will be + -- used to generate the measurement, otherwise the sending time for the + -- segment will be diffed if it's valid. + mbMeasurement = + case ackd of + seg : _ + + | Just (OptTimestamp val _) <- findTcpOption OptTagTimestamp seg -> + return (measureRTT cfg val (wTSClock win')) + + | otherwise -> + do let samples = filter (isJust . segSentAt) ackd + guard (not (null samples)) + let Segment { .. } = last samples + sent <- segSentAt + return $! diffUTCTime sent now + + [] -> Nothing + + +-- Selective ACK --------------------------------------------------------------- + +-- | Process a sack option, and return the updated window, and the segments that +-- are missing from the remote window. +handleSack :: [SackBlock] -> Window -> (Window,[(TcpHeader,L.ByteString)]) +handleSack blocks win = + let win' = processSackBlocks blocks win + in (win', sackRetransmit win') + +-- | All segments that have not been selectively acknowledged. This can be used +-- when replying to a duplicate ack that contains a SACK option, after the +-- option has been processed. NOTE: this still doesn't remove the packets from +-- the queue, it just means that we know what parts to retransmit. +sackRetransmit :: Window -> [(TcpHeader,L.ByteString)] +sackRetransmit Window { .. } = + [ (segHeader,segBody) | Segment { .. } <- wRetransmitQueue, not segSACK ] + + +-- | Mark segments that have been acknowledged through the SACK option. +processSackBlocks :: [SackBlock] -> Window -> Window +processSackBlocks blocks Window { .. } = + Window { wRetransmitQueue = go wRetransmitQueue (sortBy (comparing sbLeft) blocks) + , .. } + where + + go queue@(seg:segs) bs@(SackBlock { .. } :rest) + + -- segment falls within the block + | segWithin seg sbLeft sbRight = set sack True seg : go segs bs + + -- segment begins after the block + | view leftEdge seg >= sbRight = go queue rest + + -- segment ends before the block + | otherwise = seg : go segs bs + + go segs _ = segs + + +-- | True when the segment falls wholly within the range given. +segWithin :: Segment -> TcpSeqNum -> TcpSeqNum -> Bool +segWithin seg l r = view leftEdge seg >= l && view rightEdge seg < r + -- Remember that since SACK blocks define the right edge as being the first + -- sequence number of the /next/ block, we use strict less-than for the + -- comparison of the right edge. diff --git a/src/Hans/Tcp/State.hs b/src/Hans/Tcp/State.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/State.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} + +module Hans.Tcp.State ( + -- * Tcp State + HasTcpState(..), TcpState(), + newTcpState, + + -- ** Responder Interaction + tcpQueue, + TcpResponderRequest(..), + + -- ** Listen Sockets + incrSynBacklog, + decrSynBacklog, + registerListening, + lookupListening, + deleteListening, + + -- ** Active Sockets + Key(), tcbKey, + tcpActive, + lookupActive, + registerActive, + closeActive, + deleteActive, + + -- ** TimeWait Sockets + registerTimeWait, + lookupTimeWait, + resetTimeWait, + deleteTimeWait, + + -- ** Port Management + nextTcpPort, + + -- ** Sequence Numbers + nextIss, + ) where + +import Hans.Addr (Addr,wildcardAddr,putAddr) +import Hans.Config (HasConfig(..),Config(..)) +import qualified Hans.HashTable as HT +import Hans.Lens +import Hans.Network.Types (RouteInfo(..)) +import Hans.Tcp.Packet +import Hans.Tcp.Tcb +import Hans.Threads (forkNamed) +import Hans.Time + +import Control.Concurrent (threadDelay,MVar,newMVar,modifyMVar) +import qualified Control.Concurrent.BoundedChan as BC +import Control.Monad (guard) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Digest.Pure.SHA(sha1,integerDigest) +import qualified Data.Foldable as F +import Data.Hashable (Hashable) +import qualified Data.Heap as H +import Data.IORef (IORef,newIORef,atomicModifyIORef',readIORef) +import Data.Serialize (runPutLazy,putByteString) +import Data.Time.Clock (UTCTime,getCurrentTime,addUTCTime,diffUTCTime) +import Data.Word (Word32) +import GHC.Generics (Generic) +import System.Random (newStdGen,random,randoms) + + +-- General State --------------------------------------------------------------- + +data ListenKey = ListenKey !Addr !TcpPort + deriving (Show,Eq,Ord,Generic) + +listenKey :: Getting r ListenTcb ListenKey +listenKey = to (\ ListenTcb { .. } -> ListenKey lSrc lPort) +{-# INLINE listenKey #-} + + +data Key = Key !Addr -- Remote address + !TcpPort -- Remote port + !Addr -- Local address + !TcpPort -- Local port + deriving (Show,Eq,Ord,Generic) + +tcbKey :: Getting r Tcb Key +tcbKey = to $ \Tcb { tcbRouteInfo = RouteInfo { .. }, .. } -> + Key tcbRemote tcbRemotePort riSource tcbLocalPort +{-# INLINE tcbKey #-} + + + +instance Hashable ListenKey +instance Hashable Key + +type TimeWaitHeap = ExpireHeap TimeWaitTcb + +data TcpState = + TcpState { tcpListen_ :: {-# UNPACK #-} !(HT.HashTable ListenKey ListenTcb) + , tcpActive_ :: {-# UNPACK #-} !(HT.HashTable Key Tcb) + , tcpTimeWait_ :: {-# UNPACK #-} !(IORef TimeWaitHeap) + , tcpSynBacklog_ :: {-# UNPACK #-} !(IORef Int) + -- ^ Decrements when a connection enters SynReceived or SynSent, + -- and increments back up once it's closed, or enters Established. + + , tcpPorts :: {-# UNPACK #-} !(MVar TcpPort) + , tcpISSTimer :: {-# UNPACK #-} !(IORef Tcp4USTimer) + + , tcpQueue_ :: {-# UNPACK #-} !(BC.BoundedChan TcpResponderRequest) + } + +-- | Requests that can be made to the responder thread. +data TcpResponderRequest = SendSegment !(RouteInfo Addr) !Addr !TcpHeader !L.ByteString + | SendWithTcb !Tcb !TcpHeader !L.ByteString + +tcpQueue :: HasTcpState state => Getting r state (BC.BoundedChan TcpResponderRequest) +tcpQueue = tcpState . to tcpQueue_ +{-# INLINE tcpQueue #-} + +tcpListen :: HasTcpState state => Getting r state (HT.HashTable ListenKey ListenTcb) +tcpListen = tcpState . to tcpListen_ +{-# INLINE tcpListen #-} + +tcpActive :: HasTcpState state => Getting r state (HT.HashTable Key Tcb) +tcpActive = tcpState . to tcpActive_ +{-# INLINE tcpActive #-} + +tcpTimeWait :: HasTcpState state => Getting r state (IORef TimeWaitHeap) +tcpTimeWait = tcpState . to tcpTimeWait_ +{-# INLINE tcpTimeWait #-} + +tcpSynBacklog :: HasTcpState state => Getting r state (IORef Int) +tcpSynBacklog = tcpState . to tcpSynBacklog_ +{-# INLINE tcpSynBacklog #-} + + +class HasTcpState state where + tcpState :: Getting r state TcpState + +instance HasTcpState TcpState where + tcpState = id + {-# INLINE tcpState #-} + + + +data Tcp4USTimer = Tcp4USTimer { tcpTimer :: {-# UNPACK #-} !Word32 + , tcpSecret :: {-# UNPACK #-} !S.ByteString + , tcpLastUpdate :: !UTCTime + } + +newTcp4USTimer :: IO Tcp4USTimer +newTcp4USTimer = + do tcpLastUpdate <- getCurrentTime + gen <- newStdGen + let (tcpTimer,gen') = random gen + tcpSecret = S.pack (take 256 (randoms gen')) + return Tcp4USTimer { .. } + + + +newTcpState :: Config -> IO TcpState +newTcpState Config { .. } = + do tcpListen_ <- HT.newHashTable cfgTcpListenTableSize + tcpActive_ <- HT.newHashTable cfgTcpActiveTableSize + tcpTimeWait_ <- newIORef emptyHeap + tcpSynBacklog_ <- newIORef cfgTcpMaxSynBacklog + tcpPorts <- newMVar 32767 + tcpISSTimer <- newIORef =<< newTcp4USTimer + tcpQueue_ <- BC.newBoundedChan 128 + return TcpState { .. } + + +-- | Returns 'True' when there is space in the Syn backlog, and False if the +-- connection should be rejected. +decrSynBacklog :: HasTcpState state => state -> IO Bool +decrSynBacklog state = + atomicModifyIORef' (view tcpSynBacklog state) $ \ backlog -> + if backlog > 0 + then (backlog - 1, True) + else (backlog, False) + +-- | Yield back an entry in the Syn backlog. +incrSynBacklog :: HasTcpState state => state -> IO () +incrSynBacklog state = + atomicModifyIORef' (view tcpSynBacklog state) + (\ backlog -> (backlog + 1, ())) + + +-- Listening Sockets ----------------------------------------------------------- + +-- | Register a new listening socket. +registerListening :: HasTcpState state + => state -> ListenTcb -> IO Bool +registerListening state tcb = + HT.alter update (view listenKey tcb) (view tcpListen state) + where + update Nothing = (Just tcb, True) + update mb@Just{} = (mb, False) +{-# INLINE registerListening #-} + + +-- | Remove a listening socket. +deleteListening :: HasTcpState state + => state -> ListenTcb -> IO () +deleteListening state tcb = + HT.delete (view listenKey tcb) (view tcpListen state) +{-# INLINE deleteListening #-} + + +-- | Lookup a socket in the Listen state. +lookupListening :: HasTcpState state + => state -> Addr -> TcpPort -> IO (Maybe ListenTcb) +lookupListening state src port = + do mb <- HT.lookup (ListenKey src port) (view tcpListen state) + case mb of + Just {} -> return mb + Nothing -> + HT.lookup (ListenKey (wildcardAddr src) port) (view tcpListen state) +{-# INLINE lookupListening #-} + + +-- TimeWait Sockets ------------------------------------------------------------ + +-- | Register a socket in the TimeWait state. If the heap was empty, fork off a +-- thread to reap its contents after the timeWaitTimeout. +-- +-- NOTE: this doesn't remove the original socket from the Active set. +registerTimeWait :: (HasConfig state, HasTcpState state) + => state -> TimeWaitTcb -> IO () +registerTimeWait state tcb = + let Config { .. } = view config state + in updateTimeWait state $ \ now heap -> + let heap' = if H.size heap >= cfgTcpTimeWaitSocketLimit + then H.deleteMin heap + else heap + in fst (expireAt (addUTCTime cfgTcpTimeoutTimeWait now) tcb heap') + +-- | Reset the timer associated with a TimeWaitTcb. +resetTimeWait :: (HasConfig state, HasTcpState state) + => state -> TimeWaitTcb -> IO () +resetTimeWait state tcb = + let Config { .. } = view config state + in updateTimeWait state $ \ now heap -> + fst $ expireAt (addUTCTime cfgTcpTimeoutTimeWait now) tcb + $ filterHeap (/= tcb) heap + +-- | Modify the TimeWait heap, and spawn a reaping thread when necessary. +updateTimeWait :: (HasConfig state, HasTcpState state) + => state -> (UTCTime -> TimeWaitHeap -> TimeWaitHeap) -> IO () +updateTimeWait state update = + do now <- getCurrentTime + mbReap <- + atomicModifyIORef' (view tcpTimeWait state) $ \ heap -> + let heap' = update now heap + + -- Return a reaping action if: + -- + -- 1. The original heap was empty, signifying that there was no + -- existing reaper running + -- + -- 2. The user action added something to the heap + reaper = do guard (nullHeap heap) + future <- nextEvent heap' + return $ do delayDiff now future + reapLoop + + in (heap', reaper) + + case mbReap of + Just reaper -> do _ <- forkNamed "TimeWait Reaper" reaper + return () + + Nothing -> return () + + where + + -- delay by at least half a second, until some point in the future. + delayDiff now future = + threadDelay (max 500000 (toUSeconds (diffUTCTime future now))) + + -- The reap thread will reap TimeWait sockets according to their expiration + -- time, and then exit. + reapLoop = + do now <- getCurrentTime + mbExpire <- + atomicModifyIORef' (view tcpTimeWait state) $ \ heap -> + let heap' = dropExpired now heap + in (heap', nextEvent heap') + + case mbExpire of + Just future -> do delayDiff now future + reapLoop + + Nothing -> return () + + +-- | Lookup a socket in the TimeWait state. +lookupTimeWait :: HasTcpState state + => state -> Addr -> TcpPort -> Addr -> TcpPort + -> IO (Maybe TimeWaitTcb) +lookupTimeWait state dst dstPort src srcPort = + do heap <- readIORef (view tcpTimeWait state) + return (payload `fmap` F.find isConn heap) + where + isConn Entry { payload = TimeWaitTcb { .. } } = + and [ twRemote == dst + , twRemotePort == dstPort + , riSource twRouteInfo == src + , twLocalPort == srcPort ] +{-# INLINE lookupTimeWait #-} + + +-- | Delete an entry from the TimeWait heap. +deleteTimeWait :: HasTcpState state => state -> TimeWaitTcb -> IO () +deleteTimeWait state tw = + atomicModifyIORef' (view tcpTimeWait state) $ \ heap -> + (filterHeap (/= tw) heap, ()) +{-# INLINE deleteTimeWait #-} + + +-- Active Sockets -------------------------------------------------------------- + +-- | Register a new active socket. +registerActive :: HasTcpState state => state -> Tcb -> IO Bool +registerActive state tcb = + HT.alter update (view tcbKey tcb) (view tcpActive state) + where + update Nothing = (Just tcb, True) + update mb = (mb, False) +{-# INLINE registerActive #-} + + +-- | Lookup an active socket. +lookupActive :: HasTcpState state + => state -> Addr -> TcpPort -> Addr -> TcpPort -> IO (Maybe Tcb) +lookupActive state dst dstPort src srcPort = + HT.lookup (Key dst dstPort src srcPort) (view tcpActive state) +{-# INLINE lookupActive #-} + + +-- | Delete the 'Tcb', and notify any waiting processes. +closeActive :: HasTcpState state => state -> Tcb -> IO () +closeActive state tcb = + do finalizeTcb tcb + deleteActive state tcb +{-# INLINE closeActive #-} + + +-- | Delete an active connection from the tcp state. +deleteActive :: HasTcpState state => state -> Tcb -> IO () +deleteActive state tcb = + HT.delete (view tcbKey tcb) (view tcpActive state) +{-# INLINE deleteActive #-} + + +-- Port Management ------------------------------------------------------------- + +-- | Pick a fresh port for a connection. +nextTcpPort :: HasTcpState state + => state -> Addr -> Addr -> TcpPort -> IO (Maybe TcpPort) +nextTcpPort state src dst dstPort = + modifyMVar tcpPorts (pickFreshPort tcpActive_ (Key dst dstPort src)) + where + TcpState { .. } = view tcpState state + +pickFreshPort :: HT.HashTable Key Tcb -> (TcpPort -> Key) -> TcpPort + -> IO (TcpPort, Maybe TcpPort) +pickFreshPort ht mkKey p0 = go 0 p0 + where + + go :: Int -> TcpPort -> IO (TcpPort,Maybe TcpPort) + go i _ | i > 65535 = return (p0, Nothing) + go i 0 = go (i+1) 1025 + go i port = + do used <- HT.hasKey (mkKey port) ht + if not used + then return (port, Just port) + else go (i + 1) (port + 1) + + +-- Sequence Numbers ------------------------------------------------------------ + +nextIss :: HasTcpState state + => state -> Addr -> TcpPort -> Addr -> TcpPort -> IO TcpSeqNum +nextIss state src srcPort dst dstPort = + do let TcpState { .. } = view tcpState state + now <- getCurrentTime + (m,f_digest) <- atomicModifyIORef' tcpISSTimer $ \ Tcp4USTimer { .. } -> + let diff = diffUTCTime now tcpLastUpdate + ticks = tcpTimer + truncate (diff * 250000) -- 4us chunks + timers' = Tcp4USTimer { tcpTimer = ticks + , tcpLastUpdate = now + , .. } + + digest = integerDigest $ sha1 $ runPutLazy $ + do putAddr src + putTcpPort srcPort + putAddr dst + putTcpPort dstPort + putByteString tcpSecret + + in (timers', (ticks, digest)) + + return (fromIntegral (m + fromIntegral f_digest)) diff --git a/src/Hans/Tcp/Tcb.hs b/src/Hans/Tcp/Tcb.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Tcb.hs @@ -0,0 +1,631 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Tcp.Tcb ( + -- * Timers + SlowTicks, + TcpTimers(..), + emptyTcpTimers, + resetRetransmit, + retryRetransmit, + stopRetransmit, + reset2MSL, + updateTimers, + calibrateRTO, + + -- * TCB States + State(..), + GetState(..), + whenState, + setState, + + -- * Sending + CanSend(..), + getSndNxt, + getSndWnd, + + -- * Receiving + CanReceive(..), + getRcvNxt, + getRcvWnd, + getRcvRight, + + -- * Listening TCBs + ListenTcb(..), + newListenTcb, + createChild, + reserveSlot, releaseSlot, + acceptTcb, + + -- * Active TCBs + Tcb(..), + newTcb, + signalDelayedAck, + setRcvNxt, + finalizeTcb, + getSndUna, + resetIdleTimer, + + -- ** Active Config + TcbConfig(..), + usingTimestamps, + disableTimestamp, + + -- ** Windowing + queueBytes, + haveBytesAvail, + receiveBytes, tryReceiveBytes, + + -- * TimeWait TCBs + TimeWaitTcb(..), + mkTimeWaitTcb, + ) where + +import Hans.Addr (Addr) +import Hans.Buffer.Signal +import qualified Hans.Buffer.Stream as Stream +import Hans.Config (HasConfig(..),Config(..)) +import Hans.Lens +import Hans.Network.Types (RouteInfo) +import Hans.Tcp.Packet +import qualified Hans.Tcp.RecvWindow as Recv +import qualified Hans.Tcp.SendWindow as Send + +import Control.Monad (when) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.IORef + (IORef,newIORef,atomicModifyIORef',readIORef + ,atomicWriteIORef) +import Data.Int (Int64) +import qualified Data.Sequence as Seq +import Data.Time.Clock (NominalDiffTime,getCurrentTime) +import Data.Word (Word16,Word32) +import MonadLib (BaseM(..)) +import System.CPUTime (getCPUTime) + + +-- Timers ---------------------------------------------------------------------- + +type SlowTicks = Int + +data TcpTimers = TcpTimers { ttDelayedAck :: !Bool + + -- MSL + , tt2MSL :: !SlowTicks + + -- retransmit timer + , ttRetransmitValid :: !Bool + , ttRetransmit :: !SlowTicks + , ttRetries :: !Int + + -- retransmit timer config + , ttRTO :: !SlowTicks + , ttSRTT :: !NominalDiffTime + , ttRTTVar :: !NominalDiffTime + + -- idle timer + , ttMaxIdle :: !SlowTicks + , ttIdle :: !SlowTicks + } + +emptyTcpTimers :: TcpTimers +emptyTcpTimers = TcpTimers { ttDelayedAck = False + , tt2MSL = 0 + + , ttRetransmitValid = False + , ttRetransmit = 0 + , ttRetries = 0 + + , ttRTO = 2 -- two ticks -- one second + , ttSRTT = 0 + , ttRTTVar = 0 + , ttMaxIdle = 10 * 60 * 2 -- 10 minutes + , ttIdle = 0 + } + + +-- | Reset retransmit info. +resetRetransmit :: TcpTimers -> (TcpTimers, ()) +resetRetransmit TcpTimers { .. } = + (TcpTimers { ttRetransmitValid = True + , ttRetransmit = ttRTO + , ttRetries = 0 + , .. }, ()) + + +-- | Increment the retry count, and double the last retransmit timer. +retryRetransmit :: TcpTimers -> (TcpTimers, ()) +retryRetransmit TcpTimers { .. } = + (TcpTimers { ttRetransmitValid = True + , ttRetransmit = ttRTO * 2 ^ retries + , ttRetries = retries + , .. }, ()) + where + retries = ttRetries + 1 + + +-- | Invalidate the retransmit timer. +stopRetransmit :: TcpTimers -> (TcpTimers, ()) +stopRetransmit TcpTimers { .. } = + (TcpTimers { ttRetransmitValid = False + , ttRetries = 0 + , .. }, ()) + + +reset2MSL :: Config -> TcpTimers -> (TcpTimers, ()) +reset2MSL Config { .. } tt = (tt { tt2MSL = 4 * cfgTcpMSL }, ()) + -- NOTE: cfgTcpMSL is multiplied by four here, as it's given in seconds, but + -- counted in slow ticks (half seconds). Multiplying by four gives the value + -- of 2*MSL in slow ticks. + + +-- | Update all slow-tick timers. Return the old timers, for use with +-- 'atomicModifyIORef\''. +updateTimers :: TcpTimers -> (TcpTimers, TcpTimers) +updateTimers tt = (tt',tt) + where + tt' = tt { ttRetransmit = if ttRetransmitValid tt then ttRetransmit tt - 1 else 0 + , tt2MSL = max 0 (tt2MSL tt - 1) + , ttIdle = ttIdle tt + 1 + } + +-- | Reset idle timer in the presence of packets, for use with +-- 'atomicModifyIORef\''. +resetIdleTimer :: TcpTimers -> (TcpTimers, ()) +resetIdleTimer t = (idleReset, ()) + where + idleReset = t { ttIdle = 0 } + +-- | Calibrate the RTO timer, given a round-trip measurement, as specified by +-- RFC-6298. +calibrateRTO :: NominalDiffTime -> TcpTimers -> (TcpTimers, ()) +calibrateRTO r tt + | ttSRTT tt > 0 = (rolling, ()) + | otherwise = (initial, ()) + where + + -- 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'))) + } + + +-- Socket State ---------------------------------------------------------------- + +whenState :: (BaseM m IO, GetState tcb) => tcb -> State -> m () -> m () +whenState tcb state m = + do state' <- inBase (getState tcb) + when (state == state') m + +-- | The Tcb type is the only one that supports changing state. +setState :: Tcb -> State -> IO () +setState tcb state = + do old <- atomicModifyIORef' (tcbState tcb) (\old -> (state,old)) + case state of + Established -> tcbEstablished tcb tcb old + Closed -> tcbClosed tcb tcb old + CloseWait -> Stream.closeBuffer (tcbRecvBuffer tcb) + _ -> return () + +class GetState tcb where + getState :: tcb -> IO State + +instance GetState ListenTcb where + getState _ = return Listen + +instance GetState Tcb where + getState Tcb { .. } = readIORef tcbState + +instance GetState TimeWaitTcb where + getState _ = return TimeWait + +data State = Listen + | SynSent + | SynReceived + | Established + | FinWait1 + | FinWait2 + | CloseWait + | Closing + | LastAck + | TimeWait + | Closed + deriving (Eq,Show) + + +-- Listening Sockets ----------------------------------------------------------- + +data ListenTcb = ListenTcb { lSrc :: !Addr + , lPort :: !TcpPort + + -- accept + , lAccept :: !(IORef AcceptQueue) + , lAcceptSignal :: !Signal + + , lTSClock :: !(IORef Send.TSClock) + } + +-- | Create a new listening socket. +newListenTcb :: Addr -> TcpPort -> Int -> IO ListenTcb +newListenTcb lSrc lPort aqFree = + do lAccept <- newIORef (AcceptQueue { aqTcbs = Seq.empty, .. }) + lAcceptSignal <- newSignal + + now <- getCurrentTime + tsval <- getCPUTime + lTSClock <- newIORef (Send.initialTSClock (fromInteger tsval) now) + + return ListenTcb { .. } + + +-- | Create a child from a Syn request. +createChild :: HasConfig cfg + => cfg -> TcpSeqNum -> ListenTcb -> RouteInfo Addr -> Addr -> TcpHeader + -> (Tcb -> State -> IO ()) -- ^ On Established + -> (Tcb -> State -> IO ()) -- ^ On Closed + -> IO Tcb +createChild cxt iss parent ri remote hdr onEstablished onClosed = + do let cfg = view config cxt + + now <- getCurrentTime + tsc <- atomicModifyIORef' (lTSClock parent) $ \ tsc -> + let tsc' = Send.updateTSClock cfg now tsc + in (tsc',tsc') + + child <- newTcb cfg (Just parent) iss ri (tcpDestPort hdr) remote + (tcpSourcePort hdr) SynReceived tsc + (\c state -> do queueTcb parent c state + onEstablished c state) + (\c state -> do when (state == SynReceived) (releaseSlot parent) + onClosed c state) + + + atomicWriteIORef (tcbIrs child) (tcpSeqNum hdr) + atomicWriteIORef (tcbIss child) iss + + -- advance RCV.NXT over the SYN + _ <- setRcvNxt (tcpSeqNum hdr + 1) child + _ <- setSndNxt iss child + + return child + + +data AcceptQueue = AcceptQueue { aqFree :: !Int + , aqTcbs :: Seq.Seq Tcb + } + + +-- | Reserve a slot in the accept queue, returns True when the space has been +-- reserved. +reserveSlot :: ListenTcb -> IO Bool +reserveSlot ListenTcb { .. } = + atomicModifyIORef' lAccept $ \ aq -> + if aqFree aq > 0 + then (aq { aqFree = aqFree aq - 1 }, True) + else (aq, False) +{-# INLINE reserveSlot #-} + + +-- | Release a slot back to the accept queue. +releaseSlot :: ListenTcb -> IO () +releaseSlot ListenTcb { .. } = + atomicModifyIORef' lAccept (\ aq -> (aq { aqFree = aqFree aq + 1 }, ())) +{-# INLINE releaseSlot #-} + + +-- | Add a Tcb to the accept queue for this listening connection. +queueTcb :: ListenTcb -> Tcb -> State -> IO () +queueTcb ListenTcb { .. } tcb _ = + do atomicModifyIORef' lAccept $ \ aq -> + (aq { aqTcbs = aqTcbs aq Seq.|> tcb }, ()) + signal lAcceptSignal + + +-- | Wait until a Tcb is available in the accept queue. +acceptTcb :: ListenTcb -> IO Tcb +acceptTcb ListenTcb { .. } = + do waitSignal lAcceptSignal + atomicModifyIORef' lAccept $ \ AcceptQueue { .. } -> + case Seq.viewl aqTcbs of + + tcb Seq.:< tcbs -> + (AcceptQueue { aqTcbs = tcbs, aqFree = aqFree + 1 }, tcb) + + Seq.EmptyL -> + error "Accept queue signaled with an empty queue" + + +-- Active Sockets -------------------------------------------------------------- + +type SeqNumVar = IORef TcpSeqNum + +data TcbConfig = TcbConfig { tcUseTimestamp :: !Bool + } + +defaultTcbConfig :: TcbConfig +defaultTcbConfig = + TcbConfig { tcUseTimestamp = True + } + +-- | True when the timestamp option should be included. +usingTimestamps :: Tcb -> IO Bool +usingTimestamps Tcb { .. } = + do TcbConfig { .. } <- readIORef tcbConfig + return tcUseTimestamp + +-- | Disable the use of the timestamp option. +disableTimestamp :: Tcb -> IO () +disableTimestamp Tcb { .. } = + atomicModifyIORef' tcbConfig $ \ TcbConfig { .. } -> + (TcbConfig { tcUseTimestamp = False, .. }, ()) + +data Tcb = Tcb { tcbParent :: Maybe ListenTcb + -- ^ Parent to notify if this tcb was generated from a socket + -- in the LISTEN state + + , tcbConfig :: !(IORef TcbConfig) + + , tcbState :: !(IORef State) + , tcbEstablished :: Tcb -> State -> IO () + , tcbClosed :: Tcb -> State -> IO () + + -- Sender variables + , tcbSndUp :: !SeqNumVar -- ^ SND.UP + , tcbSndWl1 :: !SeqNumVar -- ^ SND.WL1 + , tcbSndWl2 :: !SeqNumVar -- ^ SND.WL2 + , tcbIss :: !SeqNumVar -- ^ ISS + , tcbSendWindow :: !(IORef Send.Window) + + -- Receive variables + , tcbRcvUp :: !SeqNumVar -- ^ RCV.UP + , tcbIrs :: !SeqNumVar -- ^ IRS + + , tcbNeedsDelayedAck :: !(IORef Bool) + , tcbRecvWindow :: !(IORef Recv.Window) + , tcbRecvBuffer :: !Stream.Buffer + + -- Port information + , tcbLocalPort :: !TcpPort -- ^ Local port + , tcbRemotePort :: !TcpPort -- ^ Remote port + + -- Routing information + , tcbRouteInfo :: !(RouteInfo Addr) -- ^ Cached routing + , tcbRemote :: !Addr -- ^ Remote host + + -- Fragmentation information + , tcbMss :: !(IORef Int64) -- ^ Maximum segment size + + -- Timers + , tcbTimers :: !(IORef TcpTimers) + + -- Timer option state + , tcbTSRecent :: !(IORef Word32) + , tcbLastAckSent :: !(IORef TcpSeqNum) + } + +newTcb :: HasConfig state + => state + -> Maybe ListenTcb + -> TcpSeqNum -- ^ ISS + -> RouteInfo Addr -> TcpPort -> Addr -> TcpPort + -> State + -> Send.TSClock + -> (Tcb -> State -> IO ()) + -> (Tcb -> State -> IO ()) + -> IO Tcb +newTcb cxt tcbParent iss tcbRouteInfo tcbLocalPort tcbRemote tcbRemotePort + state tsc tcbEstablished tcbClosed = + do let Config { .. } = view config cxt + + tcbConfig <- newIORef defaultTcbConfig + + tcbState <- newIORef state + tcbSndUp <- newIORef 0 + tcbSndWl1 <- newIORef 0 + tcbSndWl2 <- newIORef 0 + + tcbSendWindow <- + newIORef (Send.emptyWindow iss (fromIntegral cfgTcpInitialWindow) tsc) + + tcbIss <- newIORef iss + + -- NOTE: the size of the receive buffer is gated by the local window + tcbRecvWindow <- newIORef (Recv.emptyWindow 0 (fromIntegral cfgTcpInitialWindow)) + tcbRecvBuffer <- Stream.newBuffer + + tcbRcvUp <- newIORef 0 + tcbNeedsDelayedAck <- newIORef False + tcbIrs <- newIORef 0 + tcbMss <- newIORef (fromIntegral cfgTcpInitialMSS) + tcbTimers <- newIORef emptyTcpTimers + + tcbTSRecent <- newIORef 0 + tcbLastAckSent <- newIORef 0 + + return Tcb { .. } + +-- | Record that a delayed ack should be sent. +signalDelayedAck :: Tcb -> IO () +signalDelayedAck Tcb { .. } = atomicWriteIORef tcbNeedsDelayedAck True + +-- | Set the value of RCV.NXT. Returns 'True' when the value has been set +-- successfully, and 'False' if the receive queue was not empty. +setRcvNxt :: TcpSeqNum -> Tcb -> IO Bool +setRcvNxt rcvNxt Tcb { .. } = + atomicModifyIORef' tcbRecvWindow (Recv.setRcvNxt rcvNxt) + + +-- | Set the value of SND.NXT. Returns 'True' when the value has been set +-- successfully, and 'False' if the send queue was not empty. +setSndNxt :: TcpSeqNum -> Tcb -> IO Bool +setSndNxt sndNxt Tcb { .. } = + atomicModifyIORef' tcbSendWindow (Send.setSndNxt sndNxt) + + +-- | Cleanup the Tcb. +finalizeTcb :: Tcb -> IO () +finalizeTcb Tcb { .. } = + do Stream.closeBuffer tcbRecvBuffer + atomicModifyIORef' tcbTimers stopRetransmit + atomicModifyIORef' tcbSendWindow Send.flushWindow + +-- | Queue bytes in the receive buffer. +queueBytes :: S.ByteString -> Tcb -> IO () +queueBytes bytes Tcb { .. } = Stream.putBytes bytes tcbRecvBuffer + +-- | Determine if there are bytes in the receive buffer that can be read. +haveBytesAvail :: Tcb -> IO Bool +haveBytesAvail Tcb { .. } = + Stream.bytesAvailable tcbRecvBuffer + +-- | Remove data from the receive buffer, and move the right-side of the receive +-- window. Reading 0 bytes indicates that the remote side has closed the +-- connection. +receiveBytes :: Int -> Tcb -> IO L.ByteString +receiveBytes len Tcb { .. } = + do bytes <- Stream.takeBytes len tcbRecvBuffer + atomicModifyIORef' tcbRecvWindow + (Recv.moveRcvRight (fromIntegral (L.length bytes))) + return bytes + +-- | Non-blocking version of 'receiveBytes'. Reading 0 bytes indicates that the +-- remote side has closed the connection. +tryReceiveBytes :: Int -> Tcb -> IO (Maybe L.ByteString) +tryReceiveBytes len Tcb { .. } = + do mbBytes <- Stream.tryTakeBytes len tcbRecvBuffer + case mbBytes of + + Just bytes -> + do atomicModifyIORef' tcbRecvWindow + (Recv.moveRcvRight (fromIntegral (L.length bytes))) + return (Just bytes) + + Nothing -> + return Nothing + + +-- TimeWait Sockets ------------------------------------------------------------ + +data TimeWaitTcb = TimeWaitTcb { twSndNxt :: !TcpSeqNum -- ^ SND.NXT + + , twRcvNxt :: !SeqNumVar -- ^ RCV.NXT + , twRcvWnd :: !Word16 -- ^ RCV.WND + + -- Port information + , twLocalPort :: !TcpPort + , twRemotePort :: !TcpPort + + -- Routing information + , twRouteInfo :: !(RouteInfo Addr) + , twRemote :: !Addr + } deriving (Eq) + +mkTimeWaitTcb :: Tcb -> IO TimeWaitTcb +mkTimeWaitTcb Tcb { .. } = + do send <- readIORef tcbSendWindow + recv <- readIORef tcbRecvWindow + twRcvNxt <- newIORef (view Recv.rcvNxt recv) + + return $! TimeWaitTcb { twSndNxt = view Send.sndNxt send + , twRcvWnd = view Recv.rcvWnd recv + , twLocalPort = tcbLocalPort + , twRemotePort = tcbRemotePort + , twRouteInfo = tcbRouteInfo + , twRemote = tcbRemote + , .. } + + + +-- Sockets that send ----------------------------------------------------------- + +getSndNxt :: (BaseM io IO, CanSend sock) => sock -> io TcpSeqNum +getSndNxt sock = + do (nxt,_) <- getSendWindow sock + return nxt +{-# INLINE getSndNxt #-} + +getSndWnd :: (BaseM io IO, CanSend sock) => sock -> io TcpSeqNum +getSndWnd sock = + do (_,wnd) <- getSendWindow sock + return wnd +{-# INLINE getSndWnd #-} + +class CanSend sock where + getSendWindow :: BaseM io IO => sock -> io (TcpSeqNum,TcpSeqNum) + +instance CanSend (IORef Send.Window) where + getSendWindow ref = + do sw <- inBase (readIORef ref) + return (view Send.sndNxt sw, view Send.sndWnd sw) + {-# INLINE getSendWindow #-} + +instance CanSend Tcb where + getSendWindow Tcb { .. } = getSendWindow tcbSendWindow + {-# INLINE getSendWindow #-} + + +-- Sockets that receive -------------------------------------------------------- + +getSndUna :: BaseM io IO => Tcb -> io TcpSeqNum +getSndUna Tcb { .. } = + do sw <- inBase (readIORef tcbSendWindow) + return $! view Send.sndUna sw + +getRcvNxt :: (BaseM io IO, CanReceive sock) => sock -> io TcpSeqNum +getRcvNxt sock = + do (nxt,_) <- getRecvWindow sock + return nxt +{-# INLINE getRcvNxt #-} + +getRcvWnd :: (BaseM io IO, CanReceive sock) => sock -> io Word16 +getRcvWnd sock = + do (nxt,right) <- getRecvWindow sock + return (fromTcpSeqNum (right - nxt)) +{-# INLINE getRcvWnd #-} + +getRcvRight :: (BaseM io IO, CanReceive sock) => sock -> io TcpSeqNum +getRcvRight sock = + do (_,right) <- getRecvWindow sock + return right +{-# INLINE getRcvRight #-} + +class CanReceive sock where + -- | Retrieve the left and right edges of the receive window: + -- + -- (RCV.NXT, RCV.NXT + RCV.WND) + getRecvWindow :: BaseM io IO => sock -> io (TcpSeqNum,TcpSeqNum) + +instance CanReceive (IORef Recv.Window) where + getRecvWindow ref = inBase $ + do rw <- readIORef ref + return (view Recv.rcvNxt rw, view Recv.rcvRight rw) + {-# INLINE getRecvWindow #-} + +instance CanReceive Tcb where + getRecvWindow Tcb { .. } = getRecvWindow tcbRecvWindow + {-# INLINE getRecvWindow #-} + +instance CanReceive TimeWaitTcb where + getRecvWindow TimeWaitTcb { .. } = inBase $ + do rcvNxt <- readIORef twRcvNxt + return (rcvNxt,rcvNxt + fromIntegral twRcvWnd) + {-# INLINE getRecvWindow #-} diff --git a/src/Hans/Tcp/Timers.hs b/src/Hans/Tcp/Timers.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Tcp/Timers.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE RecordWildCards #-} +module Hans.Tcp.Timers where + +import Hans.Config +import qualified Hans.HashTable as HT +import Hans.Lens +import Hans.Tcp.Tcb +import Hans.Tcp.Output +import Hans.Tcp.SendWindow +import Hans.Time (toUSeconds) +import Hans.Types + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.IORef (atomicModifyIORef') +import Data.Time.Clock (getCurrentTime,diffUTCTime) + + +-- | Process the slow and fast tcp timers. The fast timer runs four times a +-- second, while the slow timer runs two times a second. +tcpTimers :: NetworkStack -> IO () +tcpTimers ns = loop True + where + loop runSlow = + do start <- getCurrentTime + + HT.mapHashTableM_ (\_ -> updateActive ns runSlow) (view tcpActive ns) + + -- delay to the next 250ms boundary + end <- getCurrentTime + let delay = 0.250 - diffUTCTime end start + when (delay > 0) (threadDelay (toUSeconds delay)) + + loop $! not runSlow + + +-- | The body of the fast and slow tick handlers. The boolean indicates whether +-- or not the slow tick should also be run. +updateActive :: NetworkStack -> Bool -> Tcb -> IO () +updateActive ns runSlow tcb@Tcb { .. } = + do -- the slow timer + when runSlow $ + do ts <- atomicModifyIORef' tcbTimers updateTimers + handleRTO ns tcb ts + handle2MSL ns tcb ts + + -- the fast timer + shouldAck <- atomicModifyIORef' tcbNeedsDelayedAck (\ b -> (False,b)) + when shouldAck (sendAck ns tcb) + + +-- | Handle the retransmit timer. When the timer expires, if there is anything +-- in the send window, retransmit the left-most segment. +handleRTO :: NetworkStack -> Tcb -> TcpTimers -> IO () +handleRTO ns Tcb { .. } TcpTimers { .. } + | ttRetransmitValid && ttRetransmit <= 0 = + do mbSeg <- atomicModifyIORef' tcbSendWindow retransmitTimeout + case mbSeg of + Just (hdr,body) -> + do atomicModifyIORef' tcbTimers retryRetransmit + _ <- sendTcp ns tcbRouteInfo tcbRemote hdr body + return () + + Nothing -> + return () + + | otherwise = + return () + + +-- | Make sure that the connection is still active. The Idle timer is checked +-- when the 2MSL timer expires. +handle2MSL :: NetworkStack -> Tcb -> TcpTimers -> IO () +handle2MSL ns tcb@Tcb { .. } TcpTimers { .. } + + | tt2MSL <= 0 = + -- why do we only check the idle timer when 2MSL goes off? + if ttIdle >= ttMaxIdle + then closeActive ns tcb + else atomicModifyIORef' tcbTimers (reset2MSL (view config ns)) + + | otherwise = + return () diff --git a/src/Hans/Threads.hs b/src/Hans/Threads.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Threads.hs @@ -0,0 +1,17 @@ +module Hans.Threads where + +import Control.Concurrent (forkFinally,ThreadId) +import Control.Exception (fromException,AsyncException(..)) + + +forkNamed :: String -> IO () -> IO ThreadId +forkNamed str body = forkFinally body showExn + where + + showExn Right{} = + return () + + showExn (Left e) = + case fromException e of + Just ThreadKilled -> return () + _ -> putStrLn (str ++ ": Exception escaped: " ++ show e) diff --git a/src/Hans/Time.hs b/src/Hans/Time.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Time.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Time ( + module Hans.Time, + H.Entry(..), + H.toUnsortedList, + ) where + +import qualified Data.Heap as H +import Data.Time.Clock (UTCTime,NominalDiffTime,diffUTCTime) +import Data.Tuple (swap) + + +type Expires = H.Entry UTCTime + +expiresBefore :: UTCTime -> Expires a -> Bool +expiresBefore time entry = time >= H.priority entry + + +type ExpireHeap a = H.Heap (Expires a) + +emptyHeap :: ExpireHeap a +emptyHeap = H.empty +{-# INLINE emptyHeap #-} + +fromListHeap :: [Expires a] -> ExpireHeap a +fromListHeap = H.fromList +{-# INLINE fromListHeap #-} + +filterHeap :: (a -> Bool) -> ExpireHeap a -> ExpireHeap a +filterHeap p = H.filter p' + where + p' H.Entry { .. } = p payload +{-# INLINE filterHeap #-} + +partitionHeap :: (a -> Bool) -> ExpireHeap a -> (ExpireHeap a,ExpireHeap a) +partitionHeap p = H.partition p' + where + p' H.Entry { .. } = p payload +{-# INLINE partitionHeap #-} + +-- | The next time that something in the heap will expire, if the heap is +-- non-empty. +nextEvent :: ExpireHeap a -> Maybe UTCTime +nextEvent heap = + do (entry,_) <- H.viewMin heap + return (H.priority entry) + +-- | Remove all expired entries from the heap. +dropExpired :: UTCTime -> ExpireHeap a -> ExpireHeap a +dropExpired now heap = H.dropWhile (expiresBefore now) heap +{-# INLINE dropExpired #-} + +-- | Given the current time, partition the heap into valid entries, and entries +-- that have expired. +partitionExpired :: UTCTime -> ExpireHeap a -> (ExpireHeap a, ExpireHeap a) +partitionExpired now heap = swap (H.break (expiresBefore now) heap) +{-# INLINE partitionExpired #-} + +-- | Add an entry to the 'ExpireHeap', and return the time of the next +-- expiration event. +expireAt :: UTCTime -> a -> ExpireHeap a -> (ExpireHeap a,UTCTime) +expireAt time a heap = + let heap' = H.insert H.Entry { H.priority = time, H.payload = a } heap + in (heap',H.priority (H.minimum heap')) + -- NOTE: it's safe to use the partial function minimum, as we just inserted + -- into the heap we're asking for the minimum element of. +{-# INLINE expireAt #-} + +nullHeap :: ExpireHeap a -> Bool +nullHeap = H.null +{-# INLINE nullHeap #-} + +-- | The amount of time until the top of the heap expires, relative to the time +-- given. +expirationDelay :: UTCTime -> ExpireHeap a -> Maybe NominalDiffTime +expirationDelay now heap = + do (H.Entry { .. }, _) <- H.viewMin heap + return $! diffUTCTime priority now + + +-- | Convert a 'NominalDiffTime' into microseconds for use with 'threadDelay'. +toUSeconds :: NominalDiffTime -> Int +toUSeconds diff = max 0 (truncate (diff * 1000000)) diff --git a/src/Hans/Timers.hs b/src/Hans/Timers.hs deleted file mode 100644 --- a/src/Hans/Timers.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Hans.Timers ( - Milliseconds - , Timer() - , delay - , delay_ - , cancel - , expired - ) where - -import Control.Concurrent (forkIO,ThreadId,threadDelay,killThread - ,mkWeakThreadId) -import GHC.Conc (threadStatus,ThreadStatus(..)) -import System.Mem.Weak (Weak,deRefWeak) - - -type Milliseconds = Int - --- | A handle to a scheduled timer. --- --- NOTE: This keeps a weak reference to the thread containing the timer, to --- allow it to still receive exceptions (see mkWeakThreadId). -newtype Timer = Timer (Weak ThreadId) - --- | Delay an action, giving back a handle to allow the timer to be cancelled. -delay :: Milliseconds -> IO () -> IO Timer -delay n body = - do tid <- forkIO (threadDelay (n * 1000) >> body) - wid <- mkWeakThreadId tid - return (Timer wid) - --- | Delay an action. -delay_ :: Milliseconds -> IO () -> IO () -delay_ n body = - do _ <- forkIO (threadDelay (n * 1000) >> body) - return () - --- | Cancel a delayed action. -cancel :: Timer -> IO () -cancel (Timer wid) = - do mb <- deRefWeak wid - case mb of - Just tid -> killThread tid - Nothing -> return () - -expired :: Timer -> IO Bool -expired (Timer wid) = - do mb <- deRefWeak wid - case mb of - Just tid -> do status <- threadStatus tid - case status of - ThreadRunning -> return False - ThreadBlocked _ -> return False - _ -> return True - - Nothing -> return True diff --git a/src/Hans/Types.hs b/src/Hans/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Types.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RecordWildCards #-} + +module Hans.Types ( + module Hans.Types, + module Exports + ) where + +import Hans.Config (Config,HasConfig(..)) +import Hans.Device.Types (Device) +import Hans.IP4.ArpTable as Exports (ArpTable) +import Hans.IP4.Packet +import Hans.IP4.State as Exports +import Hans.IP4.RoutingTable as Exports (RoutingTable) +import Hans.Lens +import Hans.Nat.State as Exports +import Hans.Tcp.State as Exports +import Hans.Udp.State as Exports + +import Control.Concurrent (ThreadId) +import Control.Concurrent.BoundedChan (BoundedChan) +import qualified Data.ByteString as S +import Data.IORef (IORef,atomicModifyIORef',readIORef) + + +data InputPacket = FromDevice !Device !S.ByteString + | FromIP4 !Device !IP4Header !S.ByteString + + +data NetworkStack = NetworkStack { nsConfig :: !Config + -- ^ The configuration for this instance of + -- the network stack. + + , nsNat :: !NatState + -- ^ Nat table/config + + , nsInput :: !(BoundedChan InputPacket) + -- ^ The input packet queue + + , nsDevices :: {-# UNPACK #-} !(IORef [Device]) + -- ^ All registered devices + + , nsIP4State :: !IP4State + -- ^ State for IP4 processing + + , nsIP4Responder :: !ThreadId + -- ^ Internal IP4 responder for messages + -- produced in teh fast path. + + , nsUdpState :: !UdpState + -- ^ State for UDP processing + + , nsUdpResponder :: !ThreadId + -- ^ Responder thread for UDP messages + -- produced in the fast path. + + , nsTcpState :: !TcpState + -- ^ State for TCP processing + + , nsTcpResponder :: !ThreadId + -- ^ Responder thread for TCP messages + -- produced in the fast path. + + , nsTcpTimers :: !ThreadId + -- ^ The TCP timer thread + + , nsNameServers4 :: !(IORef [IP4]) + } + +instance HasConfig NetworkStack where + config = to nsConfig + {-# INLINE config #-} + +instance HasIP4State NetworkStack where + ip4State = to nsIP4State + {-# INLINE ip4State #-} + +instance HasUdpState NetworkStack where + udpState = to nsUdpState + {-# INLINE udpState #-} + +instance HasTcpState NetworkStack where + tcpState = to nsTcpState + {-# INLINE tcpState #-} + +instance HasNatState NetworkStack where + natState = to nsNat + {-# INLINE natState #-} + + + +class HasNetworkStack ns where + networkStack :: Getting r ns NetworkStack + +instance HasNetworkStack NetworkStack where + networkStack = id + {-# INLINE networkStack #-} + + +addNameServer4 :: HasNetworkStack ns => ns -> IP4 -> IO () +addNameServer4 ns addr = + atomicModifyIORef' (nsNameServers4 (view networkStack ns)) + (\addrs -> (addr:addrs,())) + +getNameServers4 :: HasNetworkStack ns => ns -> IO [IP4] +getNameServers4 ns = readIORef (nsNameServers4 (view networkStack ns)) diff --git a/src/Hans/Udp/Input.hs b/src/Hans/Udp/Input.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Udp/Input.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} + +module Hans.Udp.Input ( + processUdp + ) where + +import Hans.Addr (Addr,toAddr) +import qualified Hans.Buffer.Datagram as DG +import Hans.Checksum (finalizeChecksum,extendChecksum) +import Hans.Device (Device(..),ChecksumOffload(..),rxOffload) +import Hans.IP4.Packet (IP4) +import Hans.Lens (view) +import Hans.Monad (Hans,decode',dropPacket,io) +import Hans.Nat.Forward (tryForwardUdp) +import Hans.Network +import Hans.Udp.Output (queueUdp) +import Hans.Udp.Packet +import Hans.Types + +import Control.Monad (unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + + +{-# SPECIALIZE processUdp :: NetworkStack -> Device -> IP4 -> IP4 + -> S.ByteString -> Hans Bool #-} + +-- | Process a message destined for the UDP layer. When the message cannot be +-- routed, 'False' is returned. +processUdp :: Network addr + => NetworkStack -> Device -> addr -> addr -> S.ByteString -> Hans Bool +processUdp ns dev src dst bytes = + do let checksum = finalizeChecksum $ extendChecksum bytes + $ pseudoHeader src dst PROT_UDP + $ S.length bytes + + unless (coUdp (view rxOffload dev) || checksum == 0) + (dropPacket (devStats dev)) + + ((hdr,payloadLen),payload) <- decode' (devStats dev) getUdpHeader bytes + + let local = toAddr dst + remote = toAddr src + + -- attempt to find a destination for this packet + io (routeMsg ns dev local remote hdr (S.take payloadLen payload)) + +routeMsg :: NetworkStack -> Device -> Addr -> Addr -> UdpHeader -> S.ByteString -> IO Bool +routeMsg ns dev local remote hdr payload = + do mb <- lookupRecv ns remote (udpDestPort hdr) + case mb of + + -- XXX: which stat should increment when writeChunk fails? + Just buf -> + do _ <- DG.writeChunk buf (dev,remote,udpSourcePort hdr,local,udpDestPort hdr) payload + return True + + -- Check to see if there's a forwarding rule to use + Nothing -> + do mbFwd <- tryForwardUdp ns local remote hdr + case mbFwd of + Just (ri,dst',hdr') -> queueUdp ns ri dst' hdr' (L.fromStrict payload) + Nothing -> return False diff --git a/src/Hans/Udp/Output.hs b/src/Hans/Udp/Output.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Udp/Output.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Udp.Output ( + primSendUdp, + + -- ** Fast-path Output + responder, + queueUdp, + ) where + +import Hans.Addr.Types (Addr) +import Hans.Checksum (finalizeChecksum,extendChecksum) +import Hans.Device.Types (ChecksumOffload(..),txOffload) +import Hans.Lens (view) +import Hans.Network +import Hans.Serialize (runPutPacket) +import Hans.Udp.Packet +import Hans.Types + +import qualified Control.Concurrent.BoundedChan as BC +import Control.Monad (forever) +import qualified Data.ByteString.Lazy as L +import Data.Serialize (putWord16be) + + +-- Fast-path Output ------------------------------------------------------------ + +responder :: NetworkStack -> IO () +responder ns = forever $ + do msg <- BC.readChan chan + case msg of + SendDatagram ri dst hdr body -> + do _ <- sendUdp ns ri dst hdr body + return () + + where + chan = view udpQueue ns + +queueUdp :: NetworkStack -> RouteInfo Addr -> Addr -> UdpHeader -> L.ByteString + -> IO Bool +queueUdp ns ri dst hdr body + -- XXX should this record an error? + | L.length body > 65527 = return False + | otherwise = BC.tryWriteChan (view udpQueue ns) + $! SendDatagram ri dst hdr body + + +-- Output ---------------------------------------------------------------------- + +-- | Send Udp over IP4 with a pre-computed route. +primSendUdp :: Network addr + => NetworkStack + -> RouteInfo addr + -> addr -- ^ Destination addr + -> UdpPort -- ^ Source port + -> UdpPort -- ^ Destination port + -> L.ByteString -- ^ Payload + -> IO Bool +primSendUdp ns ri dst udpSourcePort udpDestPort payload + -- XXX should this record an error? + | L.length payload > 65527 = return False + | otherwise = sendUdp ns ri dst UdpHeader { udpChecksum = 0, .. } payload + + +sendUdp :: Network addr + => NetworkStack + -> RouteInfo addr -> addr + -> UdpHeader -> L.ByteString + -> IO Bool +sendUdp ns ri dst hdr payload = + do let bytes = renderUdpPacket (view txOffload ri) + (riSource ri) dst hdr payload + + sendDatagram ns ri dst False PROT_UDP bytes + + return True + + +-- | Given a way to make the pseudo header, render the UDP packet. +renderUdpPacket :: Network addr + => ChecksumOffload -> addr -> addr -> UdpHeader -> L.ByteString + -> L.ByteString +renderUdpPacket ChecksumOffload { .. } src dst hdr body + | coUdp = bytes + | otherwise = beforeCS `L.append` withCS + + where + + pktlen = fromIntegral (L.length body) + bytes = runPutPacket udpHeaderSize 0 body (putUdpHeader hdr pktlen) + + udplen = udpHeaderSize + pktlen + cs = finalizeChecksum + $ extendChecksum bytes + $ pseudoHeader src dst PROT_UDP udplen + + beforeCS = L.take (fromIntegral udpHeaderSize - 2) bytes + afterCS = L.drop (fromIntegral udpHeaderSize ) bytes + + withCS = runPutPacket 2 0 afterCS (putWord16be cs) diff --git a/src/Hans/Udp/Packet.hs b/src/Hans/Udp/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Udp/Packet.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} + +module Hans.Udp.Packet where + +import Data.Serialize (Get,getWord16be,label,Putter,Put,putWord16be) +import Data.Word (Word16) + + +-- Udp Ports ------------------------------------------------------------------- + +type UdpPort = Word16 + +getUdpPort :: Get UdpPort +getUdpPort = getWord16be +{-# INLINE getUdpPort #-} + +putUdpPort :: Putter UdpPort +putUdpPort = putWord16be +{-# INLINE putUdpPort #-} + + +-- Udp Header ------------------------------------------------------------------ + +data UdpHeader = UdpHeader { udpSourcePort :: {-# UNPACK #-} !UdpPort + , udpDestPort :: {-# UNPACK #-} !UdpPort + , udpChecksum :: {-# UNPACK #-} !Word16 + } deriving (Eq,Show) + +emptyUdpHeader :: UdpHeader +emptyUdpHeader = UdpHeader { udpSourcePort = 0 + , udpDestPort = 0 + , udpChecksum = 0 } + +udpHeaderSize :: Int +udpHeaderSize = 8 + +-- | Parse out a @UdpHeader@, and the size of the payload. +getUdpHeader :: Get (UdpHeader,Int) +getUdpHeader = label "UDP Header" $ + do udpSourcePort <- getUdpPort + udpDestPort <- getUdpPort + len <- getWord16be + udpChecksum <- getWord16be + return (UdpHeader { .. },fromIntegral len - udpHeaderSize) + +-- | Render a @UdpHeader@. +putUdpHeader :: UdpHeader -> Int -> Put +putUdpHeader UdpHeader { .. } bodyLen = + do putUdpPort udpSourcePort + putUdpPort udpDestPort + putWord16be (fromIntegral (bodyLen + udpHeaderSize)) + putWord16be 0 diff --git a/src/Hans/Udp/State.hs b/src/Hans/Udp/State.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Udp/State.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} + +module Hans.Udp.State ( + UdpState(..), newUdpState, + HasUdpState(..), + UdpBuffer, + lookupRecv, + registerRecv, + nextUdpPort, + + -- ** Fast-path Resonder + UdpResponderRequest(..), + udpQueue, + ) where + +import Hans.Addr (NetworkAddr(..),Addr) +import qualified Hans.Buffer.Datagram as DG +import Hans.Config +import Hans.Device.Types (Device) +import qualified Hans.HashTable as HT +import Hans.Lens +import Hans.Network.Types (RouteInfo) +import Hans.Udp.Packet (UdpPort,UdpHeader) + +import Control.Concurrent (MVar,newMVar,modifyMVar) +import qualified Control.Concurrent.BoundedChan as BC +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import GHC.Generics (Generic) + + +data Key = Key !Addr !UdpPort + deriving (Eq,Show,Generic) + +instance Hashable Key + + +type UdpBuffer = DG.Buffer (Device,Addr,UdpPort,Addr,UdpPort) + +data UdpState = UdpState { udpRecv :: !(HT.HashTable Key UdpBuffer) + , udpPorts :: !(MVar UdpPort) + , udpQueue_:: !(BC.BoundedChan UdpResponderRequest) + } + +data UdpResponderRequest = SendDatagram !(RouteInfo Addr) !Addr !UdpHeader !L.ByteString + + +newUdpState :: Config -> IO UdpState +newUdpState Config { .. } = + do udpRecv <- HT.newHashTable cfgUdpSocketTableSize + udpPorts <- newMVar 32767 + udpQueue_<- BC.newBoundedChan 128 + return $! UdpState { .. } + + +class HasUdpState udp where + udpState :: Getting r udp UdpState + +instance HasUdpState UdpState where + udpState = id + {-# INLINE udpState #-} + +udpQueue :: HasUdpState state => Getting r state (BC.BoundedChan UdpResponderRequest) +udpQueue = udpState . to udpQueue_ + +lookupRecv :: HasUdpState state + => state -> Addr -> UdpPort -> IO (Maybe UdpBuffer) +lookupRecv state addr dstPort = + do mb <- HT.lookup (Key addr dstPort) (udpRecv (view udpState state)) + case mb of + + -- there was a receiver waiting on this address and port + Just _ -> return mb + + -- try the generic receiver for that port + Nothing -> do + mb' <- HT.lookup (Key (wildcardAddr addr) dstPort) + (udpRecv (view udpState state)) + return mb' + + +-- | Register a listener for messages to this address and port, returning 'Just' +-- an action to unregister the listener on success. +registerRecv :: HasUdpState state + => state -> Addr -> UdpPort -> UdpBuffer -> IO (Maybe (IO ())) +registerRecv state addr srcPort buf = + do registered <- HT.alter update key table + if registered + then return (Just (HT.delete key table)) + else return Nothing + where + table = udpRecv (view udpState state) + + key = Key addr srcPort + + update mb@Just{} = (mb,False) + update Nothing = (Just buf,True) + + +-- Port Management ------------------------------------------------------------- + +nextUdpPort :: HasUdpState state => state -> Addr -> IO (Maybe UdpPort) +nextUdpPort state addr = + modifyMVar udpPorts (pickFreshPort udpRecv addr) + where + UdpState { .. } = view udpState state + +pickFreshPort :: HT.HashTable Key UdpBuffer -> Addr -> UdpPort + -> IO (UdpPort, Maybe UdpPort) +pickFreshPort ht addr p0 = go 0 p0 + where + + mkKey1 = Key addr + mkKey2 = Key (wildcardAddr addr) + + check + | isWildcardAddr addr = \port -> HT.hasKey (mkKey1 port) ht + | otherwise = \port -> + do used <- HT.hasKey (mkKey1 port) ht + if not used + then HT.hasKey (mkKey2 port) ht + else return True + + go :: Int -> UdpPort -> IO (UdpPort,Maybe UdpPort) + go i _ | i > 65535 = return (p0, Nothing) + go i 0 = go (i+1) 1025 + go i port = + do used <- check port + if not used + then return (port, Just port) + else go (i + 1) (port + 1) diff --git a/src/Hans/Utils.hs b/src/Hans/Utils.hs deleted file mode 100644 --- a/src/Hans/Utils.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Hans.Utils where - -import Control.Monad (MonadPlus(mzero)) -import Numeric (showHex) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S - -type DeviceName = String - --- | Pseudo headers are constructed strictly. -type MkPseudoHeader = Int -> S.ByteString - -type Endo a = a -> a - --- | Discard the result of a monadic computation. -void :: Monad m => m a -> m () -void m = m >> return () - --- | Show a single hex number, padded with a leading 0. -showPaddedHex :: (Integral a, Show a) => a -> ShowS -showPaddedHex x - | x < 0x10 = showChar '0' . base - | otherwise = base - where base = showHex x - --- | Lift a maybe into MonadPlus -just :: MonadPlus m => Maybe a -> m a -just = maybe mzero return - --- | Make a singleton list. -singleton :: a -> [a] -singleton x = [x] - --- | Make a lazy bytestring from a strict one. -chunk :: S.ByteString -> L.ByteString -chunk bs = L.fromChunks [bs] - -strict :: L.ByteString -> S.ByteString -strict = S.concat . L.toChunks diff --git a/src/Hans/Utils/Checksum.hs b/src/Hans/Utils/Checksum.hs deleted file mode 100644 --- a/src/Hans/Utils/Checksum.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- BANNERSTART --- - Copyright 2006-2008, 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. --- Author: Adam Wick --- BANNEREND --- |A module providing checksum computations to other parts of Hans. The --- checksum here is the standard Internet 16-bit checksum (the one's --- 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 - - --- | Clear the two bytes at the checksum offset of a rendered packet. -clearChecksum :: S.ByteString -> Int -> IO S.ByteString -clearChecksum b off = S.unsafeUseAsCStringLen b $ \(ptr,len) -> do - assert (len > off + 1) (pokeByteOff ptr off (0 :: Word16)) - return b - --- | Poke a checksum into a bytestring. -pokeChecksum :: Word16 -> S.ByteString -> Int -> IO S.ByteString -pokeChecksum cs b off = S.unsafeUseAsCStringLen b $ \(ptr,len) -> do - 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 = 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 :: 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 = PartialChecksum - { pcAccum = loop (fromIntegral (pcAccum pc)) 0 - , pcCarry = carry - } - - carry - | odd n' = Just (S.unsafeIndex b (n' - 1)) - | otherwise = Nothing - - loop !acc off - | off < n = loop (step acc hi lo) (off + 2) - | otherwise = acc - where hi = S.unsafeIndex b off - lo = S.unsafeIndex b (off+1) - n = clearBit n' 0 - -step :: Word32 -> Word8 -> Word8 -> Word32 -step acc hi lo = acc + fromIntegral hi `shiftL` 8 + fromIntegral lo - -fold32 :: Word32 -> Word32 -fold32 x = (x .&. 0xFFFF) + (x `shiftR` 16) diff --git a/tcp-test-client/Main.hs b/tcp-test-client/Main.hs deleted file mode 100644 --- a/tcp-test-client/Main.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Control.Concurrent (forkIO,killThread,threadDelay) -import qualified Control.Exception as X -import Control.Monad (replicateM,when) -import qualified Data.ByteString.Char8 as S -import qualified Data.Foldable as F -import Network (withSocketsDo,connectTo,PortID(..)) -import System.Environment (getArgs) -import System.IO (hPutStrLn,hGetLine,hClose) - -main = withSocketsDo $ - do [addr] <- getArgs - - X.bracket (replicateM 100 (forkClient addr)) - (mapM_ killThread) $ \ _ -> - - do _ <- getLine - return () - -forkClient addr = - do tid <- forkIO (createClient addr) - threadDelay (100 * 1000) - return tid - -createClient addr = - X.bracket (connectTo addr (PortNumber 9001)) hClose $ \ conn -> - F.forM_ (cycle ["foo", "bar", "baz", "ASDF"]) $ \ str -> - do S.hPutStrLn conn str - str' <- S.hGetLine conn - when (str /= str') $ - do putStrLn "Invalid echo server response:" - putStr " expected: " >> S.putStrLn str - putStr " received: " >> S.putStrLn str' diff --git a/tcp-test/Main.hs b/tcp-test/Main.hs deleted file mode 100644 --- a/tcp-test/Main.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# 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 (threadDelay,forkIO) - -import Control.Monad (forever) -import System.Environment (getArgs) -import qualified Data.ByteString.Lazy as L -import qualified Control.Exception as X - -localAddr :: IP4 -localAddr = IP4 192 168 90 2 - -main :: IO () -main = do - - ns <- newNetworkStack - mac <- initEthernetDevice ns - deviceUp ns mac - putStrLn "Network stack running..." - - args <- getArgs - if args == ["dhcp"] - then do putStrLn "Discovering address" - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just ip -> do - putStrLn ("Bound to address: " ++ show ip) - - -- putStrLn "Looking up galois.com..." - -- HostEntry { .. } <- getHostByName ns "galois.com" - -- print hostAddresses - - - 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 `X.catch` \se -> do print (se :: X.SomeException) - close conn - where - loop = - do buf <- recvBytes conn 512 - if L.null buf - then putStrLn "Client closed connection" - else do _ <- sendBytes conn buf - loop - -message :: L.ByteString -message = "Hello, world\n" - -sleep :: Int -> IO () -sleep s = threadDelay (s * 1000 * 1000) - -setAddress :: Mac -> NetworkStack -> IO () -setAddress mac ns = do - addIP4Addr ns (localAddr `withMask` 24) mac 1500 - routeVia ns (IP4 0 0 0 0 `withMask` 0) (IP4 192 168 90 1) - -#ifdef HaLVM_HOST_OS -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = - do xs <- initXenStore - _ <- initXenConsole -- should set up putStrLn - nics <- listNICs xs - case nics of - [] -> fail "No NICs found to use!" - (macstr:_) -> - do let mac = read macstr - nic <- openNIC xs macstr - addDevice ns mac (xenSend nic) (xenReceiveLoop nic) - return mac -#else -initEthernetDevice :: NetworkStack -> IO Mac -initEthernetDevice ns = do - let mac = Mac 0x52 0x54 0x00 0x12 0x34 0x56 - Just dev <- openTapDevice "tap6" - addDevice ns mac (tapSend dev) (tapReceiveLoop dev) - return mac -#endif diff --git a/tests/IP4.hs b/tests/IP4.hs deleted file mode 100644 --- a/tests/IP4.hs +++ /dev/null @@ -1,11 +0,0 @@ -module IP4 where - -import IP4.Packet - -import Test.Framework (Test,testGroup) - - -ip4Tests :: Test -ip4Tests = testGroup "ip4" - [ ip4PacketTests - ] diff --git a/tests/IP4/Addr.hs b/tests/IP4/Addr.hs deleted file mode 100644 --- a/tests/IP4/Addr.hs +++ /dev/null @@ -1,15 +0,0 @@ -module IP4.Addr where - -import Hans.Address.IP4 - -import Control.Applicative ((<$>),(<*>)) -import System.Random () -import Test.QuickCheck (Gen,arbitraryBoundedRandom) - - -arbitraryIP4 :: Gen IP4 -arbitraryIP4 = IP4 - <$> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom diff --git a/tests/IP4/Packet.hs b/tests/IP4/Packet.hs deleted file mode 100644 --- a/tests/IP4/Packet.hs +++ /dev/null @@ -1,66 +0,0 @@ -module IP4.Packet where - -import IP4.Addr -import Utils - -import Hans.Message.Ip4 - -import Control.Applicative ((<$>)) -import Data.Word (Word16) -import System.Random () -import Test.Framework (Test,testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Gen,arbitrary,arbitraryBoundedRandom,choose,forAll) - - --- Packet Generation ----------------------------------------------------------- - -arbitraryIP4Header :: Gen IP4Header -arbitraryIP4Header = do - tos <- arbitraryBoundedRandom - ident <- arbitraryIdent - df <- arbitrary - mf <- arbitrary - off <- arbitraryFragmentOffset - ttl <- arbitraryBoundedRandom - prot <- arbitraryIP4Protocol - src <- arbitraryIP4 - dst <- arbitraryIP4 - return emptyIP4Header - { ip4TypeOfService = tos - , ip4DontFragment = df - , ip4MoreFragments = mf - , ip4FragmentOffset = off - , ip4TimeToLive = ttl - , ip4Protocol = prot - , ip4SourceAddr = src - , ip4DestAddr = dst - } - -arbitraryIdent :: Gen Ident -arbitraryIdent = Ident <$> arbitraryBoundedRandom - -arbitraryFragmentOffset :: Gen Word16 -arbitraryFragmentOffset = (8*) <$> choose (0,0x1fff) - -arbitraryIP4Protocol :: Gen IP4Protocol -arbitraryIP4Protocol = IP4Protocol <$> arbitraryBoundedRandom - -arbitraryIP4PacketLen :: Gen Int -arbitraryIP4PacketLen = choose (0,65535 - 20) - - --- Packet Tests ---------------------------------------------------------------- - -ip4PacketTests :: Test -ip4PacketTests = testGroup "packet parsing" - [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip - ] - -prop_headerRoundTrip = forAll arbitraryIP4PacketLen $ \ pktLen -> - let parse = do - (hdr,_,_) <- getIP4Packet - return hdr - render hdr = putIP4Header hdr pktLen - in roundTrip arbitraryIP4Header parse render - diff --git a/tests/Icmp4.hs b/tests/Icmp4.hs deleted file mode 100644 --- a/tests/Icmp4.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Icmp4 where - -import Icmp4.Packet (icmp4PacketTests) - -import Test.Framework (Test,testGroup) - - -icmp4Tests :: Test -icmp4Tests = testGroup "icmp4" - [ icmp4PacketTests - ] diff --git a/tests/Icmp4/Packet.hs b/tests/Icmp4/Packet.hs deleted file mode 100644 --- a/tests/Icmp4/Packet.hs +++ /dev/null @@ -1,139 +0,0 @@ -module Icmp4.Packet where - -import IP4.Addr -import Utils - -import Hans.Message.Icmp4 -import Hans.Message.Types (Lifetime(..)) - -import Control.Applicative ((<$>),(<*>),pure) -import System.Random () -import Test.Framework (Test,testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck - (Gen,oneof,arbitraryBoundedRandom,elements,listOf,listOf1,vectorOf) -import qualified Data.ByteString as S - - --- Packet Generation ----------------------------------------------------------- - -arbitraryIcmp4Packet :: Gen Icmp4Packet -arbitraryIcmp4Packet = oneof - [ EchoReply <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - <*> arbitraryEchoPayload - , DestinationUnreachable <$> arbitraryDestinationUnreachableCode - <*> arbitraryPayload - , SourceQuench <$> arbitraryPayload - , Redirect <$> arbitraryRedirectCode - <*> arbitraryIP4 - <*> arbitraryPayload - , Echo <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - <*> arbitraryEchoPayload - , RouterAdvertisement <$> arbitraryLifetime - <*> listOf1 arbitraryRouterAddress - , pure RouterSolicitation - , TimeExceeded <$> arbitraryTimeExceededCode - <*> arbitraryPayload - , ParameterProblem <$> arbitraryBoundedRandom - <*> arbitraryPayload - , Timestamp <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - , TimestampReply <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - , Information <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - , InformationReply <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - , TraceRoute <$> arbitraryTraceRouteCode - <*> arbitraryIdentifier - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - <*> arbitraryBoundedRandom - , AddressMask <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - , AddressMaskReply <$> arbitraryIdentifier - <*> arbitrarySequenceNumber - <*> arbitraryBoundedRandom - ] - -arbitraryIdentifier :: Gen Identifier -arbitraryIdentifier = Identifier <$> arbitraryBoundedRandom - -arbitrarySequenceNumber :: Gen SequenceNumber -arbitrarySequenceNumber = SequenceNumber <$> arbitraryBoundedRandom - -arbitraryEchoPayload :: Gen S.ByteString -arbitraryEchoPayload = S.pack <$> listOf arbitraryBoundedRandom - -arbitraryPayload :: Gen S.ByteString -arbitraryPayload = S.pack <$> vectorOf 28 arbitraryBoundedRandom - -arbitraryDestinationUnreachableCode :: Gen DestinationUnreachableCode -arbitraryDestinationUnreachableCode = elements - [ NetUnreachable - , HostUnreachable - , ProtocolUnreachable - , PortUnreachable - , FragmentationUnreachable - , SourceRouteFailed - , DestinationNetworkUnknown - , DestinationHostUnknown - , SourceHostIsolatedError - , AdministrativelyProhibited - , HostAdministrativelyProhibited - , NetworkUnreachableForTOS - , HostUnreachableForTOS - , CommunicationAdministrativelyProhibited - , HostPrecedenceViolation - , PrecedenceCutoffInEffect - ] - -arbitraryRedirectCode :: Gen RedirectCode -arbitraryRedirectCode = elements - [ RedirectForNetwork - , RedirectForHost - , RedirectForTypeOfServiceAndNetwork - , RedirectForTypeOfServiceAndHost - ] - -arbitraryLifetime :: Gen Lifetime -arbitraryLifetime = Lifetime <$> arbitraryBoundedRandom - -arbitraryRouterAddress :: Gen RouterAddress -arbitraryRouterAddress = RouterAddress - <$> arbitraryIP4 - <*> arbitraryPreferenceLevel - -arbitraryPreferenceLevel :: Gen PreferenceLevel -arbitraryPreferenceLevel = PreferenceLevel <$> arbitraryBoundedRandom - -arbitraryTimeExceededCode :: Gen TimeExceededCode -arbitraryTimeExceededCode = elements - [ TimeToLiveExceededInTransit - , FragmentReassemblyTimeExceeded - ] - -arbitraryTraceRouteCode :: Gen TraceRouteCode -arbitraryTraceRouteCode = elements - [ TraceRouteForwarded - , TraceRouteDiscarded - ] - --- Packet Tests ---------------------------------------------------------------- - -icmp4PacketTests :: Test -icmp4PacketTests = testGroup "packet parsing" - [ testProperty "roundTrip" prop_roundTrip - ] - -prop_roundTrip = - roundTrip arbitraryIcmp4Packet getIcmp4Packet putIcmp4Packet diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,16 +1,18 @@ module Main where -import Icmp4 (icmp4Tests) -import IP4 (ip4Tests) -import Tcp (tcpTests) -import Udp (udpTests) +import Tests.Checksum +import Tests.Ethernet +import Tests.IP4 -import Test.Framework (defaultMain) +import Test.Tasty +import Test.Tasty.Runners (consoleTestReporter) +import Test.Tasty.Runners.AntXML (antXMLRunner) -main = defaultMain - [ tcpTests - , udpTests - , icmp4Tests - , ip4Tests - ] +main :: IO () +main = defaultMainWithIngredients [antXMLRunner,consoleTestReporter] $ + testGroup "Properties" + [ checksumTests + , ethernetTests + , ip4Tests + ] diff --git a/tests/Tcp.hs b/tests/Tcp.hs deleted file mode 100644 --- a/tests/Tcp.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Tcp ( - tcpTests - ) where - -import Tcp.Packet -import Tcp.Window - -import Test.Framework (Test,testGroup) - -tcpTests :: Test -tcpTests = testGroup "tcp" - [ tcpPacketTests - , tcpWindowTests - ] diff --git a/tests/Tcp/Packet.hs b/tests/Tcp/Packet.hs deleted file mode 100644 --- a/tests/Tcp/Packet.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Tcp.Packet where - -import Utils - -import Hans.Message.Tcp - (TcpHeader(..),emptyTcpHeader,TcpPort(..),TcpOption(..),SackBlock(..) - ,getTcpHeader,putTcpHeader,getTcpOption,putTcpOption,tcpOptionsLength) - -import Control.Applicative (pure,(<*>),(<$>)) -import Control.Monad (replicateM) -import Data.Serialize (runGet,runPut) -import Data.Word (Word8) -import System.Random () -import Test.Framework (Test,testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck - (Gen,choose,arbitrarySizedIntegral,sized,arbitrary,listOf,oneof,forAll - ,suchThat) -import Test.QuickCheck.Property (Result(..),failed,succeeded) -import qualified Data.ByteString as S -import qualified Data.Sequence as Seq - - --- Utilities ------------------------------------------------------------------- - --- | Generate a strict bytestring of nonzero length, that falls within the MSS --- off the HaNS tcp layer. -arbitraryPayload :: Gen S.ByteString -arbitraryPayload = do - len <- choose (1,10) - S.pack `fmap` replicateM len arbitrarySizedIntegral - --- | Generate the starting point of a data packet stream. -arbitraryDataPacket :: Gen (TcpHeader,S.ByteString) -arbitraryDataPacket = do - body <- arbitraryPayload - sn <- arbitrarySizedIntegral - an <- arbitrarySizedIntegral - let hdr = emptyTcpHeader - { tcpSeqNum = sn - , tcpAckNum = an - , tcpAck = True - } - return (hdr,body) - --- | Increment the sequence number, and generate some new data. -nextDataPacket :: (TcpHeader,S.ByteString) -> Gen (TcpHeader,S.ByteString) -nextDataPacket (hdr,body) = do - body' <- arbitraryPayload - let hdr' = hdr { tcpSeqNum = tcpSeqNum hdr + fromIntegral (S.length body) } - return (hdr',body') - --- | Generate a sequence of headers and packet payloads. This will yield a --- non-empty stream whose length depends on the size parameter. -packetStream :: Gen (Seq.Seq (TcpHeader,S.ByteString)) -packetStream = do - pkt@(hdr,body) <- arbitraryDataPacket - sized (loop Seq.empty pkt) - where - loop segs pkt len - | len == 0 = return (segs Seq.|> pkt) - | otherwise = do - pkt' <- nextDataPacket pkt - loop (segs Seq.|> pkt) pkt' (len - 1) - - -arbitraryTcpPort :: Gen TcpPort -arbitraryTcpPort = TcpPort `fmap` arbitrarySizedIntegral - --- | Generate a completely arbitrary header. This may be a semantically --- incorrect header, and is mainly useful for testing the parser. -arbitraryTcpHeader :: Gen TcpHeader -arbitraryTcpHeader = TcpHeader - <$> arbitraryTcpPort - <*> arbitraryTcpPort - <*> arbitrarySizedIntegral - <*> arbitrarySizedIntegral - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrarySizedIntegral - <*> pure 0 -- checksum - <*> pure 0 -- urgent pointer - <*> arbitraryTcpOptions - -arbitraryTcpOptions :: Gen [TcpOption] -arbitraryTcpOptions = listOf arbitraryTcpOption `suchThat` (not . tooBig) - where - tooBig opts = fst (tcpOptionsLength opts) > 10 - -arbitraryTcpOption :: Gen TcpOption -arbitraryTcpOption = oneof - [ pure OptNoOption - , OptMaxSegmentSize <$> arbitrarySizedIntegral - , OptWindowScaling <$> arbitrarySizedIntegral - , pure OptSackPermitted - , do len <- choose (0,10) - OptSack <$> replicateM len arbitrarySackBlock - , OptTimestamp <$> arbitrarySizedIntegral - <*> arbitrarySizedIntegral - , do code <- unusedTcpOptionNumber - len <- choose (0, 20) - bytes <- replicateM (fromIntegral len) arbitrarySizedIntegral - return (OptUnknown code (len + 2) (S.pack bytes)) - ] - --- | Choose an unused tcp option number. -unusedTcpOptionNumber :: Gen Word8 -unusedTcpOptionNumber = - arbitrarySizedIntegral `suchThat` (not . (`elem` avoid)) - where - -- it would be nice if this could could be generated from TcpOptionTag - avoid = [0, 1, 2, 3, 4, 5, 8] - -arbitrarySackBlock :: Gen SackBlock -arbitrarySackBlock = SackBlock - <$> arbitrarySizedIntegral - <*> arbitrarySizedIntegral - - --- Properties ------------------------------------------------------------------ - -tcpPacketTests :: Test -tcpPacketTests = testGroup "packet parsing" - [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip - , testProperty "prop_optionRoundTrip" prop_optionRoundTrip - ] - -prop_headerRoundTrip = - roundTrip arbitraryTcpHeader (fst <$> getTcpHeader) putTcpHeader - -prop_optionRoundTrip = - roundTrip arbitraryTcpOption getTcpOption putTcpOption diff --git a/tests/Tcp/Window.hs b/tests/Tcp/Window.hs deleted file mode 100644 --- a/tests/Tcp/Window.hs +++ /dev/null @@ -1,61 +0,0 @@ -module Tcp.Window where - -import Tcp.Packet - -import Hans.Layer.Tcp.Window - (emptyLocalWindow,addInSegment,stepWindow,InSegment(..) - ,localWindowSackBlocks) -import Hans.Message.Tcp (TcpHeader(..)) - -import Control.Arrow ((&&&)) -import Test.Framework (Test,testGroup) -import Test.QuickCheck (forAll) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import qualified Data.ByteString as S -import qualified Data.Foldable as F -import qualified Data.Sequence as Seq - - -tcpWindowTests :: Test -tcpWindowTests = testGroup "tcp window" - [ testProperty "prop_localOrdered" prop_localOrdered - , testProperty "prop_localRandom" prop_localRandom - , testProperty "prop_sackOrdered" prop_sackOrdered - ] - - --- Local Window ---------------------------------------------------------------- - -fromInSegment :: InSegment -> (TcpHeader,S.ByteString) -fromInSegment = inHeader &&& inBody - --- | Check that if a stream of packets goes into the @LocalWindow@ in order, --- that they will come out in the same order. -prop_localOrdered = forAll packetStream $ \ segs -> - let (hdr,_) = Seq.index segs 0 - win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 - step w (h,body) = addInSegment h body w - win' = F.foldl step win segs - (segs',_) = stepWindow win' - in segs == fmap fromInSegment segs' - --- | Check that if a stream of initially ordered packets goes into the --- @LocalWindow@ in a random order, that they come out ordered again. In this --- case, we just reverse the stream, as that should be the degenrate case for --- incoming packets. -prop_localRandom = forAll packetStream $ \ segs -> - let (hdr,_) = Seq.index segs 0 - win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 - step (h,body) w = addInSegment h body w - win' = F.foldr step win segs - (segs',_) = stepWindow win' - in segs == fmap fromInSegment segs' - --- | Generating a sequence of sack blocks from a window constructed of in-order --- packets should generate a single sack block. -prop_sackOrdered = forAll packetStream $ \ segs -> - let (hdr,_) = Seq.index segs 0 - win = emptyLocalWindow (tcpSeqNum hdr) 14600 0 - step w (h,body) = addInSegment h body w - win' = F.foldl step win segs - in Seq.length (localWindowSackBlocks win') == 1 diff --git a/tests/Tests/Checksum.hs b/tests/Tests/Checksum.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Checksum.hs @@ -0,0 +1,20 @@ +module Tests.Checksum where + +import Hans.Checksum (computeChecksum) + +import Data.Serialize (runPut,putWord32be,putWord16be) +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck + + +checksumTests :: TestTree +checksumTests = testGroup "Checksum" + [ testProperty "Word16" $ + forAll arbitraryBoundedRandom $ \ w16 -> + computeChecksum (runPut (putWord16be w16)) === computeChecksum w16 + + , testProperty "Word32" $ + forAll arbitraryBoundedRandom $ \ w32 -> + computeChecksum (runPut (putWord32be w32)) === computeChecksum w32 + ] diff --git a/tests/Tests/Ethernet.hs b/tests/Tests/Ethernet.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Ethernet.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RecordWildCards #-} + +module Tests.Ethernet where + +import Tests.Utils (encodeDecodeIdentity,showReadIdentity) + +import Hans.Ethernet + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) + + +arbitraryMac :: Gen Mac +arbitraryMac = + do a <- arbitraryBoundedIntegral + b <- arbitraryBoundedIntegral + c <- arbitraryBoundedIntegral + d <- arbitraryBoundedIntegral + e <- arbitraryBoundedIntegral + f <- arbitraryBoundedIntegral + return (Mac a b c d e f) + +arbitrayEthernetHeader :: Gen EthernetHeader +arbitrayEthernetHeader = + do eSource <- arbitraryMac + eDest <- arbitraryMac + eType <- arbitraryBoundedRandom + return EthernetHeader { .. } + + +-- Ethernet Properties --------------------------------------------------------- + +ethernetTests :: TestTree +ethernetTests = testGroup "Ethernet" + [ testProperty "Mac Address encode/decode" $ + encodeDecodeIdentity putMac getMac arbitraryMac + + , testProperty "Header encode/decode" $ + encodeDecodeIdentity putEthernetHeader getEthernetHeader arbitrayEthernetHeader + + , testProperty "Mac Address read/show" $ + showReadIdentity showMac readMac arbitraryMac + ] diff --git a/tests/Tests/IP4.hs b/tests/Tests/IP4.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/IP4.hs @@ -0,0 +1,15 @@ +module Tests.IP4 (ip4Tests) where + +import Tests.IP4.Fragmentation (fragTests) +import Tests.IP4.Icmp4 (icmp4Tests) +import Tests.IP4.Packet (packetTests) + +import Test.Tasty + + +ip4Tests :: TestTree +ip4Tests = testGroup "IP4" + [ packetTests + , fragTests + , icmp4Tests + ] diff --git a/tests/Tests/IP4/Fragmentation.hs b/tests/Tests/IP4/Fragmentation.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/IP4/Fragmentation.hs @@ -0,0 +1,58 @@ +module Tests.IP4.Fragmentation where + +import Tests.IP4.Packet +import Tests.Network + +import Hans.Config +import Hans.IP4.Fragments +import Hans.IP4.Packet +import Hans.Monad (runHansOnce) + +import qualified Data.ByteString.Lazy as L +import Data.Maybe (catMaybes) +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck +import Test.QuickCheck.Monadic + + +fragTests :: TestTree +fragTests = testGroup "Fragmentation" + [ testProperty "Reassembly" propReassemble + ] + + +propReassemble :: Property +propReassemble = monadicIO $ + do src <- pick arbitraryIP4 + dst <- pick arbitraryIP4 + prot <- pick arbitraryProtocol + ident <- pick arbitraryIdent + + len <- pick (choose (100,1500)) + + -- path mtu must be at least 68 (28 for header, and 40 for options) + mtu <- pick (choose (68,len)) + bytes <- pick (arbitraryPayload len) + + let hdr = emptyIP4Header { ip4DestAddr = dst + , ip4SourceAddr = src + , ip4Protocol = prot + , ip4Ident = ident + } + + chunks = [(h,L.toStrict body) | (h,body) <- splitPacket mtu hdr bytes] + + incoming <- pick (shuffle chunks) + table <- run (newFragTable defaultConfig) + + results <- run $ sequence [ runHansOnce (processFragment table fhdr body) + | (fhdr,body) <- incoming ] + + run (cleanupFragTable table) + + -- we should only get a single successful result here, otherwise something + -- is wrong with the way that fragments are being collected + case catMaybes results of + [(_,result)] -> return (L.fromStrict result == bytes) + _ -> return False diff --git a/tests/Tests/IP4/Icmp4.hs b/tests/Tests/IP4/Icmp4.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/IP4/Icmp4.hs @@ -0,0 +1,167 @@ +module Tests.IP4.Icmp4 where + +import Tests.IP4.Packet (arbitraryIP4) +import Tests.Utils + +import Hans.IP4.Icmp4 + +import qualified Data.ByteString as S +import Test.Tasty (TestTree,testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Test.QuickCheck + (Gen,oneof,arbitraryBoundedRandom,elements,listOf,listOf1 + ,vectorOf) + + +-- Packet Generation ----------------------------------------------------------- + +arbitraryIcmp4Packet :: Gen Icmp4Packet +arbitraryIcmp4Packet = oneof + [ do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + c <- arbitraryEchoPayload + return $! EchoReply a b c + + , do a <- arbitraryDestinationUnreachableCode + b <- arbitraryPayload + return $! DestinationUnreachable a b + + , do a <- arbitraryPayload + return $! SourceQuench a + + , do a <- arbitraryRedirectCode + b <- arbitraryIP4 + c <- arbitraryPayload + return $! Redirect a b c + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + c <- arbitraryEchoPayload + return $! Echo a b c + + , do a <- arbitraryBoundedRandom + b <- listOf1 arbitraryRouterAddress + return $! RouterAdvertisement a b + + , return RouterSolicitation + + , do a <- arbitraryTimeExceededCode + b <- arbitraryPayload + return $! TimeExceeded a b + + , do a <- arbitraryBoundedRandom + b <- arbitraryPayload + return $! ParameterProblem a b + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + c <- arbitraryBoundedRandom + d <- arbitraryBoundedRandom + e <- arbitraryBoundedRandom + return $! Timestamp a b c d e + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + c <- arbitraryBoundedRandom + d <- arbitraryBoundedRandom + e <- arbitraryBoundedRandom + return $! TimestampReply a b c d e + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + return $! Information a b + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + return $! InformationReply a b + + , do a <- arbitraryTraceRouteCode + b <- arbitraryIdentifier + c <- arbitraryBoundedRandom + d <- arbitraryBoundedRandom + e <- arbitraryBoundedRandom + f <- arbitraryBoundedRandom + return $! TraceRoute a b c d e f + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + return $! AddressMask a b + + , do a <- arbitraryIdentifier + b <- arbitrarySequenceNumber + c <- arbitraryBoundedRandom + return $! AddressMaskReply a b c + ] + +arbitraryIdentifier :: Gen Identifier +arbitraryIdentifier = arbitraryBoundedRandom + +arbitrarySequenceNumber :: Gen SequenceNumber +arbitrarySequenceNumber = arbitraryBoundedRandom + +arbitraryEchoPayload :: Gen S.ByteString +arbitraryEchoPayload = + do bytes <- listOf arbitraryBoundedRandom + return $! S.pack bytes + +arbitraryPayload :: Gen S.ByteString +arbitraryPayload = + do bytes <- vectorOf 28 arbitraryBoundedRandom + return $! S.pack bytes + +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 + ] + +arbitraryRouterAddress :: Gen RouterAddress +arbitraryRouterAddress = + do a <- arbitraryIP4 + b <- arbitraryPreferenceLevel + return $! RouterAddress a b + +arbitraryPreferenceLevel :: Gen PreferenceLevel +arbitraryPreferenceLevel = arbitraryBoundedRandom + +arbitraryTimeExceededCode :: Gen TimeExceededCode +arbitraryTimeExceededCode = elements + [ TimeToLiveExceededInTransit + , FragmentReassemblyTimeExceeded + ] + +arbitraryTraceRouteCode :: Gen TraceRouteCode +arbitraryTraceRouteCode = elements + [ TraceRouteForwarded + , TraceRouteDiscarded + ] + +-- Packet Tests ---------------------------------------------------------------- + +icmp4Tests :: TestTree +icmp4Tests = testGroup "Icmp4" + [ testProperty "Packet encode/decode" $ + encodeDecodeIdentity putIcmp4Packet getIcmp4Packet arbitraryIcmp4Packet + ] diff --git a/tests/Tests/IP4/Packet.hs b/tests/Tests/IP4/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/IP4/Packet.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE RecordWildCards #-} + +module Tests.IP4.Packet where + +import Tests.Ethernet (arbitraryMac) +import Tests.Network (arbitraryProtocol) +import Tests.Utils (encodeDecodeIdentity,showReadIdentity) + +import Hans.IP4.Packet +import Hans.Lens + +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as Sh +import Data.Word (Word8) +import Test.QuickCheck +import Test.Tasty (testGroup,TestTree) +import Test.Tasty.QuickCheck (testProperty) + + +-- Packet Generator Support ---------------------------------------------------- + +arbitraryIP4 :: Gen IP4 +arbitraryIP4 = + do a <- arbitraryBoundedRandom + b <- arbitraryBoundedRandom + c <- arbitraryBoundedRandom + d <- arbitraryBoundedRandom + return $! packIP4 a b c d + + +arbitraryIP4Mask :: Gen IP4Mask +arbitraryIP4Mask = + do addr <- arbitraryIP4 + bits <- choose (0,32) + return (IP4Mask addr bits) + + +arbitraryIdent :: Gen IP4Ident +arbitraryIdent = arbitraryBoundedRandom + + +arbitraryPayload :: Int -> Gen L.ByteString +arbitraryPayload len = + do bytes <- vectorOf len arbitraryBoundedRandom + return (L.pack bytes) + +arbitraryOptionPayload :: Word8 -> Gen Sh.ShortByteString +arbitraryOptionPayload len = + do bytes <- vectorOf (fromIntegral len) arbitraryBoundedRandom + return (Sh.pack bytes) + + +arbitraryIP4Header :: Gen IP4Header +arbitraryIP4Header = + do ip4TypeOfService <- arbitraryBoundedRandom + ip4Ident <- arbitraryIdent + ip4TimeToLive <- arbitraryBoundedRandom + ip4Protocol <- arbitraryProtocol + ip4SourceAddr <- arbitraryIP4 + ip4DestAddr <- arbitraryIP4 + + -- checksum processing is validated by a different property + let ip4Checksum = 0 + + -- XXX need to generate options that fit within the additional 40 bytes + -- available + let ip4Options = [] + + -- set the members of the ip4Fragment_ field on the final header + df <- arbitraryBoundedRandom + mf <- arbitraryBoundedRandom + off <- choose (0,0x1fff) + let hdr = IP4Header { ip4Fragment_ = 0, .. } + + return $! set ip4DontFragment df + $! set ip4MoreFragments mf + $! set ip4FragmentOffset off hdr + + +arbitraryIP4Option :: Gen IP4Option +arbitraryIP4Option = + do ip4OptionCopied <- arbitraryBoundedRandom + ip4OptionClass <- choose (0,0x3) + ip4OptionNum <- choose (0,0x1f) + + ip4OptionData <- + if ip4OptionNum < 2 + then return Sh.empty + else do len <- choose (0, 0xff - 2) + arbitraryOptionPayload len + + return IP4Option { .. } + + +arbitraryArpPacket :: Gen ArpPacket +arbitraryArpPacket = + do arpOper <- elements [ArpRequest,ArpReply] + arpSHA <- arbitraryMac + arpSPA <- arbitraryIP4 + arpTHA <- arbitraryMac + arpTPA <- arbitraryIP4 + return ArpPacket { .. } + + +-- Packet Properties ----------------------------------------------------------- + +packetTests :: TestTree +packetTests = testGroup "Packet" + [ testProperty "IP4 Address encode/decode" $ + encodeDecodeIdentity putIP4 getIP4 arbitraryIP4 + + , let get = + do (hdr,20,0) <- getIP4Packet + return hdr + + put hdr = + putIP4Header hdr 0 + + in testProperty "Header encode/decode" $ + encodeDecodeIdentity put get arbitraryIP4Header + + , testProperty "Option encode/decode" $ + encodeDecodeIdentity putIP4Option getIP4Option arbitraryIP4Option + + , testProperty "Arp Message encode/decode" $ + encodeDecodeIdentity putArpPacket getArpPacket arbitraryArpPacket + + , testProperty "IP4 Addr read/show" $ + showReadIdentity showIP4 readIP4 arbitraryIP4 + + , testProperty "IP4 Mask read/show" $ + showReadIdentity showIP4Mask readIP4Mask arbitraryIP4Mask + ] diff --git a/tests/Tests/Network.hs b/tests/Tests/Network.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Network.hs @@ -0,0 +1,9 @@ +module Tests.Network where + +import Hans.Network.Types + +import Test.QuickCheck (Gen,arbitraryBoundedRandom) + + +arbitraryProtocol :: Gen NetworkProtocol +arbitraryProtocol = arbitraryBoundedRandom diff --git a/tests/Tests/Utils.hs b/tests/Tests/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/Utils.hs @@ -0,0 +1,20 @@ +module Tests.Utils where + +import Test.QuickCheck + +import Data.Serialize (Putter,Get,runGet,runPut) + + +encodeDecodeIdentity :: (Eq a, Show a) => Putter a -> Get a -> Gen a -> Property +encodeDecodeIdentity put get gen = + forAll gen $ \ a -> + case runGet get (runPut (put a)) of + Right a' -> a === a' + Left str -> property False + +showReadIdentity :: (Eq a, Show a) => (a -> ShowS) -> ReadS a -> Gen a -> Property +showReadIdentity sw rd gen = + forAll gen $ \ a -> + case rd (sw a "") of + [(a',_)] -> a === a' + _ -> property False diff --git a/tests/Udp.hs b/tests/Udp.hs deleted file mode 100644 --- a/tests/Udp.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Udp where - -import Udp.Packet - -import Test.Framework (Test,testGroup) - - -udpTests :: Test -udpTests = testGroup "udp" - [ udpPacketTests - ] diff --git a/tests/Udp/Packet.hs b/tests/Udp/Packet.hs deleted file mode 100644 --- a/tests/Udp/Packet.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Udp.Packet where - -import Hans.Message.Udp - (UdpHeader(..),UdpPort(..),parseUdpHeader,renderUdpHeader) - -import Control.Applicative ((<$>),(<*>)) -import Data.Serialize (runGet,runPut) -import System.Random (Random) -import Test.Framework (Test,testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Gen,forAll,arbitraryBoundedRandom,arbitrary,choose) -import Test.QuickCheck.Property (Result(..),failed,succeeded) - - --- Utilities ------------------------------------------------------------------- - -arbitraryUdpPacketSize :: (Random a, Num a) => Gen a -arbitraryUdpPacketSize = choose (0,65535 - 8) - -arbitraryUdpPort :: Gen UdpPort -arbitraryUdpPort = UdpPort <$> arbitraryBoundedRandom - -arbitraryUdpHeader :: Gen UdpHeader -arbitraryUdpHeader = UdpHeader - <$> arbitraryUdpPort - <*> arbitraryUdpPort - <*> arbitraryBoundedRandom -- not necessarily right - - --- Properties ------------------------------------------------------------------ - -udpPacketTests :: Test -udpPacketTests = testGroup "packet parsing" - [ testProperty "prop_headerRoundTrip" prop_headerRoundTrip - ] - -prop_headerRoundTrip = forAll packet $ \ (len,hdr) -> - case runGet parseUdpHeader (runPut (renderUdpHeader hdr len)) of - Right (hdr',len') | hdr == hdr' && len == len' -> succeeded - | otherwise -> failed - Left err -> failed { reason = err } - where - packet = (,) <$> arbitraryUdpPacketSize <*> arbitraryUdpHeader diff --git a/tests/Utils.hs b/tests/Utils.hs deleted file mode 100644 --- a/tests/Utils.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Utils where - -import Data.Serialize (runGet,runPut,Putter,Get) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Gen,forAll) -import Test.QuickCheck.Property (Property,Result(..),succeeded,failed) - - --- | Round trip something through cereal, making sure that rendered version --- parses to the same initial value. -roundTrip :: (Show a, Eq a) => Gen a -> Get a -> Putter a -> Property -roundTrip gen decode encode = forAll gen $ \ a -> - case runGet decode (runPut (encode a)) of - Right a' | a == a' -> succeeded - | otherwise -> failed - Left err -> failed { reason = err } diff --git a/web-server/Main.hs b/web-server/Main.hs deleted file mode 100644 --- a/web-server/Main.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} --- Copyright 2014 Galois, Inc. --- This software is distributed under a standard, three-clause BSD license. --- Please see the file LICENSE, distributed with this software, for specific --- 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 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 System.Exit -import System.Info -import Text.Blaze.Html5 as H hiding (map, main) -import Text.Blaze.Html5.Attributes(href) -import Text.Blaze.Html.Renderer.String - -#if !MIN_VERSION_base(4,8,0) -import System.Locale -#endif - -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 y = loop (fromIntegral y) 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) - - mbIP <- dhcpDiscover ns mac - case mbIP of - Nothing -> putStrLn "Couldn't get an IP address." - Just ipaddr -> do - putStrLn ("Device " ++ show mac ++ " has IP " ++ show ipaddr) - - lsock <- listen ns undefined 80 `catch` handler - forever $ do - sock <- accept lsock - putStrLn "Accepted socket." - _ <- forkIO (handleClient sock state) - _ <- forkIO (addHost ns (sockRemoteHost sock) (lastHosts state)) - return () - - 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 bod <- buildBody req state - putStrLn "Built response" - let lenstr = show (length bod) - 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 = bod - } - 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