diff --git a/src/App/AuthenticationDaemonAdminInterface.purs b/src/App/AuthenticationDaemonAdminInterface.purs index b07f95c..d7701ea 100644 --- a/src/App/AuthenticationDaemonAdminInterface.purs +++ b/src/App/AuthenticationDaemonAdminInterface.purs @@ -34,7 +34,11 @@ data Output | SystemMessage String | UnableToSend String -data Query a = MessageReceived ArrayBuffer a +data Query a + = MessageReceived ArrayBuffer a + | ConnectionIsDown a + | ConnectionIsUp a + type Slot = H.Slot Query Output type Input = Unit @@ -193,6 +197,15 @@ handleQuery = case _ of H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message." pure (Just a) + ConnectionIsDown a -> do + H.modify_ _ { wsUp = false } + pure (Just a) + + ConnectionIsUp a -> do + H.modify_ _ { wsUp = true } + pure (Just a) + + ----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)) diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 5c59d68..3f5936a 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -34,7 +34,10 @@ data Output | SystemMessage String | UnableToSend String -data Query a = MessageReceived ArrayBuffer a +data Query a + = MessageReceived ArrayBuffer a + | ConnectionIsDown a + | ConnectionIsUp a type Slot = H.Slot Query Output @@ -50,17 +53,11 @@ data RegisterInput | REG_INP_pass String data Action - = Initialize - -- | WebSocketParseError String - -- | ConnectWebSocket - - | HandleAuthenticationInput AuthenticationInput + = HandleAuthenticationInput AuthenticationInput | HandleRegisterInput RegisterInput - + -- | AuthenticationAttempt Event | RegisterAttempt Event - | Finalize - --| HandleWebSocket (WebSocketEvent WebSocketMessageType) type StateAuthenticationForm = { login :: String, pass :: String } type StateRegistrationForm = { login :: String, email :: String, pass :: String } @@ -68,7 +65,6 @@ type StateRegistrationForm = { login :: String, email :: String, pass :: String type State = { authenticationForm :: StateAuthenticationForm , registrationForm :: StateRegistrationForm - , wsUp :: Boolean } @@ -78,10 +74,8 @@ component = { initialState , render , eval: H.mkEval $ H.defaultEval - { initialize = Just Initialize - , handleAction = handleAction + { handleAction = handleAction , handleQuery = handleQuery - , finalize = Just Finalize } } @@ -163,12 +157,6 @@ render { wsUp, handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction = case _ of - Initialize -> - H.raise $ SystemMessage "Authentication form initialized." - - Finalize -> - H.raise $ SystemMessage "Removing the authentication form." - HandleAuthenticationInput authinp -> do case authinp of AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } } @@ -204,7 +192,7 @@ handleAction = case _ of , email: Just (Email.Email email) , password: pass } H.raise $ MessageToSend message - H.raise $ AppendMessage "[😇] Trying to register" + H.raise $ AppendMessage $ "[😇] Trying to register (login: " <> login <> ")" AuthenticationAttempt ev -> do H.liftEffect $ Event.preventDefault ev @@ -221,8 +209,7 @@ handleAction = case _ of login, pass -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass } H.raise $ MessageToSend message - H.raise $ AppendMessage $ "[😇] Trying to connect with login: " <> login - + H.raise $ AppendMessage $ "[😇] Trying to authenticate (login: " <> login <> ")" handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery = case _ of @@ -247,7 +234,7 @@ handleQuery = case _ of pure (Just a) -- The authentication was a success! (AuthD.GotToken msg) -> do - H.raise $ AppendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token + H.raise $ AppendMessage $ "[🎉] Authenticated!" H.raise $ AuthToken (Tuple msg.uid msg.token) pure (Just a) -- WTH?! @@ -255,10 +242,18 @@ handleQuery = case _ of H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message." pure Nothing + ConnectionIsDown a -> do + H.modify_ _ { wsUp = false } + pure (Just a) + + ConnectionIsUp a -> do + H.modify_ _ { wsUp = true } + pure (Just a) + --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 - H.raise $ AppendMessage $ case (value) of - Left _ -> "Cannot even fromTypedIPC the message." - Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string +--print_json_string arraybuffer = do +-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String)) +-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer +-- H.raise $ AppendMessage $ case (value) of +-- Left _ -> "Cannot even fromTypedIPC the message." +-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string diff --git a/src/App/Container.purs b/src/App/Container.purs index ab7e5e8..4b67985 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -24,8 +24,6 @@ data Action type State = { token :: Maybe String , uid :: Maybe Int - , auth_ws_connected :: Boolean - , dns_ws_connected :: Boolean } type ChildSlots = @@ -55,8 +53,6 @@ component = initialState :: forall i. i -> State initialState _ = { token: Nothing , uid: Nothing - , auth_ws_connected: false - , dns_ws_connected: false } render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m @@ -119,23 +115,28 @@ handleAction = case _ of AAI.SystemMessage message -> H.tell _log unit (Log.SystemLog message) AAI.UnableToSend message -> H.tell _log unit (Log.UnableToSend message) - -- TODO: depending on the current page, we should provide the received message to - -- different components. + -- TODO: depending on the current page, we should provide the received message to different components. 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 } + WS.WSJustConnected -> do + H.tell _af unit AF.ConnectionIsUp + H.tell _aai unit AAI.ConnectionIsUp + WS.WSJustClosed -> do + H.tell _af unit AF.ConnectionIsDown + H.tell _aai unit AAI.ConnectionIsDown WS.AppendMessage msg -> H.tell _log unit (Log.SimpleLog msg) WS.AppendSystemMessage msg -> H.tell _log unit (Log.SystemLog msg) - WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg) + WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg) DNSManagerDEvent ev -> case ev of WS.MessageReceived (Tuple _ _) -> pure unit -- TODO: H.tell _ndi unit (NewDomainInterface.MessageReceived message) - WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true } - WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false } + WS.WSJustConnected -> do + H.tell _ndi unit NewDomainInterface.ConnectionIsUp + WS.WSJustClosed -> do + H.tell _ndi unit NewDomainInterface.ConnectionIsDown WS.AppendMessage msg -> H.tell _log unit (Log.SimpleLog msg) WS.AppendSystemMessage msg -> H.tell _log unit (Log.SystemLog msg) - WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg) + WS.UnableToSend msg -> H.tell _log unit (Log.UnableToSend msg) diff --git a/src/App/DNSManagerDomainsInterface.purs b/src/App/DNSManagerDomainsInterface.purs index 08d65a2..8e1065b 100644 --- a/src/App/DNSManagerDomainsInterface.purs +++ b/src/App/DNSManagerDomainsInterface.purs @@ -32,7 +32,6 @@ 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) @@ -49,11 +48,19 @@ import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) -- Root component module -------------------------------------------------------------------------------- -data Output = Void +data Output + = MessageToSend ArrayBuffer + | AppendMessage String + | SystemMessage String + | UnableToSend String + +data Query a + = MessageReceived ArrayBuffer a + | ConnectionIsDown a + | ConnectionIsUp a + type Slot = H.Slot Query Output -type Query :: forall k. k -> Type -type Query = Const Void -- Input = url token type Input = Tuple String String @@ -62,11 +69,7 @@ data NewDomainFormAction | UpdateSelectedDomain String data Action - = Initialize - | WebSocketParseError String - | ConnectWebSocket - - | UpdateAcceptedDomains (Array String) + = UpdateAcceptedDomains (Array String) | UpdateMyDomains (Array String) | AuthenticateToDNSManager @@ -76,7 +79,6 @@ data Action | NewDomainAttempt Event | RemoveDomain String | EnterDomain String - | Finalize | HandleWebSocket (WebSocketEvent WebSocketMessageType) type NewDomainFormState @@ -84,22 +86,12 @@ type NewDomainFormState , selected_domain :: String } -type WSInfo - = { url :: String - , connection :: Maybe WS.WebSocket - , reconnect :: Boolean - , token :: String - } - type State = - { messages :: Array String - , messageHistoryLength :: Int - - , newDomainForm :: NewDomainFormState + { newDomainForm :: NewDomainFormState , accepted_domains :: Array String , my_domains :: Array String - , wsInfo :: WSInfo + , wsUp :: Boolean } component :: forall m. MonadAff m => H.Component Query Input Output m @@ -110,7 +102,7 @@ component = , eval: H.mkEval $ H.defaultEval { initialize = Just Initialize , handleAction = handleAction - , finalize = Just Finalize + , handleQuery = handleQuery } } @@ -228,27 +220,6 @@ render { handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction = case _ of - Initialize -> - handleAction ConnectWebSocket - - Finalize -> do - { wsInfo } <- H.get - 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) - UpdateAcceptedDomains domains -> do H.modify_ _ { accepted_domains = domains } @@ -256,13 +227,9 @@ handleAction = case _ of H.modify_ _ { my_domains = domains } AuthenticateToDNSManager -> do - { wsInfo } <- H.get appendMessage $ "[🤖] Trying to authenticate..." - case wsInfo.connection of - Nothing -> appendMessage $ "[🤖] Can't authenticate, websocket is down!" - Just webSocket -> H.liftEffect $ do - ab <- DNSManager.serialize $ DNSManager.MkLogin { token: wsInfo.token } - sendArrayBuffer webSocket ab + message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: wsInfo.token } + H.raise $ MessageToSend message HandleNewDomainInput adduserinp -> do case adduserinp of @@ -304,126 +271,85 @@ handleAction = case _ of { wsInfo, newDomainForm } <- H.get let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain - case wsInfo.connection, new_domain of - Nothing, _ -> - unableToSend "Not connected to server." - - Just _, "" -> + case new_domain of + "" -> unableToSend "You didn't enter the new domain!" + _ -> do + message <- H.liftEffect + $ DNSManager.serialize + $ DNSManager.MkNewDomain { domain: new_domain } + H.raise $ MessageToSend message + appendMessage "[😇] Trying to add a new domain" + handleAction $ HandleNewDomainInput $ INP_newdomain "" - Just webSocket, _ -> do - H.liftEffect (WS.readyState webSocket) >>= case _ of - Connecting -> - unableToSend "Still connecting to server." +handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) +handleQuery = case _ of - Closing -> - unableToSend "Connection to server is closing." + MessageReceived message a -> do + receivedMessage <- H.liftEffect $ DNSManager.deserialize messageEvent.message + case receivedMessage of + -- Cases where we didn't understand the message. + Left err -> do + case err of + (DNSManager.JSONERROR jerr) -> do + print_json_string messageEvent.message + handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr) + (DNSManager.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownError" <> (show unerr)) + (DNSManager.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownNumber") + 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 } } + -- Cases where we understood the message. + Right received_msg -> do + case received_msg of + -- The authentication failed. + (DNSManager.MkError errmsg) -> do + appendMessage $ "[😈] Failed, reason is: " <> errmsg.reason + (DNSManager.MkErrorUserNotLogged _) -> do + appendMessage $ "[😈] Failed! The user isn't connected!" + handleAction AuthenticateToDNSManager + (DNSManager.MkErrorInvalidToken _) -> do + appendMessage $ "[😈] Failed connection! Invalid token!" + (DNSManager.MkDomainAlreadyExists _) -> do + appendMessage $ "[😈] Failed! The domain already exists." + (DNSManager.MkUnacceptableDomain _) -> do + appendMessage $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)." - Open -> do - H.liftEffect $ do - ab <- DNSManager.serialize $ DNSManager.MkNewDomain { domain: new_domain } - sendArrayBuffer webSocket ab - appendMessage "[😇] Trying to add a new domain" - handleAction $ HandleNewDomainInput $ INP_newdomain "" + (DNSManager.MkAcceptedDomains response) -> do + appendMessage $ "[😈] Received the list of accepted domains!" + handleAction $ UpdateAcceptedDomains response.domains - HandleWebSocket wsEvent -> - case wsEvent of - WebSocketMessage messageEvent -> do - receivedMessage <- H.liftEffect $ DNSManager.deserialize messageEvent.message - case receivedMessage of - -- Cases where we didn't understand the message. - Left err -> do - case err of - (DNSManager.JSONERROR jerr) -> do - print_json_string messageEvent.message - handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr) - (DNSManager.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownError" <> (show unerr)) - (DNSManager.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownNumber") + (DNSManager.MkLogged response) -> do + appendMessage $ "[😈] Logged!" + handleAction $ UpdateAcceptedDomains response.accepted_domains + handleAction $ UpdateMyDomains response.my_domains - -- Cases where we understood the message. - Right received_msg -> do - case received_msg of - -- The authentication failed. - (DNSManager.MkError errmsg) -> do - appendMessage $ "[😈] Failed, reason is: " <> errmsg.reason - (DNSManager.MkErrorUserNotLogged _) -> do - appendMessage $ "[😈] Failed! The user isn't connected!" - handleAction AuthenticateToDNSManager - (DNSManager.MkErrorInvalidToken _) -> do - appendMessage $ "[😈] Failed connection! Invalid token!" - (DNSManager.MkDomainAlreadyExists _) -> do - appendMessage $ "[😈] Failed! The domain already exists." - (DNSManager.MkUnacceptableDomain _) -> do - appendMessage $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)." + (DNSManager.MkDomainAdded response) -> do + { my_domains } <- H.get + appendMessage $ "[😈] Domain added: " <> response.domain + handleAction $ UpdateMyDomains (my_domains <> [response.domain]) - (DNSManager.MkAcceptedDomains response) -> do - appendMessage $ "[😈] Received the list of accepted domains!" - handleAction $ UpdateAcceptedDomains response.domains + (DNSManager.MkInvalidDomainName _) -> do + appendMessage $ "[😈] Failed! The domain is not valid!" - (DNSManager.MkLogged response) -> do - appendMessage $ "[😈] Logged!" - handleAction $ UpdateAcceptedDomains response.accepted_domains - handleAction $ UpdateMyDomains response.my_domains + (DNSManager.MkDomainDeleted response) -> do + { my_domains } <- H.get + appendMessage $ "[😈] The domain '" <> response.domain <> "' has been deleted!" + handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains - (DNSManager.MkDomainAdded response) -> do - { my_domains } <- H.get - appendMessage $ "[😈] Domain added: " <> response.domain - handleAction $ UpdateMyDomains (my_domains <> [response.domain]) + (DNSManager.MkSuccess _) -> do + appendMessage $ "[😈] Success!" + -- WTH?! + _ -> do + appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." + pure (Just a) - (DNSManager.MkInvalidDomainName _) -> do - appendMessage $ "[😈] Failed! The domain is not valid!" + ConnectionIsDown a -> do + H.modify_ _ { wsUp = false } + pure (Just a) - (DNSManager.MkDomainDeleted response) -> do - { my_domains } <- H.get - appendMessage $ "[😈] The domain '" <> response.domain <> "' has been deleted!" - handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains - - (DNSManager.MkSuccess _) -> do - appendMessage $ "[😈] Success!" - -- WTH?! - _ -> do - appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." - - WebSocketOpen -> do - { wsInfo } <- H.get - systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉") - handleAction AuthenticateToDNSManager - - 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" - , "]" - ] + ConnectionIsUp a -> do + H.modify_ _ { wsUp = true } + pure (Just a) build_new_domain :: String -> String -> String build_new_domain sub tld