{-# LANGUAGE OverloadedStrings #-} module Main where import Debug.Trace import Control.Exception (evaluate) -- ,handle,SomeException(..),bracketOnError) import Control.Exception ({-evaluate,-}handle,SomeException(..),bracketOnError,ErrorCall(..)) import System.IO.Error (ioeGetErrorType) import Connection.Tcp import Control.Monad import Control.Monad.Trans.Resource import Control.Monad.IO.Class import Control.Monad.STM import Control.Monad.Fix import Control.Concurrent (threadDelay,forkOS,forkIO) import Control.Concurrent.STM.TMVar import Control.Concurrent.STM.TChan import Network.Socket import System.Process.Internals import System.Process import Data.Char import System.IO hiding (isEOF) import System.Posix.Signals hiding (Ignore) makeGots sv = do let chan = serverEvent sv gotchan <- atomically $ dupTChan chan forkIO $ do fix $ \loop -> do (k,e) <- atomically $ readTChan chan case e of Connection pingflag read write -> todo EOF -> todo loop return gotchan isConnection (_,Connection {}) = True isConnection _ = False isPending want (_,HalfConnection got) | got/=want = True isPending _ _ = False isRead str (_,Got r) | r==str = True isRead _ _ = False isEOF (_,EOF) = True isEOF _ = False -- localhost port = SockAddrInet port 127 localhost port = SockAddrInet6 port 0 (0,0,0,1) 0 withServer f = runResourceT $ do sv <- server result <- liftIO $ f sv release (serverReleaseKey sv) return result writeToPort port str = do s <- readProcess "/usr/bin/socat" ["-","TCP6:localhost:"++show port] str reverse s `seq` return () connectToPort port = do (inp,outp,err,p) <- runInteractiveProcess "/usr/bin/socat" ["-","TCP6:localhost:"++show port] Nothing Nothing hSetBuffering inp NoBuffering hSetBuffering outp NoBuffering hSetBuffering err NoBuffering forkOS $ do putStrLn $ "SOCAT-ConnectToPort:"++show (port,(inp,outp,err)) hGetContents err >>= putStrLn return (inp,outp,err,p) listenOnPort port = do putStrLn $ "socat - TCP6-LISTEN:"++show port++",fork" (inp,outp,err,p) <- runInteractiveProcess "/usr/bin/socat" ["-","TCP6-LISTEN:"++show port++",fork"] Nothing Nothing hSetBuffering inp NoBuffering hSetBuffering outp NoBuffering hSetBuffering err NoBuffering forkOS $ do { putStrLn "SOCAT-listenOnPort:"; hGetContents err >>= putStrLn } -- forkOS $ do { putStrLn "SOCAT-listenOnPort:"; hGetContents outp >>= putStrLn } return (inp,outp,err,p) stopListening (inp,outp,err,p) = do {- forkOS $ do o <- hGetContents outp void $ evaluate (length o) forkOS $ do e <- hGetContents err void $ evaluate (length e) threadDelay 1000000 hClose inp threadDelay 1000000 forkOS $ do threadDelay 100000 mapM_ hClose [outp,err] -} withProcessHandle p $ \p -> do case p of OpenHandle pid -> trace ("interrupting: "++show pid) $ signalProcess sigINT pid _ -> return () return (p,()) {- threadDelay 500000 terminateProcess p -} e <- waitForProcess p putStrLn $ "SOCAT-LISTEN exit: "++show e chanContents ch = do x <- atomically $ do bempty <- isEmptyTChan ch if bempty then return Nothing else fmap Just $ readTChan ch maybe (return []) (\x -> do xs <- chanContents ch return (x:xs)) x control sv = atomically . putTMVar (serverCommand sv) testListen = do let send con str = do hPutStr con str hFlush con threadDelay 100000 events <- withServer $ \sv -> do let _ = sv :: Server SockAddr events = serverEvent sv params :: ConnectionParameters SockAddr params = connectionDefaults (return . snd) control sv (Listen 39242 params) h1@(con1,con2,_,_)<- connectToPort 39242 send con1 "Joe was here" control sv (Ignore 39242) threadDelay 500000 stopListening h1 threadDelay 500000 return events e <- chanContents events putStrLn $ "testListen: "++ show e return $ and [ length e == 3 , isConnection $ e !! 0 , isRead "Joe was here" $ e !! 1 , isEOF $ e !! 2 ] testReplace = do let send con str = do hPutStrLn con str hFlush con threadDelay 100000 events <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = connectionDefaults (const $ return ()) control sv (Listen 39242 params) h1@(con1,_,_,_)<- connectToPort 39242 send con1 "Joe was here" h2@(con2,_,_,_) <- connectToPort 39242 send con2 "Jim also" send con1 "What?" threadDelay 500000 stopListening h1 -- misnomer stopListening h2 -- misnomer threadDelay 500000 return events e <- chanContents events -- [([::ffff:127.0.0.1]:43722,Connection) -- ,([::ffff:127.0.0.1]:43722,Got "Joe was here\n") -- ,([::ffff:127.0.0.1]:43723,Connection) -- ,([::ffff:127.0.0.1]:43723,Got "Jim also\n") -- ,([::ffff:127.0.0.1]:43722,Got "What?\n") -- ,([::ffff:127.0.0.1,EOF)]:43722 -- ,([::ffff:127.0.0.1,EOF)]:43723] -- putStrLn $ show e putStrLn $ "testReplace: "++ show e return $ case e of [(_,Connection {}) ,(_,Got "Joe was here\n") ,(_,EOF) ,(_,Connection {}) ,(_,Got "Jim also\n") ,(_,EOF)] -> True _ -> False testPendingOut = do let send con str = do hPutStr con str hFlush con threadDelay 100000 events <- withServer $ \sv -> do let _ = sv :: Server SockAddr events = serverEvent sv params :: ConnectionParameters SockAddr params = (connectionDefaults (return . snd)) { duplex = False } control sv (Listen 39249 params) h1@(con1,con2,_,_)<- connectToPort 39249 send con1 "Joe was here" stopListening h1 threadDelay 500000 return events e <- chanContents events putStrLn $ "testPendingOut: "++ show e return $ and [ length e == 3 , isPending Out $ e !! 0 , isRead "Joe was here" $ e !! 1 , isEOF $ e !! 2 ] testReplacePendingOut = do let send con str = do hPutStrLn con str hFlush con threadDelay 100000 events <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { duplex = False } control sv (Ignore 39242) control sv (Listen 39242 params) threadDelay 500000 h1@(con1,_,_,_) <- connectToPort 39242 send con1 "Joe was here" h2@(con2,_,_,_) <- connectToPort 39242 send con2 "Jim also" send con1 "What?" threadDelay 500000 control sv (Ignore 39242) threadDelay 500000 stopListening h1 -- misnomer stopListening h2 -- misnomer threadDelay 500000 return events e <- chanContents events putStrLn $ "testReplacePendingOut: "++ show e return $ case e of [ (_,HalfConnection In) ,(_,Got "Joe was here\n") ,(_,EOF) ,(_,HalfConnection In) ,(_,Got "Jim also\n") ,(_,EOF)] -> True _ -> False testReplacePendingIn = do let send con str = do hPutStrLn con str hFlush con threadDelay 100000 (events,socat) <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { duplex = False } threadDelay 500000 socat <- listenOnPort 39242 threadDelay 500000 control sv (Connect (localhost 39242) params) control sv (Connect (localhost 39242) params) return (events,socat) threadDelay 500000 stopListening socat threadDelay 500000 e <- chanContents events putStrLn $ "testReplacePendingIn: "++ show e return $ e==[((),HalfConnection Out) ,((),EOF) ,((),HalfConnection Out) ,((),EOF)] testPromotePendingOut = do putStrLn "----------- testPromotePendingOut" hFlush stdout let send con str = do hPutStr con str hFlush con threadDelay 100000 (events,s,socat) <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { duplex = False } control sv (Ignore 39244) threadDelay 500000 control sv (Listen 39244 params) socat <- listenOnPort 39243 h@(con1,con2,_,_) <- connectToPort 39244 putStrLn $ "connected to 39244, Sending Joe was here" send con1 "Joe was here" threadDelay 500000 putStrLn $ "Connecting to 39243" control sv (Connect (localhost 39243) params) threadDelay 500000 putStrLn $ "probably connected to 39243" control sv (Send () "and jim") putStrLn $ "connected to 39244, Sending Joe was here twice" hFlush stdout send con1 "Joe was here twice" threadDelay 500000 s <- fmap (take 7) $ hGetContents ((\(_,x,_,_)->x) socat) last s `seq` threadDelay 500000 stopListening h -- misnomer threadDelay 50000 return (events,s,socat) stopListening socat threadDelay 500000 e <- chanContents events putStrLn $ "testPromotePendingOut: "++ show (s,e) -- testPromotePendingOut: ("and jim",[HalfConnection () In,((),Got "Joe was here"),((),Read () "Joe was here twice",((),EOF)]),Connection) -- return . and $ [ s== "and jim" , e== [ ((),HalfConnection In) , ((),Got "Joe was here") , ((),Connection {}) , ((),Got "Joe was here twice") , ((),EOF) ] ] testPromotePendingIn = do putStrLn "----------- testPromotePendingIn" hFlush stdout let send con str = do handle (\e -> putStrLn . show $ ioeGetErrorType e) $ do hPutStrLn con str hFlush con threadDelay 500000 (events,socat,s) <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { duplex = False } -- Outgoing connection socat <- listenOnPort 39248 threadDelay 500000 putStrLn $ "Connecting to 39248..." control sv (Connect (localhost 39248) params) threadDelay 1000000 putStrLn $ "...probably connected to 39248" control sv (Send () "and jim") threadDelay 1000000 s <- fmap (take 7) $ hGetContents ((\(_,x,_,_)->x) socat) length s `seq` threadDelay 500000 control sv (Listen 39247 params) threadDelay 500000 h@(con1,con2,_,_) <- connectToPort 39247 send con1 "howdy!" h2@(con1',con2',_,_) <- connectToPort 39247 threadDelay 500000 send con1' "what?" threadDelay 1000000 hClose con1 hClose con1' threadDelay 1000000 stopListening socat threadDelay 1000000 return (events,socat,s) e <- chanContents events putStrLn $ "testPromotePendingIn: "++ show (s,e) -- testPromotePendingIn: ("and jim",[HalfConnection () Out,((),((),Got "howdy!\n"),((),EOF (),HalfConnection () In,Read () "what?\n",EOF (),EOF)]),Connection) -- ("and jim",[HalfConnection () Out,((),((),Got "howdy!\n"),((),HalfConnection () In,Read () "what?\n",EOF (),EOF)]),Connection) return . and $ [ s == "and jim" , e == [ ((),HalfConnection Out) ,((),Connection {}) ,((),Got "howdy!\n") ,((),EOF) ,((),HalfConnection In) ,((),Got "what?\n") ,((),EOF)] ] testPing = do putStrLn "----------- testPing" let send con str = do handle (\e -> putStrLn . show $ ioeGetErrorType e) $ do hPutStrLn con str hFlush con threadDelay 500000 events <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { pingInterval = 2000 , timeout = 1000 } control sv (Listen 32957 params) threadDelay 500000 socat@(h,_,_,_) <- connectToPort 32957 -- putStrLn $ "sending hey you!" send h "hey you!" -- putStrLn $ "delay" threadDelay 3500000 -- ping timeout -- putStrLn $ "sending what?" send h "what?" -- lost due to timeout -- putStrLn $ "delay-2" threadDelay 500000 -- putStrLn $ "close h" hClose h threadDelay 500000 socat@(h,_,_,_) <- connectToPort 32957 send h "try 2: hey you!" threadDelay 2500000 -- ping warning send h "try 2: what?" threadDelay 1000000 -- no warning or timeout send h "try 2: yes." stopListening socat threadDelay 1000000 return events e <- chanContents events putStrLn $ "testPing: "++show e -- testPing: [((),Connection ) {- ,((),Got "hey you!\n") ,((),RequiresPing) ,((),RequiresPing) ,((),Got "what?\n") ,((),EOF) ,((),Connection ) ,((),Got "try 2: hey you!\n") ,((),RequiresPing) ,((),Got "try 2: what?\n") ,((),Got "try 2: yes.\n") ,((),EOF)] testPing: [((),Connection ) ,((),Got "hey you!\n") ,((),RequiresPing) ,((),Got "what?\n") ,((),RequiresPing) ,((),EOF) ,((),Connection ) ,((),Got "try 2: hey you!\n") ,((),RequiresPing) ,((),Got "try 2: what?\n") ,((),RequiresPing)] testPing: [((),Connection ) ,((),Got "hey you!\n") ,((),RequiresPing) ,((),Got "what?\n") ,((),RequiresPing) ,((),EOF) ,((),Connection ) ,((),Got "try 2: hey you!\n") ,((),RequiresPing) ,((),Got "try 2: what?\n") ,((),Got "try 2: yes.\n") ,((),EOF)] -} return $ e == [((),Connection {}) ,((),Got "hey you!\n") ,((),RequiresPing) ,((),EOF) ,((),Connection {}) ,((),Got "try 2: hey you!\n") ,((),RequiresPing) ,((),Got "try 2: what?\n") ,((),Got "try 2: yes.\n") ,((),EOF)] testDisabledPing = do let send con str = do hPutStrLn con str hFlush con threadDelay 500000 events <- withServer $ \sv -> do let _ = sv :: Server () events = serverEvent sv params = (connectionDefaults (const $ return ())) { pingInterval = 0 , timeout = 0 } control sv (Listen 32958 params) threadDelay 500000 socat@(h,_,_,_) <- connectToPort 32958 send h "hey you!" threadDelay 3500000 -- ping timeout send h "what?" -- lost due to timeout threadDelay 500000 hClose h threadDelay 500000 socat@(h,_,_,_) <- connectToPort 32958 send h "try 2: hey you!" threadDelay 2500000 -- ping warning send h "try 2: what?" threadDelay 1000000 -- no warning or timeout send h "try 2: yes." stopListening socat threadDelay 5000000 return events e <- chanContents events putStrLn $ "testDisabledPing: "++show e return $ e == [((),Connection {}) ,((),Got "hey you!\n") ,((),Got "what?\n") ,((),EOF) ,((),Connection {}) ,((),Got "try 2: hey you!\n") ,((),Got "try 2: what?\n") ,((),Got "try 2: yes.\n") ,((),EOF)] main = do result1 <- testListen result2 <- testReplace result3 <- testPendingOut result4 <- testReplacePendingOut threadDelay 100000 result5 <- testReplacePendingIn result6 <- testPromotePendingOut result7 <- testPromotePendingIn result8 <- testPing result9 <- testDisabledPing let passOrFail str True = putStrLn $ str ++ ": passed" passOrFail str False = putStrLn $ str ++ ": failed" passOrFail "testListen" result1 passOrFail "testReplace" result2 passOrFail "testPendingOut" result3 passOrFail "testReplacePendingOut" result4 passOrFail "testReplacePendingIn" result5 passOrFail "testPromotePendingOut" result6 passOrFail "testPromotePendingIn" result7 passOrFail "testPing" result8 passOrFail "testDisabledPing" result9 return ()