{-# LANGUAGE CPP #-}
#ifdef ghcjs_HOST_OS
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
#endif
{-# LANGUAGE LambdaCase #-}

module Reflex.Dom.WebSocket.Foreign
  ( module Reflex.Dom.WebSocket.Foreign
  , JSVal
  ) where

import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

import Data.Bifoldable
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import Data.Text.Encoding
import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)
import GHCJS.DOM.CloseEvent
import GHCJS.DOM.MessageEvent
import GHCJS.DOM.Types (JSM, JSVal, liftJSM, fromJSValUnchecked, WebSocket(..))
import qualified GHCJS.DOM.WebSocket as DOM
import GHCJS.Foreign (JSType(..), jsTypeOf)
import Language.Javascript.JSaddle (fun, eval, toJSVal, call)
import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)
import Language.Javascript.JSaddle.Types (ghcjsPure)

newtype JSWebSocket = JSWebSocket { JSWebSocket -> WebSocket
unWebSocket :: WebSocket }

class IsWebSocketMessage a where
  webSocketSend :: JSWebSocket -> a -> JSM ()

instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
  webSocketSend :: JSWebSocket -> Either a b -> JSM ()
webSocketSend JSWebSocket
jws = (a -> JSM ()) -> (b -> JSM ()) -> Either a b -> JSM ()
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bifoldable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_ (JSWebSocket -> a -> JSM ()
forall a. IsWebSocketMessage a => JSWebSocket -> a -> JSM ()
webSocketSend JSWebSocket
jws) (JSWebSocket -> b -> JSM ()
forall a. IsWebSocketMessage a => JSWebSocket -> a -> JSM ()
webSocketSend JSWebSocket
jws)

-- Use binary websocket communication for ByteString
-- Note: Binary websockets may not work correctly in IE 11 and below
instance IsWebSocketMessage ByteString where
  webSocketSend :: JSWebSocket -> ByteString -> JSM ()
webSocketSend (JSWebSocket WebSocket
ws) ByteString
bs = do
    ab <- ByteString -> JSM ArrayBuffer
forall (m :: * -> *). MonadJSM m => ByteString -> m ArrayBuffer
bsToArrayBuffer ByteString
bs
    DOM.send ws ab

instance IsWebSocketMessage LBS.ByteString where
  webSocketSend :: JSWebSocket -> ByteString -> JSM ()
webSocketSend JSWebSocket
ws = JSWebSocket -> ByteString -> JSM ()
forall a. IsWebSocketMessage a => JSWebSocket -> a -> JSM ()
webSocketSend JSWebSocket
ws (ByteString -> JSM ())
-> (ByteString -> ByteString) -> ByteString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- Use plaintext websocket communication for Text, and String
instance IsWebSocketMessage Text where
  webSocketSend :: JSWebSocket -> Text -> JSM ()
webSocketSend (JSWebSocket WebSocket
ws) = WebSocket -> Text -> JSM ()
forall (m :: * -> *) data'.
(MonadDOM m, ToJSString data') =>
WebSocket -> data' -> m ()
DOM.sendString WebSocket
ws

closeWebSocket :: JSWebSocket -> Word -> Text -> JSM ()
closeWebSocket :: JSWebSocket -> Word -> Text -> JSM ()
closeWebSocket (JSWebSocket WebSocket
ws) Word
code Text
reason = WebSocket -> Maybe Word -> Maybe Text -> JSM ()
forall (m :: * -> *) reason.
(MonadDOM m, ToJSString reason) =>
WebSocket -> Maybe Word -> Maybe reason -> m ()
DOM.close WebSocket
ws (Word -> Maybe Word
forall a. a -> Maybe a
Just Word
code) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason)

newWebSocket
  :: Text -- url
  -> [Text] -- protocols
  -> (Either ByteString JSVal -> JSM ()) -- onmessage
  -> JSM () -- onopen
  -> JSM () -- onerror
  -> ((Bool, Word, Text) -> JSM ()) -- onclose
  -> JSM JSWebSocket
