From a14557779125ce347e639b29d7857b8025ddaa55 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Wed, 5 Jul 2023 02:06:57 +0200 Subject: [PATCH] Compiles again! :) --- src/App/Container.purs | 2 +- src/App/DNSManagerDomainsInterface.purs | 167 ++++++++---------------- 2 files changed, 56 insertions(+), 113 deletions(-) diff --git a/src/App/Container.purs b/src/App/Container.purs index 4b67985..31d199e 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -96,7 +96,7 @@ render state render_newdomain_interface = Bulma.box $ case state.token of Just token -> [ Bulma.h1 "New domain interface!" - , HH.slot_ _ndi unit NewDomainInterface.component (Tuple "ws://127.0.0.1:8081" token) + , HH.slot_ _ndi unit NewDomainInterface.component token ] Nothing -> [ Bulma.p "Here will be the new domain box." ] diff --git a/src/App/DNSManagerDomainsInterface.purs b/src/App/DNSManagerDomainsInterface.purs index 8e1065b..be70f7c 100644 --- a/src/App/DNSManagerDomainsInterface.purs +++ b/src/App/DNSManagerDomainsInterface.purs @@ -12,7 +12,7 @@ module App.DNSManagerDomainsInterface where Authentication is automatic with the token. -} -import Prelude (Unit, Void, bind, discard, map, otherwise, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), (/=)) +import Prelude (Unit, Void, bind, discard, map, otherwise, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), (/=), pure) import Bulma as Bulma @@ -61,8 +61,7 @@ data Query a type Slot = H.Slot Query Output --- Input = url token -type Input = Tuple String String +type Input = String data NewDomainFormAction = INP_newdomain String @@ -79,7 +78,6 @@ data Action | NewDomainAttempt Event | RemoveDomain String | EnterDomain String - | HandleWebSocket (WebSocketEvent WebSocketMessageType) type NewDomainFormState = { new_domain :: String @@ -92,6 +90,7 @@ type State = , my_domains :: Array String , wsUp :: Boolean + , token :: String } component :: forall m. MonadAff m => H.Component Query Input Output m @@ -100,8 +99,7 @@ component = { initialState , render , eval: H.mkEval $ H.defaultEval - { initialize = Just Initialize - , handleAction = handleAction + { handleAction = handleAction , handleQuery = handleQuery } } @@ -110,36 +108,21 @@ default_domain :: String default_domain = "netlib.re" initialState :: Input -> State -initialState (Tuple url token) = - { messages: [] - , messageHistoryLength: 10 - - , newDomainForm: { new_domain: "" +initialState token = + { newDomainForm: { new_domain: "" , selected_domain: default_domain } - , accepted_domains: [ default_domain ] , my_domains: [ ] - - , wsInfo: { url: url - , connection: Nothing - , reconnect: false - , token: token - } + , wsUp: true + , token: token } render :: forall m. State -> H.ComponentHTML Action () m -render { - messages, - accepted_domains, - my_domains, - wsInfo, - newDomainForm } +render { accepted_domains, my_domains, newDomainForm, wsUp } = HH.div_ [ Bulma.columns_ [ Bulma.column_ newdomain_form , Bulma.column_ list_of_own_domains ] - , render_messages - , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ] where @@ -153,25 +136,26 @@ render { , HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains ] + -- should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) + should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true)) + domain_buttons domain = [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , HE.onClick \_ -> EnterDomain domain - , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection + , (if wsUp then (HP.enabled true) else (HP.disabled true)) ] [ HH.text domain ] , HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , HE.onClick \_ -> RemoveDomain domain - , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection + , (if wsUp then (HP.enabled true) else (HP.disabled true)) ] [ HH.text "x" ] ] - should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) - render_adduser_form = HH.form [ HE.onSubmit NewDomainAttempt ] [ Bulma.box_input "Your new domain" "awesomewebsite" -- title, placeholder @@ -184,7 +168,7 @@ render { [ 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" ] ] @@ -195,29 +179,6 @@ render { domain_choice i = HandleNewDomainInput <<< UpdateSelectedDomain $ maybe "netlib.re" (\x -> x) $ accepted_domains A.!! i - - 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 UpdateAcceptedDomains domains -> do @@ -227,75 +188,54 @@ handleAction = case _ of H.modify_ _ { my_domains = domains } AuthenticateToDNSManager -> do - appendMessage $ "[🤖] Trying to authenticate..." - message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: wsInfo.token } + { token } <- H.get + message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token } H.raise $ MessageToSend message HandleNewDomainInput adduserinp -> do case adduserinp of INP_newdomain v -> H.modify_ _ { newDomainForm { new_domain = v } } - UpdateSelectedDomain domain -> do - H.modify_ _ { newDomainForm { selected_domain = domain } } + UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } } EnterDomain domain -> do - appendMessage $ "[???] trying to enter domain: " <> domain + H.raise $ AppendMessage $ "[???] trying to enter domain: " <> domain RemoveDomain domain -> do - { wsInfo } <- H.get - case wsInfo.connection of - Nothing -> - unableToSend "Not connected to server." - Just webSocket -> - 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 <- DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain } - sendArrayBuffer webSocket ab - appendMessage $ "[😇] Removing domain: " <> domain + message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain } + H.raise $ MessageToSend message + H.raise $ AppendMessage $ "[😇] Removing domain: " <> domain NewDomainAttempt ev -> do H.liftEffect $ Event.preventDefault ev - { wsInfo, newDomainForm } <- H.get + { newDomainForm } <- H.get let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain case new_domain of "" -> - unableToSend "You didn't enter the new domain!" + H.raise $ 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" + H.raise $ AppendMessage "[😇] Trying to add a new domain" handleAction $ HandleNewDomainInput $ INP_newdomain "" handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery = case _ of MessageReceived message a -> do - receivedMessage <- H.liftEffect $ DNSManager.deserialize messageEvent.message + receivedMessage <- H.liftEffect $ DNSManager.deserialize 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") + Left _ -> do + -- case err of + -- (DNSManager.JSONERROR jerr) -> do + -- print_json_string 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 -- Cases where we understood the message. @@ -303,44 +243,45 @@ handleQuery = case _ of case received_msg of -- The authentication failed. (DNSManager.MkError errmsg) -> do - appendMessage $ "[😈] Failed, reason is: " <> errmsg.reason + H.raise $ AppendMessage $ "[😈] Failed, reason is: " <> errmsg.reason (DNSManager.MkErrorUserNotLogged _) -> do - appendMessage $ "[😈] Failed! The user isn't connected!" + H.raise $ AppendMessage $ "[😈] Failed! The user isn't connected!" + H.raise $ AppendMessage $ "[🤖] Trying to authenticate to fix the problem..." handleAction AuthenticateToDNSManager (DNSManager.MkErrorInvalidToken _) -> do - appendMessage $ "[😈] Failed connection! Invalid token!" + H.raise $ AppendMessage $ "[😈] Failed connection! Invalid token!" (DNSManager.MkDomainAlreadyExists _) -> do - appendMessage $ "[😈] Failed! The domain already exists." + H.raise $ AppendMessage $ "[😈] Failed! The domain already exists." (DNSManager.MkUnacceptableDomain _) -> do - appendMessage $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)." + H.raise $ AppendMessage $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)." (DNSManager.MkAcceptedDomains response) -> do - appendMessage $ "[😈] Received the list of accepted domains!" + H.raise $ AppendMessage $ "[😈] Received the list of accepted domains!" handleAction $ UpdateAcceptedDomains response.domains (DNSManager.MkLogged response) -> do - appendMessage $ "[😈] Logged!" + H.raise $ AppendMessage $ "[😈] Authenticated!" handleAction $ UpdateAcceptedDomains response.accepted_domains handleAction $ UpdateMyDomains response.my_domains (DNSManager.MkDomainAdded response) -> do { my_domains } <- H.get - appendMessage $ "[😈] Domain added: " <> response.domain + H.raise $ AppendMessage $ "[😈] Domain added: " <> response.domain handleAction $ UpdateMyDomains (my_domains <> [response.domain]) (DNSManager.MkInvalidDomainName _) -> do - appendMessage $ "[😈] Failed! The domain is not valid!" + H.raise $ AppendMessage $ "[😈] Failed! The domain is not valid!" (DNSManager.MkDomainDeleted response) -> do { my_domains } <- H.get - appendMessage $ "[😈] The domain '" <> response.domain <> "' has been deleted!" + H.raise $ AppendMessage $ "[😈] The domain '" <> response.domain <> "' has been deleted!" handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains (DNSManager.MkSuccess _) -> do - appendMessage $ "[😈] Success!" + H.raise $ AppendMessage $ "[😈] Success!" -- WTH?! _ -> do - appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." + H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message." pure (Just a) ConnectionIsDown a -> do @@ -349,6 +290,8 @@ handleQuery = case _ of ConnectionIsUp a -> do H.modify_ _ { wsUp = true } + H.raise $ AppendMessage "Connection with dnsmanagerd was closed, let's re-authenticate" + handleAction AuthenticateToDNSManager pure (Just a) build_new_domain :: String -> String -> String @@ -356,10 +299,10 @@ build_new_domain sub tld | endsWith "." sub = sub <> tld | otherwise = sub <> "." <> tld -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 - Left _ -> "Cannot even fromTypedIPC the message." - Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string +--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