{-# LANGUAGE ScopedTypeVariables #-}
module FRP.Titan.Debug.CommTCP
( mkTitanCommTCPBridge )
where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Maybe
import Network.BSD
import Network.Socket
import System.IO
import FRP.Titan.Debug.Comm
mkTitanCommTCPBridge :: IO ExternalBridge
mkTitanCommTCPBridge = do
outChannel <- atomically $ newTChan
eventChannel <- atomically $ newTChan
getChannel <- atomically $ newTChan
forkIO $ mkSendMsg outChannel getChannel
forkIO $ mkSendEvent eventChannel
let sendMsg msg = do atomically $ writeTChan outChannel msg
putStrLn $ "Wrote the sync message " ++ msg
sendEvent msg = do atomically $ writeTChan eventChannel msg
putStrLn $ "Wrote the async message " ++ msg
getMsg = do a <- (fromMaybe "") <$> (atomically $ tryReadTChan getChannel)
when (not (null a)) $ putStrLn $ "Got the sync message " ++ show a
return a
return $ ExternalBridge errPrintLn sendMsg sendEvent getMsg
mkSendMsg :: TChan String -> TChan String -> IO ()
mkSendMsg outChannel getChannel = void $
forkIO $ serveSync "8081" (\msg -> do atomically $ writeTChan getChannel msg) (atomically $ readTChanAll outChannel)
readTChanAll :: TChan a -> STM [a]
readTChanAll tchan = reverse <$> readTChanAll' tchan []
readTChanAll' :: TChan a -> [a] -> STM [a]
readTChanAll' tchan acc = do
mval <- tryReadTChan tchan
case mval of
Nothing -> return acc
Just val -> readTChanAll' tchan (val : acc)
serveSync :: String
-> (String -> IO ())
-> (IO [String])
-> IO ()
serveSync port handlerGet handlerSend = withSocketsDo $
do
addrinfos <- getAddrInfo
(Just (defaultHints {addrFlags = [AI_PASSIVE]}))
Nothing (Just port)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
bind sock (addrAddress serveraddr)
listen sock 5
lock <- newMVar ()
procRequests lock sock
where
procRequests :: MVar () -> Socket -> IO ()
procRequests lock mastersock = forever $ void $ do
(connsock, _clientaddr) <- accept mastersock
connhdl <- socketToHandle connsock ReadWriteMode
putStrLn ("Socket connected.")
hSetBuffering connhdl LineBuffering
hPutStrLn connhdl "Hello 0"
hFlush connhdl
t1 <- forkIO $ procSend lock connhdl
t2 <- forkIO $ procGet lock connhdl
return ()
procGet :: MVar () -> Handle -> IO ()
procGet lock connhdl = do
let processMessage = forever $ do
message <- hGetLine connhdl
handleGet lock message
catch processMessage (\(e :: IOException) -> putStrLn "Disconnected")
procSend :: MVar () -> Handle -> IO ()
procSend lock connhdl = do
let processMessage = forever $ do
responses <- handleSend lock
mapM_ (\msg -> hPutStrLn connhdl msg >> hFlush connhdl) responses
catch processMessage (\(e :: IOException) -> putStrLn "Disconnected")
handleGet :: MVar () -> String -> IO ()
handleGet lock msg =
withMVarLock lock $ handlerGet msg
handleSend :: MVar () -> IO [String]
handleSend lock =
withMVarLock lock $ handlerSend
mkSendEvent :: TChan String -> IO ()
mkSendEvent channel = void $
forkIO $ serveAsync "8082" $ \handle -> forever $ do
response <- atomically $ readTChan channel
putStrLn $ "Sending to the event log: " ++ show response
hPutStrLn handle response
hFlush handle
serveAsync :: String
-> (Handle -> IO ())
-> IO ()
serveAsync port handlerfunc = withSocketsDo $
do
addrinfos <- getAddrInfo
(Just (defaultHints {addrFlags = [AI_PASSIVE]}))
Nothing (Just port)
let serveraddr = head addrinfos
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
bind sock (addrAddress serveraddr)
listen sock 5
lock <- newMVar ()
procRequests lock sock
where
procRequests :: MVar () -> Socket -> IO ()
procRequests lock mastersock = forever $ void $ do
(connsock, _clientaddr) <- accept mastersock
forkIO $ procMessages lock connsock
procMessages :: MVar () -> Socket -> IO ()
procMessages lock connsock = do
connhdl <- socketToHandle connsock ReadWriteMode
putStrLn ("Socket connected.")
hSetBuffering connhdl LineBuffering
hPutStrLn connhdl "DHello 0"
hFlush connhdl
handle lock connhdl
hClose connhdl
handle :: MVar () -> Handle -> IO ()
handle lock handle =
withMVarLock lock (handlerfunc handle)
putInMVar :: MVar [String] -> String -> IO ()
putInMVar mvar s = modifyMVar_ mvar (return . (++ [s]))
withMVarLock :: MVar a -> IO b -> IO b
withMVarLock lock io = do
a <- takeMVar lock
r <- io
putMVar lock a
return r
errPrintLn :: String -> IO ()
errPrintLn s = hPutStrLn stderr s >> hFlush stderr