Compiles again! :)
parent
07008d9038
commit
a145577791
|
|
@ -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." ]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue