{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
#ifdef USE_TEMPLATE_HASKELL
{-# LANGUAGE TemplateHaskell #-}
#endif
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Reflex.Dom.WebSocket
  ( module Reflex.Dom.WebSocket
  , jsonDecode
  ) where

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

import Reflex.Class
import Reflex.Dom.WebSocket.Foreign
import Reflex.PerformEvent.Class
import Reflex.PostBuild.Class
import Reflex.TriggerEvent.Class

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Lens
import Control.Monad hiding (forM, mapM, mapM_, sequence)
import Control.Monad.IO.Class
import Data.Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Default
import Data.IORef
import Data.JSString.Text
import Data.Maybe (isJust)
import Data.Text
import Data.Text.Encoding
import Foreign.JavaScript.Utils (jsonDecode)
import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
import GHCJS.DOM.WebSocket (getReadyState)
import GHCJS.Marshal
import qualified Language.Javascript.JSaddle.Monad as JS (catch)

data WebSocketConfig t a
   = WebSocketConfig { forall {k} (t :: k) a. WebSocketConfig t a -> Event t [a]
_webSocketConfig_send :: Event t [a]
                     , forall {k} (t :: k) a. WebSocketConfig t a -> Event t (Word, Text)
_webSocketConfig_close :: Event t (Word, Text)
                     , forall {k} (t :: k) a. WebSocketConfig t a -> Bool
_webSocketConfig_reconnect :: Bool
                     , forall {k} (t :: k) a. WebSocketConfig t a -> [Text]
_webSocketConfig_protocols :: [Text]
                     }

instance Reflex t => Default (WebSocketConfig t a) where
  def :: WebSocketConfig t a
def = Event t [a]
-> Event t (Word, Text) -> Bool -> [Text] -> WebSocketConfig t a
forall {k} (t :: k) a.
Event t [a]
-> Event t (Word, Text) -> Bool -> [Text] -> WebSocketConfig t a
WebSocketConfig Event t [a]
forall a. Event t a
forall {k} (t :: k) a. Reflex t => Event t a
never Event t (Word, Text)
forall a. Event t a
forall {k} (t :: k) a. Reflex t => Event t a
never Bool
True []

type WebSocket t = RawWebSocket t ByteString

data RawWebSocket t a
   = RawWebSocket { forall {k} (t :: k) a. RawWebSocket t a -> Event t a
_webSocket_recv :: Event t a
                  , forall {k} (t :: k) a. RawWebSocket t a -> Event t ()
_webSocket_open :: Event t ()
                  , forall {k} (t :: k) a. RawWebSocket t a -> Event t ()
_webSocket_error :: Event t () -- eror event does not carry any data and is always
                                                   -- followed by termination of the connection
                                                   -- for details see the close event
                  , forall {k} (t :: k) a.
RawWebSocket t a -> Event t (Bool, Word, Text)
_webSocket_close :: Event t ( Bool -- wasClean
                                                , Word -- code
                                                , Text -- reason
                                                )
                  }

webSocket :: (MonadJSM m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
webSocket :: forall (m :: * -> *) t a.
(MonadJSM m, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) =>
Text -> WebSocketConfig t a -> m (WebSocket t)
webSocket Text
url WebSocketConfig t a
config = Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM ByteString)
-> m (RawWebSocket t ByteString)
forall (m :: * -> *) t a b.
(MonadJSM m, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) =>
Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' Text
url WebSocketConfig t a
config Either ByteString JSVal -> JSM ByteString
onBSMessage

webSocket' :: (MonadJSM m, MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b)
webSocket' :: forall (m :: * -> *) t a b.
(MonadJSM m, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) =>
Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' Text
url WebSocketConfig t a
config Either ByteString JSVal -> JSM b
onRawMessage = do
  (eRecv, onMessage) <- m (Event t b, b -> IO ())
forall a. m (Event t a, a -> IO ())
forall t (m :: * -> *) a.
TriggerEvent t m =>
m (Event t a, a -> IO ())
newTriggerEvent
  currentSocketRef <- liftIO $ newIORef Nothing
  (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
  (eError, triggerEError) <- newTriggerEvent
  (eClose, triggerEClose) <- newTriggerEvent
  payloadQueue <- liftIO newTQueueIO
  isOpen       <- liftIO newEmptyTMVarIO
  let onOpen = () -> IO () -> IO ()
triggerEOpen () (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
isOpen ()
      onError = () -> IO ()
triggerEError ()
      onClose (Bool, Word, Text)
args = do
        IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ (Bool, Word, Text) -> IO ()
triggerEClose (Bool, Word, Text)
args
        _ <- IO (Maybe ()) -> JSM (Maybe ())
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ()) -> JSM (Maybe ()))
-> IO (Maybe ()) -> JSM (Maybe ())
forall a b. (a -> b) -> a -> b
$ STM (Maybe ()) -> IO (Maybe ())
forall a. STM a -> IO a
atomically (STM (Maybe ()) -> IO (Maybe ()))
-> STM (Maybe ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM (Maybe ())
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar ()
isOpen
        liftIO $ writeIORef currentSocketRef Nothing
        when (_webSocketConfig_reconnect config) $ forkJSM $ do
          liftIO $ threadDelay 1000000
          start
      start = do
        ws <- Text
-> [Text]
-> (Either ByteString JSVal -> JSM ())
-> JSM ()
-> JSM ()
-> ((Bool, Word, Text) -> JSM ())
-> JSM JSWebSocket
newWebSocket Text
url (WebSocketConfig t a -> [Text]
forall {k} (t :: k) a. WebSocketConfig t a -> [Text]
_webSocketConfig_protocols WebSocketConfig t a
config) (Either ByteString JSVal -> JSM b
onRawMessage (Either ByteString JSVal -> JSM b)
-> (b -> JSM ()) -> Either ByteString JSVal -> JSM ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> (b -> IO ()) -> b -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IO ()
onMessage) (IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onOpen) (IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
onError) (Bool, Word, Text) -> JSM ()
onClose
        liftIO $ writeIORef currentSocketRef $ Just ws
        return ()
  performEvent_ . (liftJSM start <$) =<< getPostBuild
  performEvent_ $ ffor (_webSocketConfig_send config) $ \[a]
payloads -> [a] -> (a -> Performable m ()) -> Performable m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [a]
payloads ((a -> Performable m ()) -> Performable m ())
-> (a -> Performable m ()) -> Performable m ()
forall a b. (a -> b) -> a -> b
$ \a
payload ->
    IO () -> Performable m ()
forall a. IO a -> Performable m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ()) -> IO () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
payloadQueue a
payload
  performEvent_ $ ffor (_webSocketConfig_close config) $ \(Word
code,Text
reason) -> JSM () -> Performable m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> Performable m ()) -> JSM () -> Performable m ()
forall a b. (a -> b) -> a -> b
$ do
    mws <- IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket))
