diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2006-2011 Galois Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + diff --git a/cbits/tapdevice.c b/cbits/tapdevice.c new file mode 100644 --- /dev/null +++ b/cbits/tapdevice.c @@ -0,0 +1,36 @@ + +#include +#include +#include + +#include +#include +#include +#include +#include + +int init_tap_device(char *name) { + int fd, ret; + struct ifreq ifr; + + if(name == NULL) { + return -1; + } + + fd = open("/dev/net/tun", O_RDWR); + if(fd < 0) { + return -2; + } + + memset(&ifr, 0x0, sizeof(struct ifreq)); + ifr.ifr_flags = IFF_TAP | IFF_NO_PI; + strncpy(ifr.ifr_name, name, IFNAMSIZ); + + ret = ioctl(fd, TUNSETIFF, (void*) &ifr); + if(ret != 0) { + close(fd); + return -3; + } + + return fd; +} diff --git a/example/WebServer.hs b/example/WebServer.hs new file mode 100644 --- /dev/null +++ b/example/WebServer.hs @@ -0,0 +1,153 @@ +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.Layer.Tcp.Socket + (Socket,readLine,sendSocket,acceptSocket,listenPort,closeSocket + ,SocketError(..)) +import Hans.Message.Tcp (TcpPort) +import Hans.Setup (NetworkStack(nsTcp)) +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 (nsTcp ns) port `X.catch` h + where + h ListenError{} = do + putStrLn ("Unable to listen on port: " ++ show port) + exitFailure + h se = do + print se + exitFailure + +handleClient :: POSIXTime -> Socket -> IO () +handleClient start client = body `X.catch` \se -> print (se :: X.SomeException) + where + body = do + mb <- processRequest client + case mb of + Nothing -> closeSocket client + Just (url,req) -> do + sendSocket client =<< makeResponse start url req + threadDelay 1000000 + closeSocket client + +processRequest :: Socket -> IO (Maybe (String,[S.ByteString])) +processRequest sock = do + ls <- readRequest sock + case ls of + [] -> return Nothing + l:_ -> return (Just (parseUrl l, ls)) + +crlf :: S.ByteString +crlf = S.pack [0x0d, 0x0a] + +readRequest :: Socket -> IO [S.ByteString] +readRequest sock = loop + where + loop = do + line <- readLine sock + if line == crlf + then return [] + else do + rest <- loop + return (line:rest) + +parseUrl :: S.ByteString -> String +parseUrl = head . drop 1 . words . toString + +fromString :: String -> S.ByteString +fromString = S.pack . map (toEnum . fromEnum) + +toString :: S.ByteString -> String +toString = map (toEnum . fromEnum) . S.unpack + +status200 :: S.ByteString +status200 = fromString "HTTP/1.1 200 OK\r\n" + +contentLength :: Int -> S.ByteString +contentLength len = fromString ("Content-Length: " ++ show len) + +contentType :: String -> S.ByteString +contentType ty = fromString ("Content-Type: " ++ ty) + +response404 :: S.ByteString +response404 = fromString $ concat + [ "HTTP/1.1 404 Not Found\r\n" + , "Content-Length: 0\r\n" + , "\r\n" + ] + +connectionClose :: S.ByteString +connectionClose = fromString "Connection: close" + +makeResponse :: POSIXTime -> String -> [S.ByteString] -> IO S.ByteString +makeResponse start url req + | url == "/favicon.ico" = return response404 + | otherwise = do + uptime <- timePassed start + let date = posixSecondsToUTCTime start + body = fromString (concat + [ "HaLVM" + , "

Welcome to the HaLVM!


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

HTTP Request:

