karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP: CAN'T BE COMPILED. WILL BE SOON FIXED.

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-04 13:14:04 +02:00
parent c2569bc959
commit 07008d9038
4 changed files with 135 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
src/App/AuthenticationDaemonAdminInterface.purs
View File

@ -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))

53
src/App/AuthenticationForm.purs
View File

@ -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

25
src/App/Container.purs
View File

@ -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)

242
src/App/DNSManagerDomainsInterface.purs
View File

@ -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