halogen-websocket-ipc-playzone/src/App/WS.purs

module App.WS where

{- This component handles all WS operations. -}

import Prelude (Unit, bind, discard, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map)

import Control.Monad.Except (runExcept)
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.String as String
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Foreign as F
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.Event as HQE
import Halogen.Subscription as HS
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
import Web.Socket.Event.CloseEvent as WSCE
import Web.Socket.Event.EventTypes as WSET
import Web.Socket.Event.MessageEvent as WSME
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
import Web.Socket.WebSocket as WS

import App.LogMessage


-- Input is the WS url.
type Input = String

-- MessageReceived (Tuple URL message)
data Output
  = MessageReceived (Tuple String ArrayBuffer)  -- Provide a received message to the parent.
  | WSJustConnected                             -- Inform the parent the connection is up.
  | WSJustClosed                                -- Inform the parent the connection is down.
  | Log LogMessage

type Slot = H.Slot Query Output

data Query a
  = ToSend ArrayBuffer a

data Action
  = Initialize
  | WebSocketParseError String
  | ConnectWebSocket

  | SendMessage ArrayBuffer

  | Finalize
  | HandleWebSocket (WebSocketEvent WebSocketMessageType)

type WSInfo
  = { url        :: String
    , connection :: Maybe WS.WebSocket
    , reconnect  :: Boolean
    }

type State = { wsInfo :: WSInfo }

component :: forall m. MonadAff m => H.Component Query Input Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval
        { initialize = Just Initialize
        , handleAction = handleAction
        , handleQuery  = handleQuery
        , finalize = Just Finalize
        }
    }

initialState :: Input -> State
initialState url =
  { wsInfo: { url: url
            , connection: Nothing
            , reconnect: false
            }
  }

