-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE CPP                        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.WebSocket
-- Copyright   :  (C) 2016-2025 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <code@dmj.io>
-- Stability   :  experimental
-- Portability :  non-portable
----------------------------------------------------------------------------
module Miso.Subscription.WebSocket
  ( -- *** Types
    WebSocket   (..)
  , URL         (..)
  , Protocols   (..)
  , SocketState (..)
  , CloseCode   (..)
  , WasClean    (..)
  , Reason      (..)
    -- *** Subscription
  , websocketSub
  , send
  , close
  , connect
  , getSocketState
  ) where
-----------------------------------------------------------------------------
import           Control.Concurrent (threadDelay)
import           Control.Monad (when, void, unless)
import           Control.Monad.IO.Class (liftIO)
import           Data.Aeson (FromJSON, ToJSON)
import           Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)
import           Language.Javascript.JSaddle
import           System.IO.Unsafe (unsafePerformIO)
-----------------------------------------------------------------------------
import           Miso.Effect (Sub)
import qualified Miso.FFI.Internal as FFI
import           Miso.FFI.WebSocket (Socket)
import qualified Miso.FFI.WebSocket as WS
import           Miso.String (MisoString)
import           Miso.WebSocket
-----------------------------------------------------------------------------
websocket :: IORef (Maybe Socket)
{-# NOINLINE websocket #-}
websocket :: IORef (Maybe Socket)
websocket = IO (IORef (Maybe Socket)) -> IORef (Maybe Socket)
forall a. IO a -> a
unsafePerformIO (Maybe Socket -> IO (IORef (Maybe Socket))
forall a. a -> IO (IORef a)
newIORef Maybe Socket
forall a. Maybe a
Nothing)
-----------------------------------------------------------------------------
closedCode :: IORef (Maybe CloseCode)
{-# NOINLINE closedCode #-}
closedCode :: IORef (Maybe CloseCode)
closedCode = IO (IORef (Maybe CloseCode)) -> IORef (Maybe CloseCode)
forall a. IO a -> a
unsafePerformIO (Maybe CloseCode -> IO (IORef (Maybe CloseCode))
forall a. a -> IO (IORef a)
newIORef Maybe CloseCode
forall a. Maybe a
Nothing)
-----------------------------------------------------------------------------
secs :: Int -> Int
secs :: Int -> Int
secs = (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000000)
-----------------------------------------------------------------------------
-- | WebSocket subscription
websocketSub
  :: FromJSON m
  => URL
  -> Protocols
  -> (WebSocket m -> action)
  -> Sub action
websocketSub :: forall m action.
FromJSON m =>
URL -> Protocols -> (WebSocket m -> action) -> Sub action
websocketSub (URL MisoString
u) (Protocols [MisoString]
ps) WebSocket m -> action
f Sink action
sink = do
  socket <- MisoString -> [MisoString] -> JSM Socket
createWebSocket MisoString
u [MisoString]
ps
  liftIO (writeIORef websocket (Just socket))
  void . FFI.forkJSM $ handleReconnect
  WS.addEventListener socket "open" $ \JSVal
_ -> do
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe CloseCode) -> Maybe CloseCode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe CloseCode)
closedCode Maybe CloseCode
forall a. Maybe a
Nothing)
    Sink action
sink (WebSocket m -> action
f WebSocket m
forall action. WebSocket action
WebSocketOpen)
  WS.addEventListener socket "message" $ \JSVal
v -> do
    d <- JSVal -> JSM m
forall json. FromJSON json => JSVal -> JSM json
FFI.jsonParse (JSVal -> JSM m) -> JSM JSVal -> JSM m
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> JSM JSVal
WS.data' JSVal
v
    sink $ f (WebSocketMessage d)
  WS.addEventListener socket "close" $ \JSVal
e -> do
    code <- Int -> CloseCode
codeToCloseCode (Int -> CloseCode) -> JSM Int -> JSM CloseCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> JSM Int
WS.code JSVal
e
    liftIO (writeIORef closedCode (Just code))
    reason <- WS.reason e
    clean <- WS.wasClean e
    sink $ f (WebSocketClose code clean reason)
  WS.addEventListener socket "error" $ \JSVal
v -> do
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe CloseCode) -> Maybe CloseCode -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe CloseCode)
closedCode Maybe CloseCode
forall a. Maybe a
Nothing)
    d' <- JSVal -> JSM JSVal