-> IO (Maybe JSWebSocket) -> JSM (Maybe JSWebSocket)
forall a b. (a -> b) -> a -> b
$ IORef (Maybe JSWebSocket) -> IO (Maybe JSWebSocket)
forall a. IORef a -> IO a
readIORef IORef (Maybe JSWebSocket)
currentSocketRef
    case mws of
      Maybe JSWebSocket
Nothing -> () -> JSM ()
forall a. a -> JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just JSWebSocket
ws -> JSWebSocket -> Word -> Text -> JSM ()
closeWebSocket JSWebSocket
ws (Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
code) Text
reason

  ctx <- askJSM
  _ <- liftIO $ forkIO $ forever $ do
    payload <- atomically $ do
      pl     <- readTQueue payloadQueue
      open   <- tryReadTMVar isOpen
      if isJust open then return pl else retry

    mws <- liftIO $ readIORef currentSocketRef
    success <- case mws of
      Maybe JSWebSocket
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Just JSWebSocket
ws -> (JSM Bool -> JSContextRef -> IO Bool)
-> JSContextRef -> JSM Bool -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip JSM Bool -> JSContextRef -> IO Bool
forall (m :: * -> *) a. MonadIO m => JSM a -> JSContextRef -> m a
runJSM JSContextRef
ctx (JSM Bool -> IO Bool) -> JSM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        rs <- WebSocket -> JSM Word
forall (m :: * -> *). MonadDOM m => WebSocket -> m Word
getReadyState (WebSocket -> JSM Word) -> WebSocket -> JSM Word
forall a b. (a -> b) -> a -> b
$ JSWebSocket -> WebSocket
unWebSocket JSWebSocket
ws
        if rs == 1
          then (webSocketSend ws payload >> return True) `JS.catch` (\(SomeException
_ :: SomeException) -> Bool -> JSM Bool
forall a. a -> JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          else return False
    unless success $ atomically $ unGetTQueue payloadQueue payload
  return $ RawWebSocket eRecv eOpen eError eClose

textWebSocket :: (IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket :: forall a (m :: * -> *) t.
(IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m),
 PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m,
 Reflex t) =>
Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket Text
url WebSocketConfig t a
cfg = Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM Text)
-> m (RawWebSocket t Text)
forall (m :: * -> *) t a b.
(MonadJSM m, MonadJSM (Performable m), PerformEvent t m,
 TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) =>
