{-# 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 jws :: 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 ws :: WebSocket
ws) bs :: ByteString
bs = do
    ArrayBuffer
ab <- ByteString -> JSM ArrayBuffer
forall (m :: * -> *). MonadJSM m => ByteString -> m ArrayBuffer
bsToArrayBuffer ByteString
bs
    WebSocket -> ArrayBuffer -> JSM ()
forall (m :: * -> *) data'.
(MonadDOM m, IsArrayBuffer data') =>
WebSocket -> data' -> m ()
DOM.send WebSocket
ws ArrayBuffer
ab

instance IsWebSocketMessage LBS.ByteString where
  webSocketSend :: JSWebSocket -> ByteString -> JSM ()
webSocketSend ws :: 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 ws :: 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 ws :: WebSocket
ws) code :: Word
code reason :: 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
  :: a
  -> Text -- url
  -> [Text] -- protocols
  -> (Either ByteString JSVal -> JSM ()) -- onmessage
  -> JSM () -- onopen
  -> JSM () -- onerror
  -> ((Bool, Word, Text) -> JSM ()) -- onclose
  -> JSM JSWebSocket
newWebSocket :: a
-> Text
-> [Text]
-> (Either ByteString JSVal -> JSM ())
-> JSM ()
-> JSM ()
-> ((Bool, Word, Text) -> JSM ())
-> JSM JSWebSocket
newWebSocket _ url :: Text
url protocols :: [Text]
protocols onMessage :: Either ByteString JSVal -> JSM ()
onMessage onOpen :: JSM ()
onOpen onError :: JSM ()
onError onClose :: (Bool, Word, Text) -> JSM ()
onClose = do
  let onOpenWrapped :: JSCallAsFunction
onOpenWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \_ _ _ -> JSM ()
onOpen
      onErrorWrapped :: JSCallAsFunction
onErrorWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \_ _ _ -> JSM ()
onError
      onCloseWrapped :: JSCallAsFunction
onCloseWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \_ _ (e :: JSVal
e:_) -> do
        let e' :: CloseEvent
e' = JSVal -> CloseEvent
CloseEvent JSVal
e
        Bool
wasClean <- CloseEvent -> JSM Bool
forall (m :: * -> *). MonadDOM m => CloseEvent -> m Bool
getWasClean CloseEvent
e'
        Word
code <- CloseEvent -> JSM Word
forall (m :: * -> *). MonadDOM m => CloseEvent -> m Word
getCode CloseEvent
e'
        Text
reason <- CloseEvent -> JSM Text
forall (m :: * -> *) result.
(MonadDOM m, FromJSString result) =>
CloseEvent -> m result
getReason CloseEvent
e'
        JSM () -> JSM ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ (Bool, Word, Text) -> JSM ()
onClose (Bool
wasClean, Word
code, Text
reason)
      onMessageWrapped :: JSCallAsFunction
onMessageWrapped = JSCallAsFunction -> JSCallAsFunction
fun (JSCallAsFunction -> JSCallAsFunction)
-> JSCallAsFunction -> JSCallAsFunction
forall a b. (a -> b) -> a -> b
$ \_ _ (e :: JSVal
e:_) -> do
        let e' :: MessageEvent
e' = JSVal -> MessageEvent
MessageEvent JSVal
e
        JSVal
d <- MessageEvent -> JSM JSVal
forall (m :: * -> *). MonadDOM m => MessageEvent -> m JSVal
getData MessageEvent
e'
        JSM () -> JSM ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ GHCJSPure JSType -> JSM JSType
forall a. GHCJSPure a -> JSM a
ghcjsPure (JSVal -> GHCJSPure JSType
jsTypeOf JSVal
d) JSM JSType -> (JSType -> JSM ()) -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          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
          _ -> do
            MutableArrayBuffer
ab <- JSVal -> JSM MutableArrayBuffer
mutableArrayBufferFromJSVal JSVal
d
            MutableArrayBuffer -> JSM ByteString
forall (m :: * -> *).
MonadJSM m =>
MutableArrayBuffer -> m ByteString
bsFromMutableArrayBuffer MutableArrayBuffer
ab JSM ByteString -> (ByteString -> JSM ()) -> JSM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either ByteString JSVal -> JSM ()
onMessage (Either ByteString JSVal -> JSM ())
-> (ByteString -> Either ByteString JSVal) -> ByteString -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either ByteString JSVal
forall a b. a -> Either a b
Left
  JSVal
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
    [ "(function(url, protos, open, error, close, message) {"
    , "  var ws = new window['WebSocket'](url, protos);"
    , "  ws['binaryType'] = 'arraybuffer';"
    , "  ws['addEventListener']('open', open);"
    , "  ws['addEventListener']('error', error);"
    , "  ws['addEventListener']('close', close);"
    , "  ws['addEventListener']('message', message);"
    , "  return ws;"
    , "})"
    ]
  JSVal
url' <- Text -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Text
url
  JSVal
protocols' <- [Text] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal [Text]
protocols
  JSVal
onOpen' <- JSCallAsFunction -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal JSCallAsFunction
onOpenWrapped
  JSVal
onError' <- JSCallAsFunction -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal JSCallAsFunction
onErrorWrapped
  JSVal
onClose' <- JSCallAsFunction -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal JSCallAsFunction
onCloseWrapped
  JSVal
onMessage' <- JSCallAsFunction -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal JSCallAsFunction
onMessageWrapped
  JSVal
ws <- JSVal -> JSVal -> [JSVal] -> JSM JSVal
forall f this args.
(MakeObject f, MakeObject this, MakeArgs args) =>
f -> this -> args -> JSM JSVal
call JSVal
newWS JSVal
newWS [JSVal
url', JSVal
protocols', JSVal
onOpen', JSVal
onError', JSVal
onClose', JSVal
onMessage']
  JSWebSocket -> JSM JSWebSocket
forall (m :: * -> *) a. Monad m => a -> m a
return (JSWebSocket -> JSM JSWebSocket) -> JSWebSocket -> JSM JSWebSocket
forall a b. (a -> b) -> a -> b
$ WebSocket -> JSWebSocket
JSWebSocket (WebSocket -> JSWebSocket) -> WebSocket -> JSWebSocket
forall a b. (a -> b) -> a -> b
$ JSVal -> WebSocket
WebSocket JSVal
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 (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 (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