WS.data' JSVal
v
#ifndef ghcjs_HOST_OS
    undef <- ghcjsPure (isUndefined d')
#else
    let undef = isUndefined d'
#endif
    if undef
      then do
         sink $ f (WebSocketError mempty)
      else do
         Just d <- fromJSVal d'
         sink $ f (WebSocketError d)
  where
    handleReconnect :: JSM ()
handleReconnect = do
      IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay (Int -> Int
secs Int
3))
      Just s <- IO (Maybe Socket) -> JSM (Maybe Socket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> IO (Maybe Socket)
forall a. IORef a -> IO a
readIORef IORef (Maybe Socket)
websocket)
      status <- WS.socketState s
      code <- liftIO (readIORef closedCode)
      if status == 3
        then do
          unless (code == Just CLOSE_NORMAL) $
            websocketSub (URL u) (Protocols ps) f sink
        else handleReconnect
-----------------------------------------------------------------------------
-- | Sends message to a websocket server
send :: ToJSON a => a -> JSM ()
{-# INLINE send #-}
send :: forall a. ToJSON a => a -> JSM ()
send a
x = do
  Just socket <- IO (Maybe Socket) -> JSM (Maybe Socket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> IO (Maybe Socket)
forall a. IORef a -> IO a
readIORef IORef (Maybe Socket)
websocket)
  sendJson' socket x
-----------------------------------------------------------------------------
-- | Sends message to a websocket server
close :: JSM ()
{-# INLINE close #-}
close :: JSM ()
close =
  (Socket -> JSM ()) -> Maybe Socket -> JSM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Socket -> JSM ()
WS.close (Maybe Socket -> JSM ()) -> JSM (Maybe Socket) -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    IO (Maybe Socket) -> JSM (Maybe Socket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> IO (Maybe Socket)
forall a. IORef a -> IO a
readIORef IORef (Maybe Socket)
websocket)
-----------------------------------------------------------------------------
-- | Connects to a websocket server
connect :: URL -> Protocols -> JSM ()
{-# INLINE connect #-}
connect :: URL -> Protocols -> JSM ()
connect (URL MisoString
url') (Protocols [MisoString]
ps) = do
  Just ws <- IO (Maybe Socket) -> JSM (Maybe Socket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> IO (Maybe Socket)
forall a. IORef a -> IO a
readIORef IORef (Maybe Socket)
websocket)
  s <- WS.socketState ws
  when (s == 3) $ do
    socket <- createWebSocket url' ps
    liftIO (atomicWriteIORef websocket (Just socket))
-----------------------------------------------------------------------------
-- | Retrieves current status of `WebSocket`
getSocketState :: JSM SocketState
getSocketState :: JSM SocketState
getSocketState = do
  Just ws <- IO (Maybe Socket) -> JSM (Maybe Socket)
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> IO (Maybe Socket)
forall a. IORef a -> IO a
readIORef IORef (Maybe Socket)
websocket)
  toEnum <$> WS.socketState ws
-----------------------------------------------------------------------------
sendJson' :: ToJSON json => Socket -> json -> JSM ()
sendJson' :: forall json. ToJSON json => Socket -> json -> JSM ()
sendJson' Socket
socket json
m = Socket -> MisoString -> JSM ()
WS.send Socket
socket (MisoString -> JSM ()) -> JSM MisoString -> JSM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< json -> JSM MisoString
forall json. ToJSON json => json -> JSM MisoString
FFI.jsonStringify json
m
-----------------------------------------------------------------------------
createWebSocket :: MisoString -> [MisoString] -> JSM Socket
{-# INLINE createWebSocket #-}
createWebSocket :: MisoString -> [MisoString] -> JSM Socket
createWebSocket MisoString
url' [MisoString]
protocols =
  MisoString -> JSVal -> JSM Socket
WS.create MisoString
url' (JSVal -> JSM Socket) -> JSM JSVal -> JSM Socket
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [MisoString] -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal [MisoString]
protocols
-----------------------------------------------------------------------------
codeToCloseCode :: Int -> CloseCode
codeToCloseCode :: Int -> CloseCode
codeToCloseCode = Int -> CloseCode
go
  where
    go :: Int -> CloseCode
go Int
1000 = CloseCode
CLOSE_NORMAL
    go Int
1001 = CloseCode
CLOSE_GOING_AWAY
    go Int
1002 = CloseCode
CLOSE_PROTOCOL_ERROR
    go Int
1003 = CloseCode
CLOSE_UNSUPPORTED
    go Int
1005 = CloseCode
CLOSE_NO_STATUS
    go Int
1006 = CloseCode
CLOSE_ABNORMAL
    go Int
1007 = CloseCode
Unsupported_Data
    go Int
1008 = CloseCode
Policy_Violation
    go Int
1009 = CloseCode
CLOSE_TOO_LARGE
    go Int
1010 = CloseCode
Missing_Extension
    go Int
1011 = CloseCode
Internal_Error
    go Int
1012 = CloseCode
Service_Restart
    go Int
1013 = CloseCode
Try_Again_Later
    go Int
1015 = CloseCode
TLS_Handshake
    go Int
n    = Int -> CloseCode
OtherCode Int
n
-----------------------------------------------------------------------------