newWebSocket :: Text
-> [Text]
-> (Either ByteString JSVal -> JSM ())
-> JSM ()
-> JSM ()
-> ((Bool, Word, Text) -> JSM ())
-> JSM JSWebSocket
newWebSocket Text
url [Text]
protocols Either ByteString JSVal -> JSM ()
onMessage JSM ()
onOpen JSM ()
onError (Bool, Word, Text) -> JSM ()
onClose = do
  let onOpenWrapped :: JSCallAsFunction
onOpenWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ [JSVal]
_ -> JSM ()
onOpen
      onErrorWrapped :: JSCallAsFunction
onErrorWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ [JSVal]
_ -> JSM ()
onError
      onCloseWrapped :: JSCallAsFunction
onCloseWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ (JSVal
e:[JSVal]
_) -> do
        let e' :: CloseEvent
e' = JSVal -> CloseEvent
CloseEvent JSVal
e
        wasClean <- CloseEvent -> JSM Bool
forall (m :: * -> *). MonadDOM m => CloseEvent -> m Bool
getWasClean CloseEvent
e'
        code <- getCode e'
        reason <- getReason e'
        liftJSM $ onClose (wasClean, code, reason)
      onMessageWrapped :: JSCallAsFunction
onMessageWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \JSVal
_ JSVal
_ (JSVal
e:[JSVal]
_) -> do
        let e' :: MessageEvent
e' = JSVal -> MessageEvent
MessageEvent JSVal
e
        d <- MessageEvent -> JSM JSVal
forall (m :: * -> *). MonadDOM m => MessageEvent -> m JSVal
getData MessageEvent
e'
        liftJSM $ ghcjsPure (jsTypeOf d) >>= \case
          JSType
String -> Either ByteString JSVal -> JSM ()
onMessage (Either ByteString JSVal -> JSM ())
-> Either ByteString JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSVal -> Either ByteString JSVal
forall a b. b -> Either a b
Right JSVal
d
          JSType
_ -> do
            ab <- JSVal -> JSM MutableArrayBuffer
mutableArrayBufferFromJSVal JSVal
d
            bsFromMutableArrayBuffer ab >>= onMessage . Left
  newWS <- String -> JSM JSVal
forall script. ToJSString script => script -> JSM JSVal
eval (String -> JSM JSVal) -> String -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ String
"(function(url, protos, open, error, close, message) {"
    , String
"  var ws = new window['WebSocket'](url, protos);"
    , String
"  ws['binaryType'] = 'arraybuffer';"
    , String
"  ws['addEventListener']('open', open);"
    , String
"  ws['addEventListener']('error', error);"
    , String
"  ws['addEventListener']('close', close);"
    , String
"  ws['addEventListener']('message', message);"
    , String
"  return ws;"
    , String
"})"
    ]
  url' <- toJSVal url
  protocols' <- toJSVal protocols
  onOpen' <- toJSVal onOpenWrapped
  onError' <- toJSVal onErrorWrapped
  onClose' <- toJSVal onCloseWrapped
  onMessage' <- toJSVal onMessageWrapped
  ws <- call newWS newWS [url', protocols', onOpen', onError', onClose', onMessage']
  return $ JSWebSocket $ WebSocket ws

onBSMessage :: Either ByteString JSVal -> JSM ByteString
onBSMessage :: Either ByteString JSVal -> JSM ByteString
onBSMessage = (ByteString -> JSM ByteString)
-> (JSVal -> JSM ByteString)
-> Either ByteString JSVal
-> JSM ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ByteString -> JSM ByteString
forall a. a -> JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JSVal -> JSM ByteString)
 -> Either ByteString JSVal -> JSM ByteString)
-> (JSVal -> JSM ByteString)
-> Either ByteString JSVal
-> JSM ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString) -> JSM Text -> JSM ByteString
forall a b. (a -> b) -> JSM a -> JSM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8 (JSM Text -> JSM ByteString)
-> (JSVal -> JSM Text) -> JSVal -> JSM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSVal -> JSM Text
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked