diff --git a/Dust-tools.cabal b/Dust-tools.cabal --- a/Dust-tools.cabal +++ b/Dust-tools.cabal @@ -1,5 +1,5 @@ Name: Dust-tools -Version: 1.2 +Version: 1.2.1 Description: A set of tools for exploring network filtering Synopsis: Network filtering exploration tools Category: Network @@ -14,31 +14,11 @@ type: git location: git@github.com:blanu/Dust-tools.git -Library - Build-Depends: - base >= 3 && < 5, - Dust >= 2.1, - bytestring, - entropy, - network, - cereal, - ghc-prim, - binary, - random, - random-extras, - random-source, - random-fu, - containers, - directory, - split - Exposed-modules: - Dust.Services.Replay.Replay - Executable shaper-server Main-is: Dust/Services/Shaper/ShaperServer.hs Build-Depends: base >= 3 && < 5, - Dust >= 2.1, + Dust >= 2.2.1, bytestring, entropy, network, @@ -57,7 +37,7 @@ Main-is: Dust/Services/Shaper/ShaperClient.hs Build-Depends: base >= 3 && < 5, - Dust, + Dust >= 2.2.1, bytestring, entropy, network, @@ -76,7 +56,7 @@ Main-is: Dust/Services/Replay/ReplayServer.hs Build-Depends: base >= 3 && < 5, - Dust, + Dust >= 2.2.1, bytestring, entropy, network, @@ -95,7 +75,7 @@ Main-is: Dust/Services/Replay/ReplayClient.hs Build-Depends: base >= 3 && < 5, - Dust, + Dust >= 2.2.1, bytestring, entropy, network, @@ -114,7 +94,7 @@ Main-is: Dust/Model/compile.hs Build-Depends: base >= 3 && < 5, - Dust, + Dust >= 2.2.1, bytestring, entropy, network, diff --git a/Dust/Services/Replay/Replay.hs b/Dust/Services/Replay/Replay.hs deleted file mode 100644 --- a/Dust/Services/Replay/Replay.hs +++ /dev/null @@ -1,166 +0,0 @@ -module Dust.Services.Replay.Replay -( - ReplayConfig(..), - PacketMask(..), - loadMask, - replayStream, - linger -) -where - -import System.IO -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Char8 (pack) -import Data.Serialize -import Text.Printf (printf) -import Data.List as L -import Control.Concurrent -import Network.Socket hiding (recv, sendTo, Stream) -import Network.Socket.ByteString (recv, sendAll, sendTo) -import System.Entropy -import Control.Exception -import Data.Word (Word8, Word16, Word32) -import Data.String -import Data.List.Split -import Control.Monad (forever) - -import Dust.Network.Util -import Dust.Model.TrafficModel -import Dust.Model.Packet - -data ReplayConfig = - TCPConfig PortNumber Bool - | UDPConfig PortNumber Bool String Bool - -data PacketMask = PacketMask [[(Int,Word8)]] deriving (Show) -- [[(Offset,Byte)]], list index is packet number - -nextMask :: PacketMask -> PacketMask -nextMask (PacketMask []) = PacketMask [] -nextMask (PacketMask (mask:masks)) = PacketMask masks - -loadMask :: FilePath -> IO PacketMask -loadMask path = do - file <- readFile path - return $ parseMasks $ map words (lines file) - -parseMasks :: [[String]] -> PacketMask -parseMasks sss = PacketMask $ map parseMask sss - -parseMask :: [String] -> [(Int,Word8)] -parseMask ss = map parseByteMask ss - -parseByteMask :: String -> (Int,Word8) -parseByteMask s = - let (a:b:_) = splitOn "," s - a' = (read a)::Int - b' = (read b)::Word8 - in (a',b') - -replayStream :: ReplayConfig -> Stream -> PacketMask -> Socket -> IO() -replayStream config stream@(Stream _ _ []) mask sock = do - putStrLn "Done replaying" - putStrLn "Closing socket" - case config of --- (TCPConfig _ _) -> sClose sock - (TCPConfig _ _) -> linger sock - (UDPConfig _ _ _ _) -> return() -replayStream config stream@(Stream protocol port (packet:packets)) mask sock = do - replayPacket config packet mask sock - replayStream (markNotFirst config) (Stream protocol port packets) (nextMask mask) sock - -markNotFirst :: ReplayConfig -> ReplayConfig -markNotFirst config@(TCPConfig _ _) = config -markNotFirst (UDPConfig a b c _) = UDPConfig a b c False - --- True if packet direction is the same as config direction --- False if packet direction is not the same as config direction --- Config Packet Replay --- T T T -- Server, Packet is Client->Server, Read --- T F F -- Server, Packet is Client<-Server, Send --- F T F -- Client, Packet is Client->Server, Send --- F F T -- Client, Packet is Client<-Server, Read -replayDirection :: ReplayConfig -> Packet -> Bool -replayDirection config packet = - case config of - (TCPConfig port dir) -> (packetDirection packet port) == dir - (UDPConfig port dir _ _) -> (packetDirection packet port) == dir - --- True if the destination of the packet is the config port --- Means packet is going to server --- False if the destination of the packet is any other port --- Means packet is going to client -packetDirection :: Packet -> PortNumber -> Bool -packetDirection (Packet _ _ tcp _) (PortNum port) = (destport tcp) == port - -replayPacket :: ReplayConfig -> Packet -> PacketMask -> Socket -> IO() -replayPacket config packet@(Packet _ _ _ payload) mask sock = do - case (replayDirection config packet) of - True -> getReplayedBytes (B.length payload) sock - False -> sendReplayedBytes config packet mask sock - -linger :: Socket -> IO() -linger = forever $ getReplayedBytes 1024 - -getReplayedBytes :: Int -> Socket -> IO() -getReplayedBytes count sock = do - putStrLn $ "waiting for " ++ show count - bsTry <- try (recv sock count) :: IO (Either IOError B.ByteString) - case bsTry of - Left error -> do - putStrLn $ "Error: " ++ show error - putStrLn "Closing socket" --- sClose sock - return () - Right bs -> do - putStrLn $ "got " ++ (show (B.length bs)) - if (B.length bs) == 0 - then do - putStrLn "0 length read" - putStrLn "Closing socket" --- sClose sock - return () - else if (B.length bs) < count - then getReplayedBytes (count - (B.length bs)) sock - else return () - -sendReplayedBytes :: ReplayConfig -> Packet -> PacketMask -> Socket -> IO() -sendReplayedBytes config packet@(Packet _ _ transport payload) mask sock = do - putStrLn $ "sending " ++ show (B.length payload) - putStrLn $ show packet - let maskedPayload = applyMask mask payload - case config of - (TCPConfig _ _) -> do - sendTry <- try (sendAll sock maskedPayload) :: IO (Either IOError ()) - case sendTry of - Left error -> do - putStrLn $ "Error: " ++ show error - putStrLn "Closing socket" --- sClose sock - Right _ -> do - putStrLn $ "sent " ++ (show (B.length payload)) - (UDPConfig sport dir host first) -> do - bindAddr <- inet_addr host - let addr = SockAddrInet (PortNum (if dir then 2014 else 2013)) bindAddr - sendTry <- try (sendTo sock maskedPayload addr) :: IO (Either IOError Int) - case sendTry of - Left error -> do - putStrLn $ "Error: " ++ show error - Right _ -> do - putStrLn $ "sent " ++ (show (B.length payload)) ++ " to " ++ (show addr) - return () - -applyMask :: PacketMask -> ByteString -> ByteString -applyMask (PacketMask []) bs = bs -applyMask (PacketMask (mask:_)) bs = applyByteMasks mask bs - -applyByteMasks :: [(Int,Word8)] -> ByteString -> ByteString -applyByteMasks [] bs = bs -applyByteMasks (mask:masks) bs = applyByteMasks masks (applyByteMask mask bs) - -applyByteMask :: (Int,Word8) -> ByteString -> ByteString -applyByteMask (offset,value) bs = - let front = B.take offset bs - back = B.drop (offset+1) bs - in front `B.append` (value `B.cons` back) -