top-0.2: src/Network/Top/WebSockets.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GHCForeignImportPrim #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
-- |WebSockets Connection (with GHCJS native support)
module Network.Top.WebSockets(
runWSApp
) where
import qualified Data.ByteString as B
import Network.Top.Types
#ifdef ghcjs_HOST_OS
-- GHC-JS Version
import qualified Data.ByteString.Lazy as L
import Control.Applicative (Alternative (empty, (<|>)))
import Control.Exception
import qualified Control.Concurrent.STM as S
import qualified Data.JSString as S
import Data.Maybe
import GHCJS.Buffer
import qualified GHCJS.Buffer as Buffer
import GHCJS.Foreign
import GHCJS.Foreign.Internal
import GHCJS.Marshal
import GHCJS.Marshal.Pure
import GHCJS.Types
import JavaScript.Web.Blob.Internal (Blob, SomeBlob (..))
import JavaScript.Web.MessageEvent
import JavaScript.Web.WebSocket hiding (close)
import qualified JavaScript.Web.WebSocket as JS
import JavaScript.TypedArray.ArrayBuffer
import qualified JavaScript.TypedArray.ArrayBuffer as A
import GHC.Exts
import qualified Data.Text as T
import Network.Top.Util
-- import JavaScript.TypedArray -- ArrayBuffer, SomeArrayBuffer(..))
-- import JavaScript.TypedArray.Internal -- ArrayBuffer, SomeArrayBuffer(..))
runWSApp :: Config -> WSApp r -> IO r
runWSApp cfg = bracket (newConnection cfg) close
-- |A WS connection
data Conn a = Conn {connConfig:: Config
,connStatus :: S.TVar (ConnStatus a)
,connMessages :: S.TQueue a}
-- |Connection Status
data ConnStatus a = ConnOpening
| ConnOpen {inp::IO a,out::a -> IO (),cls::IO ()}
| ConnClosed -- is this needed?
newConnection :: Config -> IO WSConnection
newConnection cfg = do
conn <- Conn cfg <$> S.newTVarIO ConnClosed <*> S.newTQueueIO
-- BUG: reopen connection without sending the protocol
-- return $ Connection
-- (open conn >>= \(i,o,c) -> i)
-- (\v -> open conn >>= \(i,o,c) -> o v)
-- (tillClose $ connStatus conn)
(i,o,c) <- open conn
return $ Connection i o (tillClose $ connStatus conn)
where
tillClose st = do
dbgS "[Close"
toClose <- S.atomically $ do
s <- S.readTVar st
case s of
ConnOpening -> S.retry
ConnOpen _ _ cls -> return $ Just cls
ConnClosed -> return Nothing
fromMaybe (return ()) toClose
dbgS "Close]"
-- changeStatus conn = S.atomically $ S.writeTVar (connStatus conn) ConnClosed
-- |Block till open
open c =
fromMaybe <$> reopen c <*> (S.atomically $ do
s <- S.readTVar (connStatus c)
case s of
ConnOpening -> S.retry
ConnOpen i o c -> return $ Just (i,o,c)
ConnClosed -> do
S.writeTVar (connStatus c) ConnOpening
return Nothing)
reopen c = do
dbgS "[reopen"
let cfg = connConfig c
econn <- tryE (JS.connect $ JS.WebSocketRequest {
url= S.pack $ concat ["ws://",cfgIP cfg,":",show (cfgPort cfg),cfgPath cfg]
,protocols=[S.pack $ T.unpack $ chatsProtocolT]
,onClose = Just $ \_ -> closeConn c
,onMessage = Just $ \event -> do
dbgS "received message"
case getDataFixed event of
Left e -> error e
Right bs -> S.atomically . S.writeTQueue (connMessages c) $ bs
-- case getDataFixed event of
-- StringData s -> dbgS "unexpected String message"
-- BlobData blob -> dbgS "unexpected Blob message"
-- ArrayBufferData ab -> S.atomically . S.writeTQueue (connMessages c) . L.fromStrict . toBS $ ab
})
case econn of
Left e -> do
dbgS "Error while opening connection"
threadDelay (seconds 5)
reopen c
Right ws -> do
let
-- if there is data return it,
-- otherwise if connection is open retry otherwise return Nothing
-- inp = do
-- mmsg <- S.atomically $
-- ((Just <$> S.readTQueue (connMessages c))
-- <|> (Do
-- connClosed <- isClosed <$> S.readTVar (connStatus c)
-- case st of
-- ConnOpening -> retry
-- ConnOpen -> retry
-- ConnClosed -> return Nothing
-- S.check connClosed
-- return Nothing
-- ))
-- case mmsg of
-- Nothing -> open c >> mmsg
-- Just msg -> return msg
inp = do
r <- S.atomically $ S.readTQueue (connMessages c)
-- dbg ["received",show $ L.unpack r]
return r
out v = do
-- dbg ["send",show $ L.unpack v]
webSocketSend ws v
-- out v = do
-- r <- tryE (webSocketSend conn (L.toStrict v))
-- case r of
-- Left err -> do
-- cls (unwords ["websockets output failed",show err])
-- (_,o,_) <- reopen c
-- o v
-- Right () -> return ()
cls reason = do
-- closeConn conn reason
JS.close Nothing Nothing ws -- (S.pack "FIX THIS") ws
dbg [reason,"closed]"]
let cls' = (cls "user request")
js_asArrayBuffer ws
S.atomically $ S.writeTVar (connStatus c) (ConnOpen inp out cls')
dbgS "reopen]"
return (inp,out,cls')
where
closeConn conn = S.atomically $ S.writeTVar (connStatus conn) ConnClosed
-- closeConn conn reason = do
-- JS.close conn
-- dbg ["Closing connection",reason]
-- runWSApp :: Config -> WSApp r -> IO r
-- runWSApp cfg app = do
-- q <- S.newTQueueIO
-- closed <- S.newTVarIO False
-- let wsClose _ = close "WebSockets Close"
-- close reason = do
-- S.atomically (S.writeTVar closed True)
-- dbg ["connection closed",reason]
-- wsMessage e = do
-- dbgS "received message"
-- case getData e of
-- StringData s -> close "unexpected String message"
-- BlobData blob -> close "unexpected Blob message"
-- ArrayBufferData ab -> S.atomically . S.writeTQueue q . L.fromStrict . toBS $ ab
-- ArrayBufferData ab -> Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer $ ab
-- Conn <- JS.connect $ JS.WebSocketRequest {
-- url= S.pack $ concat ["ws://",ip cfg,":",show (port cfg),path cfg]
-- ,protocols=[S.pack "quid2.net"]
-- ,onClose=Just wsClose
-- ,onMessage=Just wsMessage}
-- let
-- out v = do
-- r <- tryE (webSocketSend conn (L.toStrict v))
-- case r of
-- Left err -> do
-- close (unwords ["websockets output failed",show err])
-- return False
-- Right () -> return True
-- -- if there is data return it,
-- -- otherwise if connection is open retry otherwise return Nothing
-- inp = S.atomically $
-- ((Just <$> S.readTQueue q)
-- <|> (do
-- connClosed <- S.readTVar closed
-- S.check connClosed
-- return Nothing
-- ))
-- app $ Connection inp out
--putStrLn (show . L.unpack . flat . typedBytes $ (ByType::ByType Bool))
-- putStrLn (show $ B.unpack . shake128 32 . B.pack $ [])
-- app $ WSConnection {sendMsg = webSocketSend conn . L.toStrict
-- ,receiveMsg = undefined}
-- printB :: B.ByteString -> IO ()
-- printB = print
toBS :: ArrayBuffer -> B.ByteString
toBS = Buffer.toByteString 0 Nothing . Buffer.createFromArrayBuffer
-- toBS1 = Buffer.toByteString 0 Nothing
webSocketSend :: WebSocket -> B.ByteString -> IO ()
webSocketSend ws bs | B.length bs == 0 = return ()
| otherwise = do
let (b, off, len) = fromByteString bs
-- dbgS $ unwords ["BUFFER OFF",show off,"LEN",show len]
js_sendByteString ws (getArrayBuffer b) off len
foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
getDataFixed :: MessageEvent -> Either String B.ByteString -- MessageEventData
getDataFixed me = case js_getData me of
(# 1#, r #) -> Left "Unexpected String"
(# 2#, r #) -> Left "Unexpected Blob"
(# 3#, r #) -> Right $ toBS r
{-# INLINE getDataFixed #-}
foreign import javascript unsafe
--"$1.send(new Uint8Array($2,$3,$4));$r=new Uint8Array($2,$3,$4).byteLength"
"$1.send(new Uint8Array($2,$3,$4))"
js_sendByteString :: WebSocket -> ArrayBuffer -> Int -> Int -> IO ()
foreign import javascript unsafe
"$r2 = $1.data;$r1 = typeof $r2 === 'string' ? 1 : ($r2 instanceof ArrayBuffer ? 3 : 2)"
js_getData :: MessageEvent -> (# Int#, ArrayBuffer #)
-- By default, websockets would be in blob mode, so we need this.
foreign import javascript unsafe
"$1.binaryType='arraybuffer'"
js_asArrayBuffer :: WebSocket -> IO ()
#else
------------ GHC Version
import qualified Network.WebSockets as WS
-- |Run a WebSockets Application, keep connection alive.
--
-- Automatically close sockets on WSApp exit
runWSApp ::
Config -- ^ Top configuration
-> WSApp a -- ^ Application to connect
-> IO a -- ^ Value returned from the application
runWSApp cfg app =
WS.runClientWith (cfgIP cfg) (cfgPort cfg) (cfgPath cfg) opts [("Sec-WebSocket-Protocol", chatsProtocol)] $ \conn -> do
-- WS.forkPingThread conn 20 -- Keep connection alive avoiding timeouts (FIX: the server should send pings as this is required by browsers)
--WS.sendClose conn (1000::Int)
-- app $ Connection
-- (eitherToMaybe <$> tryE (WS.receiveData conn))
-- (\bs -> isRight <$> tryE (WS.sendBinaryData conn bs))
app $ Connection
(WS.receiveData conn)
(WS.sendBinaryData conn)
(WS.sendClose conn ("So long, and thanks for all the fish!"::B.ByteString))
where
opts = WS.defaultConnectionOptions -- { WS.connectionOnPong = dbgS "gotPong"}
-- -- |Send a raw binary message on a WebSocket (untyped) connection
-- sendMsg :: WS.Connection -> L.ByteString -> IO ()
-- sendMsg = WS.sendBinaryData
-- -- |Receive a raw binary message from a WebSocket (untyped) connection
-- receiveMsg :: WS.Connection -> IO L.ByteString
-- receiveMsg conn = WS.receiveData conn
#endif