Text
-> WebSocketConfig t a
-> (Either ByteString JSVal -> JSM b)
-> m (RawWebSocket t b)
webSocket' Text
url WebSocketConfig t a
cfg ((ByteString -> JSM Text)
-> (JSVal -> JSM Text) -> Either ByteString JSVal -> JSM Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> JSM Text
forall a. a -> JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> JSM Text)
-> (ByteString -> Text) -> ByteString -> JSM Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) JSVal -> JSM Text
forall a. FromJSVal a => JSVal -> JSM a
fromJSValUnchecked)

jsonWebSocket :: (ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m), PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, Reflex t) => Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
jsonWebSocket :: forall a b (m :: * -> *) t.
(ToJSON a, FromJSON b, MonadJSM m, MonadJSM (Performable m),
 PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m,
 Reflex t) =>
Text -> WebSocketConfig t a -> m (RawWebSocket t (Maybe b))
jsonWebSocket Text
url WebSocketConfig t a
cfg = do
  ws <- Text -> WebSocketConfig t Text -> m (RawWebSocket t Text)
forall a (m :: * -> *) t.
(IsWebSocketMessage a, MonadJSM m, MonadJSM (Performable m),
 PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m,
 Reflex t) =>
Text -> WebSocketConfig t a -> m (RawWebSocket t Text)
textWebSocket Text
url (WebSocketConfig t Text -> m (RawWebSocket t Text))
-> WebSocketConfig t Text -> m (RawWebSocket t Text)
forall a b. (a -> b) -> a -> b
$ WebSocketConfig t a
cfg { _webSocketConfig_send = fmap (decodeUtf8 . toStrict . encode) <$> _webSocketConfig_send cfg }
  return ws { _webSocket_recv = jsonDecode . textToJSString <$> _webSocket_recv ws }

forkJSM :: JSM () -> JSM ()
forkJSM :: JSM () -> JSM ()
forkJSM JSM ()
a = do
  jsm <- JSM JSContextRef
forall (m :: * -> *). MonadJSM m => m JSContextRef
askJSM
  void $ liftIO $ forkIO $ runJSM a jsm

#ifdef USE_TEMPLATE_HASKELL
makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
makeLensesWith (lensRules & simpleLenses .~ True) ''RawWebSocket
#else

webSocketConfig_send :: Lens' (WebSocketConfig t a) (Event t [a])
webSocketConfig_send f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig y x2 x3 x4) <$> f x1
{-# INLINE webSocketConfig_send #-}

webSocketConfig_close :: Lens' (WebSocketConfig t a) (Event t (Word, Text))
webSocketConfig_close f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 y x3 x4) <$> f x2
{-# INLINE webSocketConfig_close #-}

webSocketConfig_reconnect :: Lens' (WebSocketConfig t a) Bool
webSocketConfig_reconnect f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 y x4) <$> f x3
{-# INLINE webSocketConfig_reconnect #-}

webSocketConfig_protocols :: Lens' (WebSocketConfig t a) [Text]
webSocketConfig_protocols f (WebSocketConfig x1 x2 x3 x4) = (\y -> WebSocketConfig x1 x2 x3 y) <$> f x4
{-# INLINE webSocketConfig_protocols #-}

webSocket_recv :: Lens' (RawWebSocket t a) (Event t a)
webSocket_recv f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket y x2 x3 x4) <$> f x1
{-# INLINE webSocket_recv #-}

webSocket_open :: Lens' (RawWebSocket t a) (Event t ())
webSocket_open f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 y x3 x4) <$> f x2
{-# INLINE webSocket_open #-}

webSocket_error :: Lens' (RawWebSocket t a) (Event t ())
webSocket_error f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 y x4) <$> f x3
{-# INLINE webSocket_error #-}

webSocket_close :: Lens' (RawWebSocket t a) (Event t (Bool, Word, Text))
webSocket_close f (RawWebSocket x1 x2 x3 x4) = (\y -> RawWebSocket x1 x2 x3 y) <$> f x4
{-# INLINE webSocket_close #-}

#endif