WIP: CAN'T BE COMPILED. WILL BE SOON FIXED.
parent
c2569bc959
commit
07008d9038
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,13 +115,16 @@ 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)
|
||||
|
|
@ -133,8 +132,10 @@ handleAction = case _ of
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -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,37 +271,21 @@ 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!"
|
||||
|
||||
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 <- DNSManager.serialize $ DNSManager.MkNewDomain { domain: new_domain }
|
||||
sendArrayBuffer webSocket ab
|
||||
_ -> 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 ""
|
||||
|
||||
HandleWebSocket wsEvent ->
|
||||
case wsEvent of
|
||||
WebSocketMessage messageEvent -> do
|
||||
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
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
|
|
@ -345,6 +296,7 @@ handleAction = case _ of
|
|||
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.
|
||||
Right received_msg -> do
|
||||
|
|
@ -389,41 +341,15 @@ handleAction = case _ of
|
|||
-- WTH?!
|
||||
_ -> do
|
||||
appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
|
||||
pure (Just a)
|
||||
|
||||
WebSocketOpen -> do
|
||||
{ wsInfo } <- H.get
|
||||
systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <> "\"!🎉")
|
||||
handleAction AuthenticateToDNSManager
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue