{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Miso.Subscription.WebSocket
(
WebSocket (..)
, URL (..)
, Protocols (..)
, SocketState (..)
, CloseCode (..)
, WasClean (..)
, Reason (..)
, websocketSub
, send
, close
, connect
, getSocketState
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import Data.IORef
import Data.Maybe
import GHCJS.Marshal
import GHCJS.Foreign
import GHCJS.Types ()
import Prelude hiding (map)
import System.IO.Unsafe
import Miso.Effect (Sub)
import Miso.FFI
import Miso.FFI.WebSocket (Socket)
import qualified Miso.FFI.WebSocket as WS
import Miso.String
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)
websocketSub
:: FromJSON m
=> URL
-> Protocols
-> (WebSocket m -> action)
-> Sub action
websocketSub :: URL -> Protocols -> (WebSocket m -> action) -> Sub action
websocketSub (URL MisoString
u) (Protocols [MisoString]
ps) WebSocket m -> action
f Sink action
sink = do
Socket
socket <- MisoString -> [MisoString] -> JSM Socket
createWebSocket MisoString
u [MisoString]
ps
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> Maybe Socket -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Socket)
websocket (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
socket))
JSM () -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM () -> JSM ()) -> (JSM () -> JSM ()) -> JSM () -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSM () -> JSM ()
forkJSM (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ JSM ()
handleReconnect
Socket -> MisoString -> (JSVal -> JSM ()) -> JSM ()
WS.addEventListener Socket
socket MisoString
"open" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
_ -> IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
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)
Socket -> MisoString -> (JSVal -> JSM ()) -> JSM ()
WS.addEventListener Socket
socket MisoString
"message" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
v -> do
m
d <- JSVal -> JSM m
forall json. FromJSON json => JSVal -> JSM json
parse (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
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> Sink action -> action -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink (action -> JSM ()) -> action -> JSM ()
forall a b. (a -> b) -> a -> b
$ WebSocket m -> action
f (m -> WebSocket m
forall action. action -> WebSocket action
WebSocketMessage m
d)
Socket -> MisoString -> (JSVal -> JSM ()) -> JSM ()
WS.addEventListener Socket
socket MisoString
"close" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
e -> do
CloseCode
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
IO () -> JSM ()
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 (CloseCode -> Maybe CloseCode
forall a. a -> Maybe a
Just CloseCode
code))
Reason
reason <- JSVal -> JSM Reason
WS.reason JSVal
e
WasClean
clean <- JSVal -> JSM WasClean
WS.wasClean JSVal
e
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> Sink action -> action -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink (action -> JSM ()) -> action -> JSM ()
forall a b. (a -> b) -> a -> b
$ WebSocket m -> action
f (CloseCode -> WasClean -> Reason -> WebSocket m
forall action. CloseCode -> WasClean -> Reason -> WebSocket action
WebSocketClose CloseCode
code WasClean
clean Reason
reason)
Socket -> MisoString -> (JSVal -> JSM ()) -> JSM ()
WS.addEventListener Socket
socket MisoString
"error" ((JSVal -> JSM ()) -> JSM ()) -> (JSVal -> JSM ()) -> JSM ()
forall a b. (a -> b) -> a -> b
$ \JSVal
v -> do
IO () -> JSM ()
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)
JSVal
d' <- JSVal -> JSM JSVal
WS.data' JSVal
v
#ifndef __GHCJS__
Bool
undef <- GHCJSPure Bool -> JSM Bool
forall a. GHCJSPure a -> JSM a
ghcjsPure (JSVal -> GHCJSPure Bool
isUndefined JSVal
d')
#else
let undef = isUndefined d'
#endif
if Bool
undef
then do
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> Sink action -> action -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink (action -> JSM ()) -> action -> JSM ()
forall a b. (a -> b) -> a -> b
$ WebSocket m -> action
f (MisoString -> WebSocket m
forall action. MisoString -> WebSocket action
WebSocketError MisoString
forall a. Monoid a => a
mempty)
else do
Just MisoString
d <- JSVal -> JSM (Maybe MisoString)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal JSVal
d'
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> Sink action -> action -> JSM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sink action
sink (action -> JSM ()) -> action -> JSM ()
forall a b. (a -> b) -> a -> b
$ WebSocket m -> action
f (MisoString -> WebSocket m
forall action. MisoString -> WebSocket action
WebSocketError MisoString
d)
where
handleReconnect :: JSM ()
handleReconnect = do
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay (Int -> Int
secs Int
3))
Just Socket
s <- IO (Maybe Socket) -> JSM (Maybe Socket)
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)
Int
status <- Socket -> JSM Int
WS.socketState Socket
s
Maybe CloseCode
code <- IO (Maybe CloseCode) -> JSM (Maybe CloseCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe CloseCode) -> IO (Maybe CloseCode)
forall a. IORef a -> IO a
readIORef IORef (Maybe CloseCode)
closedCode)
if Int
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3
then do
Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe CloseCode
code Maybe CloseCode -> Maybe CloseCode -> Bool
forall a. Eq a => a -> a -> Bool
== CloseCode -> Maybe CloseCode
forall a. a -> Maybe a
Just CloseCode
CLOSE_NORMAL) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$
URL -> Protocols -> (WebSocket m -> action) -> Sub action
forall m action.
FromJSON m =>
URL -> Protocols -> (WebSocket m -> action) -> Sub action
websocketSub (MisoString -> URL
URL MisoString
u) ([MisoString] -> Protocols
Protocols [MisoString]
ps) WebSocket m -> action
f Sink action
sink
else JSM ()
handleReconnect
send :: ToJSON a => a -> JSM ()
{-# INLINE send #-}
send :: a -> JSM ()
send a
x = do
Just Socket
socket <- IO (Maybe Socket) -> JSM (Maybe Socket)
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)
Socket -> a -> JSM ()
forall json. ToJSON json => Socket -> json -> JSM ()
sendJson' Socket
socket a
x
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 (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)
connect :: URL -> Protocols -> JSM ()
{-# INLINE connect #-}
connect :: URL -> Protocols -> JSM ()
connect (URL MisoString
url') (Protocols [MisoString]
ps) = do
Just Socket
ws <- IO (Maybe Socket) -> JSM (Maybe Socket)
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)
Int
s <- Socket -> JSM Int
WS.socketState Socket
ws
Bool -> JSM () -> JSM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3) (JSM () -> JSM ()) -> JSM () -> JSM ()
forall a b. (a -> b) -> a -> b
$ do
Socket
socket <- MisoString -> [MisoString] -> JSM Socket
createWebSocket MisoString
url' [MisoString]
ps
IO () -> JSM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe Socket) -> Maybe Socket -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef (Maybe Socket)
websocket (Socket -> Maybe Socket
forall a. a -> Maybe a
Just Socket
socket))
getSocketState :: JSM SocketState
getSocketState :: JSM SocketState
getSocketState = do
Just Socket
ws <- IO (Maybe Socket) -> JSM (Maybe Socket)
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)
Int -> SocketState
forall a. Enum a => Int -> a
toEnum (Int -> SocketState) -> JSM Int -> JSM SocketState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> JSM Int
WS.socketState Socket
ws
sendJson' :: ToJSON json => Socket -> json -> JSM ()
sendJson' :: 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
stringify 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