{-# language OverloadedStrings #-}
{-# language ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module TestTCP where

import           MVC.TCP
import           MVC.Extended

import           Control.Applicative
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async
import           Control.Error
import Control.Exception
import           Control.Lens hiding (each)
import           Control.Monad
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C
import qualified Data.Set as Set
import           MVC
import qualified MVC.Prelude as MVC
import qualified Pipes.Prelude as Pipes
import           Test.Hspec
import           Test.QuickCheck
import           Test.Tasty
import qualified Test.Tasty.Hspec as Hspec

defAdd :: (String, String)
defAdd = ("0.0.0.0","3566")

instance Arbitrary ByteString where
    arbitrary = C.pack <$> (arbitrary :: Gen String) 

vcResponse :: (String, String) -> Managed (View (Either ByteString ByteString),Controller (Either ByteString ByteString))
vcResponse (h,p) = join $ managed $ \k -> do
    let server = responseServer h p ("server:" <>) (/= "/q")
    withAsync server $ \_ -> k $ do
        (rv,rc) <- responseClient h p
        let v = pure (handles _Left rv) <> pure (handles _Right (contramap show MVC.stdoutLines))
            c = pure (fmap Right rc) <> (fmap (Left . C.pack) <$> MVC.stdinLines)
        (,) <$> v <*> c

doResponse :: IO ()
doResponse = runMVC () (asPipe (Pipes.takeWhile (/= Left "q"))) $ vcResponse defAdd

tResponse :: (Functor f, Foldable f) => (String, String) -> f ByteString-> IO (SWrap() (Either ByteString ByteString) (Either ByteString ByteString))
tResponse (h,p) xs = runMVCWrapped () (Pipes.takeWhile (/= Left "q"))
                  (vcResponse (h,p) <> autoC)
  where
    autoC = (,) <$> pure mempty <*> MVC.producer unbounded (each (fmap Left xs) >> (yield (Left "q") >-> Pipes.chain (\_ -> threadDelay $ 1 * 1000000)))

-- responseless server test
vcResponseless :: (String,String) -> ByteString -> Double -> Managed (View (Either ByteString ByteString),Controller (Either ByteString ByteString))
vcResponseless (h,p) s t = join $ managed $ \k -> do
    let server = responselessServer h p s t
    withAsync server $ \_ -> k $ do
        (rv,rc) <- responselessClient h p
        (,) <$>
            (pure (handles _Left rv) <> pure (handles _Right (contramap show MVC.stdoutLines))) <*>
            pure (fmap Right rc) <> (fmap (Left . C.pack) <$> MVC.stdinLines)

doResponseless :: IO ()
doResponseless = runMVC ()
                 (asPipe (Pipes.takeWhile (/= Left "q"))) $
                 vcResponseless defAdd "doResponseless" 1

tResponseless :: (String,String) -> Double -> Double -> IO (SWrap() (Either ByteString ByteString) (Either ByteString ByteString))
tResponseless (h,p) tTick tTotal = runMVCWrapped () (Pipes.takeWhile (/= Left "q"))
                     (vcResponseless (h,p) "doResponseless" tTick <> autoC tTotal)
  where
    autoC t = (,) <$> pure mempty <*> MVC.producer unbounded (yield (Left "q") >-> Pipes.chain (\_ -> threadDelay $ floor $ t * 1000000))

testServers :: (String,String) -> [ByteString] -> Double -> Double -> Double -> IO Spec
testServers (h,p) bs tTick tTotal epsilon = do
    resr <- tResponse (h,p) bs
    sleep 0.2
    resrless <- tResponseless (h,p) tTick tTotal
    return $ describe "MVC.TCP.responseServer and responselessServer" $ do
        it "simple response example" $ map (Right . ("server:" <>)) bs `shouldBe` filter isRight (_wrapOuts resr)
        it "responseless server" $ floor ((tTotal-epsilon) / tTick) `shouldBe` length (filter isRight (_wrapOuts resrless))

-- correct behaviour for external NC client
tBroadcast :: Int -> IO (SWrap () ByteString ByteString)
tBroadcast n = runMVCWrapped () (Pipes.takeWhile (/= "q") >-> Pipes.take n) (broadcastServer defAdd)

-- doesnt close at all
tClient :: IO (SWrap() (Either ByteString ByteString) (Either ByteString ByteString))
tClient = runMVCWrapped () cat vcClient
  where
    vcClient = do
        (tcpV, tcpC) <- normalClient defAdd
        let v = pure (handles _Right (contramap C.unpack MVC.stdoutLines))
                <> pure (handles _Left tcpV)
            c = (fmap (Left . C.pack) <$> MVC.stdinLines)
                <> (fmap Right <$> pure tcpC)
        (,) <$> v <*> c

tBSC :: Int -> IO ()
tBSC n = do
    a0 <- async $ tBroadcast n
    threadDelay (2*10^6)
    putStrLn "ready"
    a1 <- async tClient
    res <- waitEitherCancel a0 a1
    print res

tBSCSingle :: (String, String) -> [ByteString]-> Double-> IO(SWrap() (Either ByteString ByteString) (Either ByteString ByteString),SWrap () ByteString ByteString)
tBSCSingle (h,p) bs t = do
    a0 <- async $ tBroadcast 100
    sleep 0.1
    putStrLn "ready"
    a1 <- async $ clientAuto (h,p) bs t
    resClient <- wait a1
    sleep 1.0
    clientQuit (h,p) "q"
    resServer <- wait a0
    return (resClient, resServer)

tBSCMulti :: (String,String) -> Int -> [ByteString] -> Double -> IO([SWrap() (Either ByteString ByteString) (Either ByteString ByteString)],SWrap () ByteString ByteString)
tBSCMulti (h,p) nClients bs t = do
    a0 <- async $ tBroadcast 100
    sleep 0.1
    putStrLn "ready"
    as <- mapM ((\x -> async $ tClientAutoNamed (h,p) x bs t) . C.pack . show) [1..nClients]
    resClients <- mapM wait as
    sleep 1.0
    clientQuit (h,p) "q"
    resServer <- wait a0
    return (resClients, resServer)

-- locally exits
tClientAutoNamed :: (String,String) -> ByteString -> [ByteString] -> Double -> IO (SWrap() (Either ByteString ByteString) (Either ByteString ByteString))
tClientAutoNamed (h,p) name bs t = runMVCWrapped () (Pipes.takeWhile (/= Left "q") >-> nameLefts) vcClient
  where
    nameLefts = forever $ do
        a <- await
        case a of
            Left a'  -> yield $ Left $ name <> a'
            Right _ -> yield a
    vcClient = do
        (tcpV, tcpC) <- normalClient (h,p)
        incoming <- MVC.producer (bounded 1)
                    (each bs >->
                     Pipes.map Left >->
                     Pipes.chain (\_ -> sleep t))
        exit <- MVC.producer (bounded 1) (yield (Left "q") >-> Pipes.chain (\_ -> sleep(1.0 + t * fromIntegral (length bs))))
        let v = pure (handles _Left tcpV)
            c = undefined -- pure (MVC.finally incoming exit)
                <> (fmap Right <$> pure tcpC)
        (,) <$> v <*> c

testBroadcast :: (String, String) -> Int -> [ByteString] -> ByteString -> Double -> IO Spec
testBroadcast (h,p) nClients bs quitter t = do
    resSingle <- tBSCSingle (h,p) bs t
    resMulti <- tBSCMulti (h,p) nClients bs t
    let -- clientLefts = (\x -> filter (C.isPrefixOf ((C.pack . show) x)) (_wrapOuts (snd resMulti))) <$> [1..nClients]
        allEvents = [ C.cons x' y | x <- [1..nClients], x' <- show x, y <- bs]
    return $ describe "MVC.TCP" $ do
        it "single client outs have the correct Lefts" $ keeps' _Left (_wrapOuts (fst resSingle)) `shouldBe` bs
        it "and Rights have an extra \\n" $ keeps' _Right (_wrapOuts (fst resSingle)) `shouldBe` ((<>"\n") <$> bs)
        it "last of the ins should be the quit signal" $ last (keeps' _Left (_wrapIns (fst resSingle))) `shouldBe` quitter
        it "server outs includes the original bytestrings and the quitter" $ _wrapIns (snd resSingle) `shouldBe` (bs <> [quitter])
        it "last of the server ins should be the quit signal" $ last (_wrapIns (snd resSingle)) `shouldBe` quitter
        it "with multiple clients, event arrival will not be deterministic, but every event from every client should arrive in the server Ins" $ Set.fromList (_wrapOuts (snd resMulti)) `shouldBe` Set.fromList allEvents

-- The tests yay!
unitTests :: IO [TestTree]
unitTests = sequence
    [ Hspec.testSpec "testBroadcast" =<< testBroadcast defAdd 2 ((C.pack . show) <$> [1..10]) "q" 0.1
    , Hspec.testSpec "testServers"   =<< testServers defAdd ((C.pack . show) <$> [1..10]) 0.1 1.1 0.05
    ]

tClientErrors :: IO ()
tClientErrors = do
    let (h,p) = ("0.0.0.0","3568")
        bs = (C.pack . show) <$> [1..5]
        t = 0.5
        server = runMVCWrapped () (Pipes.takeWhile (/= "q") >-> Pipes.take 100)
           (broadcastServer (h,p))
        serverTimeout t' =
            runMVCWrapped ()
            (Pipes.takeWhile (/= "q") >-> Pipes.take 100)
            (broadcastServer (h,p) <>
             ((,) <$> pure mempty <*>
              MVC.producer (bounded 1) (yield "q" >-> Pipes.chain (\_ -> sleep t'))))
        client = clientAuto (h,p) bs t
        quitter = clientQuit (h,p) "q"

    noerror <- do
        aServer <- async $ tryAny server
        sleep 0.1
        aClient <- async $ tryAny client
        sleep (t * fromIntegral (length bs) + 0.1)
        rQuitter <- tryAny quitter
        rServer <- wait aServer
        rClient <- wait aClient
        return (rServer, rClient, rQuitter)
    putStrLn "no errors"
    print noerror
    noserver <- do
        aClient <- async $ tryAny client
        wait aClient
    putStrLn "no server error"
    print noserver
    fracearlyexit <- do
        aServer <- async $ tryAny server
        sleep 0.1
        aClient <- async $ tryAny client
        sleep (t * fromIntegral (length bs) - 0.2)
        rQuitter <- tryAny quitter
        rServer <- wait aServer
        rClient <- wait aClient
        return (rServer, rClient, rQuitter)
    putStrLn "server exits fractionally early"
    print fracearlyexit
    earlyexit <- do
        aServer <- async $ tryAny server
        sleep 0.1
        aClient <- async $ tryAny client
        sleep 0.1
        rQuitter <- tryAny quitter
        rServer <- wait aServer
        rClient <- wait aClient
        return (rServer, rClient, rQuitter)
    putStrLn "server exits early"
    print earlyexit
    serverdup <- do
        aServer <- async $ tryAny (serverTimeout 20)
        sleep 0.1
        a2Server <- async $ tryAny (serverTimeout 20)
        sleep 0.1
        aClient <- async $ tryAny client
        sleep (t * fromIntegral (length bs) + 0.1)
        rQuitter <- tryAny quitter
        sleep 1.0
        rClient <- wait aClient
        rServer <- wait aServer
        r2Server <- wait a2Server
        return (rServer, r2Server, rClient, rQuitter)
    putStrLn "server dup"
    print serverdup

{-
no errors
(Right (SWrap {_wrapOrig = (), _wrapOuts = ["1","2","3","4","5"], _wrapIns = ["1","2","3","4","5","q"]}),Right (SWrap {_wrapOrig = (), _wrapOuts = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5",Right "5\n"], _wrapIns = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5",Right "5\n",Left "q"]}),Right ())
no server error
Left connect: does not exist (Connection refused)
server exits fractionally early
(Right (SWrap {_wrapOrig = (), _wrapOuts = ["1","2","3","4"], _wrapIns = ["1","2","3","4","q"]}),Right (SWrap {_wrapOrig = (), _wrapOuts = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5"], _wrapIns = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5",Left "q"]}),Right ())
server exits early
(Right (SWrap {_wrapOrig = (), _wrapOuts = [], _wrapIns = ["q"]}),Left send: resource vanished (Broken pipe),Right ())
server dup
(Right (SWrap {_wrapOrig = (), _wrapOuts = ["1","2","3","4","5"], _wrapIns = ["1","2","3","4","5","q"]}),Right (SWrap {_wrapOrig = (), _wrapOuts = [], _wrapIns = ["q"]}),Right (SWrap {_wrapOrig = (), _wrapOuts = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5",Right "5\n"], _wrapIns = [Left "1",Right "1\n",Left "2",Right "2\n",Left "3",Right "3\n",Left "4",Right "4\n",Left "5",Right "5\n",Left "q"]}),Right ())

-}

-- client that sends a list of ByteStrings and then the exit string
clientAutoStdout :: (String, String) -> [ByteString] -> Double -> IO (SWrap() (Either ByteString ByteString) (Either ByteString ByteString))
clientAutoStdout (h,p) bs t =
    runMVCWrapped () (Pipes.takeWhile (/= Left "q")) (vcClient <> ((,) <$> pure (contramap (("client:"<>) . show) MVC.stdoutLines) <*> pure mempty))
  where
    vcClient = do
        (tcpV, tcpC) <- normalClient (h,p)
        incoming <- MVC.producer (bounded 1)
                    (MVC.each bs >->
                     Pipes.map Left >->
                     Pipes.chain (\_ -> sleep t))
        exit <- MVC.producer (bounded 1) (yield (Left "q") >-> Pipes.chain (\_ -> sleep(1.0 + t * fromIntegral (length bs))))
        let v = pure (handles _Left tcpV)
            c = pure undefined -- (MVC.finally incoming exit)
                <> (fmap Right <$> pure tcpC)
        (,) <$> v <*> c

-- a client that sends the quit signal to server
clientQuitStdout :: (String,String) -> ByteString -> IO ()
clientQuitStdout (h,p) quitStr = 
    toView 1 [quitStr] (return . fst =<< normalClientStdout (h,p))

normalClientStdout :: (String, String)-> Managed (View ByteString, Controller ByteString)
normalClientStdout (h,p) =
    normalClient (h,p) <>
    ((,)
     <$>
     pure (contramap (("quitter:"<>) . show) MVC.stdoutLines)
    <*> pure mempty)


tryAny :: IO a -> IO (Either SomeException a)
tryAny action = withAsync action waitCatch

catchAny :: IO a -> (SomeException -> IO a) -> IO a
catchAny action onE = tryAny action >>= either onE return
