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, ($), (&&), (<$>), (<>), (>>=))


import Data.Maybe (Maybe(..), isJust, isNothing)
import Data.String as String
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Socket.WebSocket as WS
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))

import App.Utils

import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))

-- 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.
  | AppendSystemMessage String                  -- System message to print.
  | AppendMessage String                        -- Basic message to print.
  | UnableToSend String                         -- Message to print: cannot send a packet.

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"
            ]

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 $ AppendSystemMessage $ "Closing websocket for '" <> wsInfo.url <> "'"
      case wsInfo.connection of
        Nothing -> H.raise $ AppendSystemMessage "No socket? How is that even possible?"
        Just socket -> H.liftEffect $ WS.close socket

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

    ConnectWebSocket -> do
      H.raise $ AppendSystemMessage ("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 $ AppendMessage $ "[🤖] 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 $ MessageReceived $ Tuple wsInfo.url received_message.message
          H.raise $ AppendMessage $ "[😈] Received a message"

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

        WebSocketClose { code, reason, wasClean } -> do
          H.raise $ AppendSystemMessage $ 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 $ AppendSystemMessage $ 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 $ UnableToSend "Not connected to server."
        pure Nothing

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

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

          Closed -> do
            H.raise $ 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)