packages feed

hans 2.6.0.0 → 3.0.2

raw patch · 134 files changed

Files

cbits/tapdevice.c view
@@ -9,8 +9,8 @@ #include <linux/if.h> #include <linux/if_tun.h> -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 <stdio.h> #include <sys/ioctl.h> #include <net/if.h>+#include <net/if_dl.h>+#include <ifaddrs.h> #include <errno.h> #include <string.h> -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) {
− echo-client/Main.hs 
@@ -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
− example/WebServer.hs 
@@ -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-               [ "<html><head><title>HaLVM</title></head><body>"-               , "<h1>Welcome to the HaLVM!</h1><br />\r\n\r\n"-               , "Started on: "-               , formatDate date-               , ", and up for "-               , uptime-               , "\r\n<h2>HTTP Request:</h2>\r\n<pre>"-               ]) `S.append` S.concat req-                  `S.append` fromString "</pre></body></html>"-    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-    ]
− example/test.hs 
@@ -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: <prog> dhcp"-      putStrLn "       <prog> <ip> <gateway>"-      exitFailure
+ examples/echo-server/Main.hs view
@@ -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
hans.cabal view
@@ -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
− src/Data/PrefixTree.hs 
@@ -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
+ src/Hans.hs view
@@ -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 #-}
+ src/Hans/Addr.hs view
@@ -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 #-}
+ src/Hans/Addr/Types.hs view
@@ -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
− src/Hans/Address.hs 
@@ -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
− src/Hans/Address/IP4.hs 
@@ -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
− src/Hans/Address/Mac.hs 
@@ -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
+ src/Hans/Buffer/Datagram.hs view
@@ -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)
+ src/Hans/Buffer/Signal.hs view
@@ -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
+ src/Hans/Buffer/Stream.hs view
@@ -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, .. }, ())
− src/Hans/Channel.hs 
@@ -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
+ src/Hans/Checksum.hs view
@@ -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 <awick@galois.com>+-- 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 #-}
+ src/Hans/Config.hs view
@@ -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 #-}+
+ src/Hans/Device.hs view
@@ -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
− src/Hans/Device/Ivc.hs 
@@ -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)
+ src/Hans/Device/Loopback.hs view
@@ -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 ()+                      , .. }
− src/Hans/Device/Tap.hs 
@@ -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-
+ src/Hans/Device/Tap.hsc view
@@ -0,0 +1,171 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Hans.Device.Tap (listDevices,openDevice) where++#include <sys/types.h>+#include <sys/uio.h>+#include <unistd.h>++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 ()
+ src/Hans/Device/Types.hs view
@@ -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)
src/Hans/Device/Xen.hs view
@@ -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
− src/Hans/DhcpClient.hs 
@@ -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
+ src/Hans/Dns.hs view
@@ -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+          , .. }
+ src/Hans/Dns/Packet.hs view
@@ -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)
+ src/Hans/Ethernet.hs view
@@ -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)
+ src/Hans/Ethernet/Types.hs view
@@ -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
+ src/Hans/HashTable.hs view
@@ -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 #-}
+ src/Hans/IP4.hs view
@@ -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(..))
+ src/Hans/IP4/ArpTable.hs view
@@ -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)
+ src/Hans/IP4/Dhcp/Client.hs view
@@ -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
+ src/Hans/IP4/Dhcp/Codec.hs view
@@ -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)
+ src/Hans/IP4/Dhcp/Options.hs view
@@ -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)
+ src/Hans/IP4/Dhcp/Packet.hs view
@@ -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)+  }
+ src/Hans/IP4/Fragments.hs view
@@ -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+           }
+ src/Hans/IP4/Icmp4.hs view
@@ -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+
+ src/Hans/IP4/Input.hs view
@@ -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
+ src/Hans/IP4/Output.hs view
@@ -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)
+ src/Hans/IP4/Packet.hs view
@@ -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 #-}
+ src/Hans/IP4/RoutingTable.hs view
@@ -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
+ src/Hans/IP4/State.hs view
@@ -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
+ src/Hans/Input.hs view
@@ -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)
− src/Hans/Layer.hs 
@@ -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)
− src/Hans/Layer/Arp.hs 
@@ -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 <protocol type, sender protocol address> 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 <protocol type,-  --           sender protocol address, sender hardware address> 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
− src/Hans/Layer/Arp/Table.hs 
@@ -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
− src/Hans/Layer/Dns.hs 
@@ -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)
− src/Hans/Layer/Ethernet.hs 
@@ -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 }
− src/Hans/Layer/IP4.hs 
@@ -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)
− src/Hans/Layer/IP4/Fragmentation.hs 
@@ -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
− src/Hans/Layer/IP4/Routing.hs 
@@ -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
− src/Hans/Layer/Icmp4.hs 
@@ -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)))
− src/Hans/Layer/Tcp.hs 
@@ -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
− src/Hans/Layer/Tcp/Handlers.hs 
@@ -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
− src/Hans/Layer/Tcp/Messages.hs 
@@ -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)
− src/Hans/Layer/Tcp/Monad.hs 
@@ -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 })
− src/Hans/Layer/Tcp/Socket.hs 
@@ -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)
− src/Hans/Layer/Tcp/Timers.hs 
@@ -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')))-    }
− src/Hans/Layer/Tcp/Types.hs 
@@ -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)
− src/Hans/Layer/Tcp/WaitBuffer.hs 
@@ -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 })
− src/Hans/Layer/Tcp/Window.hs 
@@ -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)
− src/Hans/Layer/Udp.hs 
@@ -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
+ src/Hans/Lens.hs view
@@ -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)
− src/Hans/Message/Arp.hs 
@@ -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
− src/Hans/Message/Dhcp4.hs 
@@ -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)-  }
− src/Hans/Message/Dhcp4Codec.hs 
@@ -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)
− src/Hans/Message/Dhcp4Options.hs 
@@ -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
− src/Hans/Message/Dns.hs 
@@ -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)
− src/Hans/Message/EthernetFrame.hs 
@@ -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)
− src/Hans/Message/Icmp4.hs 
@@ -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
− src/Hans/Message/Ip4.hs 
@@ -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)
− src/Hans/Message/Tcp.hs 
@@ -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-
− src/Hans/Message/Types.hs 
@@ -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
− src/Hans/Message/Udp.hs 
@@ -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
+ src/Hans/Monad.hs view
@@ -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
+ src/Hans/Nat.hs view
@@ -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
+ src/Hans/Nat/Forward.hs view
@@ -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
+ src/Hans/Nat/State.hs view
@@ -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
+ src/Hans/Network.hs view
@@ -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' #-}
+ src/Hans/Network/Types.hs view
@@ -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
− src/Hans/NetworkStack.hs 
@@ -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)
− src/Hans/Ports.hs 
@@ -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 = "<Active ports: " ++ show (portActive 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
+ src/Hans/Serialize.hs view
@@ -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)
− src/Hans/Simple.hs 
@@ -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)
+ src/Hans/Socket.hs view
@@ -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
+ src/Hans/Socket/Handle.hs view
@@ -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 "<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 ()
+ src/Hans/Socket/Tcp.hs view
@@ -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, .. }
+ src/Hans/Socket/Types.hs view
@@ -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
+ src/Hans/Socket/Udp.hs view
@@ -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 #-}++
+ src/Hans/Tcp/Input.hs view
@@ -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
+ src/Hans/Tcp/Message.hs view
@@ -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)+++-- | @<SEQ=SEG.ACK><CTL=RST>@+mkRst :: TcpHeader -> IO TcpHeader+mkRst TcpHeader { .. } =+     return $ set tcpRst True+            $ emptyTcpHeader { tcpSourcePort = tcpDestPort+                             , tcpDestPort   = tcpSourcePort+                             , tcpSeqNum     = tcpAckNum+                             }+{-# INLINE mkRst #-}+++-- | @<SEQ=0><ACK=SEG.SEQ+SEG.LEN><CTL=RST,ACK>@+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 #-}+++-- | @<SEQ=ISS><ACK=RCV.NXT><CTL=SYN,ACK>@+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 #-}
+ src/Hans/Tcp/Output.hs view
@@ -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.
+ src/Hans/Tcp/Packet.hs view
@@ -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)
+ src/Hans/Tcp/RecvWindow.hs view
@@ -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
+ src/Hans/Tcp/SendWindow.hs view
@@ -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.
+ src/Hans/Tcp/State.hs view
@@ -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))
+ src/Hans/Tcp/Tcb.hs view
@@ -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 #-}
+ src/Hans/Tcp/Timers.hs view
@@ -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 ()
+ src/Hans/Threads.hs view
@@ -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)
+ src/Hans/Time.hs view
@@ -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))
− src/Hans/Timers.hs 
@@ -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
+ src/Hans/Types.hs view
@@ -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))
+ src/Hans/Udp/Input.hs view
@@ -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
+ src/Hans/Udp/Output.hs view
@@ -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)
+ src/Hans/Udp/Packet.hs view
@@ -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
+ src/Hans/Udp/State.hs view
@@ -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)
− src/Hans/Utils.hs 
@@ -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
− src/Hans/Utils/Checksum.hs 
@@ -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 <awick@galois.com>--- 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)
− tcp-test-client/Main.hs 
@@ -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'
− tcp-test/Main.hs 
@@ -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
− tests/IP4.hs 
@@ -1,11 +0,0 @@-module IP4 where--import IP4.Packet--import Test.Framework (Test,testGroup)---ip4Tests :: Test-ip4Tests  = testGroup "ip4"-  [ ip4PacketTests-  ]
− tests/IP4/Addr.hs 
@@ -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
− tests/IP4/Packet.hs 
@@ -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-
− tests/Icmp4.hs 
@@ -1,11 +0,0 @@-module Icmp4 where--import Icmp4.Packet (icmp4PacketTests)--import Test.Framework (Test,testGroup)---icmp4Tests :: Test-icmp4Tests  = testGroup "icmp4"-  [ icmp4PacketTests-  ]
− tests/Icmp4/Packet.hs 
@@ -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
tests/Main.hs view
@@ -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+    ]
− tests/Tcp.hs 
@@ -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-  ]
− tests/Tcp/Packet.hs 
@@ -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
− tests/Tcp/Window.hs 
@@ -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
+ tests/Tests/Checksum.hs view
@@ -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+  ]
+ tests/Tests/Ethernet.hs view
@@ -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+  ]
+ tests/Tests/IP4.hs view
@@ -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+  ]
+ tests/Tests/IP4/Fragmentation.hs view
@@ -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
+ tests/Tests/IP4/Icmp4.hs view
@@ -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+  ]
+ tests/Tests/IP4/Packet.hs view
@@ -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+  ]
+ tests/Tests/Network.hs view
@@ -0,0 +1,9 @@+module Tests.Network where++import Hans.Network.Types++import Test.QuickCheck (Gen,arbitraryBoundedRandom)+++arbitraryProtocol :: Gen NetworkProtocol+arbitraryProtocol  = arbitraryBoundedRandom
+ tests/Tests/Utils.hs view
@@ -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
− tests/Udp.hs 
@@ -1,11 +0,0 @@-module Udp where--import Udp.Packet--import Test.Framework (Test,testGroup)---udpTests :: Test-udpTests  = testGroup "udp"-  [ udpPacketTests-  ]
− tests/Udp/Packet.hs 
@@ -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
− tests/Utils.hs 
@@ -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 }
− web-server/Main.hs 
@@ -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