render :: forall m. State -> H.ComponentHTML Action () m
render { wsInfo }
    = HH.div_
       [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
       ]
    where

      renderFootnote :: String -> H.ComponentHTML Action () m
      renderFootnote txt =
        HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]

      renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
      renderReconnectButton cond =
        if cond
        then
          HH.p_
            [ HH.button
              [ HP.type_ HP.ButtonButton
              , HE.onClick \_ -> ConnectWebSocket
              ]
              [ HH.text "Reconnect?" ]
            ]
        else
          HH.p_
            [ renderFootnote $
                "NOTE: A 'Reconnect?' button will appear if the connection drops (for URL: '"
                <>
                wsInfo.url
                <>
                "')"
            ]

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction action = do
  { wsInfo } <- H.get
  case action of
    Initialize ->
      handleAction ConnectWebSocket

    Finalize -> do
      -- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
      case wsInfo.connection of
        Nothing -> H.raise $ Log $ SystemLog "No socket? How is that even possible?"
        Just socket -> H.liftEffect $ WS.close socket

    WebSocketParseError error ->
      H.raise $ Log $ SystemLog $ renderError (UnknownError error)

    ConnectWebSocket -> do
      -- H.raise $ Log $ SystemLog $ "Connecting to \"" <> wsInfo.url <>  "\"..."
      webSocket <- H.liftEffect $ WS.create wsInfo.url []
      H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
      H.modify_ _ { wsInfo { connection = Just webSocket } }
      void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)

    SendMessage array_buffer_to_send -> do
      case wsInfo.connection of
        Nothing -> H.raise $ Log $ SimpleLog $ "[🤖] Can't send a message, websocket is down!"
        Just webSocket -> H.liftEffect $ do
          sendArrayBuffer webSocket array_buffer_to_send

    HandleWebSocket wsEvent -> do
      case wsEvent of
        WebSocketMessage received_message -> do
          -- H.raise $ Log $ SimpleLog $ "[😈] Received a message"
          H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message

        WebSocketOpen -> do
          -- H.raise $ Log $ SystemLog ("Successfully connected to \"" <> wsInfo.url <>  "\"!🎉")
          H.raise $ WSJustConnected

        WebSocketClose { code, reason, wasClean } -> do
          H.raise $ Log $ SystemLog $ renderCloseMessage code wasClean reason
          maybeCurrentConnection <- H.gets _.wsInfo.connection
          when (isJust maybeCurrentConnection) do
            H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
          H.raise $ WSJustClosed

        WebSocketError errorType ->
          H.raise $ Log $ SystemLog $ renderError errorType
          -- TODO: MAYBE inform the parent the connection is closed (if it's the case).

  where
  renderCloseMessage
    :: Int
    -> Boolean
    -> String
    -> String
  renderCloseMessage code wasClean = case _ of
      ""     -> baseCloseMessage
      reason -> baseCloseMessage <> "Reason: " <> reason
    where
    baseCloseMessage :: String
    baseCloseMessage =
      String.joinWith " "
        [ "Connection to WebSocket closed"
        , "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]"
        ]

handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of
  ToSend message a -> do
    { wsInfo } <- H.get
    case wsInfo.connection of
      Nothing -> do
        H.raise $ Log $ UnableToSend "Not connected to server."
        pure Nothing

      Just webSocket -> do
        H.liftEffect (WS.readyState webSocket) >>= case _ of
          Connecting -> do
            H.raise $ Log $ UnableToSend "Still connecting to server."
            pure Nothing

          Closing -> do
            H.raise $ Log $ UnableToSend "Connection to server is closing."
            pure Nothing

          Closed -> do
            H.raise $ Log $ UnableToSend "Connection to server has been closed."
            maybeCurrentConnection <- H.gets _.wsInfo.connection
            when (isJust maybeCurrentConnection) do
              H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
            pure Nothing

          Open -> do
            H.liftEffect $ do
              sendArrayBuffer webSocket message
            pure (Just a)


--------------------------------------------------------------------------------
-- WebSocket mess.
--------------------------------------------------------------------------------

data WebSocketEvent :: Type -> Type
data WebSocketEvent msg
  = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
  | WebSocketOpen
  | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
  | WebSocketError ErrorType

webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
webSocketEmitter socket = do

  HS.makeEmitter \push -> do

    openId <- HS.subscribe openEmitter push
    errorId <- HS.subscribe errorEmitter push
    closeId <- HS.subscribe closeEmitter push
    messageId <- HS.subscribe messageEmitter push

    pure do
      HS.unsubscribe openId
      HS.unsubscribe errorId
      HS.unsubscribe closeId
      HS.unsubscribe messageId

  where
  target = WS.toEventTarget socket

  openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
  openEmitter =
    HQE.eventListener WSET.onOpen target \_ ->
      Just WebSocketOpen

  errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
  errorEmitter =
    HQE.eventListener WSET.onError target \_ ->
      Just (WebSocketError UnknownWebSocketError)

  closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
  closeEmitter =
    HQE.eventListener WSET.onClose target \event ->
      WSCE.fromEvent event >>= \closeEvent ->
        Just $ WebSocketClose  { code: WSCE.code closeEvent
                               , reason: WSCE.reason closeEvent
                               , wasClean: WSCE.wasClean closeEvent
                               }

  messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
  messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)

decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
decodeMessageEvent = \msgEvent -> do
  let
    foreign' :: F.Foreign
    foreign' = WSME.data_ msgEvent
  case foreignToArrayBuffer foreign' of
    Left errs -> pure $ WebSocketError $ UnknownError errs
    Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer
                                                 , origin: WSME.origin msgEvent
                                                 , lastEventId: WSME.lastEventId msgEvent }

---------------------------
-- Errors
---------------------------

data ErrorType
  = UnknownError String
  | UnknownWebSocketError

renderError :: ErrorType -> String
renderError = case _ of
  UnknownError str ->
    "Unknown error: " <> str
  UnknownWebSocketError ->
    "Unknown 'error' event has been fired by WebSocket event listener"

--------------------------------------------------------------------------------
-- WebSocket message type
--------------------------------------------------------------------------------

type WebSocketMessageType = ArrayBuffer

sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
sendArrayBuffer = WS.sendArrayBuffer

foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
foreignToArrayBuffer
  = lmap renderForeignErrors
  <<< runExcept
  <<< F.unsafeReadTagged "ArrayBuffer"
  where
  renderForeignErrors :: F.MultipleErrors -> String
  renderForeignErrors =
    String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError