A single component for WS, another one for messages. WIP!

src/App/AuthenticationForm.purs

@@ -1,6 +1,6 @@
 module App.AuthenticationForm where
 
-import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=))
+import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), pure, unit)
 
 import Bulma as Bulma
 
@@ -17,31 +17,26 @@ import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
 import Web.Event.Event (Event)
 import Web.Event.Event as Event
-import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
-import Web.Socket.WebSocket as WS
 
 import Effect.Class (class MonadEffect)
 
-import App.Utils
-
 import App.IPC as IPC
 import App.Email as Email
 
 import App.Messages.AuthenticationDaemon as AuthD
 
 import Data.ArrayBuffer.Types (ArrayBuffer)
-import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
 
---------------------------------------------------------------------------------
+data Output
--- Root component module
+  = AuthToken (Tuple Int String)
---------------------------------------------------------------------------------
+  | MessageToSend ArrayBuffer
+
+data Query a = MessageReceived ArrayBuffer a
 
-data Output = AuthToken (Tuple Int String)
 type Slot = H.Slot Query Output
 
-type Query :: forall k. k -> Type
+-- No input.
-type Query = Const Void
+type Input = Unit
-type Input = String
 
 data AuthenticationInput
   = AUTH_INP_login String
@@ -54,8 +49,8 @@ data RegisterInput
 
 data Action
   = Initialize
-  | WebSocketParseError String
+  -- | WebSocketParseError String
-  | ConnectWebSocket
+  -- | ConnectWebSocket
 
   | HandleAuthenticationInput AuthenticationInput
   | HandleRegisterInput       RegisterInput
@@ -63,25 +58,16 @@ data Action
   | AuthenticationAttempt Event
   | RegisterAttempt Event
   | Finalize
-  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
+  --| HandleWebSocket (WebSocketEvent WebSocketMessageType)
 
 type StateAuthenticationForm = { login :: String, pass :: String }
 type StateRegistrationForm = { login :: String, email :: String, pass :: String }
 
-type WSInfo
-  = { url        :: String
-    , connection :: Maybe WS.WebSocket
-    , reconnect  :: Boolean
-    }
-
 type State =
-  { messages               :: Array String
+  { authenticationForm     :: StateAuthenticationForm
-  , messageHistoryLength   :: Int
-
-  , authenticationForm     :: StateAuthenticationForm
   , registrationForm       :: StateRegistrationForm
 
-  , wsInfo                 :: WSInfo
+  , wsUp                   :: Boolean
   }
 
 component :: forall m. MonadAff m => H.Component Query Input Output m
@@ -92,35 +78,25 @@ component =
     , eval: H.mkEval $ H.defaultEval
         { initialize = Just Initialize
         , handleAction = handleAction
+        , handleQuery  = handleQuery
         , finalize = Just Finalize
         }
     }
 
 initialState :: Input -> State
