{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP                        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Subscription.WebSocket
-- Copyright   :  (C) 2016-2018 David M. Johnson
-- License     :  BSD3-style (see the file LICENSE)
-- Maintainer  :  David M. Johnson <djohnson.m@gmail.com>
-- 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
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)

-- | WebSocket subscription
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

-- | Sends message to a websocket server
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

-- | 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 (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 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))

-- | Retrieves current status of `WebSocket`
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