From 88aa80561372078925a1045d1c8bf51444ee0948 Mon Sep 17 00:00:00 2001
From: Philippe Pittoli <karchnu@karchnu.fr>
Date: Mon, 3 Jul 2023 18:03:47 +0200
Subject: [PATCH] WS component (WIP).

---
 src/App/WS.purs | 221 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 221 insertions(+)
 create mode 100644 src/App/WS.purs

diff --git a/src/App/WS.purs b/src/App/WS.purs
new file mode 100644
index 0000000..7196413
--- /dev/null
+++ b/src/App/WS.purs
@@ -0,0 +1,221 @@
+module App.WS where
+
+{- This component handles all WS operations. -}
+
+import Prelude (Unit, bind, discard, map, pure, show, void, when, ($), (&&), (<$>), (<>), (>>=))
+
+import Bulma as Bulma
+
+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 = 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.
+--type Slot = H.Slot Query Output
+
+--type Query :: forall k. k -> Type
+data Query a = ToSend ArrayBuffer a
+
+data NewDomainFormAction
+  = INP_newdomain String
+  | UpdateSelectedDomain String
+
+data Action
+  = Initialize
+  | WebSocketParseError String
+  | ConnectWebSocket
+
+  | SendMessage ArrayBuffer
+
+  | Finalize
+  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
+
+type WSInfo
+  = { url        :: String
+    , connection :: Maybe WS.WebSocket
+    , reconnect  :: Boolean
+    }
+
+type State =
+  { messages               :: Array String
+  , messageHistoryLength   :: Int
+  , 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
+        , finalize = Just Finalize
+        }
+    }
+
+initialState :: Input -> State
+initialState url =
+  { messages: []
+  , messageHistoryLength: 10
+  , wsInfo: { url: url
+            , connection: Nothing
+            , reconnect: false
+            }
+  }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { messages, wsInfo }
+    = HH.div_
+       [ Bulma.h1 "WS BOX"
+       , render_messages
+       , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
+       ]
+    where
+
+      render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
+
+      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
+      systemMessage "Finalize"
+      case wsInfo.connection of
+        Nothing -> systemMessage "No socket? How is that even possible?"
+        Just socket -> H.liftEffect $ WS.close socket
+
+    WebSocketParseError error ->
+      systemMessage $ renderError (UnknownError error)
+
+    ConnectWebSocket -> do
+      systemMessage ("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 -> 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
+          appendMessage $ "[😈] Received a message, ignored for now"
+          H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
+
+        WebSocketOpen -> do
+          systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <>  "\"!🎉")
+          H.raise $ WSJustConnected
+
+        WebSocketClose { code, reason, wasClean } -> do
+          systemMessage $ 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 ->
+          systemMessage $ 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
+        unableToSend "Not connected to server."
+        pure Nothing
+
+      Just webSocket -> do
+        H.liftEffect (WS.readyState webSocket) >>= case _ of
+          Connecting -> do
+            unableToSend "Still connecting to server."
+            pure Nothing
+
+          Closing -> do
+            unableToSend "Connection to server is closing."
+            pure Nothing
+
+          Closed -> do
+            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)
+
+--  Request reply ->
+--    pure (Just (reply true))