-initialState input =
+initialState _ =
-  { messages: []
+  { authenticationForm: { login:     "", pass:  "" }
-  , messageHistoryLength: 10
-
-  , authenticationForm: { login:     "", pass:  "" }
   , registrationForm:   { login:     "", email: "", pass: "" }
 
-  , wsInfo: { url: input
+  , wsUp: true
-            , connection: Nothing
-            , reconnect: false
-            }
   }
 
 render :: forall m. State -> H.ComponentHTML Action () m
-render {
+render { wsUp,
-  messages,
-  wsInfo,
-
   authenticationForm,
   registrationForm }
     = HH.div_
        [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ]
-       , render_messages
-       , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
        ]
     where
 
@@ -140,16 +116,16 @@ render {
             (HandleAuthenticationInput <<< AUTH_INP_login)           -- action
             authenticationForm.login                                 -- value
             true                                                     -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
+            (if wsUp then (HP.enabled true) else (HP.disabled true))  -- condition
         , Bulma.box_password "Password" "password"                   -- title, placeholder
             (HandleAuthenticationInput <<< AUTH_INP_pass)            -- action
             authenticationForm.pass                                  -- value
             true                                                     -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
+            (if wsUp then (HP.enabled true) else (HP.disabled true))  -- condition
         , HH.button
            [ HP.style "padding: 0.5rem 1.25rem;"
            , HP.type_ HP.ButtonSubmit
-           , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
+           , (if wsUp then (HP.enabled true) else (HP.disabled true))
            ]
            [ HH.text "Send Message to Server" ]
         ]
@@ -160,71 +136,34 @@ render {
             (HandleRegisterInput <<< REG_INP_login)                  -- action
             registrationForm.login                                   -- value
             true                                                     -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
+            (if wsUp then (HP.enabled true) else (HP.disabled true))  -- condition
         , Bulma.box_input "Email" "email@example.com"                -- title, placeholder
             (HandleRegisterInput <<< REG_INP_email)                  -- action
             registrationForm.email                                   -- value
             true                                                     -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
+            (if wsUp then (HP.enabled true) else (HP.disabled true))  -- condition
         , Bulma.box_password "Password" "password"                   -- title, placeholder
             (HandleRegisterInput <<< REG_INP_pass)                   -- action
             registrationForm.pass                                    -- value
             true                                                     -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
+            (if wsUp then (HP.enabled true) else (HP.disabled true))  -- condition
         , HH.div_
             [ HH.button
                 [ HP.style "padding: 0.5rem 1.25rem;"
                 , HP.type_ HP.ButtonSubmit
-                , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
+                , (if wsUp then (HP.enabled true) else (HP.disabled true))
                 ]
                 [ HH.text "Send Message to Server" ]
             ]
         ]
 
-      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 = case _ of
-  Initialize ->
+  Initialize -> pure unit
-    handleAction ConnectWebSocket
+    -- systemMessage "Component initialized!"
 
-  Finalize -> do
+  Finalize -> pure unit
-    { wsInfo } <- H.get
+    -- systemMessage "Finalize"
-    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
-    { wsInfo } <- H.get
-    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)
 
   HandleAuthenticationInput authinp -> do
     case authinp of
@@ -240,147 +179,81 @@ handleAction = case _ of
   RegisterAttempt ev -> do
     H.liftEffect $ Event.preventDefault ev
 
-    { wsInfo, registrationForm } <- H.get
+    { registrationForm } <- H.get
     let login = registrationForm.login
         email = registrationForm.email
         pass  = registrationForm.pass
 
-    case wsInfo.connection, login, email, pass of
+    case login, email, pass of
-      Nothing, _, _, _ ->
+      "", _, _ -> pure unit
-        unableToSend "Not connected to server."
+        -- unableToSend "Write your login!"
 
-      Just _, "", _, _ ->
+      _, "", _ -> pure unit
-        unableToSend "Write your login!"
+        -- unableToSend "Write your email!"
 
-      Just _, _, "", _ ->
+      _, _, "" -> pure unit
-        unableToSend "Write your email!"
+        -- unableToSend "Write your password!"
 
-      Just _, _, _, "" ->
+      _, _, _ -> do
-        unableToSend "Write your password!"
+        message <- H.liftEffect $ AuthD.serialize $
-
+          AuthD.MkRegister { login: login
-      Just webSocket, _, _, _ -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
-
-          Closing ->
-            unableToSend "Connection to server is closing."
-
-          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 }}
-
-          Open -> do
-            H.liftEffect $ do
-              ab <- AuthD.serialize $ AuthD.MkRegister { login: login
                            , email: Just (Email.Email email)
                            , password: pass }
-              sendArrayBuffer webSocket ab
+        H.raise $ MessageToSend message
-            appendMessage "[😇] Trying to register"
+        -- appendMessage "[😇] Trying to register"
 
   AuthenticationAttempt ev -> do
     H.liftEffect $ Event.preventDefault ev
 
-    { wsInfo, authenticationForm } <- H.get
+    { authenticationForm } <- H.get
 
-    case wsInfo.connection, authenticationForm.login, authenticationForm.pass of
+    case authenticationForm.login, authenticationForm.pass of
-      Nothing, _, _ ->
+      "" , _ -> pure unit
-        unableToSend "Not connected to server."
+        -- unableToSend "Write your login!"
 
-      Just _ , "" , _ ->
+      _ , "" -> pure unit
-        unableToSend "Write your login!"
+        -- unableToSend "Write your password!"
 
