path: root/test-server.hs

{-# 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 Server
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 <STM action> <IO action> <function>)
{-
,((),Got "hey you!\n")
,((),RequiresPing)
,((),RequiresPing)
,((),Got "what?\n")
,((),EOF)
,((),Connection <STM action> <IO action> <function>)
,((),Got "try 2: hey you!\n")
,((),RequiresPing)
,((),Got "try 2: what?\n")
,((),Got "try 2: yes.\n")
,((),EOF)]
testPing: [((),Connection <STM action> <IO action> <function>)
,((),Got "hey you!\n")
,((),RequiresPing)
,((),Got "what?\n")
,((),RequiresPing)
,((),EOF)
,((),Connection <STM action> <IO action> <function>)
,((),Got "try 2: hey you!\n")
,((),RequiresPing)
,((),Got "try 2: what?\n")
,((),RequiresPing)]
testPing: [((),Connection <STM action> <IO action> <function>)
,((),Got "hey you!\n")
,((),RequiresPing)
,((),Got "what?\n")
,((),RequiresPing)
,((),EOF)
,((),Connection <STM action> <IO action> <function>)
,((),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 ()