\r\n
"
+               ]) `S.append` S.concat req
+                  `S.append` fromString "
" + return $! S.concat + [ status200 + , contentLength (S.length body), crlf + , contentType "text/html", crlf + , connectionClose, crlf + , crlf + , body + ] + +formatDate :: UTCTime -> String +formatDate = formatTime defaultTimeLocale "%c" + +zeroUTCTime :: UTCTime +zeroUTCTime = UTCTime (ModifiedJulianDay 0) 0 + +timePassed :: POSIXTime -> IO String +timePassed start = do + now <- getPOSIXTime + let date@(UTCTime day _) = addUTCTime (now - start) zeroUTCTime + return $ concat + [ show (toModifiedJulianDay day) + , " days, " + , formatTime defaultTimeLocale "%k hours, %M minutes, %S seconds." date + ] diff --git a/example/test.hs b/example/test.hs new file mode 100644 --- /dev/null +++ b/example/test.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import WebServer + +import Hans.Address +import Hans.Address.IP4 +import Hans.Address.Mac +import Hans.DhcpClient (dhcpDiscover) +import Hans.Layer.Ethernet +import Hans.Message.Tcp (TcpPort(..)) +import Hans.Setup + +import 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 + addEthernetDevice (nsEthernet ns) mac (xenSend nic) (xenReceiveLoop nic) + --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" + addEthernetDevice (nsEthernet 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 <- setup + mac <- initEthernetDevice ns + startEthernetDevice (nsEthernet 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] -> apply (addrOptions ip gw mac) ns + _ -> do + putStrLn "Usage: dhcp" + putStrLn " " + exitFailure + +addrOptions :: String -> String -> Mac -> [SomeOption] +addrOptions ip gw mac = + [ SomeOption (LocalEthernet (ip4 `withMask` 24) mac) + , SomeOption (Route (IP4 0 0 0 0 `withMask` 0) gw4) + ] + where + ip4 :: IP4 + ip4 = read ip + gw4 :: IP4 + gw4 = read gw diff --git a/hans.cabal b/hans.cabal new file mode 100644 --- /dev/null +++ b/hans.cabal @@ -0,0 +1,138 @@ +name: hans +version: 2.1.0.0 +cabal-version: >= 1.8 +license: BSD3 +license-file: LICENSE +author: Galois Inc., Peng Li, Stephan Zdancewic +maintainer: halvm-devel@community.galois.com +category: Networking +synopsis: IPv4 Network Stack +build-type: Simple +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. + +source-repository head + type: git + location: git://src.galois.com/srv/git/HaNS.git + +flag bounded-channels + default: False + description: Use bounded channels for message passing + +flag example + default: False + description: Build the example program + +flag halvm + default: False + description: Build for the HaLVM + +library + if(flag(halvm)) + build-depends: XenDevice, communication + exposed-modules: Hans.Device.Xen, + Hans.Device.Ivc + else + build-depends: unix + include-dirs: cbits + c-sources: cbits/tapdevice.c + exposed-modules: Hans.Device.Tap + + if flag(bounded-channels) + build-depends: BoundedChan + cpp-options: -DBOUNDED_CHANNELS + + ghc-options: -Wall + hs-source-dirs: src + build-depends: base == 4.*, + cereal == 0.3.*, + bytestring == 0.9.1.*, + containers >= 0.4.0.0 && < 0.5.0.0, + monadLib == 3.6.*, + time >= 1.2.0.0 && < 1.3.0.0, + fingertree == 0.0.1.*, + random == 1.0.0.* + exposed-modules: Data.PrefixTree, + Hans.Address, + Hans.Utils.Checksum, + Hans.Layer, + Hans.Ports, + Hans.Setup, + Hans.Utils, + Hans.Channel, + Hans.DhcpClient, + Hans.Simple, + Hans.Layer.Tcp, + Hans.Layer.Arp.Table, + Hans.Layer.Tcp.Handlers, + Hans.Layer.Tcp.Monad, + Hans.Layer.Tcp.Socket, + Hans.Layer.IP4, + Hans.Layer.Udp, + Hans.Layer.Arp, + Hans.Layer.IP4.Routing, + Hans.Layer.IP4.Fragmentation, + Hans.Layer.Timer, + Hans.Layer.Ethernet, + Hans.Layer.Icmp4, + Hans.Message.Tcp, + Hans.Message.Types, + Hans.Message.Udp, + Hans.Message.Ip4, + Hans.Message.EthernetFrame, + Hans.Message.Arp, + Hans.Message.Dhcp4Codec, + Hans.Message.Dhcp4, + Hans.Message.Dhcp4Options, + Hans.Message.Icmp4, + Hans.Address.Mac, + Hans.Address.IP4, + Network.TCP.Aux.SockMonad, + Network.TCP.Aux.Param, + Network.TCP.Aux.Misc, + Network.TCP.Aux.Output, + Network.TCP.LTS.User, + Network.TCP.LTS.Out, + Network.TCP.LTS.InPassive, + Network.TCP.LTS.InActive, + Network.TCP.LTS.InMisc, + Network.TCP.LTS.In, + Network.TCP.LTS.InData, + Network.TCP.Type.Socket, + Network.TCP.Type.Syscall, + Network.TCP.Type.Datagram, + Network.TCP.Type.Base, + Network.TCP.Type.Timer + +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.*, + cereal == 0.3.0.*, + bytestring == 0.9.1.*, + containers >= 0.4.0.0 && < 0.5.0.0, + monadLib == 3.6.*, + time >= 1.2.0.0 && < 1.3.0.0, + old-locale == 1.0.0.*, + hans + + if flag(halvm) + build-depends: XenDevice == 1.0.0, + RendezvousLib == 1.0.0, + HALVMCore == 1.0.0, + communication == 1.0.0 + else + ghc-options: -threaded diff --git a/src/Data/PrefixTree.hs b/src/Data/PrefixTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/PrefixTree.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} + +module Data.PrefixTree ( + PrefixTree + + -- * Construction + , empty + , singleton + , insert + , delete + , toList + , fromList + + -- * Querying + , lookup + , member + , matches + , match + , elems + , keys + , key + ) where + +import Prelude hiding (lookup) +import Data.Maybe (isJust,listToMaybe) + +#ifdef TESTS +import Data.List (nub) +import Test.QuickCheck +#endif + +data PrefixTree a + = Empty + | Prefix Key (Maybe a) (PrefixTree a) + | Branch (PrefixTree a) (PrefixTree a) + deriving Show + +type Key = [Bool] + +-- Prefix Manipulation --------------------------------------------------------- + +matchPrefix :: Key -> Key -> (Key,Key,Key) +matchPrefix = loop id + where + loop k (a:as) (b:bs) | a == b = loop (k . (a:)) as bs + loop k as bs = (k [], as, bs) + + +-- Construction ---------------------------------------------------------------- + +empty :: PrefixTree a +empty = Empty + +singleton :: Key -> a -> PrefixTree a +singleton ks a = Prefix ks (Just a) empty + +fromList :: [(Key,a)] -> PrefixTree a +fromList = foldr (uncurry insert) empty + +toList :: PrefixTree a -> [([Bool], a)] +toList t = + case t of + Empty -> [] + + Prefix ls mb t' -> + case mb of + Nothing -> map (prefix ls) (toList t') + Just a -> (ls,a) : map (prefix ls) (toList t') + + Branch l r -> toList l ++ toList r + + where + prefix ls (ks,a) = (ls ++ ks, a) + +elems :: PrefixTree a -> [a] +elems t = + case t of + Empty -> [] + Prefix _ (Just a) t' -> a : elems t' + Prefix _ _ t' -> elems t' + Branch l r -> elems l ++ elems r + +insert :: Key -> a -> PrefixTree a -> PrefixTree a +insert ks a t = + case t of + + Empty -> singleton ks a + + Prefix ls mb t' -> + case matchPrefix ks ls of + -- empty node + ([],[],[]) -> Prefix [] (Just a) t' + + -- empty key + ([],[],_) -> Prefix [] (Just a) t + + -- empty node, full key + ([],_,[]) -> Prefix [] mb (insert ks a t') + + -- no common prefix, branch. + ([], k:_, _) + | k -> Branch (singleton ks a) t + | otherwise -> Branch t (singleton ks a) + + -- complete match, replace the value + (_, [], []) -> Prefix ks (Just a) t' + + -- complete prefix match, but partial key match + (_ ,ks',[]) -> Prefix ls mb (insert ks' a t') + + -- complete key match, partial prefix match + (_,[],ls') -> Prefix ks (Just a) (Prefix ls' mb t') + + -- partial common prefix, but not the full key + (ps,ks'@(k:_),ls') -> Prefix ps Nothing br + where + t1 = singleton ks' a + t2 = Prefix ls' mb t' + br | k = Branch t1 t2 + | otherwise = Branch t2 t1 + + Branch l r -> + case ks of + [] -> Prefix [] (Just a) t + b:_ | b -> Branch (insert ks a l) r + | otherwise -> Branch l (insert ks a r) + + +delete :: Key -> PrefixTree a -> PrefixTree a +delete ks t = + case t of + + Empty -> Empty + + Prefix ls mb t' -> + case matchPrefix ks ls of + (_,[],[]) -> compact (Prefix ls Nothing t') + ([],ks',[]) -> compact (Prefix ls mb (delete ks' t')) + _ -> t + + Branch l r -> + case ks of + [] -> t + b:bs | b -> compact (Branch (delete bs l) r) + | otherwise -> compact (Branch l (delete bs r)) + +compact :: PrefixTree a -> PrefixTree a +compact t = + case t of + + Prefix ls Nothing (Prefix ks mb t') -> Prefix (ls ++ ks) mb t' + + Branch l Empty -> l + Branch Empty r -> r + + _ -> t + + +-- Querying -------------------------------------------------------------------- + +member :: Key -> PrefixTree a -> Bool +member ks t = + case t of + + Empty -> False + + Prefix ls mb t' -> + case matchPrefix ks ls of + (_,[], []) -> isJust mb + (_,ks',[]) -> member ks' t' + _ -> False + + Branch l r -> + case ks of + [] -> False + b:_ | b -> member ks l + | otherwise -> member ks r + +matches :: Key -> PrefixTree a -> [a] +matches = loop [] + where + loop ms ks t = + case t of + + Empty -> ms + + Prefix ls mb t' -> + case matchPrefix ks ls of + (_,[], []) -> maybe ms (:ms) mb + (_,ks',[]) -> loop (maybe ms (:ms) mb) ks' t' + _ -> ms + + Branch l r -> + case ks of + [] -> ms + b:_ | b -> loop ms ks l + | otherwise -> loop ms ks r + +match :: Key -> PrefixTree a -> Maybe a +match k t = listToMaybe (matches k t) + +lookup :: Key -> PrefixTree a -> Maybe a +lookup = match + +keys :: Key -> PrefixTree a -> [Key] +keys = keys' [] [] + where + keys' as p ks t = + case t of + + Empty -> as + + Prefix ls _ t' -> + case matchPrefix ks ls of + (ps,ks',[]) -> keys' (p':as) p' ks' t' + where p' = p ++ ps + _ -> as + + Branch l r -> keys' ls p ks r + where ls = keys' as p ks l + +key :: Key -> PrefixTree a -> Maybe Key +key ks t = listToMaybe (keys ks t) + + +-- Tests ----------------------------------------------------------------------- + +#ifdef TESTS +forAllUniqueLists :: (Testable prop, Arbitrary a, Show a, Eq a) + => ([a] -> prop) -> Property +forAllUniqueLists = forAll (nub `fmap` arbitrary) + +prop_toList_fromList = forAllUniqueLists p + where + p :: [([Bool],())] -> Bool + p bs = length bs == length bs' && all (`elem` bs) bs' + where bs' = toList (fromList bs) + +prop_matchesOrder bs = and (map (f . fst) bs) + where + t1 = fromList bs + t2 = fromList (reverse bs) + f k = matches k t1 == matches k t2 +#endif diff --git a/src/Hans/Address.hs b/src/Hans/Address.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Address.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Hans.Address where + +import Data.Serialize (Serialize) +import Data.Word (Word8) + +class (Ord a, Serialize a) => Address a where + addrSize :: a -> Word8 + toBits :: a -> [Bool] + + +class Address addr => Mask mask addr | addr -> mask, mask -> addr where + masksAddress :: mask -> addr -> Bool + withMask :: addr -> Int -> mask + getMaskComponents :: mask -> (addr,Int) + getMaskRange :: mask -> (addr,addr) + broadcastAddress :: mask -> addr + + +isBroadcast :: (Eq addr, Mask mask addr) => mask -> addr -> Bool +isBroadcast m a = broadcastAddress m == a diff --git a/src/Hans/Address/IP4.hs b/src/Hans/Address/IP4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Address/IP4.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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 (getWord32be) +import Data.Serialize.Put (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 Numeric (readDec) + + +data IP4 = IP4 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + deriving (Ord,Eq,Typeable,Data) + +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 + +instance Serialize IP4 where + get = do + n <- getWord32be + return $! convertFromWord32 n + put ip = putWord32be (convertToWord32 ip) + +instance Show IP4 where + showsPrec _ (IP4 a b c d) = foldl (.) id + $ intersperse (showChar '.') + [shows a, shows b, shows c, shows d] + +instance Read IP4 where + readsPrec _ rest0 = do + (a, '.':rest1) <- readDec rest0 + (b, '.':rest2) <- readDec rest1 + (c, '.':rest3) <- readDec rest2 + (d, rest4) <- readDec rest3 + return (IP4 a b c d, rest4) + +convertToWord32 :: IP4 -> Word32 +convertToWord32 (IP4 a b c d) + = fromIntegral a `shiftL` 24 + + fromIntegral b `shiftL` 16 + + fromIntegral c `shiftL` 8 + + fromIntegral d + +convertFromWord32 :: Word32 -> IP4 +convertFromWord32 n = IP4 a b c d + where + a = fromIntegral (n `shiftR` 24) + b = fromIntegral (n `shiftR` 16) + c = fromIntegral (n `shiftR` 8) + d = fromIntegral n + + +data IP4Mask = IP4Mask + {-# UNPACK #-} !IP4 + {-# UNPACK #-} !Word8 + deriving (Eq,Ord,Typeable,Data,Show) + +instance Serialize IP4Mask where + put (IP4Mask i m) = put i >> put m + get = liftM2 IP4Mask get get + +instance Read IP4Mask where + readsPrec x rest0 = do + (addr,'/':rest1) <- readsPrec x rest0 + (bits, rest2) <- readsPrec x rest1 + guard (bits >= 0 && bits <= 32) + return (IP4Mask addr bits, rest2) + +instance Mask IP4Mask IP4 where + masksAddress mask@(IP4Mask _ bits) a2 = + clearHostBits mask == clearHostBits (IP4Mask a2 bits) + getMaskRange x = (clearHostBits x, setHostBits x) + withMask addr bits = IP4Mask addr (fromIntegral bits) + getMaskComponents (IP4Mask addr bits) = (addr,fromIntegral bits) + broadcastAddress = setHostBits + +modifyAsWord32 :: Endo Word32 -> Endo IP4 +modifyAsWord32 f = convertFromWord32 . f . convertToWord32 + +clearHostBits :: IP4Mask -> IP4 +clearHostBits (IP4Mask addr bits) = modifyAsWord32 (.&. mask) addr + where mask = -2 ^ (32 - bits) + +setHostBits :: IP4Mask -> IP4 +setHostBits (IP4Mask addr bits) = modifyAsWord32 (.|. mask) addr + where mask = 2 ^ (32 - bits) - 1 diff --git a/src/Hans/Address/Mac.hs b/src/Hans/Address/Mac.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Address/Mac.hs @@ -0,0 +1,77 @@ + +module Hans.Address.Mac ( + Mac(..) + , showsMac + , macMask + ) where + +import Hans.Address +import Hans.Utils (showPaddedHex) + +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get (getWord16be,getWord32be) +import Data.Serialize.Put (putByteString) +import Data.Bits (Bits(shiftR,testBit,complement)) +import Data.List (intersperse) +import Data.Word (Word8) +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 ) + + +-- | 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) + +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] + +instance Serialize Mac where + get = do + n <- getWord32be + m <- getWord16be + let f x d = fromIntegral (x `shiftR` d) + return $! Mac (f n 24) (f n 16) (f n 8) (fromIntegral n) + (f m 8) (fromIntegral m) + + put (Mac a b c d e f) = putByteString (S.pack [a,b,c,d,e,f]) diff --git a/src/Hans/Channel.hs b/src/Hans/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Channel.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} + +module Hans.Channel where + +#ifdef BOUNDED_CHANNELS +import Control.Concurrent.BoundedChan as C + +type Channel a = BoundedChan a + +newChannel :: IO (Channel a) +newChannel = newBoundedChan 20 + +receive :: Channel a -> IO a +receive c = readChan c + +send :: Channel a -> a -> IO () +send c a = writeChan c $! a + +#else +import Control.Concurrent.Chan as C + +type Channel a = Chan a + +newChannel :: IO (Channel a) +newChannel = newChan + +receive :: Channel a -> IO a +receive = readChan + +send :: Channel a -> a -> IO () +send c a = writeChan c $! a + +#endif diff --git a/src/Hans/Device/Ivc.hs b/src/Hans/Device/Ivc.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Ivc.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Hans.Device.Ivc ( + ivcSend + , ivcReceiveLoop + , Bytes(getBytes) + ) where + +import Hans.Layer.Ethernet (EthernetHandle,queueEthernet) + +import Communication.IVC as IVC (put,OutChannelEx,get,InChannelEx,Bin) +import Control.Monad (forever,when) +import Data.Serialize (Serialize(get,put),getByteString,putByteString,remaining) +import qualified Data.ByteString as S + +newtype Bytes = Bytes + { getBytes :: S.ByteString + } deriving Show + +instance Serialize Bytes where + get = Bytes `fmap` (getByteString =<< remaining) + put = putByteString . getBytes + +ivcSend :: OutChannelEx Bin Bytes -> S.ByteString -> IO () +ivcSend chan = IVC.put chan . Bytes + +ivcReceiveLoop :: InChannelEx Bin Bytes -> EthernetHandle -> IO () +ivcReceiveLoop chan eth = forever $ do + Bytes bs <- IVC.get chan + when (S.length bs > 14) (queueEthernet eth bs) diff --git a/src/Hans/Device/Tap.hs b/src/Hans/Device/Tap.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Tap.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Hans.Device.Tap where + +import Hans.Layer.Ethernet +import Hans.Utils + +import Control.Concurrent (threadWaitRead) +import Control.Monad (forever) +import Data.Word (Word8) +import Foreign.C.String (CString,withCString) +import Foreign.C.Types (CLong,CSize) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr) +import System.Posix.Types (Fd) +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S + + + +-- | 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. +tapSend :: Fd -> Packet -> IO () +tapSend fd packet = do + let (fptr, 0, len) = S.toForeignPtr 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 Packet +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 + + +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 unsafe "read" + c_read :: Fd -> Ptr Word8 -> CSize -> IO CLong diff --git a/src/Hans/Device/Xen.hs b/src/Hans/Device/Xen.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Device/Xen.hs @@ -0,0 +1,43 @@ +module Hans.Device.Xen where + +import Hans.Layer.Ethernet +import Hans.Utils + +import Data.Maybe (listToMaybe) +import XenDevice.NIC as Xen +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + + +-- Utilities ------------------------------------------------------------------- + +infixl 1 >>=? +(>>=?) :: Monad m => m (Maybe a) -> (a -> m (Maybe b)) -> m (Maybe b) +m >>=? f = do + mb <- m + case mb of + Nothing -> return Nothing + Just a -> f a + +returnJust :: Monad m => a -> m (Maybe a) +returnJust = return . Just + + +-- Xen NIC --------------------------------------------------------------------- + + +openXenDevice :: String -> IO (Maybe NIC) +openXenDevice _ = + listToMaybe `fmap` Xen.potentialNICs >>=? \ dev -> + initializeNIC dev Nothing + + +xenSend :: NIC -> S.ByteString -> IO () +xenSend nic bs = void (Xen.transmitPacket nic (L.fromChunks [bs])) + + +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)) diff --git a/src/Hans/DhcpClient.hs b/src/Hans/DhcpClient.hs new file mode 100644 --- /dev/null +++ b/src/Hans/DhcpClient.hs @@ -0,0 +1,217 @@ +module Hans.DhcpClient ( + dhcpDiscover + ) where + +import Hans.Address +import Hans.Address.IP4 +import Hans.Address.Mac +import Hans.Layer.Ethernet (sendEthernet,addEthernetHandler) +import Hans.Layer.IP4 (connectEthernet) +import Hans.Layer.Timer (delay) +import Hans.Layer.Udp (addUdpHandler,removeUdpHandler,queueUdp) +import Hans.Message.Dhcp4 +import Hans.Message.Dhcp4Codec +import Hans.Message.Dhcp4Options +import Hans.Message.EthernetFrame +import Hans.Message.Ip4 +import Hans.Message.Udp +import Hans.Setup + +import Control.Monad (guard) +import Data.Serialize (runGet,runPut) +import Data.Maybe (fromMaybe) +import System.Random (randomIO) +import qualified Data.ByteString as S + + +-- 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 + +broadcastIP4 :: IP4 +broadcastIP4 = IP4 255 255 255 255 + +broadcastMac :: Mac +broadcastMac = Mac 0xff 0xff 0xff 0xff 0xff 0xff + +udpProtocol :: IP4Protocol +udpProtocol = IP4Protocol 0x11 + +ethernetIp4 :: EtherType +ethernetIp4 = EtherType 0x0800 + +defaultRoute :: IP4Mask +defaultRoute = IP4 0 0 0 0 `withMask` 0 + + +-- DHCP ------------------------------------------------------------------------ + +type AckHandler = IP4 -> IO () + +-- | Discover a dhcp server, and request an address. +dhcpDiscover :: NetworkStack -> Mac -> AckHandler -> IO () +dhcpDiscover ns mac h = do + w32 <- randomIO + let xid = Xid (fromIntegral (w32 :: Int)) + + addEthernetHandler (nsEthernet ns) ethernetIp4 (dhcpIP4Handler ns) + addUdpHandler (nsUdp ns) bootpc (handleOffer ns (Just h)) + + let disc = discoverToMessage (mkDiscover xid mac) + sendMessage ns disc currentNetwork broadcastIP4 broadcastMac + +-- | Restore the connection between the Ethernet and IP4 layers. +restoreIp4 :: NetworkStack -> IO () +restoreIp4 ns = connectEthernet (nsIp4 ns) (nsEthernet ns) + +-- | Handle IP4 messages from the Ethernet layer, passing all relevant DHCP +-- messages to the UDP layer. +dhcpIP4Handler :: NetworkStack -> S.ByteString -> IO () +dhcpIP4Handler ns bytes = + case runGet parseIP4Packet bytes of + Left err -> putStrLn err >> return () + Right (hdr,ihl,len) + | ip4Protocol hdr == udpProtocol -> queue + | otherwise -> return () + where + queue = queueUdp (nsUdp ns) (ip4SourceAddr hdr) (ip4DestAddr hdr) + $ S.take (len - ihl) + $ S.drop ihl bytes + +-- | Handle a DHCP Offer message. +-- +-- * Remove the current UDP handler +-- * Install an DHCP Ack handler +-- * Send a DHCP Request +handleOffer :: NetworkStack -> Maybe AckHandler -> IP4 -> UdpPort + -> S.ByteString -> IO () +handleOffer ns mbh _src _srcPort bytes = + case runGet (getDhcp4Message) bytes of + Right msg -> case parseDhcpMessage msg of + + Just (Right (OfferMessage offer)) -> do + removeUdpHandler (nsUdp ns) bootpc + let req = requestToMessage (offerToRequest offer) + addUdpHandler (nsUdp ns) bootpc (handleAck ns offer mbh) + sendMessage ns req currentNetwork broadcastIP4 broadcastMac + + msg1 -> do + putStrLn (show msg) + putStrLn (show msg1) + + Left err -> putStrLn err + +-- | Handle a DHCP Ack message. +-- +-- * 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 :: NetworkStack -> Offer -> Maybe AckHandler -> IP4 -> UdpPort + -> S.ByteString -> IO () +handleAck ns offer mbh _src _srcPort bytes = + case runGet (getDhcp4Message) bytes of + Right msg -> case parseDhcpMessage msg of + + Just (Right (AckMessage ack)) -> do + removeUdpHandler (nsUdp ns) bootpc + restoreIp4 ns + apply (ackNsOptions ack) ns + let ms = fromIntegral (ackLeaseTime ack) * 500 + delay (nsTimers ns) ms (dhcpRenew ns offer) + putStrLn ("Bound to: " ++ show (ackYourAddr ack)) + + 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 renquest message, generated from the offer given. +dhcpRenew :: NetworkStack -> Offer -> IO () +dhcpRenew ns offer = do + addEthernetHandler (nsEthernet ns) ethernetIp4 (dhcpIP4Handler ns) + + let req = requestToMessage (offerToRequest offer) + addUdpHandler (nsUdp 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 :: Ack -> [SomeOption] +ackNsOptions ack = + [ toOption (LocalEthernet (addr `withMask` mask) mac) + , toOption (Route defaultRoute gateway) + ] + where + mac = ackClientHardwareAddr ack + addr = ackYourAddr ack + opts = ackOptions ack + mask = fromMaybe 24 (lookupSubnet opts) + gateway = fromMaybe (ackRelayAddr ack) (lookupGateway opts) + + +-- Packet Helpers -------------------------------------------------------------- + +sendMessage :: NetworkStack -> Dhcp4Message -> IP4 -> IP4 -> Mac -> IO () +sendMessage ns resp src dst hwdst = do + ipBytes <- mkIpBytes src dst bootpc bootps + (runPut (putDhcp4Message resp)) + let mac = dhcp4ClientHardwareAddr resp + let frame = EthernetFrame + { etherDest = hwdst + , etherSource = mac + , etherType = ethernetIp4 + , etherData = ipBytes + } + putStrLn (show mac ++ " -> " ++ show hwdst) + + sendEthernet (nsEthernet ns) frame + +mkIpBytes :: IP4 -> IP4 -> UdpPort -> UdpPort -> S.ByteString -> IO S.ByteString +mkIpBytes srcAddr dstAddr srcPort dstPort payload = do + udpBytes <- do + let udpHdr = UdpHeader srcPort dstPort 0 + udp = UdpPacket udpHdr payload + mk = mkIP4PseudoHeader srcAddr dstAddr udpProtocol + renderUdpPacket udp mk + + ipBytes <- do + let ipHdr = emptyIP4Header udpProtocol srcAddr dstAddr + ip = IP4Packet ipHdr udpBytes + renderIP4Packet ip + + return ipBytes diff --git a/src/Hans/Layer.hs b/src/Hans/Layer.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer.hs @@ -0,0 +1,140 @@ +{-# 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)) +import qualified Control.Exception as X +import qualified Data.Map 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 + | Result (LayerState i) a Action + +-- | 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 + -> Failure i r -> Success a i r + -> Result i r } + +runLayer :: LayerState i -> Layer i a -> Result i a +runLayer i0 m = getLayer m i0 mempty Error success + where success a i o = Result i a o + +loopLayer :: i -> IO msg -> (msg -> Layer i ()) -> IO () +loopLayer i0 msg k = loop (LayerState 0 i0) + where + loop i = do + a <- msg + now <- getPOSIXTime + let res = runLayer (i {lsNow = now }) (k a) + X.evaluate res `X.catch` \ se -> print (se :: X.SomeException) >> return res + case res of + Error m -> runAction m >> loop i + Result i' () m -> runAction m >> loop i' + +instance Functor (Layer i) where + fmap g m = Layer (\i0 o0 f k -> getLayer m i0 o0 f (\a i o -> k (g a) i o)) + +instance Applicative (Layer i) where + pure = return + (<*>) = ap + +instance Alternative (Layer i) where + empty = Layer (\_ o0 f _ -> f o0) + a <|> b = Layer (\i o f k -> getLayer a i o (\_ -> getLayer b i o f k) k) + +instance Monad (Layer i) where + return x = Layer (\i o _ k -> k x i o) + m >>= g = Layer $ \i0 o0 f k -> getLayer m i0 o0 f $ \a i o -> + getLayer (g a) i o f k + +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) + + +-- Utilities ------------------------------------------------------------------- + +dropPacket :: Layer i a +dropPacket = empty + +time :: Layer i POSIXTime +time = Layer $ \i0 o0 _ k -> k (lsNow i0) i0 o0 + +output :: IO () -> Layer i () +output m = Layer $ \i0 o0 _ k -> k () i0 (o0 `mappend` Action m) + +liftRight :: Either String b -> Layer i b +liftRight (Right b) = return b +liftRight (Left err) = do + output (putStrLn err) + dropPacket + +-- Handler Generalization ------------------------------------------------------ + +type Handlers k a = Map.Map k a + +emptyHandlers :: Handlers k a +emptyHandlers = Map.empty + + +class ProvidesHandlers i k a | i -> k a where + getHandlers :: i -> Handlers k a + setHandlers :: Handlers k a -> i -> i + + +getHandler :: (Ord k, ProvidesHandlers i k a) => k -> Layer i a +getHandler k = do + state <- get + just (Map.lookup k (getHandlers state)) + + +addHandler :: (Ord k, ProvidesHandlers i k a) => k -> a -> Layer i () +addHandler k a = do + state <- get + let hs' = Map.insert k a (getHandlers state) + hs' `seq` set (setHandlers hs' state) + + +removeHandler :: (Ord k, ProvidesHandlers i k a) => k -> Layer i () +removeHandler k = do + state <- get + let hs' = Map.delete k (getHandlers state) + hs' `seq` set (setHandlers hs' state) diff --git a/src/Hans/Layer/Arp.hs b/src/Hans/Layer/Arp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Arp.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +module Hans.Layer.Arp ( + ArpHandle + , runArpLayer + + -- External Interface + , arpWhoHas + , arpIP4Packet + , addLocalAddress + ) where + +import Hans.Address.IP4 +import Hans.Address.Mac +import Hans.Channel +import Hans.Layer +import Hans.Layer.Arp.Table +import Hans.Layer.Ethernet +import Hans.Layer.Timer +import Hans.Message.Arp +import Hans.Message.EthernetFrame +import Hans.Utils + +import Control.Concurrent (forkIO,takeMVar,putMVar,newEmptyMVar) +import Control.Monad (forM_,mplus,guard,unless,when) +import Data.Serialize (decode,encode) +import MonadLib (BaseM(inBase),set,get) +import qualified Data.Map as Map + +-- | A handle to a running arp layer. +type ArpHandle = Channel (Arp ()) + + +-- | Start an arp layer. +runArpLayer :: ArpHandle -> EthernetHandle -> TimerHandle -> IO () +runArpLayer h eth th = do + addEthernetHandler eth (EtherType 0x0806) (send h . handleIncoming) + let i = emptyArpState h eth th + void (forkIO (loopLayer i (receive h) id)) + + +-- | 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 -> Packet -> IO () +arpIP4Packet h !src !dst !pkt = send h (handleOutgoing src dst pkt) + + +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 :: EthernetHandle + , arpTimers :: TimerHandle + , arpSelf :: ArpHandle + } + +emptyArpState :: ArpHandle -> EthernetHandle -> TimerHandle -> ArpState +emptyArpState h eth ts = ArpState + { arpTable = Map.empty + , arpAddrs = Map.empty + , arpWaiting = Map.empty + , arpEthernet = eth + , arpTimers = ts + , arpSelf = h + } + +ethernetHandle :: Arp EthernetHandle +ethernetHandle = arpEthernet `fmap` get + +timerHandle :: Arp TimerHandle +timerHandle = arpTimers `fmap` get + +addEntry :: IP4 -> Mac -> Arp () +addEntry spa sha = do + state <- get + 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 + , etherData = encode msg + } + output (sendEthernet eth frame) + +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 = Mac 0xff 0xff 0xff 0xff 0xff 0xff + , arpTPA = ip + , arpOper = ArpRequest + } + now <- time + let table' = addPending now ip (arpTable state) + set state { arpTable = table' } + addWaiter ip k + mapM_ (sendArpPacket . msg) addrs + th <- timerHandle + output (delay th 10000 (send (arpSelf state) advanceArpTable)) + +-- Message Handling ------------------------------------------------------------ + +-- | Process an incoming arp packet +handleIncoming :: Packet -> Arp () +handleIncoming bs = do + msg <- liftRight (decode bs) + -- ?Do I have the hardware type in ar$hrd + -- Yes: (This check is enforced by the type system) + -- [optionally check the hardware length ar$hln] + -- ?Do I speak the protocol in ar$pro? + -- Yes: (This check is also enforced by the type system) + -- [optionally check the protocol length ar$pln] + -- Merge_flag := false + -- If the pair is + -- already in my translation table, update the sender + -- hardware address field of the entry with the new + -- information in the packet and set Merge_flag to true. + let sha = arpSHA msg + let spa = arpSPA msg + merge <- updateExistingEntry spa sha + -- ?Am I the target protocol address? + let tpa = arpTPA msg + lha <- localHwAddress tpa + -- Yes: + -- If Merge_flag is false, add the triplet to + -- the translation table. + unless merge (addEntry spa sha) + -- ?Is the opcode ares_op$REQUEST? (NOW look at the opcode!!) + -- Yes: + when (arpOper msg == ArpRequest) $ do + -- Swap hardware and protocol fields, putting the local + -- hardware and protocol addresses in the sender fields. + let msg' = msg { arpSHA = lha , arpSPA = tpa + , arpTHA = sha , arpTPA = spa + -- Set the ar$op field to ares_op$REPLY + , arpOper = ArpReply } + -- Send the packet to the (new) target hardware address on + -- the same hardware on which the request was received. + sendArpPacket msg' + + +-- | Handle a request to associate an ip with a mac address for a local device +handleAddAddress :: IP4 -> Mac -> Arp () +handleAddAddress ip mac = do + state <- get + let addrs' = Map.insert ip mac (arpAddrs state) + addrs' `seq` set state { arpAddrs = addrs' } + + +-- | Output a packet to the ethernet layer. +handleOutgoing :: IP4 -> IP4 -> Packet -> Arp () +handleOutgoing src dst bs = do + eth <- ethernetHandle + lha <- localHwAddress src + let frame dha = EthernetFrame + { etherDest = dha + , etherSource = lha + , etherType = 0x0800 + , etherData = bs + } + whoHas dst $ \ res -> case res of + Nothing -> return () + Just dha -> sendEthernet eth (frame dha) diff --git a/src/Hans/Layer/Arp/Table.hs b/src/Hans/Layer/Arp/Table.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Arp/Table.hs @@ -0,0 +1,59 @@ +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 as Map + + +-- Arp Table ------------------------------------------------------------------- + +arpEntryTimeout :: POSIXTime +arpEntryTimeout = 60 + +data ArpEntry + = ArpEntry { arpMac :: Mac + , arpTimeout :: POSIXTime + } + | ArpPending { arpTimeout :: POSIXTime + } + deriving Show + +data ArpResult + = KnownAddress 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 ent where + ent = ArpPending + { arpTimeout = now + arpEntryTimeout -- FIXME: should queries stay longer? + } + +-- | If the ARP table has a fully realized entry for the given IP address, +-- then return it. Otherwise return Pending if we're waiting for this info, +-- or Unknown if nothing is currently known about it. +lookupArpEntry :: IP4 -> ArpTable -> ArpResult +lookupArpEntry ip arp = + case Map.lookup ip arp of + Just (ArpEntry mac _) -> KnownAddress mac + Just (ArpPending _) -> Pending + _ -> Unknown diff --git a/src/Hans/Layer/Ethernet.hs b/src/Hans/Layer/Ethernet.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Ethernet.hs @@ -0,0 +1,182 @@ +{-# 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 (Packet,void,just) + +import Control.Concurrent (forkIO,ThreadId,killThread) +import Control.Monad (mplus) +import Data.Serialize (decode,encode) +import MonadLib (get,set) +import qualified Data.Map as Map + + +-- Messages -------------------------------------------------------------------- + +type Handler = Packet -> IO () + +type Tx = Packet -> IO () +type Rx = EthernetHandle -> IO () + +type EthernetHandle = Channel (Eth ()) + +-- | Run the ethernet layer. +runEthernetLayer :: EthernetHandle -> IO () +runEthernetLayer h = + void (forkIO (loopLayer (emptyEthernetState h) (receive h) id)) + +sendEthernet :: EthernetHandle -> EthernetFrame -> IO () +sendEthernet h !frame = send h (handleOutgoing frame) + +queueEthernet :: EthernetHandle -> Packet -> 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 :: 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 :: Packet -> Eth () +handleIncoming pkt = do + frame <- liftRight (decode pkt) + h <- getHandler (etherType frame) + output (h (etherData frame)) + + +-- | 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 -> Eth () +handleOutgoing frame = do + dev <- getDevice (etherSource frame) + output (devTx dev (encode frame)) + + +-- | Add an ethernet device to the state. +addDevice :: Mac -> Tx -> Rx -> Eth () +addDevice mac tx rx = do + stopDevice mac `mplus` return () + h <- self + setDevice mac (emptyDevice tx (rx h)) + + +-- | Remove a device +delDevice :: Mac -> Eth () +delDevice mac = do + stopDevice mac + state <- get + let ds' = Map.delete mac (ethDevices state) + ds' `seq` set state { ethDevices = ds' } + + +-- | Stop an ethernet device. +stopDevice :: Mac -> Eth () +stopDevice mac = do + dev <- getDevice mac + case devUp dev of + Nothing -> return () + Just tid -> do + output (killThread tid) + setDevice mac dev { devUp = Nothing } + + +-- | Start an ethernet device. +startDevice :: Mac -> Eth () +startDevice mac = do + dev <- getDevice mac + case devUp dev of + Just _ -> return () + -- XXX: add functionality to pipe the threadid back into the layer state. + Nothing -> output (void (forkIO (devRx dev))) + --setDevice mac dev { devUp = Just tid } diff --git a/src/Hans/Layer/IP4.hs b/src/Hans/Layer/IP4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/IP4.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Layer.IP4 ( + IP4Handle + , runIP4Layer + , Rule(..) + + -- * External Interface + , connectEthernet + , withIP4Source + , sendIP4Packet + , addIP4RoutingRule + , addIP4Handler + , removeIP4Handler + ) 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,mplus,(<=<)) +import Data.Serialize.Get (runGet) +import MonadLib (get,set) +import qualified Data.ByteString as S + + +type Handler = IP4 -> IP4 -> Packet -> IO () + +type IP4Handle = Channel (IP ()) + +runIP4Layer :: IP4Handle -> ArpHandle -> EthernetHandle -> IO () +runIP4Layer h arp eth = do + void (forkIO (loopLayer (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 -> IP4Protocol -> IP4 -> Packet -> IO () +sendIP4Packet h !prot !dst !pkt = send h (handleOutgoing prot dst 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 :: Ident + , ip4ArpHandle :: 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 :: IP4Protocol -> IP4 -> Packet -> IP () +sendBytes prot dst bs = do + rule@(src,_,mtu) <- findRoute dst + let hdr = emptyIP4Header prot src dst + hdr' <- if fromIntegral (S.length bs) + 20 < mtu + then return hdr + else do + i <- nextIdent + return (setIdent i hdr) + sendPacket' (IP4Packet hdr' bs) rule + +sendPacket :: IP4Packet -> IP () +sendPacket pkt = do + rule@(src,_,_) <- findRoute (ip4DestAddr (ip4Header pkt)) + guard (src /= ip4SourceAddr (ip4Header pkt)) + sendPacket' pkt rule + +-- | Send a packet using a given routing rule +sendPacket' :: IP4Packet -> (IP4,IP4,Mtu) -> IP () +sendPacket' pkt (src,dst,mtu) = do + arp <- arpHandle + output $ do + let frags = splitPacket mtu pkt + mapM_ (arpIP4Packet arp src dst <=< 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 +forward :: IP4Packet -> IP () +forward pkt = sendPacket pkt + + +-- | 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 :: IP4Packet -> IP () +routeLocal pkt@(IP4Packet hdr _) = do + let dest = ip4DestAddr hdr + localAddress dest `mplus` broadcastDestination dest + h <- getHandler (ip4Protocol hdr) + mb <- handleFragments pkt + case mb of + Nothing -> return () + Just bs -> output (h (ip4SourceAddr hdr) (ip4DestAddr hdr) bs) + + +handleFragments :: IP4Packet -> IP (Maybe Packet) +handleFragments pkt = do + state <- get + now <- time + let (table',mb) = processIP4Packet now (ip4Fragments state) pkt + 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 :: Packet -> IP () +handleIncoming bs = do + (hdr,hlen,plen) <- liftRight (runGet parseIP4Packet bs) + let (header,rest) = S.splitAt hlen bs + let payload = S.take plen rest + let checksum = computeChecksum 0 header + let pkt = IP4Packet hdr payload + guard $ and + [ S.length bs >= 20 + , hlen >= 20 + , checksum == 0 + , ip4Version hdr == 4 + ] + + -- forward? + routeLocal pkt `mplus` forward pkt + + +-- | Outgoing packet +handleOutgoing :: IP4Protocol -> IP4 -> Packet -> IP () +handleOutgoing prot dst bs = do + sendBytes prot dst bs + + +handleAddRule :: Rule IP4Mask IP4 -> IP () +handleAddRule rule = do + state <- get + let routes' = addRule rule (ip4Routes state) + routes' `seq` set state { ip4Routes = routes' } + + +handleSource :: IP4 -> (IP4 -> IO ()) -> IP () +handleSource dst k = do + (s,_,_) <- findRoute dst + output (k s) diff --git a/src/Hans/Layer/IP4/Fragmentation.hs b/src/Hans/Layer/IP4/Fragmentation.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/IP4/Fragmentation.hs @@ -0,0 +1,111 @@ + +module Hans.Layer.IP4.Fragmentation where + +import Hans.Address +import Hans.Address.IP4 +import Hans.Message.Ip4 +import Hans.Utils + +import Data.Ord (comparing) +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.ByteString as S +import qualified Data.Map as Map + + +type FragmentationTable addr = Map.Map (Ident,addr,addr) Fragments + +emptyFragmentationTable :: FragmentationTable IP4 +emptyFragmentationTable = Map.empty + + +data Fragments = Fragments + { startTime :: !POSIXTime + , totalSize :: !Int + , fragments :: [Fragment] + } deriving Show + +data Fragment = Fragment + { fragmentOffset :: !Int + , fragmentLength :: !Int + , fragmentPayload :: !Packet + } 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 `S.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 -> Packet + -> (FragmentationTable addr, Maybe Packet) +processFragment _ table False 0 _ _ _ bs = (table, Just bs) +processFragment now table areMore off src dest ident bs = case group of + Fragments _ x [Fragment 0 y bs'] + | x == y -> (Map.delete entry table, Just bs') + _ -> (Map.insert entry group table, Nothing) + where + entry = (ident,src,dest) + group = case Map.lookup (ident,src,dest) table of + Nothing -> Fragments now newTotalLen [cur] + Just g -> expandGroup g cur newTotalLen + curlen = fromIntegral (S.length bs) + cur = Fragment off curlen bs + newTotalLen | areMore = -1 + | otherwise = off + curlen + + +processIP4Packet :: POSIXTime -> FragmentationTable IP4 -> IP4Packet + -> (FragmentationTable IP4, Maybe Packet) +processIP4Packet now table (IP4Packet hdr bs) = + processFragment now table areMore off src dest ident bs + where + off = fromIntegral (ip4FragmentOffset hdr) + ident = fromIntegral (ip4Ident hdr) + areMore = ip4MoreFragments hdr + src = ip4SourceAddr hdr + dest = ip4DestAddr hdr diff --git a/src/Hans/Layer/IP4/Routing.hs b/src/Hans/Layer/IP4/Routing.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/IP4/Routing.hs @@ -0,0 +1,87 @@ +module Hans.Layer.IP4.Routing ( + -- * Routing Rules + Rule(..) + , Mtu + + -- * Routing Table + , RoutingTable + , emptyRoutingTable + , addRule + , route + , localAddrs + , sourceMask + ) where + +import Data.PrefixTree as PT +import Hans.Address.IP4 +import Hans.Address + +import Data.Maybe (mapMaybe) + + +-- Routing Rules --------------------------------------------------------------- + +type Mtu = Int + +data Rule mask addr + = Direct mask addr Mtu + | Indirect mask addr + deriving Show + + +-- Routing Table --------------------------------------------------------------- + +type RoutingTable addr = PrefixTree (Dest addr) + +data Dest addr + = NextHop addr + | Via addr Mtu + deriving Show + + +emptyRoutingTable :: Address addr => RoutingTable addr +emptyRoutingTable = PT.empty + + +{-# SPECIALIZE addRule :: Rule IP4Mask IP4 -> RoutingTable IP4 + -> RoutingTable IP4 #-} +-- | Add a rule to the routing table. +addRule :: Mask mask addr + => Rule mask addr -> RoutingTable addr -> RoutingTable addr +addRule rule table = case rule of + Direct mask addr mtu -> k mask (Via addr mtu) + Indirect mask addr -> k mask (NextHop addr) + where + k m d = insert ks d table + where + (addr,bits) = getMaskComponents m + ks = take bits (toBits addr) + + +{-# SPECIALIZE route :: IP4 -> RoutingTable IP4 -> Maybe (IP4,IP4,Mtu) #-} +-- | Discover the source and destination when trying to route an address. +route :: Address addr => addr -> RoutingTable addr -> Maybe (addr,addr,Mtu) +route addr t = do + r <- match (toBits addr) t + case r of + Via s mtu -> return (s,addr,mtu) + NextHop hop -> do + Via s mtu <- match (toBits hop) t + return (s,hop,mtu) + + +{-# SPECIALIZE sourceMask :: IP4 -> RoutingTable IP4 -> Maybe IP4Mask #-} +-- | Find the mask that would be used to route an address. +sourceMask :: Mask mask addr => addr -> RoutingTable addr -> Maybe mask +sourceMask addr table = do + src <- key (toBits addr) table + let bits = fromIntegral (addrSize addr * 8) - length src + return (addr `withMask` bits) + + +-- | Dump all local addresses. +localAddrs :: Address addr => RoutingTable addr -> [addr] +localAddrs table = mapMaybe p (PT.elems table) + where + p (Via s _) = Just s + p _ = Nothing diff --git a/src/Hans/Layer/Icmp4.hs b/src/Hans/Layer/Icmp4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Icmp4.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Layer.Icmp4 ( + Icmp4Handle + , runIcmp4Layer + , addIcmp4Handler + ) where + +import Hans.Address.IP4 +import Hans.Channel +import Hans.Layer +import Hans.Layer.IP4 +import Hans.Message.Icmp4 +import Hans.Message.Ip4 +import Hans.Utils + +import Control.Concurrent (forkIO) +import Data.Serialize (decode,encode) +import MonadLib (get,set) + +type Handler = Icmp4Packet -> IO () + +type Icmp4Handle = Channel (Icmp4 ()) + +icmpProtocol :: IP4Protocol +icmpProtocol = IP4Protocol 0x1 + +runIcmp4Layer :: Icmp4Handle -> IP4Handle -> IO () +runIcmp4Layer h ip4 = do + let handles = Icmp4Handles ip4 [] + addIP4Handler ip4 icmpProtocol + $ \src dst bs -> send h (handleIncoming src dst bs) + void (forkIO (loopLayer handles (receive h) id)) + +data Icmp4Handles = Icmp4Handles + { icmpIp4 :: IP4Handle + , icmpHandlers :: [Handler] + } + +type Icmp4 = Layer Icmp4Handles + +ip4Handle :: Icmp4 IP4Handle +ip4Handle = icmpIp4 `fmap` get + +sendPacket :: IP4 -> Icmp4Packet -> Icmp4 () +sendPacket dst pkt = do + ip4 <- ip4Handle + output $ sendIP4Packet ip4 icmpProtocol dst (encode pkt) + +-- | Add a handler for Icmp4 messages that match the provided predicate. +addIcmp4Handler :: Icmp4Handle -> Handler -> IO () +addIcmp4Handler h k = send h (handleAdd k) + +-- Message Handling ------------------------------------------------------------ + +-- | Handle incoming ICMP packets +handleIncoming :: IP4 -> IP4 -> Packet -> Icmp4 () +handleIncoming src _dst bs = do + pkt <- liftRight (decode bs) + matchHandlers pkt + case pkt of + -- XXX: Only echo-request is handled at the moment + Echo ident seqNum dat -> handleEchoRequest src ident seqNum dat + _ty -> do + --output (putStrLn ("Unhandled ICMP message type: " ++ show ty)) + dropPacket + + +-- | 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 :: IP4 -> Identifier -> SequenceNumber -> Packet -> Icmp4 () +handleEchoRequest src ident seqNum dat = do + sendPacket src (EchoReply ident seqNum dat) + + +-- | Output the IO actions for each handler that's registered. +matchHandlers :: Icmp4Packet -> Icmp4 () +matchHandlers pkt = do + s <- get + output (mapM_ ($ pkt) (icmpHandlers s)) diff --git a/src/Hans/Layer/Tcp.hs b/src/Hans/Layer/Tcp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Hans.Layer.Tcp ( + TcpHandle + , runTcpLayer + , queueTcp + + , module Exports + ) where + +import Hans.Address.IP4 +import Hans.Channel +import Hans.Layer +import Hans.Layer.IP4 +import Hans.Layer.Tcp.Monad (Tcp,TcpHandle,TcpState(..),emptyTcpState) +import Hans.Layer.Tcp.Socket as Exports +import Hans.Layer.Timer (TimerHandle,udelay) +import Hans.Message.Tcp (tcpProtocol) +import Hans.Layer.Tcp.Handlers (handleIncomingTcp,handleOutgoing) +import Hans.Utils (void) + +import Network.TCP.Type.Base (posixtime_to_time) +import Network.TCP.Type.Socket (update_host_time) + +import Control.Concurrent (forkIO) +import MonadLib (get,set) +import qualified Data.ByteString as S + + +runTcpLayer :: TcpHandle -> IP4Handle -> TimerHandle -> IO () +runTcpLayer tcp ip4 t = do + let s0 = emptyTcpState tcp ip4 t + void (forkIO (loopLayer s0 (receive tcp) updateTimeAndRun)) + addIP4Handler ip4 tcpProtocol (queueTcp tcp) + +-- | Queue a tcp packet. +queueTcp :: TcpHandle -> IP4 -> IP4 -> S.ByteString -> IO () +queueTcp tcp !src !dst !bs = send tcp (handleIncomingTcp src dst bs) + +-- | Pull the time out of the Layer monad, and convert it to a value that can be +-- used with the TCP layer. +updateTimeAndRun :: Tcp () -> Tcp () +updateTimeAndRun body = do + now <- time + s <- get + set $! s { tcpHost = update_host_time (posixtime_to_time now) (tcpHost s) } + body + handleOutgoing diff --git a/src/Hans/Layer/Tcp/Handlers.hs b/src/Hans/Layer/Tcp/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Handlers.hs @@ -0,0 +1,74 @@ +module Hans.Layer.Tcp.Handlers ( + handleIncomingTcp + , handleOutgoing + ) where + +import Hans.Address.IP4 (IP4,convertFromWord32) +import Hans.Channel (send) +import Hans.Layer (output,liftRight) +import Hans.Layer.IP4 (sendIP4Packet,withIP4Source) +import Hans.Layer.Tcp.Monad + (Tcp,TcpState(..),ip4Handle,ip4Handle,ip4Handle,ip4Handle) +import Hans.Layer.Timer (udelay) +import Hans.Message.Tcp + (tcpProtocol,renderWithTcpChecksumIP4,TcpPacket(..),getTcpPacket + ,recreateTcpChecksumIP4,TcpHeader(..)) + +import Network.TCP.LTS.In (tcp_deliver_in_packet) +import Network.TCP.Type.Base (get_ip,bufferchain_collapse,IPAddr(..)) +import Network.TCP.Type.Datagram + (ICMPDatagram(..),UDPDatagram(..),TCPSegment(..),IPMessage(..) + ,mkTCPSegment) +import Network.TCP.Type.Socket (Host(..)) + +import Control.Monad (unless,guard) +import Data.Serialize (runGet) +import MonadLib (get,set) +import qualified Data.ByteString as S + + +-- | Handle a TCP message from the IP4 layer. +handleIncomingTcp :: IP4 -> IP4 -> S.ByteString -> Tcp () +handleIncomingTcp src dst bytes = do + let cs = recreateTcpChecksumIP4 src dst bytes + pkt@(TcpPacket hdr _body) <- liftRight (runGet getTcpPacket bytes) + guard (tcpChecksum hdr == cs) + tcp_deliver_in_packet (mkTCPSegment src dst pkt) + +-- | Force packets out of the pure layer. +handleOutgoing :: Tcp () +handleOutgoing = do + s <- get + let h = tcpHost s + set (s { tcpHost = h { output_queue = [], ready_list = [] } }) + let msgs = output_queue h + unless (null msgs) (mapM_ deliverIPMessage msgs) + let ready = ready_list h + unless (null ready) (mapM_ output ready) + +deliverIPMessage :: IPMessage -> Tcp () +deliverIPMessage msg = + case msg of + TCPMessage seg -> deliverTCPSegment seg + ICMPMessage icmp -> deliverICMPDatagram icmp + UDPMessage udp -> deliverUDPDatagram udp + +deliverTCPSegment :: TCPSegment -> Tcp () +deliverTCPSegment seg = do + let hdr = tcp_header seg + IPAddr dst = get_ip (tcp_dst seg) + dstAddr = convertFromWord32 dst + ip4 <- ip4Handle + output $ withIP4Source ip4 dstAddr $ \ srcAddr -> do + body <- bufferchain_collapse (tcp_data seg) + let pkt = renderWithTcpChecksumIP4 srcAddr dstAddr (TcpPacket hdr body) + sendIP4Packet ip4 tcpProtocol dstAddr pkt + +deliverICMPDatagram :: ICMPDatagram -> Tcp () +deliverICMPDatagram _icmp = do + output (putStrLn "Ignoring TCP icmp packet") + +deliverUDPDatagram :: UDPDatagram -> Tcp () +deliverUDPDatagram _udp = do + output (putStrLn "Ignoring TCP udp packet") + diff --git a/src/Hans/Layer/Tcp/Monad.hs b/src/Hans/Layer/Tcp/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Monad.hs @@ -0,0 +1,92 @@ +module Hans.Layer.Tcp.Monad where + +import Hans.Channel +import Hans.Layer +import Hans.Layer.IP4 +import Hans.Layer.Timer + +import MonadLib +import Network.TCP.Type.Datagram (IPMessage) +import Network.TCP.Type.Socket (Host(..),empty_host,TCPSocket) +import Network.TCP.Type.Syscall (SocketID) +import qualified Data.Map as Map + + +-- TCP Monad ------------------------------------------------------------------- + +type TcpHandle = Channel (Tcp ()) + +type Tcp = Layer (TcpState (IO ())) + +data TcpState t = TcpState + { tcpSelf :: TcpHandle + , tcpIP4 :: IP4Handle + , tcpTimers :: TimerHandle + , tcpHost :: Host t + } + +emptyTcpState :: TcpHandle -> IP4Handle -> TimerHandle -> TcpState t +emptyTcpState tcp ip4 timer = TcpState + { tcpSelf = tcp + , tcpIP4 = ip4 + , tcpTimers = timer + , tcpHost = empty_host + } + +-- | 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 + +-- | Get the handle to the Timer layer. +timerHandle :: Tcp TimerHandle +timerHandle = tcpTimers `fmap` get + + +-- Compatibility Layer --------------------------------------------------------- + +type HMonad t = Layer (TcpState t) + +get_host :: HMonad t (Host t) +get_host = tcpHost `fmap` get + +put_host :: Host t -> HMonad t () +put_host h = do + s <- get + set $! s { tcpHost = h } + +modify_host :: (Host t -> Host t) -> HMonad t () +modify_host f = do + h <- get_host + put_host $! f h + +emit_segs :: [IPMessage] -> HMonad t () +emit_segs segs = modify_host (\h -> h { output_queue = output_queue h ++ segs }) + +emit_ready :: [t] -> HMonad t () +emit_ready ts = modify_host (\h -> h { ready_list = ready_list h ++ ts }) + +has_sock :: SocketID -> HMonad t Bool +has_sock sid = (Map.member sid . sock_map) `fmap` get_host + +lookup_sock :: SocketID -> HMonad t (TCPSocket t) +lookup_sock sid = do + h <- get_host + case Map.lookup sid (sock_map h) of + Nothing -> fail "lookup_sock: sid not found" + Just res -> return res + +delete_sock :: SocketID -> HMonad t () +delete_sock sid = + modify_host (\h -> h { sock_map = Map.delete sid (sock_map h) } ) + +update_sock :: SocketID -> (TCPSocket t -> TCPSocket t) -> HMonad t () +update_sock sid f = + modify_host (\h -> h { sock_map = Map.adjust f sid (sock_map h) }) + +insert_sock :: SocketID -> TCPSocket t -> HMonad t () +insert_sock sid sock = do + modify_host (\h -> h { sock_map = Map.insert sid sock (sock_map h) }) diff --git a/src/Hans/Layer/Tcp/Socket.hs b/src/Hans/Layer/Tcp/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Tcp/Socket.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Hans.Layer.Tcp.Socket ( + -- * Socket Layer + Socket() + , SocketError(..) + , listenPort + , acceptSocket + , connect + , sendSocket + , closeSocket + , readBytes + , readLine + ) where + +import Hans.Address.IP4 +import Hans.Channel +import Hans.Layer +import Hans.Layer.Tcp.Monad +import Hans.Message.Tcp (TcpPort(..)) + +import Network.TCP.LTS.User (tcp_process_user_request) +import Network.TCP.Type.Base + (IPAddr(..),SocketID,TCPAddr(..)) +import Network.TCP.Type.Syscall (SockReq(..),SockRsp(..)) + +import Control.Exception (throwIO,Exception) +import Control.Concurrent (MVar,newMVar,newEmptyMVar,takeMVar,putMVar) +import Data.Typeable (Typeable) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +-- Socket Layer ---------------------------------------------------------------- + +data Socket = Socket + { socketTcpHandle :: TcpHandle + , socketId :: !SocketID + , socketBuffer :: MVar L.ByteString + } + +data SocketResult a + = SocketResult a + | SocketError SocketError + +data SocketError + = ListenError String + | AcceptError String + | ConnectError String + | SendError String + | RecvError String + | CloseError String + deriving (Typeable,Show) + +instance Exception SocketError + +-- | Block on a socket operation, waiting for the TCP layer to finish an action. +blockResult :: TcpHandle -> (MVar (SocketResult a) -> Tcp ()) -> IO a +blockResult tcp k = do + var <- newEmptyMVar + send tcp (k var) + sr <- takeMVar var + case sr of + SocketResult a -> return a + SocketError se -> throwIO se + +-- | Call @output@ if the @Tcp@ action returns a @Just@. +maybeOutput :: Tcp (Maybe (IO ())) -> Tcp () +maybeOutput body = do + mb <- body + case mb of + Just m -> output m + Nothing -> return () + +-- | Listen on a port. +listenPort :: TcpHandle -> TcpPort -> IO Socket +listenPort tcp (TcpPort port) = blockResult tcp $ \ res -> do + let mkError = SocketError . ListenError + k rsp = case rsp of + SockNew sid -> do + buf <- newMVar L.empty + putMVar res (SocketResult (Socket tcp sid buf)) + SockError err -> putMVar res (mkError err) + _ -> putMVar res (mkError "Unexpected response") + maybeOutput (tcp_process_user_request (SockListen port,k)) + +-- | Accept a client connection on a @Socket@. +acceptSocket :: Socket -> IO Socket +acceptSocket sock = blockResult (socketTcpHandle sock) $ \ res -> do + let mkError = SocketError . AcceptError + k rsp = case rsp of + SockNew sid -> do + buf <- newMVar L.empty + putMVar res (SocketResult (Socket (socketTcpHandle sock) sid buf)) + SockError err -> putMVar res (mkError err) + _ -> putMVar res (mkError "Unexpected response") + maybeOutput (tcp_process_user_request (SockAccept (socketId sock),k)) + +-- | Connect to a remote server. +connect :: TcpHandle -> IP4 -> IP4 -> TcpPort -> IO Socket +connect tcp src dst (TcpPort port) = blockResult tcp $ \ res -> do + let us = IPAddr (convertToWord32 src) + them = TCPAddr (IPAddr (convertToWord32 dst), port) + mkError = SocketError . ConnectError + k rsp = case rsp of + SockNew sid -> do + buf <- newMVar L.empty + putMVar res (SocketResult (Socket tcp sid buf)) + SockError err -> putMVar res (mkError err) + _ -> putMVar res (mkError "Unexpected response") + maybeOutput (tcp_process_user_request (SockConnect us them,k)) + +-- | Send on a @Socket@. +sendSocket :: Socket -> S.ByteString -> IO () +sendSocket sock bytes = blockResult (socketTcpHandle sock) $ \ res -> do + let mkError = SocketError . SendError + k rsp = putMVar res $! case rsp of + SockOK -> SocketResult () + SockError err -> mkError err + _ -> mkError "Unexpected response" + maybeOutput (tcp_process_user_request (SockSend (socketId sock) bytes,k)) + +-- | Receive from a @Socket@. +recvSocket :: Socket -> IO S.ByteString +recvSocket sock = blockResult (socketTcpHandle sock) $ \ res -> do + let mkError = SocketError . RecvError + k rsp = putMVar res $! case rsp of + SockData bs -> SocketResult bs + SockError err -> mkError err + _ -> mkError "Unexpected response" + maybeOutput (tcp_process_user_request (SockRecv (socketId sock),k)) + +-- | Close a socket. +closeSocket :: Socket -> IO () +closeSocket sock = + blockResult (socketTcpHandle sock) $ \ res -> do + let mkError = SocketError . CloseError + k rsp = putMVar res $! case rsp of + SockOK -> SocketResult () + SockError err -> mkError err + _ -> mkError "Unexpected response" + maybeOutput (tcp_process_user_request (SockClose (socketId sock),k)) + + +-- Derived Interaction --------------------------------------------------------- + +-- | Read n bytes from a @Socket@. +readBytes :: Socket -> Int -> IO S.ByteString +readBytes sock goal = do + buf <- takeMVar (socketBuffer sock) + loop buf (fromIntegral (L.length buf)) + where + loop buf len + | goal <= len = finish buf + | otherwise = do + bytes <- recvSocket sock + if S.null bytes + then finish buf + else loop (buf `L.append` L.fromChunks [bytes]) (len + S.length bytes) + + finish buf = do + let (as,bs) = L.splitAt (fromIntegral goal) buf + putMVar (socketBuffer sock) bs + return (S.concat (L.toChunks as)) + +-- | Read until a CRLF, LF or CR are read. +readLine :: Socket -> IO S.ByteString +readLine sock = do + buf <- takeMVar (socketBuffer sock) + loop False 0 buf + where + loop cr ix buf + | L.null buf = fillBuffer cr ix buf + | otherwise = + case L.index buf ix of + 0x0d -> loop True (ix+1) buf + 0x0a -> finish (ix+1) buf + _ | cr -> finish ix buf + | otherwise -> loop False (ix+1) buf + + fillBuffer cr ix buf = do + bytes <- recvSocket sock + if S.null bytes + then finish ix buf + else loop cr ix (buf `L.append` L.fromChunks [bytes]) + + finish ix buf = do + let (as,bs) = L.splitAt ix buf + putMVar (socketBuffer sock) bs + return (S.concat (L.toChunks as)) diff --git a/src/Hans/Layer/Timer.hs b/src/Hans/Layer/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Timer.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS -fno-warn-orphans #-} + +module Hans.Layer.Timer ( + TimerHandle + , runTimerLayer + + , Milliseconds + , delay + , Microseconds + , udelay + ) where + +import Hans.Channel + +import Control.Concurrent (forkIO,threadDelay,MVar,newMVar,takeMVar,putMVar) +import Data.FingerTree as FT +import Data.Monoid (Monoid(..)) +import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime) +import MonadLib + + +-- The Timers Structure -------------------------------------------------------- + +data Timer a = Timer + { timerAt :: POSIXTime + , timerValue :: a + } + +instance Monoid POSIXTime where + mempty = 0 + mappend a b | a > b = a + | otherwise = b + +instance Measured POSIXTime (Timer a) where + measure t = timerAt t + +type Timers a = FingerTree POSIXTime (Timer a) + + +-- | Add an action to happen sometime in the future. +at :: POSIXTime -> a -> Timers a -> Timers a +at fut a ts = as' >< bs + where + (as,bs) = runnable fut ts + as' = as |> Timer fut a + + +-- | Partition the actions into runnable and deferred. +runnable :: POSIXTime -> Timers a -> (Timers a, Timers a) +runnable now ts = FT.split (> now) ts + + +-- | Step through the timers in a group. +stepTimers :: Timers a -> Maybe (a, Timers a) +stepTimers ts = case viewl ts of + EmptyL -> Nothing + r :< rs -> Just (timerValue r,rs) + + +-- | Run all timers, when the action is an IO action. +runTimers :: Timers (IO a) -> IO (Timers (IO a)) +runTimers ts = do + now <- getPOSIXTime + let loop (Just (a,as)) = a >> loop (stepTimers as) + loop Nothing = return () + (rs,rest) = runnable now ts + loop (stepTimers rs) + return rest + + +-- The External Message Interface ---------------------------------------------- + +type ActionTimers = Timers (IO ()) + +-- | Mesages handled by the timer thread. +data TimerMessage = AddTimer POSIXTime (IO ()) + +-- | A channel to the timer thread. +type TimerHandle = Channel TimerMessage + + +-- | Start the timer thread. +runTimerLayer :: TimerHandle -> IO () +runTimerLayer h = do + timers <- newMVar FT.empty + _ <- forkIO (actionHandler timers) + _ <- forkIO (messageHandler h timers) + return () + + +type Milliseconds = Int + +-- | Add a message to happen after some number of milliseconds. +delay :: TimerHandle -> Milliseconds -> IO () -> IO () +delay h !off = udelay h (off * 1000) + +type Microseconds = Int + +-- | Add a message to happen after some number of microseconds. +udelay :: TimerHandle -> Microseconds -> IO () -> IO () +udelay h !micros k = do + now <- getPOSIXTime + -- the granularity for a NominalTimeDiff is 10^-12 + let off = fromIntegral micros / 1000000 + send h (AddTimer (now + off) k) + + +-- Internal Loops -------------------------------------------------------------- + +-- | The delay granularity of the timer layer. +timerStep :: Microseconds +timerStep = 100 + + +-- | Loop, running available timer actions. +actionHandler :: MVar ActionTimers -> IO () +actionHandler timers = forever $ do + threadDelay timerStep + putMVar timers =<< runTimers =<< takeMVar timers + + +-- | Loop, processing timer add requests. +messageHandler :: TimerHandle -> MVar ActionTimers -> IO () +messageHandler h timers = forever $ do + AddTimer t k <- receive h + ts <- takeMVar timers + putMVar timers $! at t k ts diff --git a/src/Hans/Layer/Udp.hs b/src/Hans/Layer/Udp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Layer/Udp.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Layer.Udp ( + UdpHandle + , runUdpLayer + + , queueUdp + , sendUdp + , addUdpHandler + , removeUdpHandler + ) where + +import Hans.Address.IP4 +import Hans.Channel +import Hans.Layer +import Hans.Layer.IP4 +import Hans.Layer.Icmp4 +import Hans.Message.Ip4 +import Hans.Message.Udp +import Hans.Ports +import Hans.Utils + +import Control.Concurrent (forkIO) +import Data.Serialize.Get (runGet) +import MonadLib (get,set) + + +type Handler = IP4 -> UdpPort -> Packet -> IO () + +type UdpHandle = Channel (Udp ()) + +udpProtocol :: IP4Protocol +udpProtocol = IP4Protocol 0x11 + +runUdpLayer :: UdpHandle -> IP4Handle -> Icmp4Handle -> IO () +runUdpLayer h ip4 icmp4 = do + addIP4Handler ip4 udpProtocol (queueUdp h) + void (forkIO (loopLayer (emptyUdp4State ip4 icmp4) (receive h) id)) + +sendUdp :: UdpHandle -> IP4 -> Maybe UdpPort -> UdpPort -> Packet -> IO () +sendUdp h !dst mb !dp !bs = send h (handleOutgoing dst mb dp bs) + +queueUdp :: UdpHandle -> IP4 -> IP4 -> Packet -> IO () +queueUdp h !src !dst !bs = send h (handleIncoming src dst bs) + +addUdpHandler :: UdpHandle -> UdpPort -> Handler -> IO () +addUdpHandler h !sp k = send h (handleAddHandler sp k) + +removeUdpHandler :: UdpHandle -> UdpPort -> IO () +removeUdpHandler h !sp = send h (handleRemoveHandler sp) + + +-- Udp State ------------------------------------------------------------------- + +type Udp = Layer UdpState + +data UdpState = UdpState + { udpPorts :: PortManager UdpPort + , udpHandlers :: Handlers UdpPort Handler + , udpIp4Handle :: IP4Handle + , udpIcmp4Handle :: Icmp4Handle + } + +emptyUdp4State :: IP4Handle -> 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 ------------------------------------------------------------------- + +ip4Handle :: Udp IP4Handle +ip4Handle = udpIp4Handle `fmap` get + +--icmp4Handle :: Udp Icmp4Handle +--icmp4Handle = udpIcmp4Handle `fmap` get + +maybePort :: Maybe UdpPort -> Udp UdpPort +maybePort (Just p) = return p +maybePort Nothing = do + state <- get + (p,pm') <- nextPort (udpPorts state) + pm' `seq` set state { udpPorts = pm' } + return p + +-- Message Handling ------------------------------------------------------------ + +handleAddHandler :: UdpPort -> Handler -> Udp () +handleAddHandler sp k = do + state <- get + pm' <- reserve sp (udpPorts state) + pm' `seq` set state { udpPorts = pm' } + addHandler sp k + +handleRemoveHandler :: UdpPort -> Udp () +handleRemoveHandler sp = do + state <- get + pm' <- unreserve sp (udpPorts state) + pm' `seq` set state { udpPorts = pm' } + removeHandler sp + + +handleIncoming :: IP4 -> IP4 -> Packet -> Udp () +handleIncoming src _dst bs = do + UdpPacket hdr pkt <- liftRight (runGet parseUdpPacket bs) + h <- getHandler (udpDestPort hdr) + output (h src (udpSourcePort hdr) pkt) + + +handleOutgoing :: IP4 -> Maybe UdpPort -> UdpPort -> Packet -> Udp () +handleOutgoing dst mb dp bs = do + sp <- maybePort mb + ip4 <- ip4Handle + let udp = UdpPacket (UdpHeader sp dp 0) bs + output $ withIP4Source ip4 dst $ \ src -> do + pkt <- renderUdpPacket udp (mkIP4PseudoHeader src dst udpProtocol) + sendIP4Packet ip4 udpProtocol dst pkt diff --git a/src/Hans/Message/Arp.hs b/src/Hans/Message/Arp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Arp.hs @@ -0,0 +1,74 @@ +module Hans.Message.Arp where + +import Hans.Address + +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get (getWord8,getWord16be) +import Data.Serialize.Put (putWord16be,putWord8) +import Data.Word (Word16) + + +-- Arp Packets ----------------------------------------------------------------- + +data ArpPacket hw p = ArpPacket + { arpHwType :: !Word16 + , arpPType :: !Word16 + , arpOper :: ArpOper + , arpSHA :: hw + , arpSPA :: p + , arpTHA :: hw + , arpTPA :: p + } + +-- | Decode an Arp message. +instance (Address hw, Address p) => Serialize (ArpPacket hw p) where + get = do + hty <- getWord16be + pty <- getWord16be + _ <- getWord8 + _ <- getWord8 + oper <- get + sha <- get + spa <- get + tha <- get + tpa <- get + return $! ArpPacket + { arpHwType = hty + , arpPType = pty + , arpOper = oper + , arpSHA = sha + , arpSPA = spa + , arpTHA = tha + , arpTPA = tpa + } + + put msg = do + putWord16be (arpHwType msg) + putWord16be (arpPType msg) + putWord8 (addrSize (arpSHA msg)) + putWord8 (addrSize (arpSPA msg)) + put (arpOper msg) + put (arpSHA msg) + put (arpSPA msg) + put (arpTHA msg) + put (arpTPA msg) + + +-- Arp Opcodes ----------------------------------------------------------------- + +data ArpOper + = ArpRequest -- ^ 0x1 + | ArpReply -- ^ 0x2 + deriving (Eq) + + +instance Serialize ArpOper where + get = do + b <- getWord16be + case b of + 0x1 -> return ArpRequest + 0x2 -> return ArpReply + _ -> fail "invalid Arp opcode" + + put ArpRequest = putWord16be 0x1 + put ArpReply = putWord16be 0x2 diff --git a/src/Hans/Message/Dhcp4.hs b/src/Hans/Message/Dhcp4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Dhcp4.hs @@ -0,0 +1,568 @@ +{- | 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 Control.Applicative ((<*), (<$>)) +import Control.Monad (unless) +import Data.Bits (testBit,bit) +import Data.Maybe (mapMaybe) +import Data.Serialize.Get (Get, getByteString, isolate, remaining, label, skip) +import Data.Serialize.Put (Put, putByteString) +import Data.Word (Word8,Word16,Word32) +import Numeric (showHex) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +-- 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 + , 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 <* (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 = 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 + , 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 + , 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 + , requestClientHardwareAddress = offerClientHardwareAddr offer + , requestParameters = [ OptTagSubnetMask + , OptTagBroadcastAddress + , OptTagTimeOffset + , OptTagRouters + , OptTagDomainName + , OptTagNameServers + , OptTagHostName + ] + , requestAddress = Just (offerYourAddr offer) + } diff --git a/src/Hans/Message/Dhcp4Codec.hs b/src/Hans/Message/Dhcp4Codec.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Dhcp4Codec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hans.Message.Dhcp4Codec where + +import Control.Applicative +import Data.List (find) +import qualified Data.Serialize +import Data.Serialize.Get +import Data.Serialize.Put +import Data.Word (Word8, Word16, Word32) + +import Hans.Address.IP4 (IP4,IP4Mask) +import Hans.Address.Mac (Mac) +import Hans.Address (Mask(..)) + +class CodecAtom a where + getAtom :: Get a + putAtom :: a -> Put + atomSize :: a -> Int + +instance (CodecAtom a, CodecAtom b) => CodecAtom (a,b) where + getAtom = (,) <$> getAtom <*> getAtom + putAtom (a,b) = putAtom a *> putAtom b + atomSize (a,b)= atomSize a + atomSize b + +instance CodecAtom Word8 where + getAtom = getWord8 + putAtom n = putWord8 n + atomSize _ = 1 + +instance CodecAtom Word16 where + getAtom = getWord16be + putAtom n = putWord16be n + atomSize _ = 2 + +instance CodecAtom Word32 where + getAtom = getWord32be + putAtom n = putWord32be n + atomSize _ = 4 + +instance CodecAtom Bool where + getAtom = do b <- getWord8 + case b of + 0 -> return False + 1 -> return True + _ -> fail "Expected 0/1 in boolean option" + putAtom False = putWord8 0 + putAtom True = putWord8 1 + atomSize _ = 1 + +instance CodecAtom IP4 where + getAtom = Data.Serialize.get + putAtom = Data.Serialize.put + atomSize _ = 4 + +instance CodecAtom IP4Mask where + getAtom = withMask <$> getAtom <*> (unmask <$> getAtom) + putAtom ip4mask = putAtom addr *> putAtom (SubnetMask mask) + where (addr, mask) = getMaskComponents ip4mask + atomSize _ = atomSize (undefined :: IP4) + + atomSize (undefined :: SubnetMask) + +instance CodecAtom Mac where + getAtom = Data.Serialize.get + putAtom = Data.Serialize.put + atomSize _ = 6 + +----------------------------------------------------------------------- +-- Subnet parser/unparser operations ---------------------------------- +----------------------------------------------------------------------- + +newtype SubnetMask = SubnetMask { unmask :: Int} + deriving (Show, Eq) + +word32ToSubnetMask :: Word32 -> Maybe SubnetMask +word32ToSubnetMask mask = + SubnetMask <$> find (\ i -> computeMask i == mask) [0..32] + +subnetMaskToWord32 :: SubnetMask -> Word32 +subnetMaskToWord32 (SubnetMask n) = computeMask n + +computeMask :: Int -> Word32 +computeMask n = 0-2^(32-n) + +instance CodecAtom SubnetMask where + getAtom = do x <- getAtom + case word32ToSubnetMask x of + Just mask -> return mask + Nothing -> fail "Invalid subnet mask" + putAtom = putAtom . subnetMaskToWord32 + atomSize _ = atomSize (undefined :: Word32) diff --git a/src/Hans/Message/Dhcp4Options.hs b/src/Hans/Message/Dhcp4Options.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Dhcp4Options.hs @@ -0,0 +1,869 @@ +module Hans.Message.Dhcp4Options where + +import Control.Monad (unless) +import Control.Applicative +import Data.Maybe (fromMaybe) +import Data.Foldable (traverse_) +import Data.Traversable (sequenceA) +import Data.Word (Word8, Word16, Word32) +import Data.Serialize.Get +import Data.Serialize.Put +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Numeric (showHex) + +import Hans.Address.IP4 (IP4,IP4Mask) +import Hans.Message.Dhcp4Codec + +----------------------------------------------------------------------- +-- Magic constants ---------------------------------------------------- +----------------------------------------------------------------------- + +data MagicCookie = MagicCookie + +dhcp4MagicCookie :: Word32 +dhcp4MagicCookie = 0x63825363 + +instance CodecAtom MagicCookie where + getAtom = do cookie <- getAtom + unless (cookie == dhcp4MagicCookie) + (fail "Incorrect magic cookie.") + return MagicCookie + putAtom MagicCookie = putAtom dhcp4MagicCookie + atomSize MagicCookie = atomSize dhcp4MagicCookie + + +----------------------------------------------------------------------- +-- DHCP option type and operations ------------------------------------ +----------------------------------------------------------------------- + +data Dhcp4Option + = OptSubnetMask SubnetMask + | OptTimeOffset Word32 + | OptRouters [IP4] + | OptTimeServers [IP4] + | OptIEN116NameServers [IP4] + | OptNameServers [IP4] + | OptLogServers [IP4] + | OptCookieServers [IP4] + | OptLPRServers [IP4] + | OptImpressServers [IP4] + | OptResourceLocationServers [IP4] + | OptHostName NVTAsciiString + | OptBootFileSize Word16 + | OptMeritDumpFile NVTAsciiString + | OptDomainName NVTAsciiString + | OptSwapServer IP4 + | OptRootPath NVTAsciiString + | OptExtensionsPath NVTAsciiString + | OptEnableIPForwarding Bool + | OptEnableNonLocalSourceRouting Bool + | OptPolicyFilters [IP4Mask] + | OptMaximumDatagramReassemblySize Word16 + | OptDefaultTTL Word8 + | OptPathMTUAgingTimeout Word32 + | OptPathMTUPlateauTable [Word16] + | OptInterfaceMTU Word16 + | OptAllSubnetsAreLocal Bool + | OptBroadcastAddress IP4 + | OptPerformMaskDiscovery Bool + | OptShouldSupplyMasks Bool + | OptShouldPerformRouterDiscovery Bool + | OptRouterSolicitationAddress IP4 + | OptStaticRoutes [(IP4,IP4)] + | OptShouldNegotiateArpTrailers Bool + | OptArpCacheTimeout Word32 + | OptUseRFC1042EthernetEncapsulation Bool + | OptTcpDefaultTTL Word8 + | OptTcpKeepaliveInterval Word32 + | OptTcpKeepaliveUseGarbage Bool + | OptNisDomainName NVTAsciiString + | OptNisServers [IP4] + | OptNtpServers [IP4] + | OptVendorSpecific ByteString + | OptNetBiosNameServers [IP4] + | OptNetBiosDistributionServers [IP4] + | OptNetBiosNodeType NetBiosNodeType + | OptNetBiosScope NVTAsciiString + | OptXWindowsFontServer [IP4] + | OptXWindowsDisplayManagers [IP4] + | OptNisPlusDomain NVTAsciiString + | OptNisPlusServers [IP4] + | OptSmtpServers [IP4] + | OptPopServers [IP4] + | OptNntpServers [IP4] + | OptWwwServers [IP4] + | OptFingerServers [IP4] + | OptIrcServers [IP4] + | OptStreetTalkServers [IP4] + | OptStreetTalkDirectoryAssistanceServers [IP4] + | OptFQDN NVTAsciiString -- RFC 4702 + | OptRequestIPAddress IP4 + | OptIPAddressLeaseTime Word32 + | OptOverload OverloadOption + | OptTftpServer NVTAsciiString + | OptBootfileName NVTAsciiString + | OptMessageType Dhcp4MessageType + | OptServerIdentifier IP4 + | OptParameterRequestList [OptionTagOrError] + | OptErrorMessage NVTAsciiString + | OptMaxDHCPMessageSize Word16 + | OptRenewalTime Word32 + | OptRebindingTime Word32 + | OptVendorClass NVTAsciiString + | OptClientIdentifier ByteString + | OptNetWareDomainName NVTAsciiString -- RFC 2242 + | OptNetWareInfo ByteString -- RFC 2242 + | OptAutoconfiguration Bool -- RFC 2563 + deriving (Show,Eq) + +getDhcp4Option :: Get (Either ControlTag Dhcp4Option) +getDhcp4Option = do + mb_tag <- getOptionTag + case mb_tag of + UnknownTag t -> do xs <- getBytes =<< remaining + fail ("getDhcp4Option failed tag (" ++ show t ++ ") " ++ show xs) + KnownTag tag -> do + let r con = Right . con <$> getOption + case tag of + OptTagPad -> Left <$> pure ControlPad + OptTagEnd -> Left <$> pure ControlEnd + OptTagSubnetMask -> r OptSubnetMask + OptTagTimeOffset -> r OptTimeOffset + OptTagRouters -> r OptRouters + OptTagTimeServers -> r OptTimeServers + OptTagIEN116NameServers -> r OptIEN116NameServers + OptTagNameServers -> r OptNameServers + OptTagLogServers -> r OptLogServers + OptTagCookieServers -> r OptCookieServers + OptTagLPRServers -> r OptLPRServers + OptTagImpressServers -> r OptImpressServers + OptTagResourceLocationServers -> r OptResourceLocationServers + OptTagHostName -> r OptHostName + OptTagBootFileSize -> r OptBootFileSize + OptTagMeritDumpFile -> r OptMeritDumpFile + OptTagDomainName -> r OptDomainName + OptTagSwapServer -> r OptSwapServer + OptTagRootPath -> r OptRootPath + OptTagExtensionsPath -> r OptExtensionsPath + OptTagEnableIPForwarding -> r OptEnableIPForwarding + OptTagEnableNonLocalSourceRouting -> r OptEnableNonLocalSourceRouting + OptTagPolicyFilters -> r OptPolicyFilters + OptTagMaximumDatagramReassemblySize -> r OptMaximumDatagramReassemblySize + OptTagDefaultTTL -> r OptDefaultTTL + OptTagPathMTUAgingTimeout -> r OptPathMTUAgingTimeout + OptTagPathMTUPlateauTable -> r OptPathMTUPlateauTable + OptTagInterfaceMTU -> r OptInterfaceMTU + OptTagAllSubnetsAreLocal -> r OptAllSubnetsAreLocal + OptTagBroadcastAddress -> r OptBroadcastAddress + OptTagPerformMaskDiscovery -> r OptPerformMaskDiscovery + OptTagShouldSupplyMasks -> r OptShouldSupplyMasks + OptTagShouldPerformRouterDiscovery -> r OptShouldPerformRouterDiscovery + OptTagRouterSolicitationAddress -> r OptRouterSolicitationAddress + OptTagStaticRoutes -> r OptStaticRoutes + OptTagShouldNegotiateArpTrailers -> r OptShouldNegotiateArpTrailers + OptTagArpCacheTimeout -> r OptArpCacheTimeout + OptTagUseRFC1042EthernetEncapsulation -> r OptUseRFC1042EthernetEncapsulation + OptTagTcpDefaultTTL -> r OptTcpDefaultTTL + OptTagTcpKeepaliveInterval -> r OptTcpKeepaliveInterval + OptTagTcpKeepaliveUseGarbage -> r OptTcpKeepaliveUseGarbage + OptTagNisDomainName -> r OptNisDomainName + OptTagNisServers -> r OptNisServers + OptTagNtpServers -> r OptNtpServers + OptTagVendorSpecific -> r OptVendorSpecific + OptTagNetBiosNameServers -> r OptNetBiosNameServers + OptTagNetBiosDistributionServers -> r OptNetBiosDistributionServers + OptTagNetBiosNodeType -> r OptNetBiosNodeType + OptTagNetBiosScope -> r OptNetBiosScope + OptTagXWindowsFontServer -> r OptXWindowsFontServer + OptTagXWindowsDisplayManagers -> r OptXWindowsDisplayManagers + OptTagNisPlusDomain -> r OptNisPlusDomain + OptTagNisPlusServers -> r OptNisPlusServers + OptTagSmtpServers -> r OptSmtpServers + OptTagPopServers -> r OptPopServers + OptTagNntpServers -> r OptNntpServers + OptTagWwwServers -> r OptWwwServers + OptTagFingerServers -> r OptFingerServers + OptTagIrcServers -> r OptIrcServers + OptTagStreetTalkServers -> r OptStreetTalkServers + OptTagStreetTalkDirectoryAssistanceServers -> r OptStreetTalkDirectoryAssistanceServers + OptTagFQDN -> r OptFQDN + OptTagRequestIPAddress -> r OptRequestIPAddress + OptTagIPAddressLeaseTime -> r OptIPAddressLeaseTime + OptTagOverload -> r OptOverload + OptTagTftpServer -> r OptTftpServer + OptTagBootfileName -> r OptBootfileName + OptTagMessageType -> r OptMessageType + OptTagServerIdentifier -> r OptServerIdentifier + OptTagParameterRequestList -> r OptParameterRequestList + OptTagErrorMessage -> r OptErrorMessage + OptTagMaxDHCPMessageSize -> r OptMaxDHCPMessageSize + OptTagRenewalTime -> r OptRenewalTime + OptTagRebindingTime -> r OptRebindingTime + OptTagVendorClass -> r OptVendorClass + OptTagClientIdentifier -> r OptClientIdentifier + OptTagNetWareDomainName -> r OptNetWareDomainName + OptTagNetWareInfo -> r OptNetWareInfo + OptTagAutoconfiguration -> r OptAutoconfiguration + +putDhcp4Option :: Dhcp4Option -> Put +putDhcp4Option opt = + let p tag val = putAtom (KnownTag tag) *> putOption val in + case opt of + OptSubnetMask mask -> p OptTagSubnetMask mask + OptTimeOffset offset -> p OptTagTimeOffset offset + OptRouters routers -> p OptTagRouters routers + OptTimeServers servers -> p OptTagTimeServers servers + OptIEN116NameServers servers -> p OptTagIEN116NameServers servers + OptNameServers servers -> p OptTagNameServers servers + OptLogServers servers -> p OptTagLogServers servers + OptCookieServers servers -> p OptTagCookieServers servers + OptLPRServers servers -> p OptTagLPRServers servers + OptImpressServers servers -> p OptTagImpressServers servers + OptResourceLocationServers servers -> p OptTagResourceLocationServers servers + OptHostName hostname -> p OptTagHostName hostname + OptBootFileSize sz -> p OptTagBootFileSize sz + OptMeritDumpFile file -> p OptTagMeritDumpFile file + OptDomainName domainname -> p OptTagDomainName domainname + OptSwapServer server -> p OptTagSwapServer server + OptRootPath path -> p OptTagRootPath path + OptExtensionsPath path -> p OptTagExtensionsPath path + OptEnableIPForwarding enabled -> p OptTagEnableIPForwarding enabled + OptEnableNonLocalSourceRouting enab -> p OptTagEnableNonLocalSourceRouting enab + OptPolicyFilters filters -> p OptTagPolicyFilters filters + OptMaximumDatagramReassemblySize n -> p OptTagMaximumDatagramReassemblySize n + OptDefaultTTL ttl -> p OptTagDefaultTTL ttl + OptPathMTUAgingTimeout timeout -> p OptTagPathMTUAgingTimeout timeout + OptPathMTUPlateauTable mtus -> p OptTagPathMTUPlateauTable mtus + OptInterfaceMTU mtu -> p OptTagInterfaceMTU mtu + OptAllSubnetsAreLocal arelocal -> p OptTagAllSubnetsAreLocal arelocal + OptBroadcastAddress addr -> p OptTagBroadcastAddress addr + OptPerformMaskDiscovery perform -> p OptTagPerformMaskDiscovery perform + OptShouldSupplyMasks should -> p OptTagShouldSupplyMasks should + OptShouldPerformRouterDiscovery b -> p OptTagShouldPerformRouterDiscovery b + OptRouterSolicitationAddress addr -> p OptTagRouterSolicitationAddress addr + OptStaticRoutes routes -> p OptTagStaticRoutes routes + OptShouldNegotiateArpTrailers b -> p OptTagShouldNegotiateArpTrailers b + OptArpCacheTimeout timeout -> p OptTagArpCacheTimeout timeout + OptUseRFC1042EthernetEncapsulation b-> p OptTagUseRFC1042EthernetEncapsulation b + OptTcpDefaultTTL ttl -> p OptTagTcpDefaultTTL ttl + OptTcpKeepaliveInterval interval -> p OptTagTcpKeepaliveInterval interval + OptTcpKeepaliveUseGarbage use -> p OptTagTcpKeepaliveUseGarbage use + OptNisDomainName domainname -> p OptTagNisDomainName domainname + OptNisServers servers -> p OptTagNisServers servers + OptNtpServers servers -> p OptTagNtpServers servers + OptVendorSpecific bs -> p OptTagVendorSpecific bs + OptNetBiosNameServers servers -> p OptTagNetBiosNameServers servers + OptNetBiosDistributionServers srvs -> p OptTagNetBiosDistributionServers srvs + OptNetBiosNodeType node -> p OptTagNetBiosNodeType node + OptNetBiosScope scope -> p OptTagNetBiosScope scope + OptXWindowsFontServer servers -> p OptTagXWindowsFontServer servers + OptXWindowsDisplayManagers servers -> p OptTagXWindowsDisplayManagers servers + OptNisPlusDomain domain -> p OptTagNisPlusDomain domain + OptNisPlusServers servers -> p OptTagNisPlusServers servers + OptSmtpServers servers -> p OptTagSmtpServers servers + OptPopServers servers -> p OptTagPopServers servers + OptNntpServers servers -> p OptTagNntpServers servers + OptWwwServers servers -> p OptTagWwwServers servers + OptFingerServers servers -> p OptTagFingerServers servers + OptIrcServers servers -> p OptTagIrcServers servers + OptStreetTalkServers servers -> p OptTagStreetTalkServers servers + OptStreetTalkDirectoryAssistanceServers servers -> p OptTagStreetTalkDirectoryAssistanceServers servers + OptFQDN fqdn -> p OptTagFQDN fqdn + OptRequestIPAddress addr -> p OptTagRequestIPAddress addr + OptIPAddressLeaseTime time -> p OptTagIPAddressLeaseTime time + OptOverload overload -> p OptTagOverload overload + OptTftpServer server -> p OptTagTftpServer server + OptBootfileName filename -> p OptTagBootfileName filename + OptMessageType t -> p OptTagMessageType t + OptServerIdentifier server -> p OptTagServerIdentifier server + OptParameterRequestList ps -> p OptTagParameterRequestList ps + OptErrorMessage msg -> p OptTagErrorMessage msg + OptMaxDHCPMessageSize maxsz -> p OptTagMaxDHCPMessageSize maxsz + OptRenewalTime time -> p OptTagRenewalTime time + OptRebindingTime time -> p OptTagRebindingTime time + OptVendorClass str -> p OptTagVendorClass str + OptClientIdentifier client -> p OptTagClientIdentifier client + OptNetWareDomainName name -> p OptTagNetWareDomainName name + OptNetWareInfo info -> p OptTagNetWareInfo info + OptAutoconfiguration autoconf -> p OptTagAutoconfiguration autoconf + +----------------------------------------------------------------------- +-- Message Type type and operations ----------------------------------- +----------------------------------------------------------------------- + +data Dhcp4MessageType + = Dhcp4Discover + | Dhcp4Offer + | Dhcp4Request + | Dhcp4Decline + | Dhcp4Ack + | Dhcp4Nak + | Dhcp4Release + | Dhcp4Inform + deriving (Eq,Show) + +instance Option Dhcp4MessageType where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom Dhcp4MessageType where + getAtom = do + b <- getAtom + case b :: Word8 of + 1 -> return Dhcp4Discover + 2 -> return Dhcp4Offer + 3 -> return Dhcp4Request + 4 -> return Dhcp4Decline + 5 -> return Dhcp4Ack + 6 -> return Dhcp4Nak + 7 -> return Dhcp4Release + 8 -> return Dhcp4Inform + _ -> fail ("Unknown DHCP Message Type 0x" ++ showHex b "") + + putAtom t = putAtom $ case t of + Dhcp4Discover -> 1 :: Word8 + Dhcp4Offer -> 2 + Dhcp4Request -> 3 + Dhcp4Decline -> 4 + Dhcp4Ack -> 5 + Dhcp4Nak -> 6 + Dhcp4Release -> 7 + Dhcp4Inform -> 8 + + atomSize _ = 1 + +----------------------------------------------------------------------- +-- Control tag type and operations ------------------------------------ +----------------------------------------------------------------------- + +data ControlTag + = ControlPad + | ControlEnd + deriving (Eq, Show) + +putControlOption :: ControlTag -> Put +putControlOption opt = case opt of + ControlPad -> putAtom (KnownTag OptTagPad) + ControlEnd -> putAtom (KnownTag OptTagEnd) + +----------------------------------------------------------------------- +-- Option tag type and operations ------------------------------------- +----------------------------------------------------------------------- + +data Dhcp4OptionTag + = OptTagPad + | OptTagEnd + | OptTagSubnetMask + | OptTagTimeOffset + | OptTagRouters + | OptTagTimeServers + | OptTagIEN116NameServers + | OptTagNameServers + | OptTagLogServers + | OptTagCookieServers + | OptTagLPRServers + | OptTagImpressServers + | OptTagResourceLocationServers + | OptTagHostName + | OptTagBootFileSize + | OptTagMeritDumpFile + | OptTagDomainName + | OptTagSwapServer + | OptTagRootPath + | OptTagExtensionsPath + | OptTagEnableIPForwarding + | OptTagEnableNonLocalSourceRouting + | OptTagPolicyFilters + | OptTagMaximumDatagramReassemblySize + | OptTagDefaultTTL + | OptTagPathMTUAgingTimeout + | OptTagPathMTUPlateauTable + | OptTagInterfaceMTU + | OptTagAllSubnetsAreLocal + | OptTagBroadcastAddress + | OptTagPerformMaskDiscovery + | OptTagShouldSupplyMasks + | OptTagShouldPerformRouterDiscovery + | OptTagRouterSolicitationAddress + | OptTagStaticRoutes + | OptTagShouldNegotiateArpTrailers + | OptTagArpCacheTimeout + | OptTagUseRFC1042EthernetEncapsulation + | OptTagTcpDefaultTTL + | OptTagTcpKeepaliveInterval + | OptTagTcpKeepaliveUseGarbage + | OptTagNisDomainName + | OptTagNisServers + | OptTagNtpServers + | OptTagVendorSpecific + | OptTagNetBiosNameServers + | OptTagNetBiosDistributionServers + | OptTagNetBiosNodeType + | OptTagNetBiosScope + | OptTagXWindowsFontServer + | OptTagXWindowsDisplayManagers + | OptTagNisPlusDomain + | OptTagNisPlusServers + | OptTagSmtpServers + | OptTagPopServers + | OptTagNntpServers + | OptTagWwwServers + | OptTagFingerServers + | OptTagIrcServers + | OptTagStreetTalkServers + | OptTagStreetTalkDirectoryAssistanceServers + | OptTagFQDN + | OptTagRequestIPAddress + | OptTagIPAddressLeaseTime + | OptTagOverload + | OptTagTftpServer + | OptTagBootfileName + | OptTagMessageType + | OptTagServerIdentifier + | OptTagParameterRequestList + | OptTagErrorMessage + | OptTagMaxDHCPMessageSize + | OptTagRenewalTime + | OptTagRebindingTime + | OptTagVendorClass + | OptTagClientIdentifier + | OptTagNetWareDomainName + | OptTagNetWareInfo + | OptTagAutoconfiguration + deriving (Show,Eq) + +data OptionTagOrError = UnknownTag Word8 | KnownTag Dhcp4OptionTag + deriving (Show,Eq) + +getOptionTag :: Get OptionTagOrError +getOptionTag = f =<< getWord8 + where + r = return . KnownTag + f 0 = r OptTagPad + f 1 = r OptTagSubnetMask + f 2 = r OptTagTimeOffset + f 3 = r OptTagRouters + f 4 = r OptTagTimeServers + f 5 = r OptTagIEN116NameServers + f 6 = r OptTagNameServers + f 7 = r OptTagLogServers + f 8 = r OptTagCookieServers + f 9 = r OptTagLPRServers + f 10 = r OptTagImpressServers + f 11 = r OptTagResourceLocationServers + f 12 = r OptTagHostName + f 13 = r OptTagBootFileSize + f 14 = r OptTagMeritDumpFile + f 15 = r OptTagDomainName + f 16 = r OptTagSwapServer + f 17 = r OptTagRootPath + f 18 = r OptTagExtensionsPath + f 19 = r OptTagEnableIPForwarding + f 20 = r OptTagEnableNonLocalSourceRouting + f 21 = r OptTagPolicyFilters + f 22 = r OptTagMaximumDatagramReassemblySize + f 23 = r OptTagDefaultTTL + f 24 = r OptTagPathMTUAgingTimeout + f 25 = r OptTagPathMTUPlateauTable + f 26 = r OptTagInterfaceMTU + f 27 = r OptTagAllSubnetsAreLocal + f 28 = r OptTagBroadcastAddress + f 29 = r OptTagPerformMaskDiscovery + f 30 = r OptTagShouldSupplyMasks + f 31 = r OptTagShouldPerformRouterDiscovery + f 32 = r OptTagRouterSolicitationAddress + f 33 = r OptTagStaticRoutes + f 34 = r OptTagShouldNegotiateArpTrailers + f 35 = r OptTagArpCacheTimeout + f 36 = r OptTagUseRFC1042EthernetEncapsulation + f 37 = r OptTagTcpDefaultTTL + f 38 = r OptTagTcpKeepaliveInterval + f 39 = r OptTagTcpKeepaliveUseGarbage + f 40 = r OptTagNisDomainName + f 41 = r OptTagNisServers + f 42 = r OptTagNtpServers + f 43 = r OptTagVendorSpecific + f 44 = r OptTagNetBiosNameServers + f 45 = r OptTagNetBiosDistributionServers + f 46 = r OptTagNetBiosNodeType + f 47 = r OptTagNetBiosScope + f 48 = r OptTagXWindowsFontServer + f 49 = r OptTagXWindowsDisplayManagers + f 50 = r OptTagRequestIPAddress + f 51 = r OptTagIPAddressLeaseTime + f 52 = r OptTagOverload + f 53 = r OptTagMessageType + f 54 = r OptTagServerIdentifier + f 55 = r OptTagParameterRequestList + f 56 = r OptTagErrorMessage + f 57 = r OptTagMaxDHCPMessageSize + f 58 = r OptTagRenewalTime + f 59 = r OptTagRebindingTime + f 60 = r OptTagVendorClass + f 61 = r OptTagClientIdentifier + f 62 = r OptTagNetWareDomainName + f 63 = r OptTagNetWareInfo + f 64 = r OptTagNisPlusDomain + f 65 = r OptTagNisPlusServers + f 66 = r OptTagTftpServer + f 67 = r OptTagBootfileName + f 69 = r OptTagSmtpServers + f 70 = r OptTagPopServers + f 71 = r OptTagNntpServers + f 72 = r OptTagWwwServers + f 73 = r OptTagFingerServers + f 74 = r OptTagIrcServers + f 75 = r OptTagStreetTalkServers + f 76 = r OptTagStreetTalkDirectoryAssistanceServers + f 81 = r OptTagFQDN + f 116 = r OptTagAutoconfiguration + f 255 = r OptTagEnd + f t = return (UnknownTag t) + +putOptionTag :: OptionTagOrError -> Put +putOptionTag (UnknownTag t) = putAtom t +putOptionTag (KnownTag t) = putAtom (f t) + where + f :: Dhcp4OptionTag -> Word8 + f OptTagPad = 0 + f OptTagEnd = 255 + f OptTagSubnetMask = 1 + f OptTagTimeOffset = 2 + f OptTagRouters = 3 + f OptTagTimeServers = 4 + f OptTagIEN116NameServers = 5 + f OptTagNameServers = 6 + f OptTagLogServers = 7 + f OptTagCookieServers = 8 + f OptTagLPRServers = 9 + f OptTagImpressServers = 10 + f OptTagResourceLocationServers = 11 + f OptTagHostName = 12 + f OptTagBootFileSize = 13 + f OptTagMeritDumpFile = 14 + f OptTagDomainName = 15 + f OptTagSwapServer = 16 + f OptTagRootPath = 17 + f OptTagExtensionsPath = 18 + f OptTagEnableIPForwarding = 19 + f OptTagEnableNonLocalSourceRouting = 20 + f OptTagPolicyFilters = 21 + f OptTagMaximumDatagramReassemblySize = 22 + f OptTagDefaultTTL = 23 + f OptTagPathMTUAgingTimeout = 24 + f OptTagPathMTUPlateauTable = 25 + f OptTagInterfaceMTU = 26 + f OptTagAllSubnetsAreLocal = 27 + f OptTagBroadcastAddress = 28 + f OptTagPerformMaskDiscovery = 29 + f OptTagShouldSupplyMasks = 30 + f OptTagShouldPerformRouterDiscovery = 31 + f OptTagRouterSolicitationAddress = 32 + f OptTagStaticRoutes = 33 + f OptTagShouldNegotiateArpTrailers = 34 + f OptTagArpCacheTimeout = 35 + f OptTagUseRFC1042EthernetEncapsulation = 36 + f OptTagTcpDefaultTTL = 37 + f OptTagTcpKeepaliveInterval = 38 + f OptTagTcpKeepaliveUseGarbage = 39 + f OptTagNisDomainName = 40 + f OptTagNisServers = 41 + f OptTagNtpServers = 42 + f OptTagVendorSpecific = 43 + f OptTagNetBiosNameServers = 44 + f OptTagNetBiosDistributionServers = 45 + f OptTagNetBiosNodeType = 46 + f OptTagNetBiosScope = 47 + f OptTagXWindowsFontServer = 48 + f OptTagXWindowsDisplayManagers = 49 + f OptTagRequestIPAddress = 50 + f OptTagIPAddressLeaseTime = 51 + f OptTagOverload = 52 + f OptTagMessageType = 53 + f OptTagServerIdentifier = 54 + f OptTagParameterRequestList = 55 + f OptTagErrorMessage = 56 + f OptTagMaxDHCPMessageSize = 57 + f OptTagRenewalTime = 58 + f OptTagRebindingTime = 59 + f OptTagVendorClass = 60 + f OptTagClientIdentifier = 61 + f OptTagNetWareDomainName = 62 + f OptTagNetWareInfo = 63 + f OptTagNisPlusDomain = 64 + f OptTagNisPlusServers = 65 + f OptTagTftpServer = 66 + f OptTagBootfileName = 67 + f OptTagSmtpServers = 69 + f OptTagPopServers = 70 + f OptTagNntpServers = 71 + f OptTagWwwServers = 72 + f OptTagFingerServers = 73 + f OptTagIrcServers = 74 + f OptTagStreetTalkServers = 75 + f OptTagStreetTalkDirectoryAssistanceServers = 76 + f OptTagFQDN = 81 + f OptTagAutoconfiguration = 116 + +----------------------------------------------------------------------- +-- NetBIOS node type and operations ----------------------------------- +----------------------------------------------------------------------- + +data NetBiosNodeType + = BNode + | PNode + | MNode + | HNode + deriving (Show,Eq) + +instance Option NetBiosNodeType where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom NetBiosNodeType where + getAtom = do + b <- getAtom + case b :: Word8 of + 0x1 -> return BNode + 0x2 -> return PNode + 0x4 -> return MNode + 0x8 -> return HNode + _ -> fail "Unknown NetBIOS node type" + + putAtom t = putAtom $ case t of + BNode -> 0x1 :: Word8 + PNode -> 0x2 + MNode -> 0x4 + HNode -> 0x8 + + atomSize _ = 1 + +----------------------------------------------------------------------- +-- Overload option type and operations -------------------------------- +----------------------------------------------------------------------- + +data OverloadOption + = UsedFileField + | UsedSNameField + | UsedBothFields + deriving (Show, Eq) + +instance Option OverloadOption where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption + +instance CodecAtom OverloadOption where + getAtom = do b <- getAtom + case b :: Word8 of + 1 -> return UsedFileField + 2 -> return UsedSNameField + 3 -> return UsedBothFields + _ -> fail ("Bad overload value 0x" ++ showHex b "") + putAtom t = putAtom $ case t of + UsedFileField -> 1 :: Word8 + UsedSNameField -> 2 + UsedBothFields -> 3 + + atomSize _ = atomSize (undefined :: Word8) + +----------------------------------------------------------------------- +-- Options list operations -------------------------------------------- +----------------------------------------------------------------------- + +getDhcp4Options :: ByteString -> ByteString + -> Get (String, String, [Dhcp4Option]) +getDhcp4Options sname file = do + MagicCookie <- getAtom + options0 <- remainingAsOptions + case lookupOverload options0 of + Nothing -> return (nullTerminated sname, nullTerminated file, options0) + + Just UsedFileField -> do + options1 <- localParse file remainingAsOptions + let options = options0 ++ options1 + NVTAsciiString fileString + = fromMaybe (NVTAsciiString "") (lookupFile options) + return (nullTerminated sname, fileString, options) + + Just UsedSNameField -> do + options1 <- localParse sname remainingAsOptions + let options = options0 ++ options1 + NVTAsciiString snameString + = fromMaybe (NVTAsciiString "") (lookupSname options) + return (snameString, nullTerminated file, options) + + Just UsedBothFields -> do + + -- The file field MUST be interpreted for options before the sname field. + -- RFC 2131, Section 4.1, Page 24 + options1 <- localParse file remainingAsOptions + options2 <- localParse sname remainingAsOptions + let options = options0 ++ options1 ++ options2 + NVTAsciiString snameString + = fromMaybe (NVTAsciiString "") (lookupSname options) + NVTAsciiString fileString + = fromMaybe (NVTAsciiString "") (lookupFile options) + return (snameString, fileString, options) + + where + remainingAsOptions = scrubControls =<< repeatedly getDhcp4Option + + localParse bs m = case runGet m bs of + Right x -> return x + Left err -> fail err + + +putDhcp4Options :: [Dhcp4Option] -> Put +putDhcp4Options opts = putAtom MagicCookie + *> traverse_ putDhcp4Option opts + *> putControlOption ControlEnd + +scrubControls :: (Applicative m, Monad m) + => [Either ControlTag Dhcp4Option] -> m [Dhcp4Option] +scrubControls [] = fail "No END option found" +scrubControls (Left ControlPad : xs) = scrubControls xs +scrubControls (Left ControlEnd : xs) = [] <$ traverse_ eatPad xs +scrubControls (Right o : xs) = (o :) <$> scrubControls xs + +-- | 'eatPad' fails on any non 'ControlPad' option with an error message. +eatPad :: Monad m => Either ControlTag Dhcp4Option -> m () +eatPad (Left ControlPad) = return () +eatPad _ = fail "Unexpected option after END option" + +replicateA :: Applicative f => Int -> f a -> f [a] +replicateA n f = sequenceA (replicate n f) + +repeatedly :: Get a -> Get [a] +repeatedly m = do + done <- isEmpty + if done then return [] + else (:) <$> m <*> repeatedly m + +nullTerminated :: ByteString -> String +nullTerminated = takeWhile (/= '\NUL') . BS8.unpack + +lookupOverload :: [Dhcp4Option] -> Maybe OverloadOption +lookupOverload = foldr f Nothing + where f (OptOverload o) _ = Just o + f _ a = a + +lookupFile :: [Dhcp4Option] -> Maybe NVTAsciiString +lookupFile = foldr f Nothing + where f (OptBootfileName fn) _ = Just fn + f _ a = a + +lookupSname :: [Dhcp4Option] -> Maybe NVTAsciiString +lookupSname = foldr f Nothing + where f (OptTftpServer n) _ = Just n + f _ a = a + +lookupParams :: [Dhcp4Option] -> Maybe [OptionTagOrError] +lookupParams = foldr f Nothing + where f (OptParameterRequestList n) _ = Just n + f _ a = a + +lookupMessageType :: [Dhcp4Option] -> Maybe Dhcp4MessageType +lookupMessageType = foldr f Nothing + where f (OptMessageType n) _ = Just n + f _ a = a + +lookupRequestAddr :: [Dhcp4Option] -> Maybe IP4 +lookupRequestAddr = foldr f Nothing + where f (OptRequestIPAddress n) _ = Just n + f _ a = a + +lookupLeaseTime :: [Dhcp4Option] -> Maybe Word32 +lookupLeaseTime = foldr f Nothing + where f (OptIPAddressLeaseTime t) _ = Just t + f _ a = a + +----------------------------------------------------------------------- +-- Protected parser and unparser monad -------------------------------- +----------------------------------------------------------------------- + +class Option a where + getOption :: Get a + putOption :: a -> Put + +instance CodecAtom a => Option [a] where + getOption = do + let (n, m) = getRecord + len <- getLen + let (count, remainder) = divMod len n + unless (remainder == 0) (fail ("Length was not a multiple of " ++ show n)) + unless (count > 0) (fail "Minimum length not met") + replicateA count $ label "List of fixed-length values" $ isolate n m + putOption xs = do putLen (atomSize (head xs) * length xs) + traverse_ putAtom xs + +instance (CodecAtom a, CodecAtom b) => Option (a,b) where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Bool where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word8 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word16 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option Word32 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option IP4 where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option SubnetMask where + getOption = defaultFixedGetOption + putOption = defaultFixedPutOption +instance Option ByteString where + getOption = do len <- getLen + getByteString len + putOption bs = do putLen (BS.length bs) + putByteString bs + +defaultFixedGetOption :: CodecAtom a => Get a +defaultFixedGetOption = fixedLen n m + where (n,m) = getRecord + +defaultFixedPutOption :: CodecAtom a => a -> Put +defaultFixedPutOption x = do + putLen (atomSize x) + putAtom x + +fixedLen :: Int -> Get a -> Get a +fixedLen expectedLen m = do + len <- getLen + unless (len == expectedLen) (fail "Bad length on \"fixed-length\" option.") + label "Fixed length field" (isolate expectedLen m) + +getRecord :: CodecAtom a => (Int, Get a) +getRecord = (atomSize undef, m) + where + (undef, m) = (undefined, getAtom) :: CodecAtom a => (a, Get a) + + +instance CodecAtom OptionTagOrError where + getAtom = getOptionTag + putAtom x = putOptionTag x + atomSize _ = 1 + +newtype NVTAsciiString = NVTAsciiString String + deriving (Eq, Show) + +instance Option NVTAsciiString where + getOption = do len <- getLen + bs <- getByteString len + return (NVTAsciiString (nullTerminated bs)) + putOption (NVTAsciiString str) = do + putLen (length str) + putByteString (BS8.pack str) + +getLen :: Get Int +getLen = fromIntegral <$> getWord8 + +putLen :: Int -> Put +putLen n = putWord8 $ fromIntegral n diff --git a/src/Hans/Message/EthernetFrame.hs b/src/Hans/Message/EthernetFrame.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/EthernetFrame.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hans.Message.EthernetFrame ( + EtherType(..) + , EthernetFrame(..) + ) where + +import Hans.Address.Mac (Mac) + +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get (Get,getBytes,remaining) +import Data.Serialize.Put (Put,putByteString) +import Data.ByteString (ByteString) +import Data.Word (Word16) +import Numeric (showHex) + +newtype EtherType = EtherType { getEtherType :: Word16 } + deriving (Eq,Num,Ord,Serialize) + +instance Show EtherType where + showsPrec _ (EtherType et) = showString "EtherType 0x" . showHex et + +data EthernetFrame = EthernetFrame + { etherDest :: !Mac + , etherSource :: !Mac + , etherType :: !EtherType + , etherData :: ByteString + } deriving (Eq,Show) + +instance Serialize EthernetFrame where + get = parseEthernetFrame + put = renderEthernetFrame + +parseEthernetFrame :: Get EthernetFrame +parseEthernetFrame = do + dst <- get + src <- get + ty <- get + body <- getBytes =<< remaining + return $! EthernetFrame dst src ty body + +renderEthernetFrame :: EthernetFrame -> Put +renderEthernetFrame (EthernetFrame s d t da) = + put s >> put d >> put t >> putByteString da diff --git a/src/Hans/Message/Icmp4.hs b/src/Hans/Message/Icmp4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Icmp4.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hans.Message.Icmp4 where + +import Hans.Address.IP4 (IP4) +import Hans.Message.Types (Lifetime) +import Hans.Utils (Packet) +import Hans.Utils.Checksum (pokeChecksum, computeChecksum) + +import Control.Monad (liftM2, unless, when, replicateM) +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get (getWord8, getByteString, remaining, skip, Get, label, + lookAhead, getBytes, isEmpty) +import Data.Serialize.Put (putWord8,putByteString, Put, runPut) +import Data.Int (Int32) +import Data.Word (Word8,Word16,Word32) +import System.IO.Unsafe (unsafePerformIO) + + +-- General ICMP Packets -------------------------------------------------------- + +data Icmp4Packet + -- RFC 792 - Internet Control Message Protocol + = EchoReply Identifier SequenceNumber Packet + | DestinationUnreachable DestinationUnreachableCode Packet + | SourceQuench Packet + | Redirect RedirectCode IP4 Packet + | Echo Identifier SequenceNumber Packet + | RouterAdvertisement Lifetime [RouterAddress] + | RouterSolicitation + | TimeExceeded TimeExceededCode Packet + | ParameterProblem Word8 Packet + | 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 Show + +noCode :: String -> Get () +noCode str = do + code <- getWord8 + unless (code == 0) + (fail (str ++ " expects code 0")) + +instance Serialize Icmp4Packet where + get = label "ICMP" $ do + rest <- lookAhead (getBytes =<< remaining) + unless (computeChecksum 0 rest == 0) + (fail "Bad checksum") + ty <- get + + 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 <- get + 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) + + + put = putByteString . unsafePerformIO . setChecksum . runPut . put' + -- Argument for safety: The bytestring being + -- destructively modified here is only accessible + -- through the composition and will never escape + where + setChecksum pkt = pokeChecksum (computeChecksum 0 pkt) pkt 2 + + 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 + put 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 17 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 + deriving Show + +instance Serialize DestinationUnreachableCode where + get = do b <- getWord8 + case b of + 0 -> return NetUnreachable + 1 -> return HostUnreachable + 2 -> return ProtocolUnreachable + 3 -> return PortUnreachable + 4 -> return FragmentationUnreachable + 5 -> return SourceRouteFailed + _ -> fail "Invalid code for Destination Unreachable" + + put NetUnreachable = putWord8 0 + put HostUnreachable = putWord8 1 + put ProtocolUnreachable = putWord8 2 + put PortUnreachable = putWord8 3 + put FragmentationUnreachable = putWord8 4 + put SourceRouteFailed = putWord8 5 + +data TimeExceededCode + = TimeToLiveExceededInTransit + | FragmentReassemblyTimeExceeded + deriving 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 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 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 Show + +instance Serialize RouterAddress where + get = liftM2 RouterAddress get get + + put ra = do + put (raAddr ra) + put (raPreferenceLevel ra) + +newtype Identifier = Identifier Word16 + deriving (Show, Eq, Ord, Num, Serialize) + +newtype SequenceNumber = SequenceNumber Word16 + deriving (Show, Eq, Ord, Num, Serialize) + +getUntilDone :: Serialize a => Get [a] +getUntilDone = do + empty <- isEmpty + if empty then return [] + else liftM2 (:) get getUntilDone diff --git a/src/Hans/Message/Ip4.hs b/src/Hans/Message/Ip4.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Ip4.hs @@ -0,0 +1,280 @@ +{-# 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.Serialize (Serialize(..)) +import Data.Serialize.Get (Get,getWord8,getWord16be,getByteString,isolate,label) +import Data.Serialize.Put (runPut,runPutM,putWord8,putWord16be,putByteString) +import Data.Bits (Bits((.&.),(.|.),testBit,setBit,shiftR,shiftL,bit)) +import Data.Word (Word8,Word16) +import qualified Data.ByteString as S + + +-- 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 IP4Packet = IP4Packet + { ip4Header :: !IP4Header + , ip4Payload :: S.ByteString + } deriving Show + +data IP4Header = IP4Header + { ip4Version :: !Word8 + , ip4TypeOfService :: !Word8 + , ip4Ident :: !Ident + , ip4MayFragment :: Bool + , ip4MoreFragments :: Bool + , ip4FragmentOffset :: !Word16 + , ip4TimeToLive :: !Word8 + , ip4Protocol :: !IP4Protocol + , ip4Checksum :: !Word16 + , ip4SourceAddr :: !IP4 + , ip4DestAddr :: !IP4 + , ip4Options :: [IP4Option] + } deriving Show + +emptyIP4Header :: IP4Protocol -> IP4 -> IP4 -> IP4Header +emptyIP4Header prot src dst = IP4Header + { ip4Version = 4 + , ip4TypeOfService = 0 + , ip4Ident = 0 + , ip4MayFragment = False + , ip4MoreFragments = False + , ip4FragmentOffset = 0 + , ip4TimeToLive = 127 + , ip4Protocol = prot + , ip4Checksum = 0 + , ip4SourceAddr = src + , ip4DestAddr = dst + , 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 :: IP4Packet -> Int +ip4PacketSize (IP4Packet hdr bs) = + ip4HeaderSize hdr + fromIntegral (S.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 -> IP4Packet -> [IP4Packet] +splitPacket mtu pkt + | ip4PacketSize pkt > mtu = fragmentPacket mtu' pkt + | otherwise = [pkt] + where + mtu' = fromIntegral (mtu - ip4HeaderSize (ip4Header pkt)) + + +-- | Given a fragment size and a packet, fragment the packet into multiple +-- smaller ones. +fragmentPacket :: Int -> IP4Packet -> [IP4Packet] +fragmentPacket mtu pkt@(IP4Packet hdr bs) + | payloadLen <= mtu = [pkt { ip4Header = noMoreFragments hdr }] + | otherwise = frag : fragmentPacket mtu pkt' + where + payloadLen = S.length bs + (as,rest) = S.splitAt mtu bs + alen = fromIntegral (S.length as) + pkt' = pkt { ip4Header = hdr', ip4Payload = rest } + hdr' = addOffset alen hdr + frag = pkt { ip4Header = moreFragments hdr, ip4Payload = as } + + +-- 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 | +-- +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ +parseIP4Packet :: Get (IP4Header, Int, Int) +parseIP4Packet = 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 + , ip4MayFragment = 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) + + +-- | The final step to render an IP header and its payload out as a bytestring. +renderIP4Packet :: IP4Packet -> IO Packet +renderIP4Packet (IP4Packet hdr pkt) = do + let (len,bs) = runPutM $ do + let (optbs,optlen) = renderOptions (ip4Options hdr) + let ihl = 20 + optlen + putWord8 (ip4Version hdr `shiftL` 4 .|. (ihl `div` 4)) + putWord8 (ip4TypeOfService hdr) + putWord16be (fromIntegral (S.length pkt) + fromIntegral ihl) + + put (ip4Ident hdr) + let frag | ip4MayFragment hdr = (`setBit` 1) + | otherwise = id + let morefrags | ip4MoreFragments hdr = (`setBit` 0) + | otherwise = id + let flags = frag (morefrags 0) + let off = ip4FragmentOffset hdr `div` 8 + putWord16be (flags `shiftL` 13 .|. off .&. 0x1fff) + + putWord8 (ip4TimeToLive hdr) + put (ip4Protocol hdr) + putWord16be 0 -- (ip4Checksum hdr) + + put (ip4SourceAddr hdr) + + put (ip4DestAddr hdr) + + putByteString optbs + + putByteString pkt + + return ihl + let cs = computeChecksum 0 (S.take (fromIntegral len) bs) + pokeChecksum cs bs 10 + + +-- 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 Show + + +ip4OptionSize :: IP4Option -> Int +ip4OptionSize opt = case ip4OptionNum opt of + 0 -> 1 + 1 -> 1 + _ -> 2 + fromIntegral (S.length (ip4OptionData opt)) + + +instance Serialize IP4Option where + get = do + b <- getWord8 + let optCopied = testBit b 7 + let optClass = (b `shiftR` 5) .&. 0x3 + let optNum = b .&. 0x1f + bs <- case optNum of + 0 -> return S.empty + 1 -> return S.empty + _ -> do + len <- getWord8 + unless (len >= 2) (fail "Option length parameter is to small") + getByteString (fromIntegral (len - 2)) + return $! IP4Option + { ip4OptionCopied = optCopied + , ip4OptionClass = optClass + , ip4OptionNum = optNum + , ip4OptionData = bs + } + put opt = do + let copied | ip4OptionCopied opt = bit 7 + | otherwise = 0 + putWord8 (copied .|. ((ip4OptionClass opt .&. 0x3) `shiftL` 5) + .|. ip4OptionNum opt .&. 0x1f) + case ip4OptionNum opt of + 0 -> return () + 1 -> return () + _ -> do + putWord8 (fromIntegral (S.length (ip4OptionData opt))) + putByteString (ip4OptionData opt) diff --git a/src/Hans/Message/Tcp.hs b/src/Hans/Message/Tcp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Tcp.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Message.Tcp where + +import Hans.Address.IP4 (IP4) +import Hans.Message.Ip4 (mkIP4PseudoHeader,IP4Protocol(..)) +import Hans.Utils.Checksum (computePartialChecksum,computeChecksum,pokeChecksum) + +import Control.Monad (when,unless,ap) +import Data.Bits ((.&.),setBit,testBit,shiftL,shiftR) +import Data.List (foldl',find) +import Data.Serialize + (Get,Put,Putter,getWord16be,putWord16be,getWord32be,putWord32be,getWord8 + ,putWord8,putByteString,getBytes,remaining,label,isolate,skip,runPut) +import Data.Word (Word8,Word16,Word32) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as S + + +-- Tcp Support Types ----------------------------------------------------------- + +tcpProtocol :: IP4Protocol +tcpProtocol = IP4Protocol 0x6 + +newtype TcpPort = TcpPort + { getPort :: Word16 + } deriving Show + +putTcpPort :: Putter TcpPort +putTcpPort (TcpPort w16) = putWord16be w16 + +getTcpPort :: Get TcpPort +getTcpPort = TcpPort `fmap` getWord16be + + +newtype TcpSeqNum = TcpSeqNum + { getSeqNum :: Word32 + } deriving (Eq,Ord,Show) + +putTcpSeqNum :: Putter TcpSeqNum +putTcpSeqNum (TcpSeqNum w32) = putWord32be w32 + +getTcpSeqNum :: Get TcpSeqNum +getTcpSeqNum = TcpSeqNum `fmap` getWord32be + + +newtype TcpAckNum = TcpAckNum + { getAckNum :: Word32 + } deriving (Eq,Ord,Show) + +putTcpAckNum :: Putter TcpAckNum +putTcpAckNum (TcpAckNum w32) = putWord32be w32 + +getTcpAckNum :: Get TcpAckNum +getTcpAckNum = TcpAckNum `fmap` getWord32be + + +-- 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 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 = TcpSeqNum 0 + , tcpAckNum = 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 + +-- | Calculate the length of a TcpHeader, in 4-byte octets. +tcpHeaderLength :: TcpHeader -> Int +tcpHeaderLength hdr = + tcpFixedHeaderLength + tcpOptionsLength (tcpOptions hdr) + +-- | Render a TcpHeader. The checksum value is never rendered, as it is +-- expected to be calculated and poked in afterwords. +putTcpHeader :: Putter TcpHeader +putTcpHeader hdr = do + putTcpPort (tcpSourcePort hdr) + putTcpPort (tcpDestPort hdr) + putTcpSeqNum (tcpSeqNum hdr) + putTcpAckNum (tcpAckNum hdr) + putWord8 (fromIntegral (tcpHeaderLength hdr) `shiftL` 4) + putTcpControl hdr + putWord16be (tcpWindow hdr) + putWord16be 0 + putWord16be (tcpUrgentPointer hdr) + putTcpOptions (tcpOptions hdr) + +-- | Parse out a TcpHeader, and its length. The resulting length is in bytes, +-- and is derived from the data offset. +getTcpHeader :: Get (TcpHeader,Int) +getTcpHeader = do + 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 <- getTcpOptions optsLen + let hdr = setTcpControl cont emptyTcpHeader + { tcpSourcePort = src + , tcpDestPort = dst + , tcpSeqNum = seqNum + , tcpAckNum = ackNum + , tcpWindow = win + , tcpChecksum = cs + , tcpUrgentPointer = urgent + , tcpOptions = 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 + +data TcpOptionTag + = OptTagEndOfOptions + | OptTagNoOption + | OptTagMaxSegmentSize + | OptTagWindowScaling + | 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 + 8 -> OptTagTimestamp + _ -> OptTagUnknown ty + +putTcpOptionTag :: Putter TcpOptionTag +putTcpOptionTag tag = + putWord8 $ case tag of + OptTagEndOfOptions -> 0 + OptTagNoOption -> 1 + OptTagMaxSegmentSize -> 2 + OptTagWindowScaling -> 3 + 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 + | OptTimestamp !Word32 !Word32 + | OptUnknown !Word8 !Word8 !S.ByteString + deriving Show + +tcpOptionTag :: TcpOption -> TcpOptionTag +tcpOptionTag opt = case opt of + OptEndOfOptions{} -> OptTagEndOfOptions + OptNoOption{} -> OptTagNoOption + OptMaxSegmentSize{} -> OptTagMaxSegmentSize + OptWindowScaling{} -> OptTagWindowScaling + OptTimestamp{} -> OptTagTimestamp + OptUnknown ty _ _ -> OptTagUnknown ty + +-- | Get the length of a TcpOptions, in 4-byte words. This rounds up to the +-- nearest 4-byte word. +tcpOptionsLength :: [TcpOption] -> Int +tcpOptionsLength opts + | left == 0 = len + | otherwise = len + 1 + where + (len,left) = foldl' step 0 opts `quotRem` 4 + step acc opt = tcpOptionLength opt + acc + +tcpOptionLength :: TcpOption -> Int +tcpOptionLength OptEndOfOptions{} = 1 +tcpOptionLength OptNoOption{} = 1 +tcpOptionLength OptMaxSegmentSize{} = 4 +tcpOptionLength OptWindowScaling{} = 3 +tcpOptionLength OptTimestamp{} = 10 +tcpOptionLength (OptUnknown _ len _) = fromIntegral len + + +-- | Render out the tcp options, and pad with zeros if they don't fall on a +-- 4-byte boundary. +putTcpOptions :: Putter [TcpOption] +putTcpOptions opts = do + let len = tcpOptionsLength opts + left = len `rem` 4 + padding + | left == 0 = 0 + | otherwise = 4 - left + mapM_ putTcpOption opts + when (padding > 0) (putByteString (S.replicate padding 0)) + +putTcpOption :: Putter TcpOption +putTcpOption opt = + case opt of + OptEndOfOptions -> putWord8 0 + OptNoOption -> putWord8 1 + OptMaxSegmentSize mss -> putMaxSegmentSize mss + OptWindowScaling w -> putWindowScaling w + OptTimestamp v r -> putTimestamp v r + OptUnknown ty len bs -> putUnknown ty len bs + +-- | Parse in known tcp options. +getTcpOptions :: Int -> Get [TcpOption] +getTcpOptions len = label ("Tcp Options (" ++ show len ++ ")") + $ isolate (len * 4) loop + where + loop = do + left <- remaining + if left <= 0 then return [] else body + + body = do + opt <- getTcpOption + case opt of + OptNoOption -> loop + + 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 + 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 + +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 8 + 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 -> Word8 -> S.ByteString -> Put +putUnknown ty len body = do + putWord8 ty + putWord8 len + putByteString body + + +-- Tcp Packet ------------------------------------------------------------------ + +data TcpPacket = TcpPacket + { tcpHeader :: !TcpHeader + , tcpBody :: !S.ByteString + } deriving Show + +-- | Parse a TcpPacket. +getTcpPacket :: Get TcpPacket +getTcpPacket = do + pktLen <- remaining + (hdr,hdrLen) <- getTcpHeader + body <- getBytes (pktLen - hdrLen) + return (TcpPacket hdr body) + +-- | Render out a TcpPacket, without calculating its checksum. +putTcpPacket :: Putter TcpPacket +putTcpPacket (TcpPacket hdr body) = do + putTcpHeader hdr + putByteString body + +-- | Calculate the checksum of a TcpHeader, and its body. +renderWithTcpChecksumIP4 :: IP4 -> IP4 -> TcpPacket -> S.ByteString +renderWithTcpChecksumIP4 src dst pkt@(TcpPacket _ body) = hdrbs `S.append` body + where + (hdrbs,_) = computeTcpChecksumIP4 src dst pkt + +-- | Calculate the checksum of a tcp packet, and return its rendered header. +computeTcpChecksumIP4 :: IP4 -> IP4 -> TcpPacket -> (S.ByteString,Word16) +computeTcpChecksumIP4 src dst (TcpPacket hdr body) = + -- this is safe, as the header bytestring that gets modified is modified at + -- its creation time. + (cs `seq` unsafePerformIO (pokeChecksum cs hdrbs 16), cs) + where + hdrbs = runPut (putTcpHeader hdr { tcpChecksum = 0 }) + phcs = computePartialChecksum 0 + $ mkIP4PseudoHeader src dst tcpProtocol + $ S.length hdrbs + S.length body + hdrcs = computePartialChecksum phcs hdrbs + cs = computeChecksum hdrcs body + +-- | Re-create the checksum, minimizing duplication of the original, rendered +-- TCP packet. +recreateTcpChecksumIP4 :: IP4 -> IP4 -> S.ByteString -> Word16 +recreateTcpChecksumIP4 src dst bytes = computeChecksum hdrcs rest + where + phcs = computePartialChecksum 0 + $ mkIP4PseudoHeader src dst tcpProtocol + $ S.length bytes + (hdrbs,rest) = S.splitAt 18 bytes + hdrbs' = unsafePerformIO (pokeChecksum 0 (S.copy hdrbs) 16) + hdrcs = computePartialChecksum phcs hdrbs' + diff --git a/src/Hans/Message/Types.hs b/src/Hans/Message/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Types.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Hans.Message.Types where + +import Data.Serialize (Serialize) +import Data.Word (Word16) + +newtype Lifetime = Lifetime Word16 + deriving (Show,Eq,Ord,Num,Serialize) diff --git a/src/Hans/Message/Udp.hs b/src/Hans/Message/Udp.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Message/Udp.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Hans.Message.Udp where + +import Hans.Utils +import Hans.Utils.Checksum + +import Data.Serialize (Serialize(..)) +import Data.Serialize.Get (Get,getWord16be,getByteString,isolate,label) +import Data.Serialize.Put (runPut,putWord16be,putByteString) +import Data.Word (Word16) +import qualified Data.ByteString as S + +newtype UdpPort = UdpPort { getUdpPort :: Word16 } + deriving (Eq,Ord,Num,Show,Serialize,Enum,Bounded) + +data UdpPacket = UdpPacket + { udpHeader :: !UdpHeader + , udpPayload :: S.ByteString + } deriving Show + +data UdpHeader = UdpHeader + { udpSourcePort :: !UdpPort + , udpDestPort :: !UdpPort + , udpChecksum :: !Word16 + } deriving Show + +parseUdpPacket :: Get UdpPacket +parseUdpPacket = do + src <- get + dst <- get + b16 <- getWord16be + let len = fromIntegral b16 + label "UDPPacket" $ isolate (len - 6) $ do + cs <- getWord16be + bs <- getByteString (len - 8) + let hdr = UdpHeader + { udpSourcePort = src + , udpDestPort = dst + , udpChecksum = cs + } + return $! UdpPacket hdr bs + +-- | Given a way to make the pseudo header, render the UDP packet. +renderUdpPacket :: UdpPacket -> MkPseudoHeader -> IO Packet +renderUdpPacket (UdpPacket hdr bs) mk = do + let hdrSize = 8 + let len = S.length bs + hdrSize + let ph = mk len + let pcs = computePartialChecksum 0 ph + let bytes = runPut $ do + put (udpSourcePort hdr) + put (udpDestPort hdr) + putWord16be (fromIntegral len) + putWord16be 0 -- initial checksum + putByteString bs + -- the checksum is 6 bytes into the rendered packet + let cs = computeChecksum pcs bytes + pokeChecksum cs bytes 6 diff --git a/src/Hans/Ports.hs b/src/Hans/Ports.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Ports.hs @@ -0,0 +1,56 @@ + +module Hans.Ports ( + -- * Port Management + PortManager + , emptyPortManager + , isReserved + , reserve + , unreserve + , nextPort + ) where + +import Control.Monad (MonadPlus(mzero),guard) +import Data.List (delete) +import qualified Data.Set as Set + + +-- Port Management ------------------------------------------------------------- + +data PortManager i = PortManager + { portNext :: [i] + , portActive :: Set.Set i + } + +emptyPortManager :: [i] -> PortManager i +emptyPortManager range = PortManager + { portNext = range + , portActive = Set.empty + } + +isReserved :: (Eq i, Ord i) => i -> PortManager i -> Bool +isReserved i pm = i `Set.member` portActive pm + +reserve :: (MonadPlus m, Eq i, Ord i) => i -> PortManager i -> m (PortManager i) +reserve i pm = do + guard (not (isReserved i pm)) + return $! pm + { portNext = delete i (portNext pm) + , portActive = Set.insert i (portActive pm) + } + +unreserve :: (MonadPlus m, Eq i, Ord i) + => i -> PortManager i -> m (PortManager i) +unreserve i pm = do + guard (isReserved i pm) + return $! pm + { portNext = i : portNext pm + , portActive = Set.delete i (portActive pm) + } + +nextPort :: (MonadPlus m, Eq i, Ord i) + => PortManager i -> m (i, PortManager i) +nextPort pm = case portNext pm of + [] -> mzero + i:_ -> do + pm' <- reserve i pm + return $! (i,pm') diff --git a/src/Hans/Setup.hs b/src/Hans/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Setup.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Hans.Setup where + +import Hans.Address +import Hans.Address.IP4 +import Hans.Address.Mac +import Hans.Channel +import Hans.Layer.Arp +import Hans.Layer.Ethernet +import Hans.Layer.IP4 +import Hans.Layer.Icmp4 +import Hans.Layer.Tcp +import Hans.Layer.Timer +import Hans.Layer.Udp + + +data NetworkStack = NetworkStack + { nsArp :: ArpHandle + , nsEthernet :: EthernetHandle + , nsIp4 :: IP4Handle + , nsIcmp4 :: Icmp4Handle + , nsTimers :: TimerHandle + , nsUdp :: UdpHandle + , nsTcp :: TcpHandle + } + + +setup :: IO NetworkStack +setup = do + eth <- newChannel + arp <- newChannel + ip4 <- newChannel + icmp <- newChannel + th <- newChannel + udp <- newChannel + tcp <- newChannel + + runTimerLayer th + runEthernetLayer eth + runArpLayer arp eth th + runIP4Layer ip4 arp eth + runIcmp4Layer icmp ip4 + runUdpLayer udp ip4 icmp + runTcpLayer tcp ip4 th + + return NetworkStack + { nsArp = arp + , nsEthernet= eth + , nsIp4 = ip4 + , nsIcmp4 = icmp + , nsTimers = th + , nsUdp = udp + , nsTcp = tcp + } + + +data SomeOption = forall o. Option o => SomeOption o + +instance Show SomeOption where + showsPrec p (SomeOption o) = parens (showsPrec 11 o) + where + parens body | p > 10 = showString "(SomeOption " . body . showChar ')' + | otherwise = showString "SomeOption " . body + +toOption :: Option o => o -> SomeOption +toOption = SomeOption + +class Show o => Option o where + apply :: o -> NetworkStack -> IO () + + +instance Option SomeOption where + apply (SomeOption o) ns = apply o ns + +instance Option o => Option [o] where + apply os ns = mapM_ (`apply` ns) os + + +data OptEthernet mask = LocalEthernet mask Mac + deriving Show + +instance Option (OptEthernet IP4Mask) where + apply (LocalEthernet mask mac) ns = do + let (addr,_) = getMaskComponents mask + addLocalAddress (nsArp ns) addr mac + addIP4RoutingRule (nsIp4 ns) (Direct mask addr 1500) + + +data OptRoute mask addr = Route mask addr + deriving Show + +instance Option (OptRoute IP4Mask IP4) where + apply (Route mask addr) ns = addIP4RoutingRule (nsIp4 ns) (Indirect mask addr) diff --git a/src/Hans/Simple.hs b/src/Hans/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Simple.hs @@ -0,0 +1,59 @@ +module Hans.Simple ( + -- * UDP Messages + renderUdp + , renderIp4 + + -- * Ident + , Ident + , newIdent + , nextIdent + ) where + +import Hans.Address.IP4 (IP4) +import Hans.Message.Ip4 (IP4Packet(..),IP4Header(..),IP4Protocol(..) + ,mkIP4PseudoHeader,splitPacket,renderIP4Packet + ,emptyIP4Header) +import Hans.Message.Udp (UdpHeader(..),UdpPort,UdpPacket(..),renderUdpPacket) +import qualified Hans.Message.Ip4 as IP4 + +import Control.Concurrent (MVar,newMVar,modifyMVar) +import Data.Word (Word16) +import qualified Data.ByteString as S + +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 + -> S.ByteString + -> IO [S.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 (UdpPacket hdr payload) mk + renderIp4 i mb prot source dest udp + + +-- | Render an IP4 packet. +renderIp4 :: Ident -> Maybe MTU -> IP4Protocol -> IP4 -> IP4 -> S.ByteString + -> IO [S.ByteString] +renderIp4 ident mb prot source dest payload = do + i <- nextIdent ident + let hdr = (emptyIP4Header prot source dest) { ip4Ident = i } + mapM renderIP4Packet (splitPacket (fromMTU mb) (IP4Packet hdr payload)) diff --git a/src/Hans/Utils.hs b/src/Hans/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Utils.hs @@ -0,0 +1,32 @@ +module Hans.Utils where + +import Control.Monad (MonadPlus(mzero)) +import Data.ByteString (ByteString) +import Numeric (showHex) + +type DeviceName = String + +type Packet = ByteString + +type MkPseudoHeader = Int -> Packet + +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) => 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] diff --git a/src/Hans/Utils/Checksum.hs b/src/Hans/Utils/Checksum.hs new file mode 100644 --- /dev/null +++ b/src/Hans/Utils/Checksum.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +-- BANNERSTART +-- - Copyright 2006-2008, Galois, Inc. +-- - This software is distributed under a standard, three-clause BSD license. +-- - Please see the file LICENSE, distributed with this software, for specific +-- - terms and conditions. +-- Author: Adam Wick +-- BANNEREND +-- |A module providing checksum computations to other parts of Hans. The +-- checksum here is the standard Internet 16-bit checksum (the one's +-- complement of the one's complement sum of the data). +module Hans.Utils.Checksum( + computeChecksum + , computePartialChecksum + , clearChecksum + , pokeChecksum + ) + where + +import Control.Exception (assert) +import Data.Bits (Bits(shiftL,shiftR,complement,clearBit,(.&.),rotate)) +import Data.Word (Word8,Word16,Word32) +import Foreign.Storable (pokeByteOff) +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 + +-- | Compute the final checksum, using the given initial value. +computeChecksum :: Word32 -> S.ByteString -> Word16 +computeChecksum c0 = + complement . fromIntegral . fold32 . fold32 . computePartialChecksum c0 + +-- | Compute a partial checksum, yielding a value suitable to be passed to +-- computeChecksum. +computePartialChecksum :: Word32 -> S.ByteString -> Word32 +computePartialChecksum base b = result + where + !n' = S.length b + + !result + | odd n' = step most hi 0 + | otherwise = most + where hi = S.unsafeIndex b (n'-1) + + !most = loop (fromIntegral base) 0 + + loop !acc off + | off < n = loop (step acc hi lo) (off + 2) + | otherwise = acc + where hi = S.unsafeIndex b off + lo = S.unsafeIndex b (off+1) + n = clearBit n' 0 + +step :: Word32 -> Word8 -> Word8 -> Word32 +step acc hi lo = acc + fromIntegral hi `shiftL` 8 + fromIntegral lo + +fold32 :: Word32 -> Word32 +fold32 x = (x .&. 0xFFFF) + (x `shiftR` 16) diff --git a/src/Network/TCP/Aux/Misc.hs b/src/Network/TCP/Aux/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Aux/Misc.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Aux.Misc where + +import Network.TCP.Type.Base +import Network.TCP.Type.Timer +import Network.TCP.Type.Datagram +import Network.TCP.Type.Socket +import Network.TCP.Aux.Param +import Foreign +import Data.Map as Map +import Data.List as List +import Data.Maybe +import Data.List as List +import System.IO.Unsafe +import Control.Exception + +debug :: (Monad m) => String -> m a +debug s = seq (unsafePerformIO $ putStrLn s) return undefined + + +bound_ports :: Map SocketID (TCPSocket threadt) -> [Port] +bound_ports sockmap = List.map get_local_port (keys sockmap) + +-- not considering SO_REUSEADDR +-- bound_port_allowed :: Map SocketID (TCPSocket threadt) -> Port -> Bool +-- bound_port_allowed m p = not $ List.elem p (bound_ports m) + +-- lookup_socketid_by_seg :: Map SocketID (TCPSocket threadt) -> TCPSegment -> Maybe SocketID +-- lookup_socketid_by_seg m s = +-- let fakeid = (tcp_dst s, tcp_src s) in +-- if (member fakeid m) then +-- Just fakeid +-- else +-- Nothing +-- +create_timer (curr_time :: Time) (offset :: Time) = curr_time + offset +slow_timer = create_timer + +create_timewindow (curr_time :: Time) (offset :: Time) a = Just (Timed a (create_timer curr_time offset)) + +-- queues + +-- enqueue_message msg q = addToQueue q msg +-- enqueue_messages msgs q = foldl addToQueue q msgs +-- +accept_incoming_q0 :: SocketListen -> Bool +accept_incoming_q0 lis = + (length $ lis_q lis) < (backlog_fudge (lis_qlimit lis)) +accept_incoming_q lis = + (length $ lis_q lis) < 3 * (backlog_fudge (lis_qlimit lis `div` 2)) +drop_from_q0 lis = + (length $ lis_q0 lis) >= tcp_q0maxlimit + +do_tcp_options :: Time -> Bool -> (TimeWindow Timestamp) -> Timestamp -> Maybe (Timestamp,Timestamp) +do_tcp_options curr_time cb_tf_doing_tstmp cb_ts_recent cb_ts_val = + if cb_tf_doing_tstmp then + let ts_ecr' = case timewindow_val curr_time cb_ts_recent of + Just x -> x + Nothing -> Timestamp 0 + in Just(cb_ts_val, ts_ecr') + else + Nothing + +calculate_tcp_options_len cb_tf_doing_tstmp = + if cb_tf_doing_tstmp then 12 else 0 + +rounddown bs v = if v < bs then v else (v `div` bs) * bs +roundup bs v = ((v+(bs-1)) `div` bs) * bs + +calculate_buf_sizes (cb_t_maxseg :: Int) + (seg_mss :: Maybe Int) + (bw_delay_product_for_rt :: Maybe Int) + (is_local_conn :: Bool) + (rcvbufsize :: Int) + (sndbufsize :: Int) + (cb_tf_doing_tstmp :: Bool) + = let t_maxseg' = + let maxseg = (min cb_t_maxseg (max 64 $ (case seg_mss of Nothing -> mssdflt; Just x-> x))) in + -- BSD + maxseg - (calculate_tcp_options_len cb_tf_doing_tstmp) + in + let t_maxseg'' = rounddown mclbytes (t_maxseg') in + let rcvbufsize' = case bw_delay_product_for_rt of Nothing->rcvbufsize; Just x->x in + let (rcvbufsize'', t_maxseg''') = ( if rcvbufsize' < t_maxseg'' + then (rcvbufsize', rcvbufsize') + else (min (sb_max) (roundup (t_maxseg'') rcvbufsize'), + t_maxseg'')) in + let sndbufsize' = case bw_delay_product_for_rt of Nothing->sndbufsize; Just x->x in + let sndbufsize'' = (if sndbufsize' < t_maxseg''' + then sndbufsize' + else min (sb_max) (roundup (t_maxseg'') sndbufsize')) in + let snd_cwnd = t_maxseg''' * ((if is_local_conn then ss_fltsz_local else ss_fltsz)) in + (rcvbufsize'', sndbufsize'', t_maxseg''', snd_cwnd) + + +calculate_bsd_rcv_wnd :: TCPSocket t -> Int +calculate_bsd_rcv_wnd (tcp_sock :: TCPSocket t)= + let cb = cb_rcv tcp_sock in + assert ((rcv_adv cb) >= (rcv_nxt cb)) $ -- assertion for debugging + max (seq_diff (rcv_adv cb) (rcv_nxt cb)) + (freebsd_so_rcvbuf - (bufc_length $ rcvq cb)) + +send_queue_space sndq_max sndq_size = (sndq_max - sndq_size) + + + +update_idle (curr_time :: Time) tcp_sock = + let tt_keep' = if not (st tcp_sock == SYN_RECEIVED && tf_needfin (cb tcp_sock)) then + Just (slow_timer curr_time tcptv_keep_idle) + else + tt_keep $ cb_time tcp_sock + tt_fin_wait_2' = if st tcp_sock == FIN_WAIT_2 then + Just (slow_timer curr_time tcptv_maxidle ) + else + tt_fin_wait_2 $ cb_time tcp_sock + in + (tt_keep', tt_fin_wait_2') + +-- tcp timing and rtt + + +tcp_backoffs = tcp_bsd_backoffs +tcp_syn_backoffs = tcp_syn_backoffs + +mode_of :: Maybe (Timed (RexmtMode,Int)) -> Maybe RexmtMode +mode_of (Just (Timed (x,_) _)) = Just x +mode_of Nothing = Nothing + +shift_of :: Maybe (Timed (RexmtMode,Int)) -> Int +shift_of (Just (Timed (_,shift) _ )) = shift + +-- todo: check types! + +-- compute the retransmit timeout to use +computed_rto :: [Int] -> Int -> Rttinf -> Time +computed_rto (backoffs :: [Int]) (shift :: Int) (ri::Rttinf) = + (to_Int64 $ backoffs !! shift ) * (max (t_rttmin ri) ((t_srtt ri) + 4*(t_rttvar ri))) + +-- compute the last-used rxtcur +computed_rxtcur (ri :: Rttinf) = + max (t_rttmin ri) + (min (tcptv_rexmtmax) + ((computed_rto ( if t_wassyn ri then tcp_syn_backoffs else tcp_backoffs ) + (t_lastshift ri) ri ))) + +start_tt_rexmt_gen (mode :: RexmtMode) (backoffs :: [Int]) (shift :: Int) + (wantmin :: Bool) (ri :: Rttinf) (curr_time :: Time) = + let rxtcur = max (if wantmin + then max (t_rttmin ri) (t_lastrtt ri + (2*1000*1000 `div` 100)) -- 2s/100 + else t_rttmin ri ) + ( min (tcptv_rexmtmax ) + ( computed_rto backoffs shift ri) ) + in + Just ( Timed (mode,shift) (create_timer curr_time rxtcur ) ) + +start_tt_rexmt = start_tt_rexmt_gen Rexmt tcp_backoffs +start_tt_rexmtsyn = start_tt_rexmt_gen RexmtSyn tcp_syn_backoffs + +start_tt_persist (shift :: Int) (ri::Rttinf) (curr_time :: Time) = + let cur = max (tcptv_persmin) + (min (tcptv_persmax) + (computed_rto tcp_backoffs shift ri) ) + in + Just ( Timed (Persist, shift) (create_timer curr_time cur)) + +update_rtt :: Time -> Rttinf -> Rttinf +update_rtt rtt ri = + let (t_srtt'', t_rttvar'') + = if tf_srtt_valid ri then + let delta = (rtt - 1000*10) - (t_srtt ri) -- 1000*10 = 1/HZ + vardelta = (abs delta) - (t_rttvar ri) + t_srtt' = max (1000*1000 `div` (32*100)) (t_srtt ri + (delta `div` 8)) + t_rttvar'=max (1000*1000 `div` (16*100)) (t_rttvar ri + (vardelta `div` 4)) + in (t_srtt', t_rttvar') + else + let t_srtt' = rtt + t_rttvar' = rtt `div` 2 + in (t_srtt',t_rttvar') + in + ri { t_rttupdated = t_rttupdated ri + 1 + , tf_srtt_valid = True + , t_srtt = t_srtt'' + , t_rttvar = t_rttvar'' + , t_lastrtt = rtt + , t_lastshift = 0 + , t_wassyn = False + } + +expand_cwnd ssthresh maxseg maxwin cwnd + = min maxwin (cwnd + (if cwnd > ssthresh then (maxseg * maxseg) `div` cwnd else maxseg)) + +-- Path MTU Discovery + +mtu_tab = [65535, 32000, 17914, 8166, 4352, 2002, 1492, 1006, 508, 296, 88] + +next_smaller :: [Int] -> Int -> Int +next_smaller (x:xs) value = if value >= x then x else next_smaller xs value + + +initial_cb_time = TCBTiming + { tt_keep = Nothing + , tt_conn_est = Nothing + , tt_fin_wait_2 = Nothing + , tt_2msl = Nothing + , t_idletime = 0 + , ts_recent = Nothing + , t_badrxtwin = Nothing + } + +initial_cb_snd = TCBSending + { sndq = bufferchain_empty + , snd_una = SeqLocal 0 + , snd_wnd = 0 + , snd_wl1 = SeqForeign 0 + , snd_wl2 = SeqLocal 0 + , snd_cwnd = tcp_maxwin `shiftL` tcp_maxwinscale + , snd_nxt = SeqLocal 0 + , snd_max = SeqLocal 0 + , t_dupacks = 0 + , t_rttinf = Rttinf { t_rttupdated = 0 + , tf_srtt_valid = False + , t_srtt = tcptv_rtobase + , t_rttvar = tcptv_rttvarbase + , t_rttmin = tcptv_min + , t_lastrtt = 0 + , t_lastshift = 0 + , t_wassyn = False + } + , t_rttseg = Nothing + , tt_rexmt = Nothing + } + +{-# INLINE hasfin #-} +{-# INLINE tcp_reass #-} +{-# INLINE tcp_reass_prune #-} + +hasfin seg = case trs_FIN seg of True -> 1; False -> 0 + +-- returns (1) the string +-- (2) the SEQ for the next byte +-- (3) whether FIN has been reached +-- (4) remaining... +-- this is a very SLOW algorithm and should be replaced .... + +tcp_reass :: SeqForeign -> [TCPReassSegment] -> (BufferChain, SeqForeign, Bool, [TCPReassSegment]) +tcp_reass seq rsegq = + let searchpkt rseg = + let seq1 = (trs_seq rseg) + seq2 = seq1 `seq_plus` (bufc_length $ trs_data rseg) `seq_plus` (hasfin rseg) + in (seq >= seq1 && seq < seq2) + in + case List.find searchpkt rsegq of + Nothing -> + (bufferchain_empty, seq, False, rsegq) + Just rseg -> + let data_to_trim = seq `seq_diff` (trs_seq rseg) in + let result_buf = bufferchain_drop data_to_trim (trs_data rseg) in + let next_seq = (trs_seq rseg) `seq_plus` (bufc_length $ trs_data rseg) `seq_plus` (hasfin rseg) in + let new_rsegq = tcp_reass_prune next_seq rsegq in + if trs_FIN rseg then + (result_buf + , next_seq + , True + , new_rsegq + ) + else + let (bufc2, next_seq2, hasfin2, rsegq2) = tcp_reass next_seq new_rsegq in + ( bufferchain_concat result_buf bufc2 + , next_seq2 + , hasfin2 + , rsegq2 + ) + +tcp_reass_prune :: SeqForeign -> [TCPReassSegment] -> [TCPReassSegment] +tcp_reass_prune seq rsegq = + List.filter (\seg -> + let nxtseq = (trs_seq seg) `seq_plus` (bufc_length $ trs_data seg) `seq_plus` (hasfin seg) + in nxtseq > seq + ) rsegq + +initial_cb_rcv = TCBReceiving + { last_ack_sent = SeqForeign 0 + , tf_rxwin0sent = False + , tf_shouldacknow = False + , tt_delack = False + , rcv_adv = SeqForeign 0 + , rcv_wnd = 0 + , rcv_nxt = SeqForeign 0 + , rcvq = bufferchain_empty + , t_segq = [] + } + +initial_cb_misc = TCBMisc + { -- retransmission + snd_ssthresh = tcp_maxwin `shiftL` tcp_maxwinscale + , snd_cwnd_prev = 0 + , snd_ssthresh_prev = 0 + , snd_recover = SeqLocal 0 + -- some tags + , cantsndmore = False + , cantrcvmore = False + , bsd_cantconnect = False + -- initialization parameters + , self_id = SocketID (0,TCPAddr (IPAddr 0,0)) + , parent_id = SocketID (0,TCPAddr (IPAddr 0,0)) + , local_addr = TCPAddr (IPAddr 0,0) + , remote_addr = TCPAddr (IPAddr 0,0) + , t_maxseg = mssdflt + , t_advmss = Nothing + , tf_doing_ws = False + , tf_doing_tstmp = False + , tf_req_tstmp = False + , request_r_scale = Nothing + , snd_scale = 0 + , rcv_scale = 0 + , iss = SeqLocal 0 + , irs = SeqForeign 0 + -- other things i don't use for the moment + , sndurp = Nothing + , rcvurp = Nothing + , iobc = NO_OOBDATA + , rcv_up = SeqForeign 0 + , tf_needfin = False + } + +initial_tcp_socket = TCPSocket + { st = CLOSED + , cb_time = initial_cb_time + , cb_snd = initial_cb_snd + , cb_rcv = initial_cb_rcv + , cb = initial_cb_misc + , sock_listen = SocketListen [] [] 0 + , waiting_list = [] + } + +empty_sid :: SocketID +empty_sid = SocketID (0,TCPAddr (IPAddr 0,0)) + + diff --git a/src/Network/TCP/Aux/Output.hs b/src/Network/TCP/Aux/Output.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Aux/Output.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Aux.Output where + +import Hans.Message.Tcp + +import Network.TCP.Type.Base +import Network.TCP.Type.Timer +import Network.TCP.Type.Datagram as Datagram +import Network.TCP.Type.Socket +import Network.TCP.Type.Syscall +import Network.TCP.Aux.Param +import Network.TCP.Aux.Misc +import Hans.Layer.Tcp.Monad +import Foreign +import Control.Exception +import Control.Monad + +make_syn_segment :: Time -> TCPSocket t -> Timestamp -> TCPSegment +make_syn_segment curr_time sock (ts_val::Timestamp) = + let ws = request_r_scale $ cb sock -- should assert it's <= tcp_maxwinscale ? + mss = t_advmss $ cb $ sock + ts = do_tcp_options curr_time (tf_req_tstmp $ cb sock) (ts_recent $ cb_time $ sock ) ts_val + hdr = + set_tcp_mss mss $ + set_tcp_ws ws $ + set_tcp_ts ts $ emptyTcpHeader + { tcpSeqNum = TcpSeqNum (seq_val (iss (cb sock))) + , tcpAckNum = TcpAckNum 0 + , tcpSyn = True + , tcpWindow = fromIntegral (rcv_wnd (cb_rcv sock)) + } + in mkTCPSegment' + (local_addr (cb sock)) (remote_addr (cb sock)) hdr bufferchain_empty + +make_syn_ack_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) = + let urp_any = 0 + tcb = cb sock + win = rcv_wnd (cb_rcv sock) -- `shiftR` (rcv_scale $ cb sock) + ws = if tf_doing_ws tcb then Just (rcv_scale tcb) else Nothing + mss = t_advmss tcb + ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val + hdr = + set_tcp_mss mss $ + set_tcp_ws ws $ + set_tcp_ts ts $ emptyTcpHeader + { tcpSeqNum = TcpSeqNum (seq_val (iss tcb)) + , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) + , tcpAck = True + , tcpSyn = True + , tcpWindow = fromIntegral win + , tcpUrgentPointer = urp_any + } + in mkTCPSegment' addrfrom addrto hdr bufferchain_empty + +make_ack_segment curr_time sock (fin::Bool) (ts_val::Timestamp) = + let urp_garbage = 0 + tcb = cb sock + win = (rcv_wnd $ cb_rcv sock) `shiftR` (rcv_scale tcb) + ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val + sn | fin = snd_una (cb_snd sock) + | otherwise = snd_nxt (cb_snd sock) + hdr = + set_tcp_ts ts $ emptyTcpHeader + { tcpSeqNum = TcpSeqNum (seq_val sn) + , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) + , tcpAck = True + , tcpFin = fin + , tcpWindow = fromIntegral win + , tcpUrgentPointer = urp_garbage + } + in mkTCPSegment' (local_addr tcb) (remote_addr tcb) hdr bufferchain_empty + +bsd_make_phantom_segment curr_time sock (addrfrom::TCPAddr) (addrto::TCPAddr) (ts_val::Timestamp) (cantsendmore::Bool) = + let urp_garbage = 0 + tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + win = (rcv_wnd rcb) `shiftR` (rcv_scale tcb) + fin = (cantsendmore && seq_lt (snd_una scb) (seq_minus (snd_max scb) 1)) + ts = do_tcp_options curr_time (tf_req_tstmp tcb) (ts_recent $ cb_time sock) ts_val + sn | fin = snd_una scb + | otherwise = snd_max scb + hdr = + set_tcp_ts ts emptyTcpHeader + { tcpSourcePort = TcpPort 0 + , tcpDestPort = TcpPort 0 + , tcpSeqNum = TcpSeqNum (seq_val sn) + , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt rcb)) + , tcpFin = fin + , tcpWindow = fromIntegral win + , tcpUrgentPointer = urp_garbage + } + in + mkTCPSegment' addrfrom addrto hdr bufferchain_empty + +make_rst_segment_from_cb sock (addrfrom::TCPAddr) (addrto::TCPAddr) = + let hdr = emptyTcpHeader + { tcpSourcePort = TcpPort 0 + , tcpDestPort = TcpPort 0 + , tcpSeqNum = TcpSeqNum (seq_val (snd_nxt (cb_snd sock))) + , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt (cb_rcv sock))) + , tcpAck = False + , tcpRst = False + } + in mkTCPSegment' addrfrom addrto hdr bufferchain_empty + +make_rst_segment_from_seg (seg::TCPSegment) = + let tcp_ACK' = not (tcp_ACK seg) + seq' = if tcp_ACK seg then tcp_ack seg else 0 + ack' = if tcp_ACK' + then let s1 = tcp_seq seg + in s1 `seq_plus` bufc_length (tcp_data seg) + `seq_plus` (if tcp_SYN seg then 1 else 0) + else 0 + + + hdr = emptyTcpHeader + { tcpSeqNum = TcpSeqNum seq' + , tcpAckNum = TcpAckNum ack' + , tcpAck = tcp_ACK' + , tcpRst = True + } + in + mkTCPSegment' (tcp_src seg) (tcp_dst seg) hdr bufferchain_empty + + +dropwithreset (seg::TCPSegment) = + if tcp_RST seg then [] + else let seg' = make_rst_segment_from_seg seg + in [TCPMessage seg'] + +dropwithreset_ignore_or_fail = dropwithreset + +tcp_close_temp sock = + sock { cb = (cb sock) { cantrcvmore = True + , cantsndmore = True + , local_addr = TCPAddr (IPAddr 0,0) + , remote_addr = TCPAddr (IPAddr 0,0) + , bsd_cantconnect = True + } + , st = CLOSED + , cb_snd = (cb_snd sock) { sndq = bufferchain_empty } + } + + +tcp_close :: SocketID -> HMonad t () +tcp_close sid = + do b <- has_sock sid + when b $ do + sock <- lookup_sock sid + let pending_tasks = waiting_list sock + has_parent = (get_local_port $ parent_id $ cb sock) /= 0 + let result = map (\(_,cont) -> cont (SockError "tcpclose")) pending_tasks + emit_ready result + delete_sock sid + when (not has_parent) $ free_local_port $ get_local_port sid + +tcp_drop_and_close :: SocketID -> HMonad t () +tcp_drop_and_close sid = + do b <- has_sock sid + when b $ do + sock <- lookup_sock sid + let outsegs = if st sock `notElem` [CLOSED,LISTEN,SYN_SENT] + then [TCPMessage $ make_rst_segment_from_cb + (sock) (local_addr $ cb sock) (remote_addr $ cb sock)] + else [] + emit_segs outsegs + tcp_close sid + +alloc_local_port :: HMonad t (Maybe Port) +alloc_local_port = do + h <- get_host + case local_ports h of + [] -> return Nothing + port:rest -> do put_host $ h { local_ports = rest } + return $ Just port + +free_local_port port = + modify_host $ \h -> h { local_ports = port:(local_ports h) } + diff --git a/src/Network/TCP/Aux/Param.hs b/src/Network/TCP/Aux/Param.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Aux/Param.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Aux.Param where + +import Network.TCP.Type.Base + +dschedmax = seconds_to_time 1 +dinput_queuemax = seconds_to_time 1 +doutput_queuemax = seconds_to_time 1 + +hz = 100 + +tickintvlmin = seconds_to_time $ 100/(105*hz) +tickintvlmax = seconds_to_time $ 105/(100*hz) + +slow_timer_intvl = seconds_to_time $ 1/2 +-- slow_timer_model_intvl = seconds_to_time $ 1/1000 + +fast_timer_intvl = seconds_to_time $ 1/5 +-- fast_timer_model_intvl = seconds_to_time $ 1/1000 + +kern_timer_intvl = tickintvlmax +-- kern_timer_model_intvl = + + +-- listen queue length +somaxconn ::Int= 128 + +-- buffers +mclbytes ::Int= 2048 +msize ::Int= 256 +sb_max ::Int= 256*1024 + +-- rfc limits + +dtsinval::Time = seconds_to_time $ 24*24*60*60 +tcp_maxwin :: Int = 65535 +tcp_maxwinscale :: Int = 14 + + +--default +freebsd_so_rcvbuf :: Int = 42080 +freebsd_so_sndbuf :: Int = 9216 + +-- tcp parameters + +mssdflt :: Int = 1400 -- 512 +ss_fltsz_local :: Int = 4 +ss_fltsz :: Int = 1 +tcp_do_newreno = True +tcp_q0minlimit :: Int = 30 +tcp_q0maxlimit :: Int = 512*30 + +backlog_fudge :: Int -> Int +backlog_fudge n = min somaxconn n + +-- time values (TCP only) + +tcptv_delack = seconds_to_time 0.1 +tcptv_rtobase = seconds_to_time 3 +tcptv_rttvarbase = seconds_to_time 0 +tcptv_min = seconds_to_time 1 +tcptv_rexmtmax = seconds_to_time 64 +tcptv_msl = seconds_to_time 1 -- this is too stringent... good for testing +tcptv_persmin = seconds_to_time 5 +tcptv_persmax = seconds_to_time 60 +tcptv_keep_init = seconds_to_time 75 +tcptv_keep_idle = seconds_to_time $ 120*60 +tcptv_keepintvl = seconds_to_time $ 75 +tcptv_keepcnt = seconds_to_time $ 8 +tcptv_maxidle = tcptv_keepintvl*8 + + +-- timing related parameters (TCP only) + +tcp_bsd_backoffs :: [Int]= [1,2,4,8,16,32,64, 64,64,64, 64,64,64] +tcp_linux_backoffs = [1,2,4,8,16,32,64, 128,256,512, 512] +tcp_winxp_backoffs = [1,2,4,8,16] + +--tcp_maxrxtshift = 12 +tcp_maxrxtshift :: Int = 3 -- this is not right... for testing only +tcp_synackmaxrxtshift :: Int = 3 + +tcp_syn_bsd_backoffs :: [Int] = [1,1,1,1,1,2,4,8,16,32,64,64,64] +tcp_syn_linux_backoffs =[1,2,4,8,16] +tcp_syn_winxp_backoffs=[1,2] + +listen_qlimit :: Int = 100 diff --git a/src/Network/TCP/Aux/SockMonad.hs b/src/Network/TCP/Aux/SockMonad.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Aux/SockMonad.hs @@ -0,0 +1,127 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Aux.SockMonad where + +import Network.TCP.Type.Base +import Network.TCP.Type.Socket +import Network.TCP.Aux.Misc +import Hans.Layer.Tcp.Monad +import Control.Exception + +data HState t = HState + { hs_host :: !(Host t) + , hs_sock :: !(TCPSocket t) + } + +newtype SMonad t a = SMonad (HState t -> (a, HState t)) + +instance Monad (SMonad t) where + return a = SMonad $ \s -> (a,s) + x >>= f = bindSMonad x f + {-# INLINE return #-} + {-# INLINE (>>=) #-} + +bindSMonad :: SMonad t a -> (a -> SMonad t b) -> SMonad t b +bindSMonad (SMonad x) f = + SMonad $ \s -> let (res, s') = x s + (SMonad z) = f res in z s' +{-# INLINE bindSMonad #-} + +get_host_ :: SMonad t (Host t) +get_host_ = SMonad $ \s -> (hs_host s,s) + +modify_host_ f = SMonad $ \s -> ((), s { hs_host = f (hs_host s)}) +emit_segs_ segs = modify_host_ $ \h -> h { output_queue = (output_queue h)++ segs} +emit_ready_ threads = modify_host_ $ \h -> h { ready_list = (ready_list h)++ threads} + +{-# INLINE get_host_ #-} +{-# INLINE modify_host_ #-} +{-# INLINE emit_segs_ #-} +{-# INLINE emit_ready_ #-} + +-------------------------------------------------- +-- get_sid = do +-- SMonad $ \s -> (hs_sid s,s) +-- {-# INLINE get_sid #-} + +get_sock = do + SMonad $ \s -> (hs_sock s,s) + +put_sock sock = do + SMonad $ \s -> ((), s { hs_sock = sock}) + +modify_sock f = do + SMonad $ \s -> ((), s { hs_sock = f (hs_sock s)}) +modify_cb f = + SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb =f (cb sock) }}) +modify_cb_snd f = + SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb_snd=f (cb_snd sock) }}) +modify_cb_rcv f = + SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock { cb_rcv=f (cb_rcv sock) }}) +modify_cb_time f= + SMonad $ \s-> let sock=hs_sock s in ((), s { hs_sock=sock {cb_time=f (cb_time sock)}}) +{-# INLINE get_sock #-} +{-# INLINE put_sock #-} +{-# INLINE modify_sock #-} +{-# INLINE modify_cb #-} +{-# INLINE modify_cb_snd #-} +{-# INLINE modify_cb_rcv #-} +{-# INLINE modify_cb_time #-} + + +----------------------------------------------------- +-- has_sock_ :: SocketID -> SMonad t Bool +-- has_sock_ sid = do +-- h <- get_host_ +-- return $ Map.member sid (sock_map h) +-- +-- lookup_sock_ sid = do +-- h <- get_host_ +-- res <- Map.lookup sid (sock_map h) +-- return res +-- +-- {-# INLINE has_sock_ #-} +-- {-# INLINE lookup_sock_ #-} +-- +------------------ + +runSMonad :: SocketID -> (SMonad t a) -> HMonad t a +runSMonad sid (SMonad m) = do + h <- get_host + sock <- lookup_sock sid + let initstate = HState h sock + let (res, finalstate) = m initstate + put_host $ hs_host finalstate + update_sock sid $ \_ -> hs_sock finalstate + return res diff --git a/src/Network/TCP/LTS/In.hs b/src/Network/TCP/LTS/In.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/In.hs @@ -0,0 +1,200 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.In + ( tcp_deliver_in_packet + ) +where + +import Hans.Layer.Tcp.Monad +import Hans.Message.Tcp + +import Foreign +import Foreign.C +import Data.List as List +import Control.Exception +import Control.Monad + +import Network.TCP.Type.Base +import Network.TCP.Type.Syscall +import Network.TCP.Type.Timer +import Network.TCP.Type.Socket +import Network.TCP.Type.Datagram +import Network.TCP.Aux.Param + +import Network.TCP.Aux.Misc +import Network.TCP.Aux.Output +import Network.TCP.Aux.SockMonad +import Network.TCP.Aux.Output + +import Network.TCP.LTS.InPassive +import Network.TCP.LTS.InActive +import Network.TCP.LTS.InData +import Network.TCP.LTS.User +import Network.TCP.LTS.Out + +tcp_deliver_in_packet seg = do + let sid = SocketID (get_port (tcp_dst seg), tcp_src seg) + ok <- has_sock sid + if ok + then tcp_deliver_packet_to_sock sid seg + else if tcp_SYN seg && (not $ tcp_ACK seg) && (not $ tcp_RST seg) + then tcp_deliver_syn_packet seg + else emit_segs $ dropwithreset seg + +-- Note: if there exists a socket in TIME_WAIT state, and an SYN +-- packet matches it, the SYN packet will always be delivered to this +-- socket; it will never be delivered to a listening socket. This +-- makes the implementation simpler... + +--pre-condition: sid exists +tcp_deliver_packet_to_sock :: SocketID -> TCPSegment -> HMonad t () +tcp_deliver_packet_to_sock sid seg = + do h <- get_host + sock <- lookup_sock sid + let tcb = cb sock + rcb = cb_rcv sock + scb = cb_snd sock + seqnum = SeqForeign (tcp_seq seg) + acknum = SeqLocal (tcp_ack seg) + + success <- header_prediction seg h sid sock tcb rcb scb seqnum acknum + when (not success) $ + case st sock of + CLOSED -> assert (False) return () + LISTEN -> assert (False) return () + SYN_SENT -> let goodack = (iss tcb) < acknum && acknum <= (snd_max scb) in + if tcp_RST seg then + when (tcp_ACK seg && goodack) $ tcp_close sid + else + if tcp_SYN seg && tcp_ACK seg then + if goodack then runSMonad sid $ deliver_in_2 seg + else emit_segs $ dropwithreset seg + else return () + SYN_RECEIVED -> + let invalidack = acknum <= snd_una scb || acknum > snd_max scb in + if tcp_RST seg then + tcp_close sid + else if tcp_SYN seg || not (tcp_ACK seg) then -- check with spec? + return () + else if invalidack || (seqnum < (irs tcb)) then + return () + else do + sock <- runSMonad sid $ deliver_in_3 seg + if st sock == CLOSED then + tcp_close sid + else when (st sock /= SYN_RECEIVED) $ + di3_socks_update sid + _ -> if tcp_RST seg then + when (st sock /= TIME_WAIT) $ tcp_close sid + else if tcp_SYN seg then + when (st sock==TIME_WAIT) $ emit_segs $ dropwithreset seg + else + if st sock `elem` [FIN_WAIT_1, CLOSING, LAST_ACK, FIN_WAIT_2, TIME_WAIT] + && seqnum `seq_plus` (bufc_length $ tcp_data seg) > (rcv_nxt rcb) + then return () -- data coming into closing socket? + else do sock <- runSMonad sid $ deliver_in_3 seg + --debug $ (show $ st sock) + when (st sock == CLOSED) $ tcp_close sid + +{-# INLINE header_prediction #-} +header_prediction seg h sid sock tcb rcb scb seqnum acknum = + if st sock == ESTABLISHED + && not (tcp_SYN seg) + && not (tcp_FIN seg) + && not (tcp_URG seg) + && not (tcp_RST seg) + && tcp_ACK seg + && seqnum == rcv_nxt rcb + && snd_wnd scb == fromIntegral (tcp_win seg) `shiftL` snd_scale tcb + && snd_max scb == snd_nxt scb + then if bufc_length (tcp_data seg) == 0 + && acknum > (snd_una scb) + && acknum <= (snd_max scb) + && snd_cwnd scb >= snd_wnd scb + && t_dupacks scb < 3 + then do -- pure ack for outstanding data + -------------------------------------------------------------------------------- + --debug $ "prediction 2.1!" + let emission_time = case (tcp_ts seg, t_rttseg scb) of + (Just (ts_val, ts_ecr), _ ) -> Just (ts_ecr `seq_minus` 1) + (Nothing, Just (ts0, seq0)) -> if acknum > seq0 then Just ts0 else Nothing + (Nothing, Nothing) -> Nothing + let t_rttinf' = case emission_time of + Just emtime -> assert ((ticks h) >= emtime) $ + update_rtt ( ((ticks h) `seq_diff` emtime)*10000 ) (t_rttinf scb) + Nothing -> t_rttinf scb + let tt_rexmt' = if acknum == snd_max scb then + Nothing + else case mode_of (tt_rexmt scb) of + Nothing -> start_tt_rexmt 0 True t_rttinf' (clock h) + Just Rexmt -> start_tt_rexmt 0 True t_rttinf' (clock h) + _ -> tt_rexmt scb + let acked = acknum `seq_diff` (snd_una scb) + let snd_wnd' = snd_wnd scb - acked + let sndq' = bufferchain_drop acked (sndq scb) + runSMonad sid $ do + modify_sock $ \s -> s { cb_snd = scb + { sndq = sndq' + , t_dupacks = 0 + , t_rttinf = t_rttinf' + , tt_rexmt = tt_rexmt' + , t_rttseg = if emission_time == Nothing then t_rttseg scb else Nothing + , snd_cwnd = expand_cwnd (snd_ssthresh tcb) + (t_maxseg tcb) + (tcp_maxwin `shiftL` (snd_scale tcb)) + (snd_cwnd scb) + , snd_wnd = snd_wnd' + , snd_una = acknum + --, snd_nxt = max acknum (snd_nxt scb) + } + } + tcp_wakeup + tcp_output_all + return True + -------------------------------------------------------------------------------- + else if acknum == snd_una scb + && List.null (t_segq rcb) + && bufc_length (tcp_data seg) < (freebsd_so_rcvbuf - (bufc_length $ rcvq rcb)) + then do -- pure in-sequence data packet + -------------------------------------------------------------------------------- + return False + -------------------------------------------------------------------------------- + else do + -- debug $ "predictions 2.1, 2.2 fail!" + return False + else do + -- debug $ "prediction 1 fail!" ++ (show $ snd_wnd tcb) + -- ++ " " ++ (show (tcp_win seg)) ++ " " ++ (show $ snd_scale tcb) + return False + diff --git a/src/Network/TCP/LTS/InActive.hs b/src/Network/TCP/LTS/InActive.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/InActive.hs @@ -0,0 +1,170 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.InActive where + +import Foreign +import Foreign.C +import Data.Maybe +import Network.TCP.Type.Base +import Network.TCP.Type.Syscall +import Network.TCP.Aux.Misc +import Network.TCP.Aux.Param +import Network.TCP.Aux.Output +import Network.TCP.Type.Socket +import Network.TCP.Type.Datagram +import Network.TCP.Aux.SockMonad +import Network.TCP.LTS.User + +deliver_in_2 seg = do + sock <- get_sock + h <- get_host_ + --debug $ "deliver_in_3 " ++ (show seg) + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + acknum = SeqLocal (tcp_ack seg) + seqnum = SeqForeign (tcp_seq seg) + let { + -- window scaling + (rcv_scale', snd_scale', tf_doing_ws') = + ( case (request_r_scale tcb, tcp_ws seg) of + (Just rs, Just ss) -> (rs, ss, True) + _ -> (0,0,False) + ); + + -- timestamping + + tf_rcvd_tstmp' = isJust $ tcp_ts seg; + tf_doing_tstmp' = tf_rcvd_tstmp' && (tf_req_tstmp tcb); + -- mss negotiation + ourmss = ( case (t_advmss tcb) of + Nothing -> (t_maxseg tcb) + Just v -> v + ); + + (rcvbufsize', sndbufsize', t_maxseg'', snd_cwnd') = + calculate_buf_sizes ourmss (tcp_mss seg) Nothing False + (freebsd_so_rcvbuf) (freebsd_so_sndbuf) tf_doing_tstmp'; + + rcv_window = min tcp_maxwin freebsd_so_rcvbuf; + + emission_time = + ( case tcp_ts seg of + Just (ts_val, ts_ecr) -> Just (ts_ecr `seq_minus` 1) + Nothing -> case t_rttseg scb of + Just (ts0, seq0) -> if acknum > seq0 then Just ts0 else Nothing + Nothing -> Nothing; + ); + + t_rttseg' = ( case emission_time of + Nothing -> Nothing + Just _ -> t_rttseg scb ); + + t_rttinf' = ( case emission_time of + Just emtime -> update_rtt ( ((ticks h) `seq_diff` emtime)*10*1000 ) (t_rttinf scb) + Nothing -> t_rttinf scb ); + + tt_rexmt' = if acknum == snd_max scb then Nothing else tt_rexmt scb; + + fin' = tcp_FIN seg; + rcvq' = tcp_data seg; + rcv_nxt' = seqnum `seq_plus` 1 `seq_plus` (if fin' then 1 else 0); + rcv_wnd' = rcv_window - (bufc_length $ tcp_data seg); + + cantrcvmore' = if fin' then True else cantrcvmore tcb; + + new_st = if fin' then + if cantsndmore tcb then LAST_ACK else CLOSE_WAIT + else + if cantsndmore tcb then + if snd_max scb > iss tcb `seq_plus` 1 && acknum >= snd_max scb then + FIN_WAIT_2 + else + FIN_WAIT_1 + else + ESTABLISHED; + + newsock = sock + { st = new_st + , cb_time = (cb_time sock) + { t_idletime = clock h + , tt_keep = Just (create_timer (clock h) tcptv_keep_idle) + , tt_conn_est = Nothing + , ts_recent = case tcp_ts seg of + Nothing -> ts_recent $ cb_time sock + Just (ts_val, ts_ecr) -> create_timewindow (clock h) dtsinval (ts_val) + } + , cb_snd = scb + { tt_rexmt = tt_rexmt' + , snd_una = acknum + , snd_nxt = if cantsndmore tcb then acknum else snd_nxt scb + , snd_max = if cantsndmore tcb && acknum > snd_max scb then acknum else snd_max scb + , snd_wl1 = seqnum `seq_plus` 1 + , snd_wl2 = acknum + , snd_wnd = fromIntegral (tcp_win seg) `shiftL` snd_scale' + , snd_cwnd = if acknum > (iss tcb `seq_plus` 1) + then min snd_cwnd' (tcp_maxwin `shiftL` snd_scale') + else snd_cwnd' + , t_rttseg = t_rttseg' + , t_rttinf = t_rttinf' + } + , cb_rcv = rcb + { rcvq = rcvq' + , tt_delack = False + , rcv_nxt = rcv_nxt' + , rcv_wnd = rcv_wnd' + , tf_rxwin0sent = (rcv_wnd' == 0) + , rcv_adv = rcv_nxt' `seq_plus` (( rcv_wnd' `shiftR` rcv_scale') `shiftL` rcv_scale') + , last_ack_sent = rcv_nxt' + } + , cb = tcb + { --local_addr = tcp_dst seg + rcv_scale = rcv_scale' + , snd_scale = snd_scale' + , tf_doing_ws = tf_doing_ws' + , irs = seqnum + , t_maxseg = t_maxseg'' + , tf_req_tstmp = tf_doing_tstmp' + , tf_doing_tstmp = tf_doing_tstmp' + , cantrcvmore = cantrcvmore' + } + }; + } + put_sock newsock + emit_segs_ [ TCPMessage $ make_ack_segment (clock h) newsock + (cantsndmore tcb && acknum < (iss tcb `seq_plus` 2)) (ticks h)] + tcp_wakeup + return () + + diff --git a/src/Network/TCP/LTS/InData.hs b/src/Network/TCP/LTS/InData.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/InData.hs @@ -0,0 +1,385 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.InData where + +import Foreign +import Foreign.C +import Control.Exception +import Control.Monad +import Data.List as List + +import Network.TCP.Type.Base +import Network.TCP.Type.Timer +import Network.TCP.Type.Socket +import Network.TCP.Type.Datagram as Datagram +import Network.TCP.Type.Syscall + +import Network.TCP.Aux.Param +import Network.TCP.Aux.Misc +import Network.TCP.Aux.Output +import Hans.Layer.Tcp.Monad +import Network.TCP.Aux.SockMonad + +import Network.TCP.LTS.User +import Network.TCP.LTS.Out + +deliver_in_3 seg = + do sock <- get_sock + h <- get_host_ + --debug $ "deliver_in_3 " ++ (show seg) + let tcb = cb sock + scb = cb_snd sock + acknum = SeqLocal (tcp_ack seg) + seqnum = SeqForeign (tcp_seq seg) `seq_plus` + if tcp_SYN seg then 1 else 0 + seg_win = fromIntegral (tcp_win seg) `shiftL` (snd_scale tcb) + let wesentafin = (snd_max scb) > (snd_una scb `seq_plus` (bufc_length $ sndq scb)) + ourfinisacked = wesentafin && tcp_ACK seg && acknum >= (snd_max scb) + + -- update idle time + -- seqnum bound checking + drop_it <- di3_topstuff seg seqnum acknum h + when (not drop_it) $ do + -- acknum bound checking + -- fast retransmit + -- correct bad retransmit + -- update send queue + ack_ok <- di3_ackstuff seg seqnum acknum seg_win h ourfinisacked + when ack_ok $ do + -- update send window + -- receive data + fin_reass <- di3_datastuff seg seqnum acknum seg_win h ourfinisacked + -- update socket state + di3_ststuff fin_reass h ourfinisacked acknum + tcp_wakeup + tcp_output_all + get_sock + +{-# INLINE di3_topstuff #-} +di3_topstuff seg seqnum acknum h = + do sock <- get_sock + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + let rseq = seqnum `seq_plus` (bufc_length $ tcp_data seg) + let seg_ts = tcp_ts seg + -- PAWS check: -- todo + let paws_failed = False + let rcv_wnd' = calculate_bsd_rcv_wnd sock + let segment_off_right_hand_edge = + (seqnum >= (rcv_nxt rcb `seq_plus` rcv_wnd')) + && (rseq > (rcv_nxt rcb `seq_plus` rcv_wnd')) + && (rcv_wnd' /= 0) + let drop_it = paws_failed || segment_off_right_hand_edge + let Just seg_ts_val = seg_ts + let (tt_keep', tt_fin_wait_2') = update_idle (clock h) sock + let ts_recent'' = if not drop_it && seg_ts /= Nothing && seqnum <= (last_ack_sent rcb) + then create_timewindow (clock h) dtsinval (fst $ seg_ts_val) + else ts_recent $ cb_time sock + modify_cb_time $ \t -> t { tt_keep = tt_keep' + , tt_fin_wait_2 = tt_fin_wait_2' + , t_idletime = clock h + , ts_recent = ts_recent'' + } + return drop_it + +{-# INLINE di3_ackstuff #-} +di3_ackstuff seg seqnum acknum seg_win h ourfinisacked = + do sock <- get_sock + let scb = cb_snd sock + if acknum > snd_max scb then return False + else if acknum > snd_una scb + then di3_newackstuff sock seg acknum h ourfinisacked + else di3_oldackstuff sock seg seqnum acknum seg_win h + +{-# INLINE di3_oldackstuff #-} +di3_oldackstuff sock seg seqnum acknum seg_win h = + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock in + let has_data = bufc_length (tcp_data seg) > 0 + && (rcv_nxt rcb) < (seqnum `seq_plus` (bufc_length $ tcp_data seg)) + && seqnum < ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb)) in + let maybe_dup_ack = not has_data + && seg_win == (snd_wnd scb) + && mode_of (tt_rexmt scb) == Just Rexmt in + if not maybe_dup_ack then do + modify_cb_snd $ \c -> c { t_dupacks = 0 } + return True + else + let t_dupacks' = t_dupacks scb + 1 in + if acknum < (snd_una scb) then + do modify_cb_snd $ \c -> c { t_dupacks = 0} + return False + else if t_dupacks' < 3 then + do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks'} + return True -- in case FIN is set + else if t_dupacks' > 3 || (t_dupacks' == 3 && tcp_do_newreno && acknum < (snd_recover tcb)) then + do modify_cb_snd $ \c -> c { t_dupacks = if t_dupacks' == 3 then 0 else t_dupacks' + , snd_cwnd = (snd_cwnd scb) + (t_maxseg tcb) + } + tcp_output False + return False + else -- t_dupacks' == 3 && not (tcp_do_newreno && acknum < (snd_recover tcb)) + do modify_cb_snd $ \c -> c { t_dupacks = t_dupacks' + , tt_rexmt = Nothing + , t_rttseg = Nothing + , snd_nxt = acknum + , snd_cwnd = t_maxseg tcb + } + modify_cb $ \c -> c { snd_ssthresh = (max 2 ( (min (snd_wnd scb) (snd_cwnd scb)) + `div` 2 `div` (t_maxseg tcb))) + * (t_maxseg tcb) + , snd_recover = if tcp_do_newreno then snd_max scb else snd_recover c + } + tcp_output False + modify_cb_snd $ \c -> c { snd_cwnd = (snd_ssthresh tcb) + (t_maxseg tcb) * t_dupacks' + , snd_nxt = max (snd_nxt scb) (snd_nxt c) + } + return False + +{-# INLINE di3_newackstuff #-} +di3_newackstuff sock seg acknum h ourfinisacked = + do let seg_ts = tcp_ts seg + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + if (not tcp_do_newreno) || t_dupacks scb < 3 then + modify_cb_snd $ \c->c { t_dupacks = 0 + , snd_cwnd = if t_dupacks c >= 3 + then min (snd_cwnd c) (snd_ssthresh tcb) + else snd_cwnd c } + -- below: tcp_do_newreno && t_dupacks scb >= 3 + else if acknum < (snd_recover tcb) then + do modify_cb_snd $ \c -> c { tt_rexmt = Nothing + , t_rttseg = Nothing + , snd_nxt = acknum + , snd_cwnd = t_maxseg tcb } + tcp_output False + modify_cb_snd $ \c->c{ snd_cwnd = (snd_cwnd c-(acknum `seq_diff` (snd_una c))+(t_maxseg tcb)) + , snd_nxt = snd_nxt scb } + else --acknum >= snd_recover tcb + modify_cb_snd $ \c -> c { t_dupacks = 0 + , snd_cwnd = if snd_max c `seq_diff` acknum < (snd_ssthresh tcb) + then snd_max c `seq_diff` acknum + (t_maxseg tcb) + else snd_ssthresh tcb } + + let revert_rexmt = mode_of (tt_rexmt scb) `elem` [ Just Rexmt, Just RexmtSyn ] + && shift_of (tt_rexmt scb) == 1 + && timewindow_open (clock h) (t_badrxtwin $ cb_time sock) + when revert_rexmt $ do + modify_cb_snd $ \c -> c { snd_cwnd = snd_cwnd_prev tcb + , snd_nxt = snd_max scb + } + modify_cb_time $ \c -> c { t_badrxtwin = Nothing } + modify_cb $ \c -> c { snd_ssthresh = snd_ssthresh_prev tcb } + + -- to understand: timestamping + let emission_time = case (seg_ts, t_rttseg scb) of + (Just (ts_val, ts_ecr), _ ) -> Just (ts_ecr `seq_minus` 1) + (Nothing, Just (ts0, seq0)) -> if acknum > seq0 then Just ts0 else Nothing + (Nothing, Nothing) -> Nothing + -- to understand: rtt update + let t_rttinf' = case emission_time of + Just emtime -> assert ((ticks h) >= emtime) $ + update_rtt ( ((ticks h) `seq_diff` emtime)*10*1000 ) (t_rttinf scb) + Nothing -> t_rttinf scb + let tt_rexmt' = if acknum == snd_max scb then + Nothing + else case mode_of (tt_rexmt scb) of + Nothing -> start_tt_rexmt 0 True t_rttinf' (clock h) + Just Rexmt -> start_tt_rexmt 0 True t_rttinf' (clock h) + _ -> tt_rexmt scb + let (snd_wnd', sndq') = if ourfinisacked then + (snd_wnd scb - (bufc_length $ sndq scb), bufferchain_empty) + else + (snd_wnd scb - (acknum `seq_diff` (snd_una scb)), + bufferchain_drop (acknum `seq_diff` (snd_una scb)) (sndq scb)) + + modify_cb_snd $ \c -> c { t_rttinf = t_rttinf' + , tt_rexmt = tt_rexmt' + , t_rttseg = if emission_time == Nothing then t_rttseg c else Nothing + , snd_cwnd = if not tcp_do_newreno || t_dupacks scb == 0 then + expand_cwnd (snd_ssthresh tcb) + (t_maxseg tcb) + (tcp_maxwin `shiftL` (snd_scale tcb)) + (snd_cwnd c) + else snd_cwnd c + , snd_wnd = snd_wnd' + , snd_una = acknum + , snd_nxt = max acknum (snd_nxt c) + , sndq = sndq' + } + + when (st sock == TIME_WAIT) $ + modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl))} + + if (st sock == LAST_ACK) && ourfinisacked then do + modify_sock tcp_close_temp + return False + else return True + +{-# INLINE di3_datastuff #-} +di3_datastuff seg seqnum acknum seg_win h ourfinisacked = do + sock <- get_sock + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + let update_send_window = + tcp_ACK seg + && seqnum <= ( (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb) ) + && ( snd_wl1 scb < seqnum + || ( snd_wl1 scb == seqnum + && ( snd_wl2 scb < acknum + || ( snd_wl2 scb == acknum && seg_win > snd_wnd scb ) + ) + ) + || (st sock == SYN_RECEIVED && not (tcp_FIN seg) ) + ) + let seq_trimmed = max seqnum (min (rcv_nxt rcb) (seqnum `seq_plus` (bufc_length $ tcp_data seg))) + when update_send_window $ + --debug $ "send window updated" + modify_cb_snd $ \c -> c { snd_wnd = seg_win + , snd_wl1 = seq_trimmed + , snd_wl2 = acknum + } + if st sock == TIME_WAIT || (st sock == CLOSING && ourfinisacked) + then do modify_cb $ \c -> c { rcv_up = max (rcv_up c) (rcv_nxt rcb) } + return False + else di3_datastuff_really seg seqnum acknum seg_win h + +{-# INLINE di3_datastuff_really #-} +di3_datastuff_really seg seqnum acknum seg_win h = + do let dat = tcp_data seg + sock <- get_sock + let tcb = cb sock + scb = cb_snd sock + rcb = cb_rcv sock + + let trim_amt_left = if rcv_nxt rcb > seqnum + then min (rcv_nxt rcb `seq_diff` seqnum) (bufc_length dat) + else 0 + data_trimmed_left = bufferchain_drop trim_amt_left dat + seq_trimmed = seqnum `seq_plus` trim_amt_left + let data_trimmed_left_right = bufferchain_take (rcv_wnd rcb) data_trimmed_left + fin_trimmed = if bufc_length data_trimmed_left_right == + bufc_length data_trimmed_left then tcp_FIN seg else False + let rseg = TCPReassSegment { trs_seq = seq_trimmed + , trs_FIN = fin_trimmed + , trs_data = data_trimmed_left_right + } + -- processing incoming data + if seq_trimmed == rcv_nxt rcb + && seq_trimmed `seq_plus` (bufc_length data_trimmed_left_right) + `seq_plus` (if fin_trimmed then 1 else 0) > (rcv_nxt rcb) + && rcv_wnd rcb > 0 + then do + -- case 1: reassambling possible + let have_stuff_to_ack = bufc_length data_trimmed_left_right >0 || fin_trimmed + let delay_ack = st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, FIN_WAIT_2, CLOSING, LAST_ACK] + && have_stuff_to_ack && not fin_trimmed && List.null (t_segq rcb) + && not (tf_rxwin0sent rcb) + && tt_delack rcb == False + let rsegq = rseg:(t_segq rcb) + let (data_reass, rcv_nxt', fin_reass0, t_segq') = tcp_reass (rcv_nxt rcb) rsegq + let rcvq' = bufferchain_concat (rcvq rcb) data_reass + let rcv_wnd' = rcv_wnd rcb - (bufc_length data_reass) + modify_cb_rcv $ \c -> c + { tt_delack = if delay_ack then True else tt_delack c + , tf_shouldacknow = if have_stuff_to_ack then not delay_ack else tf_shouldacknow c + , t_segq = t_segq' + , rcv_nxt = rcv_nxt' + , rcv_wnd = rcv_wnd' + , rcvq = rcvq' + } + return fin_reass0 + else if seq_trimmed > (rcv_nxt rcb) + && seq_trimmed < ((rcv_nxt rcb) `seq_plus` (rcv_wnd rcb)) + && bufc_length data_trimmed_left_right + (if fin_trimmed then 1 else 0) > 0 + && rcv_wnd rcb > 0 + then do + -- case 2: wait for future reassambling + modify_cb_rcv $ \c -> c { t_segq = rseg:(t_segq c) + , tf_shouldacknow = True + } + return False + else if tcp_ACK seg && seq_trimmed == rcv_nxt rcb + && bufc_length dat + (if tcp_FIN seg then 1 else 0) == 0 then + -- case 3: no data + return False + else do + -- case 4: other cases... maybe windows is closed + modify_cb_rcv $ \c -> c { tf_shouldacknow = True } + return False + +{-# INLINE di3_ststuff #-} +di3_ststuff fin_reass h ourfinisacked acknum = + do sock <- get_sock + let tcb = cb sock + let enter_TIME_WAIT = do + modify_sock $ \s -> s { st = TIME_WAIT } + modify_cb_time $ \c -> c { tt_2msl = Just (create_timer (clock h) (2*tcptv_msl)) + , tt_keep = Nothing + , tt_conn_est = Nothing + , tt_fin_wait_2 = Nothing + } + modify_cb_snd $ \c -> c { tt_rexmt = Nothing } + modify_cb_rcv $ \c -> c { tt_delack = False } + + when fin_reass $ + modify_cb $ \s -> s { cantrcvmore = True } + + case (st sock, fin_reass) of + (SYN_RECEIVED,False) -> when (acknum >= (iss tcb) `seq_plus` 1 ) $ + modify_sock $ \s -> s + { st = if not (cantsndmore tcb) then ESTABLISHED else + if ourfinisacked then FIN_WAIT_2 else FIN_WAIT_1 + } + (SYN_RECEIVED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT } + (ESTABLISHED, False) -> return () + (ESTABLISHED, True) -> modify_sock $ \s -> s { st = CLOSE_WAIT } + (CLOSE_WAIT, _ ) -> return () + (FIN_WAIT_1, False) -> when ourfinisacked $ do + modify_sock $ \s -> s { st = FIN_WAIT_2 } + when (cantrcvmore tcb) $ + modify_cb_time $ \c -> c { tt_fin_wait_2 = + Just (create_timer (clock h) (tcptv_maxidle)) } + (FIN_WAIT_1, True) -> if ourfinisacked then enter_TIME_WAIT + else modify_sock $ \s->s { st=CLOSING } + (FIN_WAIT_2, False) -> return () + (FIN_WAIT_2, True) -> enter_TIME_WAIT + (CLOSING, _) -> when ourfinisacked enter_TIME_WAIT + (LAST_ACK, False) -> return () + (LAST_ACK, True) -> error "di3_ststuff" + (TIME_WAIT, _ ) -> return () diff --git a/src/Network/TCP/LTS/InMisc.hs b/src/Network/TCP/LTS/InMisc.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/InMisc.hs @@ -0,0 +1,36 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.InMisc where + + diff --git a/src/Network/TCP/LTS/InPassive.hs b/src/Network/TCP/LTS/InPassive.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/InPassive.hs @@ -0,0 +1,192 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.InPassive where +import Data.List as List +import Control.Exception +import Control.Monad + +--import Foreign.C +import Network.TCP.Type.Base +import Network.TCP.Type.Syscall +import Network.TCP.Type.Timer +import Network.TCP.Type.Socket +import Network.TCP.Type.Datagram +import Network.TCP.Aux.Misc +import Network.TCP.Aux.Param +import Network.TCP.Aux.Output +import Hans.Layer.Tcp.Monad +import Network.TCP.Aux.SockMonad + +import Network.TCP.LTS.Out +import Network.TCP.LTS.User + +tcp_deliver_syn_packet seg = do + -- precondition: sid does not exist + -- try if seg matches a listening socket... + let sidlisten = SocketID ((get_port $ tcp_dst seg), TCPAddr (IPAddr 0,0)) + h <- get_host + haslisten <- has_sock sidlisten + if not haslisten then return () else do + -- matches a socket... + sock <- lookup_sock sidlisten + if st sock /= LISTEN then return () else do + -- now we find a listening socket maching incoming SYN=1 ACK=0 RST=0 + if accept_incoming_q0 (sock_listen sock) + then deliver_in_1 sidlisten sock seg + else return () + +deliver_in_1 sid sock seg = + do let newsid = SocketID ((get_port $ tcp_dst seg), tcp_src seg) + h <- get_host + -- at this point, newsid is an unique socket id in the system... + + -- drop the first sid from q0 if needed, append newsid to q0. + let lis1 = sock_listen sock + should_drop = drop_from_q0 lis1 + drop_sid = head $ lis_q0 lis1 + oldq = lis_q0 lis1 + newq = if should_drop then tail oldq else oldq + lis2 = lis1 { lis_q0 = newq++[newsid]} + -- update listening socket (sid) + update_sock sid $ \_ -> sock { sock_listen = lis2 } + -- delete old socket if needed + when should_drop $ tcp_close drop_sid + + -- Create a new socket + let advmss = mssdflt -- todo: lookup interface mss + advmss' = Nothing -- not advertising MSS (todo: change it) + + tf_rcvd_tstmp = case tcp_ts seg of Just _ -> True; Nothing -> False + tf_doing_tstmp' = False -- not doing timestamping (todo: change it) + + (rcvbufsize', sndbufsize', t_maxseg', snd_cwnd') = + calculate_buf_sizes advmss (tcp_mss seg) Nothing False + (freebsd_so_rcvbuf) (freebsd_so_sndbuf) tf_doing_tstmp' + + tf_doing_ws' = False -- not doing window scaling (todo: change it) + rcv_scale' = 0 + snd_scale' = 0 + rcv_window = min tcp_maxwin freebsd_so_rcvbuf + + newiss = SeqLocal 1000 -- beginning iss. (todo: add more randomness) + t_rttseg' = Just (ticks h, newiss) + seqnum = SeqForeign (tcp_seq seg) + acknum = SeqLocal (tcp_ack seg) + ack' = seqnum `seq_plus` 1 + cb_time' = (cb_time sock) + { tt_keep = Just (create_timer (clock h) tcptv_keep_idle) + , ts_recent = case (tcp_ts seg) of + Nothing -> ts_recent (cb_time sock) + Just (ts_val, ts_ecr) -> create_timewindow (clock h) (dtsinval) ts_val + } + cb_snd' = (cb_snd sock) + { tt_rexmt = start_tt_rexmt 0 False (t_rttinf (cb_snd sock)) (clock h) + , snd_una = newiss + , snd_max = newiss `seq_plus` 1 + , snd_nxt = newiss `seq_plus` 1 + , snd_cwnd = snd_cwnd' + , t_rttseg = t_rttseg' + } + cb_rcv' = (cb_rcv sock) + { rcv_wnd = rcv_window + , tf_rxwin0sent = (rcv_window == 0) + , last_ack_sent = ack' + , rcv_adv = ack' `seq_plus` rcv_window + , rcv_nxt = ack' + } + cb' = (cb sock) + { iss = newiss + , irs = seqnum + , rcv_up = seqnum `seq_plus` 1 + , t_maxseg = t_maxseg' + , t_advmss = advmss' + , rcv_scale = rcv_scale' + , snd_scale = snd_scale' + , tf_doing_ws = tf_doing_ws' + , tf_req_tstmp = tf_doing_tstmp' + , tf_doing_tstmp = tf_doing_tstmp' + , local_addr = tcp_dst seg + , remote_addr = tcp_src seg + , self_id = newsid + , parent_id = sid + } + -- create new socket (newsid) + let newsock = initial_tcp_socket + { st = SYN_RECEIVED + , cb = cb' + , cb_time = cb_time' + , cb_snd = cb_snd' + , cb_rcv = cb_rcv' + } + insert_sock newsid newsock + -- emit [SYN,ACK] packet + emit_segs [TCPMessage $ make_syn_ack_segment (clock h) newsock + (tcp_dst seg) (tcp_src seg) (ticks h) ] + +-- After receiving ACK on SYN_RECEIVED, a connection is established. +-- Now we need to update the queues of the listening socket... +di3_socks_update sid = do + h <- get_host + -- precondition: sid exists + newsock <- lookup_sock sid + let tcb = cb newsock + rcb = cb_rcv newsock + sidlisten = parent_id tcb + haslisten <- has_sock sidlisten + assert (haslisten) return () + listensock <- lookup_sock sidlisten + let lis1 = sock_listen listensock + assert (sid `elem` (lis_q0 lis1)) return () + -- found the listening socket! + if accept_incoming_q lis1 then do + -- delete socket from q0 + -- move into completed queue + let lis2 = lis1 { lis_q0 = List.delete sid (lis_q0 lis1) + , lis_q = sid : (lis_q lis1) + } + let rcv_window = calculate_bsd_rcv_wnd newsock + let newcb = (cb_rcv newsock) { rcv_wnd = rcv_window + , rcv_adv = (rcv_nxt rcb) `seq_plus` (rcv_wnd rcb) + } + update_sock sidlisten $ \_ -> listensock { sock_listen = lis2 } + update_sock sid $ \_ -> newsock { cb_rcv = newcb } + runSMonad sidlisten $ tcp_wakeup + else do + -- delete socket from q0, backlog full -> delete socket + let lis2 = lis1 { lis_q0 = List.delete sid (lis_q0 lis1) } + update_sock sidlisten $ \_ -> listensock { sock_listen = lis2 } + tcp_close sid + --endif + + diff --git a/src/Network/TCP/LTS/Out.hs b/src/Network/TCP/LTS/Out.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/Out.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.Out + ( tcp_output_all + , tcp_output + , tcp_close + , tcp_drop_and_close + ) +where + +import Hans.Message.Tcp + +import Data.List as List +import Network.TCP.Aux.Output +import Network.TCP.Aux.Misc +import Network.TCP.Type.Base +import Network.TCP.Type.Syscall +import Network.TCP.Type.Socket +import Hans.Layer.Tcp.Monad +import Network.TCP.Aux.SockMonad +import Control.Monad +import Control.Exception +import Foreign +import Network.TCP.Type.Timer +import Network.TCP.Type.Datagram as Datagram +import Network.TCP.Aux.Param + +tcp_output_all :: SMonad t () +tcp_output_all = do + h <- get_host_ + sock <- get_sock + let scb = cb_snd sock + tcb = cb sock + when ((st sock `elem` [ESTABLISHED, CLOSE_WAIT, FIN_WAIT_1, + FIN_WAIT_2, CLOSING, LAST_ACK, TIME_WAIT] + && (snd_una scb /= iss tcb)) -- does this make sense? + || ( st sock `elem` [SYN_SENT, SYN_RECEIVED] && + cantsndmore tcb && (tf_shouldacknow $ cb_rcv sock))) $ + output_loop h sock + +output_loop h sock = + let (sock1, outsegs) = tcp_output_really (clock h) False (ticks h) sock in + if List.null outsegs then + put_sock sock1 + else do + --debug $ "tcp_output_all: " ++ (show outsegs) + emit_segs_ $! outsegs + output_loop h sock1 + +{-# INLINE tcp_output_all #-} +{-# INLINE output_loop #-} + + +{-# INLINE tcp_output_really #-} + +tcp_output_really (curr_time :: Time) (window_probe::Bool) (ts_val'::Timestamp) tcp_sock = + let tcb = cb tcp_sock + scb = cb_snd tcp_sock + rcb = cb_rcv tcp_sock + in + assert ((rcv_adv rcb) >= (rcv_nxt rcb)) $ + assert ((snd_nxt scb) >= (snd_una scb)) $ + let snd_cwnd' = if snd_max scb == snd_una scb && + (t_idletime $ cb_time tcp_sock) - curr_time + >= (computed_rxtcur $ t_rttinf scb) + then (t_maxseg tcb) * ss_fltsz -- has been idle for a while, slowstart + else snd_cwnd scb + win0 = min (snd_wnd scb) snd_cwnd' + win = if window_probe && win0==0 then 1 else win0 + snd_wnd_unused ::Int = win - ((snd_nxt scb) `seq_diff` (snd_una scb)) + syn_not_acked = (st tcp_sock `elem` [SYN_SENT, SYN_RECEIVED]) + fin_required = (cantsndmore tcb && st tcp_sock `notElem` [FIN_WAIT_2, TIME_WAIT]) + last_sndq_data_seq = (snd_una scb) `seq_plus` (bufc_length $ sndq scb) + last_sndq_data_and_fin_seq = last_sndq_data_seq `seq_plus` + (if fin_required then 1 else 0) `seq_plus` + (if syn_not_acked then 1 else 0) + have_data_to_send = (snd_nxt scb) < last_sndq_data_seq + have_data_or_fin_to_send = (snd_nxt scb) < last_sndq_data_and_fin_seq + window_update_delta = (min (tcp_maxwin `shiftL` (rcv_scale tcb)) + (freebsd_so_rcvbuf - (bufc_length $ rcvq rcb)) + ) - ( (rcv_adv rcb) `seq_diff` (rcv_nxt rcb)) + need_to_send_a_window_update = (window_update_delta >= 2 * (t_maxseg tcb)) || + (2*window_update_delta >= freebsd_so_rcvbuf) + do_output = ( have_data_or_fin_to_send && (if have_data_to_send then snd_wnd_unused>0 else True) ) + || need_to_send_a_window_update -- sndurp tcp_sock /= Nothing + || tf_shouldacknow rcb + cant_send = (not do_output) && + (bufc_length (sndq scb) > 0 ) && + mode_of (tt_rexmt scb) == Nothing + window_shrunk = win==0 && + snd_wnd_unused <0 && + st tcp_sock /= SYN_SENT + tcp_sock0 = if cant_send then + tcp_sock { cb_snd = scb {tt_rexmt = start_tt_persist 0 (t_rttinf scb) curr_time}} + else if window_shrunk then + tcp_sock { cb_snd = scb { + tt_rexmt = case tt_rexmt scb of + Just(Timed (Persist, shift) d ) -> Just (Timed (Persist, 0) d) + _ -> start_tt_persist 0 (t_rttinf scb) curr_time + , snd_nxt = snd_una scb + }} + else tcp_sock + in + if (not do_output) then (tcp_sock0, []) else + ------------ really do it --------------------------------------------- + let tcp_sock = tcp_sock0 + scb = cb_snd tcp_sock + + data' = bufferchain_drop (snd_nxt scb `seq_diff` (snd_una scb)) (sndq scb) + data_to_send = bufferchain_take (min (snd_wnd_unused) ( t_maxseg tcb)) data' + bFIN = fin_required && (snd_nxt scb) `seq_plus` (bufc_length data_to_send) >= last_sndq_data_seq + bACK = if bFIN && st tcp_sock == SYN_SENT then False else True + snd_nxt' = if bFIN && + ((snd_nxt scb `seq_plus` (bufc_length data_to_send) == + last_sndq_data_seq `seq_plus` 1 && snd_una scb /= iss tcb ) + || (snd_nxt scb) `seq_diff` (iss tcb) == 2) + then snd_nxt scb `seq_minus` 1 + else snd_nxt scb + bPSH = bufc_length data_to_send > 0 && + snd_nxt scb `seq_plus` (bufc_length data_to_send) == last_sndq_data_seq + rcv_wnd'' = calculate_bsd_rcv_wnd tcp_sock + rcv_wnd' = max (rcv_adv rcb `seq_diff` (rcv_nxt rcb)) + (min (tcp_maxwin `shiftL` (rcv_scale tcb)) + (if rcv_wnd'' < (freebsd_so_rcvbuf `div` 4) && rcv_wnd'' < (t_maxseg tcb) + then 0 else rcv_wnd'')) + want_tstmp = if st tcp_sock == SYN_SENT then tf_req_tstmp tcb else tf_doing_tstmp tcb + ts_ = do_tcp_options curr_time want_tstmp (ts_recent $ cb_time tcp_sock) ts_val' + in + let win_ = rcv_wnd' `shiftR` (rcv_scale tcb) + hdr = set_tcp_ts ts_ emptyTcpHeader + { tcpSeqNum = TcpSeqNum (seq_val snd_nxt') + , tcpAckNum = TcpAckNum (fseq_val (rcv_nxt rcb)) + , tcpAck = bACK + , tcpPsh = bPSH + , tcpFin = bFIN + , tcpWindow = fromIntegral win_ + } + seg = mkTCPSegment' (local_addr tcb) (remote_addr tcb) hdr data_to_send + st' = if bFIN then + case st tcp_sock of + ESTABLISHED -> FIN_WAIT_1 + CLOSE_WAIT -> LAST_ACK + xxx -> xxx + else + st tcp_sock + snd_nxt'' = snd_nxt' `seq_plus` (bufc_length data_to_send) `seq_plus` (if bFIN then 1 else 0) + snd_max' = max (snd_max scb) snd_nxt'' + tt_rexmt' = if (mode_of (tt_rexmt scb) == Nothing || + (mode_of (tt_rexmt scb) == Just Persist && not window_probe)) && + snd_nxt'' > (snd_una scb) then + start_tt_rexmt 0 False (t_rttinf scb) curr_time + else if (window_probe {-- || sndurp tcp_sock /= Nothing --} ) && win0 /= 0 && + mode_of (tt_rexmt scb) == Just Persist then + Nothing + else + tt_rexmt scb + t_rttseg' = if t_rttseg scb == Nothing && (bufc_length data_to_send > 0 || bFIN) && + snd_nxt'' > (snd_max scb) && not window_probe then + Just (ts_val', snd_nxt') + else + t_rttseg scb + tcp_sock' = tcp_sock + { st = st' + , cb_snd = scb { tt_rexmt = tt_rexmt' + , snd_cwnd = snd_cwnd' + , t_rttseg = t_rttseg' + , snd_max = snd_max' + , snd_nxt = snd_nxt'' + } + , cb_rcv = rcb { last_ack_sent = rcv_nxt rcb + , rcv_adv = rcv_nxt rcb `seq_plus` rcv_wnd' + , tt_delack = False + , rcv_wnd = rcv_wnd' + , tf_rxwin0sent = (rcv_wnd' == 0) + , tf_shouldacknow = False + } + } + outsegs' = [TCPMessage seg] + in + (tcp_sock', outsegs') + +{-# INLINE tcp_output #-} +tcp_output :: Bool -> SMonad t () +tcp_output win_probe = + do sock <- get_sock + h <- get_host_ + let (newsock, segs) = tcp_output_really (clock h) win_probe (ticks h) sock + put_sock newsock + emit_segs_ segs + --if List.null segs then return () else debug $ "tcp_output: " ++ (show segs) + + + diff --git a/src/Network/TCP/LTS/User.hs b/src/Network/TCP/LTS/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/LTS/User.hs @@ -0,0 +1,293 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.LTS.User + ( tcp_process_user_request + , tcp_wakeup + ) +where + +import Foreign.C +import Data.List as List +import Control.Monad +import Data.Maybe +import Network.TCP.Type.Base +import Network.TCP.Type.Datagram +import Network.TCP.Type.Syscall +import Network.TCP.Type.Socket +import Hans.Layer.Tcp.Monad +import Network.TCP.Aux.SockMonad +import Network.TCP.Aux.Misc +import Network.TCP.Aux.Param +import Network.TCP.Aux.Output + +import Network.TCP.LTS.Out + +--------------------------------------------------------------------------------------- +-- input: a list of sock request +-- output: threads that have taken the completed requests (back in running state) +-- side effect: host state changes +-- blocked threads goes into the wait queue of each socket +-- tcp_process_user_requests :: (Monad m) => [(SockReq,SockRsp->t)] -> HMonad t m [t] +-- tcp_process_user_requests reqs = +-- do r <- mapM tcp_process_user_request reqs +-- return $ concat r + +tcp_process_user_request :: (SockReq,SockRsp->t) -> HMonad t (Maybe t) +tcp_process_user_request (req, cont) = + case req of + SockListen addr -> process_listen addr cont + SockClose sid -> process_close sid cont + SockConnect local addr -> process_connect local addr cont + SockAccept sid -> process_accept sid cont + SockSend sid d -> process_send sid d cont + SockRecv sid -> process_recv sid cont + +tcp_wakeup_request req cont = + case req of + SockConnect local addr -> wakeup_connect cont + SockAccept sid -> wakeup_accept sid cont + SockSend sid d -> wakeup_send sid d cont + SockRecv sid -> wakeup_recv sid cont + +-- pre-cond: sock is set +-- post-cond: sock is set, tcp_output needed +tcp_wakeup = + do sock <- get_sock + case waiting_list sock of + [] -> return () + (req,cont):reqs -> do + res <- tcp_wakeup_request req cont + case res of + Nothing -> return () + Just th -> do + emit_ready_ [th] + modify_sock $ \s -> s {waiting_list = reqs} + +-- pre-cond: sock not set +-- post-cond: sock not set +process_listen :: Port -> (SockRsp->t) -> HMonad t (Maybe t) +process_listen port cont = + do let sock_id = SocketID (port, TCPAddr (IPAddr 0,0)) + h <- get_host + -- check if port has been used... + if port `elem` (local_ports h) then + do let listen = SocketListen [] [] listen_qlimit + let newsock = initial_tcp_socket + { cb = (cb initial_tcp_socket) { local_addr = TCPAddr (IPAddr 0,port), self_id=sock_id } + , st = LISTEN + , sock_listen = listen + } + insert_sock sock_id newsock + modify_host $ \h -> h { local_ports = List.delete port (local_ports h) } + return $ Just $ cont $ SockNew sock_id + else + return $ Just $ cont $ SockError "Port not available" + +process_close :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) +process_close sid cont = + do ok <- has_sock sid + if not ok then + return $ Just $ cont $ SockError "Socket not found" + else do + sock <- lookup_sock sid + if st sock `elem` [CLOSED,SYN_SENT,SYN_RECEIVED] then do + -- close_7 : delete sid + tcp_close sid + return $ Just $ cont $ SockOK + else if st sock /= LISTEN then runSMonad sid $ do + -- close_1 : change the flags so FIN can be sent later + modify_sock $ \sock-> sock { cb = (cb sock) { cantsndmore=True, cantrcvmore=True} + , cb_rcv = (cb_rcv sock) { rcvq=bufferchain_empty } + } + tcp_output_all + return $ Just $ cont $ SockOK + else do + -- close_8 : closing a LISTEN socket + -- todo: not implemented yet + return $ Just $ cont $ SockError "not implemented yet: close_8 : closing a LISTEN socket" + +-- pre-cond: sock not set +-- post-cond: sock not set +process_accept :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) +process_accept sid cont = + do ok <- has_sock sid + if not ok then + return $ Just $ cont $ SockError "Socket not found" + else runSMonad sid $ do + res <- try_accept cont + when (isNothing res) $ + -- put thread in waiting list + modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockAccept sid, cont)] } + return res +wakeup_accept sid cont + = try_accept cont + +-- pre-cond: sock is set +-- post-cond: sock is set, listening queue updated +try_accept :: (SockRsp->t) -> SMonad t (Maybe t) +try_accept cont = + do sock <- get_sock + if st sock /= LISTEN then + return $ Just $ cont $ SockError "Socket not in LISTEN state" + else do + -- find the listen queue + let listen = sock_listen sock + case lis_q listen of + [] -> return Nothing -- no connection to accept, can't proceed + (sid2:qs) -> do -- try to accept sid2, either success or fail + modify_sock $ \sock -> sock { sock_listen = listen { lis_q = qs } } + return $ Just $ cont $ SockNew sid2 + +process_recv :: SocketID -> (SockRsp->t) -> HMonad t (Maybe t) +process_recv sid cont = + do ok <- has_sock sid + if not ok then + return $ Just $ cont $ SockError "Socket not found" + else runSMonad sid $ do + res <- try_recv cont + when (isNothing res) $ + -- put thread in waiting list + modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockRecv sid, cont)] } + return res + +wakeup_recv sid cont = + try_recv cont + +try_recv :: (SockRsp->t) -> SMonad t (Maybe t) +try_recv cont = + do sock <- get_sock + let q = rcvq $ cb_rcv sock + if st sock `elem` [ CLOSED, SYN_SENT, SYN_RECEIVED] then + return $ Just $ cont $ SockError "Socket not in synchronized state" + else if bufc_length q == 0 then + if cantrcvmore $ cb sock + then return $ Just $ cont $ SockData buffer_empty -- EOF + else return Nothing -- no data, can't proceed + else do + -- let rcvnum = min size (length q) + -- (q1,q2) = splitAt rcvnum q + put_sock $ sock { cb_rcv = (cb_rcv sock) {rcvq = bufferchain_tail q }} + return $ Just $ cont $ SockData $ bufferchain_head q + +process_send :: SocketID -> Buffer -> (SockRsp->t) -> HMonad t (Maybe t) +process_send sid d cont = + do ok <- has_sock sid + if not ok then + return $ Just $ cont $ SockError "Socket not found" + else runSMonad sid $ do + (res,remain) <- try_send d cont + when (isNothing res) $ + -- put thread in waiting list + modify_sock $ \sock -> sock {waiting_list = (waiting_list sock)++[(SockSend sid remain, cont)] } + return res + +wakeup_send sid d cont = + do (res,remain) <- try_send d cont + when (isNothing res) $ + -- put thread in waiting list again + modify_sock $ \sock -> sock {waiting_list = (tail $ waiting_list sock)++[(SockSend sid remain, cont)] } + return res + +try_send :: Buffer -> (SockRsp->t) -> SMonad t (Maybe t, Buffer) +try_send d cont = + do sock <- get_sock + if st sock `notElem` [ ESTABLISHED, CLOSE_WAIT] then + return (Just $ cont $ SockError "Socket not in synchronized state", buffer_empty ) + else if cantsndmore $ cb sock then + return (Just $ cont $ SockError "Socket cantsndmore=true, cannot send...", buffer_empty) + else do + let max_can_send = freebsd_so_sndbuf - (bufc_length $ sndq $ cb_snd sock) + num_to_send = min max_can_send (buf_len d) + (d1,d2) = buffer_split num_to_send d + modify_cb_snd $ \c -> c { sndq = (sndq c) `bufferchain_append` d1 } + --if (bufc_length (sndq $ cb_snd $ sock) == 0) then + -- modify_cb_rcv $ \c -> c { tt_delack = True } + -- else + tcp_output_all + if buf_len d2 == 0 then return (Just $ cont $ SockOK, d2) + else return (Nothing, d2) + + +process_connect :: IPAddr -> TCPAddr -> (SockRsp->t) -> HMonad t (Maybe t) +process_connect local addr cont = do + h <- get_host + m_port <- alloc_local_port + if m_port == Nothing then return $ Just $ cont $ SockError "cannot allocate local port" else do + let (Just port) = m_port + sock_id = SocketID (port, addr) + newiss = SeqLocal 1000 -- beginning iss. (todo: add more randomness) + request_r_scale' = 0 + rcv_wnd' = freebsd_so_rcvbuf + adv_mss = Just mssdflt + tf_req_tstmp' = False -- todo: change it + t_rttseg' = Just (ticks h, newiss) + let { newsock = initial_tcp_socket + { st = SYN_SENT + , cb_time = initial_cb_time + { tt_conn_est = Just (create_timer (clock h) tcptv_keep_init) + } + , cb_snd = initial_cb_snd + { tt_rexmt = start_tt_rexmtsyn 0 False (t_rttinf initial_cb_snd) (clock h) + , snd_una = newiss + , snd_nxt = newiss `seq_plus` 1 + , snd_max = newiss `seq_plus` 1 + , t_rttseg = t_rttseg' + } + , cb_rcv = initial_cb_rcv + { rcv_wnd = rcv_wnd' + , rcv_adv = (rcv_nxt initial_cb_rcv) `seq_plus` rcv_wnd' + , tf_rxwin0sent = (rcv_wnd' == 0) + } + , cb = initial_cb_misc + { local_addr = TCPAddr (local,port) + , remote_addr = addr + , self_id=sock_id + , cantsndmore = False + , cantrcvmore = False + , iss = newiss + , request_r_scale = Just request_r_scale' + , t_advmss = adv_mss + , tf_req_tstmp = tf_req_tstmp' + } + }} + insert_sock sock_id newsock + emit_segs $ [TCPMessage $ make_syn_segment (clock h) newsock (ticks h)] + return $ Nothing + +wakeup_connect :: (SockRsp->t) -> SMonad t (Maybe t) +wakeup_connect cont = do + sock <- get_sock + if st sock == SYN_SENT + then return Nothing + else return $ Just $ cont $ SockNew $ self_id $ cb sock diff --git a/src/Network/TCP/Type/Base.hs b/src/Network/TCP/Type/Base.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Type/Base.hs @@ -0,0 +1,271 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Type.Base where + +import Data.Time.Clock.POSIX (POSIXTime,getPOSIXTime) +import Foreign +import Foreign.C +import System.IO.Unsafe +import Control.Exception +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + + +to_Int x = (fromIntegral x)::Int +to_Int8 x = (fromIntegral x)::Int8 +to_Int16 x = (fromIntegral x)::Int16 +to_Int32 x = (fromIntegral x)::Int32 +to_Int64 x = (fromIntegral x)::Int64 + +to_Word x = (fromIntegral x)::Word +to_Word8 x = (fromIntegral x)::Word8 +to_Word16 x = (fromIntegral x)::Word16 +to_Word32 x = (fromIntegral x)::Word32 +to_Word64 x = (fromIntegral x)::Word64 + + +{-# INLINE to_Int #-} +{-# INLINE to_Int8 #-} +{-# INLINE to_Int16 #-} +{-# INLINE to_Int32 #-} +{-# INLINE to_Int64 #-} +{-# INLINE to_Word #-} +{-# INLINE to_Word8 #-} +{-# INLINE to_Word16 #-} +{-# INLINE to_Word32 #-} +{-# INLINE to_Word64 #-} + +-- Port numbers, IP addresses + +type Port = Word16 +newtype IPAddr = IPAddr Word32 deriving (Eq,Ord) +newtype TCPAddr = TCPAddr (IPAddr, Port) deriving (Eq,Ord) +newtype SocketID = SocketID (Port, TCPAddr) deriving (Eq,Ord,Show) + +instance Show IPAddr where + show (IPAddr w) = (show $ w .&. 255) ++ "." ++ + (show $ (w `shiftR` 8) .&. 255) ++ "." ++ + (show $ (w `shiftR` 16) .&. 255) ++ "." ++ + (show $ (w `shiftR` 24) .&. 255) +instance Show TCPAddr where + show (TCPAddr (ip,pt)) = (show ip) ++ ":" ++ (show pt) + + +get_ip :: TCPAddr -> IPAddr +get_ip (TCPAddr (i,p)) = i + +get_port :: TCPAddr -> Port +get_port (TCPAddr (i,p)) = p + +get_remote_addr :: SocketID -> TCPAddr +get_remote_addr (SocketID (p,a)) = a + +get_local_port :: SocketID -> Port +get_local_port (SocketID (p,a)) = p + +{-# INLINE get_ip #-} +{-# INLINE get_port #-} +{-# INLINE get_remote_addr #-} +{-# INLINE get_local_port #-} + +-- TCP Sequence numbers + +class (Eq a) => Seq32 a where + seq_val :: a -> Word32 + seq_lt :: a -> a -> Bool + seq_leq :: a -> a -> Bool + seq_gt :: a -> a -> Bool + seq_geq :: a -> a -> Bool + seq_plus :: (Integral n) => a -> n -> a + seq_minus :: (Integral n) => a -> n -> a + seq_diff :: (Integral n) => a -> a -> n + +instance Seq32 Word32 where + seq_val w = w + seq_lt x y = (to_Int32 (x-y)) < 0 + seq_leq x y = (to_Int32 (x-y)) <= 0 + seq_gt x y = (to_Int32 (x-y)) > 0 + seq_geq x y = (to_Int32 (x-y)) >= 0 + seq_plus s i = assert (i>=0) $ s + (to_Word32 i) + seq_minus s i = assert (i>=0) $ s - (to_Word32 i) + seq_diff s t = let res=fromIntegral $ to_Int32 (s-t) in assert (res>=0) res + {-# INLINE seq_val #-} + {-# INLINE seq_lt #-} + {-# INLINE seq_leq #-} + {-# INLINE seq_gt #-} + {-# INLINE seq_geq #-} + {-# INLINE seq_plus #-} + {-# INLINE seq_minus #-} + {-# INLINE seq_diff #-} + +newtype SeqLocal = SeqLocal Word32 deriving (Eq,Show,Seq32) +newtype SeqForeign = SeqForeign Word32 deriving (Eq,Show,Seq32) +newtype Timestamp = Timestamp Word32 deriving (Eq,Show,Seq32) + +instance Ord SeqLocal where + (<) = seq_lt + (>) = seq_gt + (<=) = seq_leq + (>=) = seq_geq + {-# INLINE (<) #-} + {-# INLINE (>) #-} + {-# INLINE (<=) #-} + {-# INLINE (>=) #-} +instance Ord SeqForeign where + (<) = seq_lt + (>) = seq_gt + (<=) = seq_leq + (>=) = seq_geq + {-# INLINE (<) #-} + {-# INLINE (>) #-} + {-# INLINE (<=) #-} + {-# INLINE (>=) #-} +instance Ord Timestamp where + (<) = seq_lt + (>) = seq_gt + (<=) = seq_leq + (>=) = seq_geq + {-# INLINE (<) #-} + {-# INLINE (>) #-} + {-# INLINE (<=) #-} + {-# INLINE (>=) #-} + +seq_flip_ltof (SeqLocal w) = SeqForeign w +seq_flip_ftol (SeqForeign w) = SeqLocal w + +fseq_val :: SeqForeign -> Word32 +fseq_val (SeqForeign w32) = w32 + +{-# INLINE seq_flip_ltof #-} +{-# INLINE seq_flip_ftol #-} + + +-- | Clock time, in microseconds. +type Time = Int64 + +seconds_to_time :: RealFrac a => a -> Time +seconds_to_time f = round (f * 1000*1000) + +{-# INLINE seconds_to_time #-} + +get_current_time :: IO Time +get_current_time = posixtime_to_time `fmap` getPOSIXTime + +posixtime_to_time :: POSIXTime -> Time +posixtime_to_time = seconds_to_time . toRational + +--------------------------------------------------------------------------- + +type Buffer = S.ByteString + +buf_len :: Buffer -> Int +buf_len = S.length + +buffer_ok :: Buffer -> Bool +buffer_ok _ = True + +buffer_empty :: Buffer +buffer_empty = S.empty + +buffer_to_string :: Buffer -> IO String +buffer_to_string = return . map (toEnum . fromEnum) . S.unpack + +string_to_buffer :: String -> IO Buffer +string_to_buffer = return . S.pack . map (toEnum . fromEnum) + +buffer_split :: Int -> Buffer -> (Buffer,Buffer) +buffer_split = S.splitAt + +buffer_take = S.take +buffer_drop = S.drop + +buffer_merge :: Buffer -> Buffer -> [Buffer] +buffer_merge bs1 bs2 + | S.length bs1 == 0 = [bs2] + | S.length bs2 == 0 = [bs1] + | otherwise = [bs1,bs2] + + +type BufferChain = L.ByteString + +bufc_length :: BufferChain -> Int +bufc_length = fromIntegral . L.length + +bufferchain_empty = L.empty +bufferchain_singleton b + | S.null b = L.empty + | otherwise = L.fromChunks [b] + +bufferchain_add bs bc = bufferchain_singleton bs `L.append` bc + +bufferchain_get :: BufferChain -> Int -> BufferChain +bufferchain_get bc ix = L.take 1 (L.drop (fromIntegral ix) bc) + +bufferchain_append bc bs = bc `L.append` bufferchain_singleton bs + +bufferchain_concat :: BufferChain -> BufferChain -> BufferChain +bufferchain_concat = L.append + +bufferchain_head :: BufferChain -> Buffer +bufferchain_head = head . L.toChunks + +bufferchain_tail :: BufferChain -> BufferChain +bufferchain_tail = L.fromChunks . tail . L.toChunks + +bufferchain_take :: Int -> BufferChain -> BufferChain +bufferchain_take = L.take . fromIntegral + +bufferchain_drop :: Int -> BufferChain -> BufferChain +bufferchain_drop = L.drop . fromIntegral + +bufferchain_split_at :: Int -> BufferChain -> (BufferChain,BufferChain) +bufferchain_split_at = L.splitAt . fromIntegral + +bufferchain_collapse :: BufferChain -> IO Buffer +bufferchain_collapse = return . S.concat . L.toChunks + +-- bufferchain_output bc@(BufferChain lst len) (ptr::Ptr CChar) = +-- copybuf ptr lst +-- where copybuf ptrDest [] = return () +-- copybuf ptrDest (x:xs) = +-- withForeignPtr (buf_ptr x) +-- (\ptrSrc -> do +-- copyArray ptrDest (ptrSrc `plusPtr` (buf_offset x)) (buf_len x) +-- copybuf (ptrDest `plusPtr` (buf_len x)) xs +-- ) + +bufferchain_ok :: BufferChain -> Bool +bufferchain_ok _ = True diff --git a/src/Network/TCP/Type/Datagram.hs b/src/Network/TCP/Type/Datagram.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Type/Datagram.hs @@ -0,0 +1,217 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Type.Datagram +( TCPSegment (..) +, UDPDatagram (..) +, Protocol (..) +, ICMPType (..) +, ICMPDatagram (..) +, IPMessage (..) +, tcp_ws +, set_tcp_ws +, tcp_mss +, set_tcp_mss +, tcp_ts +, set_tcp_ts +, tcp_seq +, tcp_ack +, tcp_URG +, tcp_ACK +, tcp_PSH +, tcp_RST +, tcp_SYN +, tcp_FIN +, tcp_win +, tcp_urp +, mkTCPSegment +, mkTCPSegment' +) +where + +import Hans.Address.IP4 (IP4,convertToWord32) +import Hans.Message.Tcp + (TcpHeader(..),TcpPacket(..),TcpPort(..),TcpAckNum(..),TcpSeqNum(..) + ,findTcpOption,setTcpOption,TcpOptionTag(..),TcpOption(..)) + +import Network.TCP.Type.Base + +data TCPSegment = TCPSegment + { tcp_src :: !TCPAddr + , tcp_dst :: !TCPAddr + , tcp_header :: !TcpHeader + , tcp_data :: !BufferChain + } + +mkTCPSegment :: IP4 -> IP4 -> TcpPacket -> TCPSegment +mkTCPSegment src dst (TcpPacket hdr body) = TCPSegment + { tcp_src = TCPAddr (IPAddr (convertToWord32 src),srcP) + , tcp_dst = TCPAddr (IPAddr (convertToWord32 dst),dstP) + , tcp_header = hdr + , tcp_data = bufferchain_singleton body + } + where + TcpPort srcP = tcpSourcePort hdr + TcpPort dstP = tcpDestPort hdr + +mkTCPSegment' :: TCPAddr -> TCPAddr -> TcpHeader -> BufferChain -> TCPSegment +mkTCPSegment' s@(TCPAddr (_, srcP)) d@(TCPAddr (_, dstP)) hdr body = + TCPSegment + { tcp_src = s + , tcp_dst = d + , tcp_header = hdr + { tcpSourcePort = TcpPort srcP + , tcpDestPort = TcpPort dstP + } + , tcp_data = body + } + where + +tcp_seq = getSeqNum . tcpSeqNum . tcp_header +tcp_ack = getAckNum . tcpAckNum . tcp_header +tcp_URG = tcpUrg . tcp_header +tcp_ACK = tcpAck . tcp_header +tcp_PSH = tcpPsh . tcp_header +tcp_RST = tcpRst . tcp_header +tcp_SYN = tcpSyn . tcp_header +tcp_FIN = tcpFin . tcp_header +tcp_win = tcpWindow . tcp_header +tcp_urp = tcpUrgentPointer . tcp_header + +tcp_ws :: TCPSegment -> Maybe Int +tcp_ws = fmap prj . findTcpOption OptTagWindowScaling . tcp_header + where + prj (OptWindowScaling ws) = fromIntegral ws + +set_tcp_ws :: Maybe Int -> TcpHeader -> TcpHeader +set_tcp_ws Nothing = id +set_tcp_ws (Just ws) = setTcpOption (OptWindowScaling (fromIntegral ws)) + +tcp_mss :: TCPSegment -> Maybe Int +tcp_mss = fmap prj . findTcpOption OptTagMaxSegmentSize . tcp_header + where + prj (OptMaxSegmentSize mss) = fromIntegral mss + +set_tcp_mss :: Maybe Int -> TcpHeader -> TcpHeader +set_tcp_mss Nothing = id +set_tcp_mss (Just mss) = setTcpOption (OptMaxSegmentSize (fromIntegral mss)) + +tcp_ts :: TCPSegment -> Maybe (Timestamp,Timestamp) +tcp_ts = fmap prj . findTcpOption OptTagTimestamp . tcp_header + where + prj (OptTimestamp v r) = (Timestamp v, Timestamp r) + +set_tcp_ts :: Maybe (Timestamp,Timestamp) -> TcpHeader -> TcpHeader +set_tcp_ts Nothing = id +set_tcp_ts (Just (Timestamp v, Timestamp r)) = setTcpOption (OptTimestamp v r) + +{- +data TCPSegment = TCPSegment + { tcp_src :: !TCPAddr + , tcp_dst :: !TCPAddr + , tcp_seq :: !SeqLocal + , tcp_ack :: !SeqForeign + , tcp_URG :: !Bool + , tcp_ACK :: !Bool + , tcp_PSH :: !Bool + , tcp_RST :: !Bool + , tcp_SYN :: !Bool + , tcp_FIN :: !Bool + , tcp_win :: !Int + , tcp_urp :: !Int + , tcp_data :: !BufferChain + -- option: window scaling + , tcp_ws :: !(Maybe Int) + -- option: max segment size + , tcp_mss :: !(Maybe Int) + -- option: RFC1323 + , tcp_ts :: !(Maybe (Timestamp, Timestamp)) + } -} + +instance Show TCPSegment where + show seg = + let part1 = + if (get_port $ tcp_src seg) > 9999 || (get_port $ tcp_dst seg) == 8888 then + "<==" ++ (show $ tcp_src seg) + ++ " ack=" ++(show $ seq_val $ tcp_ack seg) + ++ " seq=" ++(show $ seq_val $ tcp_seq seg) + else + "==>" ++ (show $ tcp_dst seg) + ++ " seq=" ++(show $ seq_val $ tcp_seq seg) + ++ " ack=" ++(show $ seq_val $ tcp_ack seg) + in + let part2 = + " ["++ + (if tcp_URG seg then " URG(urp="++ (show $ tcp_urp seg) ++ ")" else "") ++ + (if tcp_SYN seg then " SYN" else "") ++ + (if tcp_FIN seg then " FIN" else "") ++ + (if tcp_RST seg then " RST" else "") ++ + (if tcp_ACK seg then " ACK" else "") ++ + (if tcp_PSH seg then " PSH" else "") ++ + " ]" + in + part1 + ++ " WIN=" ++(show $ tcp_win seg) + ++ " LEN=" ++(show $ bufc_length $ tcp_data seg) + ++ part2 + +data UDPDatagram = UDPDatagram + { udp_src :: TCPAddr + , udp_dst :: TCPAddr + , udp_data :: [Char] + } deriving (Show, Eq) + +data Protocol = PROTO_TCP | PROTO_UDP deriving (Show, Eq) + +data ICMPType = + ICMP_UNREACH Int + | ICMP_SOURCE_QUENCE Int + | ICMP_REDIRECT Int + | ICMP_TIME_EXCEEDED Int + | ICMP_PARAMPROB Int + deriving (Show, Eq) + +data ICMPDatagram = ICMPDatagram + { icmp_send :: IPAddr + , icmp_recv :: IPAddr + , icmp_src :: Maybe TCPAddr + , icmp_dst :: Maybe TCPAddr + , icmp_proto :: Protocol + , icmp_seq :: Maybe SeqLocal + , icmp_t :: ICMPType + } deriving (Show, Eq) + +data IPMessage = TCPMessage !TCPSegment + | ICMPMessage !ICMPDatagram + | UDPMessage !UDPDatagram + deriving (Show) diff --git a/src/Network/TCP/Type/Socket.hs b/src/Network/TCP/Type/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Type/Socket.hs @@ -0,0 +1,199 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Type.Socket +where + +import Network.TCP.Type.Base +import Network.TCP.Type.Timer +import Network.TCP.Type.Datagram +import Network.TCP.Type.Syscall +import Data.Map as Map + +data TCPState = CLOSED + | LISTEN + | SYN_SENT + | SYN_RECEIVED + | ESTABLISHED + | CLOSE_WAIT + | FIN_WAIT_1 + | FIN_WAIT_2 + | CLOSING + | LAST_ACK + | TIME_WAIT + deriving (Show,Eq) + +data TCPReassSegment = TCPReassSegment + { trs_seq :: !SeqForeign + , trs_FIN :: !Bool + , trs_data :: !BufferChain + } deriving (Show) + +data RexmtMode = RexmtSyn + | Rexmt + | Persist + deriving (Show,Eq) + +data Rttinf = Rttinf + { t_rttupdated :: !Int + , tf_srtt_valid :: !Bool + , t_srtt :: !Time + , t_rttvar :: !Time + , t_rttmin :: !Time + , t_lastrtt :: !Time + , t_lastshift :: !Int + , t_wassyn :: !Bool + } deriving (Show) + + +data IOBC = NO_OOBDATA | OOBDATA Buffer | HAD_OOBDATA deriving (Show) + +data SocketListen = SocketListen + { lis_q0 :: ![SocketID] -- q0 + , lis_q :: ![SocketID] -- q + , lis_qlimit :: !Int + } deriving (Show,Eq) + +data TCBTiming = TCBTiming + { tt_keep :: !(Maybe Time) + , tt_conn_est :: !(Maybe Time) + , tt_fin_wait_2 :: !(Maybe Time) + , tt_2msl :: !(Maybe Time) + , t_idletime :: !Time + , ts_recent :: !(TimeWindow Timestamp) + , t_badrxtwin :: !(TimeWindow ()) + } deriving (Show) +data TCBSending = TCBSending + { sndq :: !BufferChain + , snd_una :: !SeqLocal + , snd_wnd :: !Int + , snd_wl1 :: !SeqForeign + , snd_wl2 :: !SeqLocal + , snd_cwnd :: !Int + , snd_nxt :: !SeqLocal + , snd_max :: !SeqLocal + , t_dupacks :: !Int + , t_rttinf :: !Rttinf + , t_rttseg :: !(Maybe (Timestamp, SeqLocal)) + , tt_rexmt :: !(Maybe (Timed (RexmtMode, Int))) + } deriving (Show) +data TCBReceiving = TCBReceiving + { last_ack_sent :: !SeqForeign + , tf_rxwin0sent :: !Bool + , tf_shouldacknow :: !Bool + , tt_delack :: !Bool + , rcv_adv :: !SeqForeign + , rcv_wnd :: !Int + , rcv_nxt :: !SeqForeign + , rcvq :: !BufferChain + , t_segq :: ![TCPReassSegment] + } deriving (Show) +data TCBMisc = TCBMisc + { -- retransmission + snd_ssthresh :: !Int + , snd_cwnd_prev :: !Int + , snd_ssthresh_prev :: !Int + , snd_recover :: !SeqLocal + -- some tags + , cantsndmore :: !Bool + , cantrcvmore :: !Bool + , bsd_cantconnect :: !Bool -- not very useful... + -- initialization parameters + , self_id :: !SocketID + , parent_id :: !SocketID + , local_addr :: !TCPAddr + , remote_addr :: !TCPAddr + , t_maxseg :: !Int + , t_advmss :: !(Maybe Int) + , tf_doing_ws :: !Bool + , tf_doing_tstmp :: !Bool + , tf_req_tstmp :: !Bool + , request_r_scale :: !(Maybe Int) + , snd_scale :: !Int + , rcv_scale :: !Int + , iss :: !SeqLocal + , irs :: !SeqForeign + -- other things i don't use for the moment + , sndurp :: !(Maybe Int) + , rcvurp :: !(Maybe Int) + , iobc :: !IOBC + , rcv_up :: !SeqForeign + , tf_needfin :: !Bool + } deriving (Show) + +data TCPSocket threadt = TCPSocket + { st :: !TCPState + , cb_time :: !TCBTiming + , cb_snd :: !TCBSending + , cb_rcv :: !TCBReceiving + , cb :: !TCBMisc + , sock_listen :: !SocketListen + -- suspended commands (threads) + , waiting_list :: ![(SockReq, SockRsp -> threadt)] + } + +instance Show (TCPSocket t) where + show (TCPSocket s cb1 cb2 cb3 cb4 lis wl) = + "TCPSocket state ="++(show s) ++ "\n" ++ + " " ++ (show cb1) ++ "\n" ++ + " " ++ (show cb2) ++ "\n" ++ + " " ++ (show cb3) ++ "\n" ++ + " " ++ (show cb4) ++ "\n" ++ + " " ++ (show lis) ++ "\n" ++ + " waiting: " ++ (show $ length wl) + +data Host threadt = Host + { sock_map :: !(Map SocketID (TCPSocket threadt)) + , output_queue :: ![IPMessage] + , ready_list :: ![threadt] + , ticks :: !Timestamp + , clock :: !Time + , next_timers :: !(Time,Time) -- fast timer, slow timer + , local_ports :: ![Port] + } + +empty_host :: Host t +empty_host = Host + { sock_map = Map.empty + , output_queue = [] + , ready_list = [] + , ticks = Timestamp 0 + , clock = 0 + , next_timers = (0,0) + , local_ports = [0..65535] + } + +update_host_time :: Time -> Host t -> Host t +update_host_time now h = h + { clock = now + } diff --git a/src/Network/TCP/Type/Syscall.hs b/src/Network/TCP/Type/Syscall.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Type/Syscall.hs @@ -0,0 +1,57 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Type.Syscall +( SocketID +, TCPAddr +, Buffer (..) +, SockReq (..) +, SockRsp (..) +) + +where + +import Network.TCP.Type.Base + +data SockReq = SockConnect !IPAddr !TCPAddr -- create a client socket and connect (return: SockNew sock) + | SockListen !Port -- create a listening Socket (return: SockNew sock) + | SockAccept !SocketID -- accept connection from a listening socket (return: SockNew sock) + | SockSend !SocketID !Buffer -- (return: SockOK) + | SockRecv !SocketID -- (return: SockData) + | SockClose !SocketID -- (return: SockOK) + +data SockRsp = SockOK + | SockError !String + | SockNew !SocketID + | SockData !Buffer + deriving Show diff --git a/src/Network/TCP/Type/Timer.hs b/src/Network/TCP/Type/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Network/TCP/Type/Timer.hs @@ -0,0 +1,68 @@ +{-- +Copyright (c) 2006, Peng Li + 2006, Stephan A. Zdancewic +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright owners nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +--} + +module Network.TCP.Type.Timer + +where + +import Network.TCP.Type.Base + +data Timed a = Timed { timed_val :: a + , timed_exp :: Time + } deriving (Show, Eq) + +timed_expires :: Time -> Timed a -> Bool +timed_expires t (Timed x tm) = t >= tm + +timer_expires :: Time -> Time -> Bool +timer_expires t tm = t >= tm + +maybe_timed_expires :: Time -> Maybe (Timed a) -> Bool +maybe_timed_expires _ Nothing = False +maybe_timed_expires curr_time (Just t) = timed_expires curr_time t + +maybe_timer_expires :: Time -> Maybe Time -> Bool +maybe_timer_expires _ Nothing = False +maybe_timer_expires curr_time (Just t) = curr_time >= t + +type TimeWindow a = Maybe (Timed a) + +timewindow_open :: Time -> TimeWindow a -> Bool +timewindow_open = maybe_timed_expires + +timewindow_val :: Time -> TimeWindow a -> Maybe a +timewindow_val t Nothing = Nothing +timewindow_val t (Just tmd) = + if timed_expires t tmd then Nothing else Just (timed_val tmd) + +