-      Just _ , _ , "" ->
+      login, pass -> do
-        unableToSend "Write your password!"
+        message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass }
+        H.raise $ MessageToSend message
+        -- appendMessage $ "[😇] Trying to connect with login: " <> login
 
-      Just webSocket, login, pass -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
 
-          Closing ->
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
-            unableToSend "Connection to server is closing."
+handleQuery = case _ of
-
+  MessageReceived message a -> do
-          Closed -> do
+    receivedMessage <- H.liftEffect $ AuthD.deserialize message
-            unableToSend "Connection to server has been closed."
-            maybeCurrentConnection <- H.gets _.wsInfo.connection
-            when (isJust maybeCurrentConnection) do
-              H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}
-
-          Open -> do
-            H.liftEffect $ do
-              ab <- AuthD.serialize (AuthD.MkLogin { login: login, password: pass })
-              sendArrayBuffer webSocket ab
-            appendMessage $ "[😇] Trying to connect with login: " <> login
-
-  HandleWebSocket wsEvent ->
-    case wsEvent of
-      WebSocketMessage messageEvent -> do
-        receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
     case receivedMessage of
         -- Cases where we didn't understand the message.
-            Left err -> do
+        Left _ -> pure Nothing
-              case err of
+          --case err of
-                (AuthD.JSONERROR jerr) -> do
+          --  (AuthD.JSONERROR jerr) -> do
-                  print_json_string messageEvent.message
+          --    print_json_string messageEvent.message
-                  handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
+          --    handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
-                (AuthD.UnknownError   unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
+          --  (AuthD.UnknownError   unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
-                (AuthD.UnknownNumber       ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
+          --  (AuthD.UnknownNumber       ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
 
         -- Cases where we understood the message.
         Right response -> do
           case response of
             -- The authentication failed.
-                (AuthD.GotError errmsg) -> do
+            (AuthD.GotError errmsg) -> pure (Just a)
-                  appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
+              -- appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
             -- The authentication was a success!
             (AuthD.GotToken msg) -> do
-                  appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
+              -- appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
               H.raise $ AuthToken (Tuple msg.uid msg.token)
+              pure (Just a)
             -- WTH?!
-                _ -> do
+            _ -> pure Nothing
-                  appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
+              -- appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
-
-      WebSocketOpen -> do
-        { wsInfo } <- H.get
-        systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <>  "\"!🎉")
-
-      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 }}
-
-      WebSocketError errorType ->
-        systemMessage $ renderError errorType
-
-  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"
-        , "]"
-        ]
 
 print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
 print_json_string arraybuffer = do
   -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
   value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-  appendMessage $ case (value) of
+  pure unit
-    Left _ -> "Cannot even fromTypedIPC the message."
+  --appendMessage $ case (value) of
-    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
+  --  Left _ -> "Cannot even fromTypedIPC the message."
+  --  Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

src/App/Container.purs

@@ -7,6 +7,7 @@ import Bulma as Bulma
 import Data.Maybe (Maybe(..))
 import Data.Tuple (Tuple(..))
 import App.AuthenticationForm as AF
+import App.WS as WS
 import App.AuthenticationDaemonAdminInterface as AAI
 import App.DNSManagerDomainsInterface         as NewDomainInterface
 import Halogen as H
@@ -15,17 +16,27 @@ import Type.Proxy (Proxy(..))
 import Effect.Aff.Class (class MonadAff)
 
 data Action
-  = Authenticated AF.Output -- User has been authenticated.
+  = OutputAuthComponent  AF.Output  -- User has been authenticated.
+  | AuthDEvent           WS.Output  -- Events from authd.
+  | DNSManagerDEvent     WS.Output  -- Events from dnsmanagerd.
 
-type State = { token :: Maybe String, uid :: Maybe Int }
+type State = { token :: Maybe String
+             , uid :: Maybe Int
+             , auth_ws_connected :: Boolean
+             , dns_ws_connected  :: Boolean
+             }
 
 type ChildSlots =
   ( af  :: AF.Slot Unit
+  , ws_auth :: WS.Slot Unit
+  , ws_dns  :: WS.Slot Unit
   , aai :: AAI.Slot Unit
   , ndi :: NewDomainInterface.Slot Unit
   )
 
 _af      = Proxy :: Proxy "af"
+_ws_auth = Proxy :: Proxy "ws_auth"
+_ws_dns  = Proxy :: Proxy "ws_dns"
 _aai     = Proxy :: Proxy "aai"
 _ndi     = Proxy :: Proxy "ndi"
 
@@ -38,12 +49,18 @@ component =
     }
 
 initialState :: forall i. i -> State
-initialState _ = { token: Nothing, uid: Nothing }
+initialState _ = { token: Nothing
+                 , uid: Nothing
+                 , auth_ws_connected: false
+                 , dns_ws_connected:  false
+                 }
 
 render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
 render state
   = HH.div_ $
-    [ render_auth_form
+    [ render_auth_WS
+    , render_dnsmanager_WS
+    , render_auth_form
     , render_authd_admin_interface
     , render_newdomain_interface
     , div_token
@@ -52,9 +69,17 @@ render state
     div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
     div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ]
 
+    render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_auth_WS = Bulma.box [ HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthDEvent ]
+
+    render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_dnsmanager_WS = Bulma.box $ case state.token of
+      Nothing -> [ Bulma.p "We don't have a token right now." ]
+      Just _ ->  [ HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDEvent ]
+
     render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
     render_auth_form = Bulma.box $ case state.token of
-      Nothing -> [ HH.slot _af unit AF.component "ws://127.0.0.1:8080" Authenticated ]
+      Nothing -> [ HH.slot _af unit AF.component unit OutputAuthComponent ]
       Just current_token -> [ Bulma.p ("Token is: " <> current_token) ]
 
     render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
@@ -75,4 +100,19 @@ render state
 
 handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
 handleAction = case _ of
-  Authenticated (AF.AuthToken (Tuple uid token)) -> H.modify_ _ { uid = Just uid, token = Just token }
+  OutputAuthComponent ev -> case ev of
+   AF.AuthToken (Tuple uid token) -> H.modify_ _ { uid = Just uid, token = Just token }
+   AF.MessageToSend message -> do
+     H.tell _ws_auth unit (WS.ToSend message)
+
+  AuthDEvent ev -> case ev of
+    WS.MessageReceived (Tuple _ message) ->
+     H.tell _af unit (AF.MessageReceived message)
+    WS.WSJustConnected -> H.modify_ _ { auth_ws_connected = true }
+    WS.WSJustClosed    -> H.modify_ _ { auth_ws_connected = false }
+
+  DNSManagerDEvent ev -> case ev of
+    WS.MessageReceived (Tuple _ _) -> pure unit -- TODO
+    WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true }
+    WS.WSJustClosed    -> H.modify_ _ { dns_ws_connected = false }
+

src/App/WS.purs

@@ -22,8 +22,9 @@ import App.Utils
 import Data.ArrayBuffer.Types (ArrayBuffer)
 import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
 
--- Input = url
+-- 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.
@@ -31,14 +32,11 @@ data Output
   | 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
+type Slot = H.Slot Query Output
-data Query a = ToSend ArrayBuffer a
 
-data NewDomainFormAction
+data Query a
-  = INP_newdomain String
+  = ToSend ArrayBuffer a
-  | UpdateSelectedDomain String
 
 data Action
   = Initialize
@@ -70,6 +68,7 @@ component =
     , eval: H.mkEval $ H.defaultEval
         { initialize = Just Initialize
         , handleAction = handleAction
+        , handleQuery  = handleQuery
         , finalize = Just Finalize
         }
     }
@@ -147,7 +146,7 @@ handleAction action = do
     HandleWebSocket wsEvent -> do
       case wsEvent of
         WebSocketMessage received_message -> do
-          appendMessage $ "[😈] Received a message, ignored for now"
+          appendMessage $ "[😈] Received a message"
           H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
 
         WebSocketOpen -> do
@@ -216,6 +215,3 @@ handleQuery = case _ of
             H.liftEffect $ do
               sendArrayBuffer webSocket message
             pure (Just a)
-
---  Request reply ->
---    pure (Just (reply true))