diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 2b9be78..17e3783 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -1,6 +1,6 @@ module App.AuthenticationForm where -import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=)) +import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), pure, unit) import Bulma as Bulma @@ -17,31 +17,26 @@ 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) -import App.Utils - import App.IPC as IPC import App.Email as Email import App.Messages.AuthenticationDaemon as AuthD import Data.ArrayBuffer.Types (ArrayBuffer) -import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) --------------------------------------------------------------------------------- --- Root component module --------------------------------------------------------------------------------- +data Output + = AuthToken (Tuple Int String) + | MessageToSend ArrayBuffer + +data Query a = MessageReceived ArrayBuffer a -data Output = AuthToken (Tuple Int String) type Slot = H.Slot Query Output -type Query :: forall k. k -> Type -type Query = Const Void -type Input = String +-- No input. +type Input = Unit data AuthenticationInput = AUTH_INP_login String @@ -54,8 +49,8 @@ data RegisterInput data Action = Initialize - | WebSocketParseError String - | ConnectWebSocket + -- | WebSocketParseError String + -- | ConnectWebSocket | HandleAuthenticationInput AuthenticationInput | HandleRegisterInput RegisterInput @@ -63,25 +58,16 @@ data Action | AuthenticationAttempt Event | RegisterAttempt Event | Finalize - | HandleWebSocket (WebSocketEvent WebSocketMessageType) + --| HandleWebSocket (WebSocketEvent WebSocketMessageType) type StateAuthenticationForm = { login :: String, pass :: String } type StateRegistrationForm = { login :: String, email :: String, pass :: String } -type WSInfo - = { url :: String - , connection :: Maybe WS.WebSocket - , reconnect :: Boolean - } - type State = - { messages :: Array String - , messageHistoryLength :: Int - - , authenticationForm :: StateAuthenticationForm + { authenticationForm :: StateAuthenticationForm , registrationForm :: StateRegistrationForm - , wsInfo :: WSInfo + , wsUp :: Boolean } component :: forall m. MonadAff m => H.Component Query Input Output m @@ -92,35 +78,25 @@ component = , eval: H.mkEval $ H.defaultEval { initialize = Just Initialize , handleAction = handleAction + , handleQuery = handleQuery , finalize = Just Finalize } } initialState :: Input -> State -initialState input = - { messages: [] - , messageHistoryLength: 10 - - , authenticationForm: { login: "", pass: "" } +initialState _ = + { authenticationForm: { login: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" } - , wsInfo: { url: input - , connection: Nothing - , reconnect: false - } + , wsUp: true } render :: forall m. State -> H.ComponentHTML Action () m -render { - messages, - wsInfo, - +render { wsUp, authenticationForm, registrationForm } = HH.div_ [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ] - , render_messages - , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ] where @@ -136,95 +112,58 @@ render { render_auth_form = HH.form [ HE.onSubmit AuthenticationAttempt ] - [ Bulma.box_input "Login" "login" -- title, placeholder - (HandleAuthenticationInput <<< AUTH_INP_login) -- action - authenticationForm.login -- value - true -- validity (TODO) - (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition - , Bulma.box_password "Password" "password" -- title, placeholder - (HandleAuthenticationInput <<< AUTH_INP_pass) -- action - authenticationForm.pass -- value - true -- validity (TODO) - (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition + [ Bulma.box_input "Login" "login" -- title, placeholder + (HandleAuthenticationInput <<< AUTH_INP_login) -- action + authenticationForm.login -- value + true -- validity (TODO) + (if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition + , Bulma.box_password "Password" "password" -- title, placeholder + (HandleAuthenticationInput <<< AUTH_INP_pass) -- action + authenticationForm.pass -- value + true -- validity (TODO) + (if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition , 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" ] ] render_register_form = HH.form [ HE.onSubmit RegisterAttempt ] - [ Bulma.box_input "Login" "login" -- title, placeholder - (HandleRegisterInput <<< REG_INP_login) -- action - registrationForm.login -- value - true -- validity (TODO) - (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition - , Bulma.box_input "Email" "email@example.com" -- title, placeholder - (HandleRegisterInput <<< REG_INP_email) -- action - registrationForm.email -- value - true -- validity (TODO) - (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition - , Bulma.box_password "Password" "password" -- title, placeholder - (HandleRegisterInput <<< REG_INP_pass) -- action - registrationForm.pass -- value - true -- validity (TODO) - (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition + [ Bulma.box_input "Login" "login" -- title, placeholder + (HandleRegisterInput <<< REG_INP_login) -- action + registrationForm.login -- value + true -- validity (TODO) + (if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition + , Bulma.box_input "Email" "email@example.com" -- title, placeholder + (HandleRegisterInput <<< REG_INP_email) -- action + registrationForm.email -- value + true -- validity (TODO) + (if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition + , Bulma.box_password "Password" "password" -- title, placeholder + (HandleRegisterInput <<< REG_INP_pass) -- action + registrationForm.pass -- value + true -- validity (TODO) + (if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition , HH.div_ [ 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" ] ] ] - 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 - Initialize -> - handleAction ConnectWebSocket + Initialize -> pure unit + -- systemMessage "Component initialized!" - 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) + Finalize -> pure unit + -- systemMessage "Finalize" HandleAuthenticationInput authinp -> do case authinp of @@ -240,147 +179,81 @@ handleAction = case _ of RegisterAttempt ev -> do H.liftEffect $ Event.preventDefault ev - { wsInfo, registrationForm } <- H.get + { registrationForm } <- H.get let login = registrationForm.login email = registrationForm.email pass = registrationForm.pass - case wsInfo.connection, login, email, pass of - Nothing, _, _, _ -> - unableToSend "Not connected to server." + case login, email, pass of + "", _, _ -> pure unit + -- unableToSend "Write your login!" - Just _, "", _, _ -> - unableToSend "Write your login!" + _, "", _ -> pure unit + -- unableToSend "Write your email!" - Just _, _, "", _ -> - unableToSend "Write your email!" + _, _, "" -> pure unit + -- unableToSend "Write your password!" - Just _, _, _, "" -> - unableToSend "Write your password!" - - 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 <- AuthD.serialize $ AuthD.MkRegister { login: login - , email: Just (Email.Email email) - , password: pass } - sendArrayBuffer webSocket ab - appendMessage "[😇] Trying to register" + _, _, _ -> do + message <- H.liftEffect $ AuthD.serialize $ + AuthD.MkRegister { login: login + , email: Just (Email.Email email) + , password: pass } + H.raise $ MessageToSend message + -- appendMessage "[😇] Trying to register" AuthenticationAttempt ev -> do H.liftEffect $ Event.preventDefault ev - { wsInfo, authenticationForm } <- H.get + { authenticationForm } <- H.get - case wsInfo.connection, authenticationForm.login, authenticationForm.pass of - Nothing, _, _ -> - unableToSend "Not connected to server." + case authenticationForm.login, authenticationForm.pass of + "" , _ -> pure unit + -- unableToSend "Write your login!" - Just _ , "" , _ -> - unableToSend "Write your login!" + _ , "" -> pure unit + -- unableToSend "Write your password!" - Just _ , _ , "" -> - unableToSend "Write your password!" + login, pass -> do + message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass } + H.raise $ MessageToSend message + -- appendMessage $ "[😇] Trying to connect with login: " <> login - Just webSocket, login, pass -> do - H.liftEffect (WS.readyState webSocket) >>= case _ of - Connecting -> - unableToSend "Still connecting to server." - Closing -> - unableToSend "Connection to server is closing." +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 $ AuthD.deserialize message + case receivedMessage of + -- Cases where we didn't understand the message. + Left _ -> pure Nothing + --case err of + -- (AuthD.JSONERROR jerr) -> do + -- print_json_string messageEvent.message + -- handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr) + -- (AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr)) + -- (AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber") - 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 <- AuthD.serialize (AuthD.MkLogin { login: login, password: pass }) - sendArrayBuffer webSocket ab - appendMessage $ "[😇] Trying to connect with login: " <> login - - HandleWebSocket wsEvent -> - case wsEvent of - WebSocketMessage messageEvent -> do - receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message - case receivedMessage of - -- Cases where we didn't understand the message. - Left err -> do - case err of - (AuthD.JSONERROR jerr) -> do - print_json_string messageEvent.message - handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr) - (AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr)) - (AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber") - - -- Cases where we understood the message. - Right response -> do - case response of - -- The authentication failed. - (AuthD.GotError errmsg) -> do - appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason - -- The authentication was a success! - (AuthD.GotToken msg) -> do - appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token - H.raise $ AuthToken (Tuple msg.uid msg.token) - -- 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 <> "\"!🎉") - - 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" - , "]" - ] + -- Cases where we understood the message. + Right response -> do + case response of + -- The authentication failed. + (AuthD.GotError errmsg) -> pure (Just a) + -- appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason + -- The authentication was a success! + (AuthD.GotToken msg) -> do + -- appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token + H.raise $ AuthToken (Tuple msg.uid msg.token) + pure (Just a) + -- WTH?! + _ -> pure Nothing + -- appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." 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 + pure unit + --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 6bfbefc..ae376cc 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -7,6 +7,7 @@ import Bulma as Bulma import Data.Maybe (Maybe(..)) import Data.Tuple (Tuple(..)) import App.AuthenticationForm as AF +import App.WS as WS import App.AuthenticationDaemonAdminInterface as AAI import App.DNSManagerDomainsInterface as NewDomainInterface import Halogen as H @@ -15,19 +16,29 @@ import Type.Proxy (Proxy(..)) import Effect.Aff.Class (class MonadAff) data Action - = Authenticated AF.Output -- User has been authenticated. + = OutputAuthComponent AF.Output -- User has been authenticated. + | AuthDEvent WS.Output -- Events from authd. + | DNSManagerDEvent WS.Output -- Events from dnsmanagerd. -type State = { token :: Maybe String, uid :: Maybe Int } +type State = { token :: Maybe String + , uid :: Maybe Int + , auth_ws_connected :: Boolean + , dns_ws_connected :: Boolean + } type ChildSlots = ( af :: AF.Slot Unit + , ws_auth :: WS.Slot Unit + , ws_dns :: WS.Slot Unit , aai :: AAI.Slot Unit , ndi :: NewDomainInterface.Slot Unit ) -_af = Proxy :: Proxy "af" -_aai = Proxy :: Proxy "aai" -_ndi = Proxy :: Proxy "ndi" +_af = Proxy :: Proxy "af" +_ws_auth = Proxy :: Proxy "ws_auth" +_ws_dns = Proxy :: Proxy "ws_dns" +_aai = Proxy :: Proxy "aai" +_ndi = Proxy :: Proxy "ndi" component :: forall q i o m. MonadAff m => H.Component q i o m component = @@ -38,12 +49,18 @@ component = } initialState :: forall i. i -> State -initialState _ = { token: Nothing, uid: Nothing } +initialState _ = { token: Nothing + , uid: Nothing + , auth_ws_connected: false + , dns_ws_connected: false + } render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render state = HH.div_ $ - [ render_auth_form + [ render_auth_WS + , render_dnsmanager_WS + , render_auth_form , render_authd_admin_interface , render_newdomain_interface , div_token @@ -52,9 +69,17 @@ render state div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ] + render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + render_auth_WS = Bulma.box [ HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthDEvent ] + + render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + render_dnsmanager_WS = Bulma.box $ case state.token of + Nothing -> [ Bulma.p "We don't have a token right now." ] + Just _ -> [ HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDEvent ] + render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_form = Bulma.box $ case state.token of - Nothing -> [ HH.slot _af unit AF.component "ws://127.0.0.1:8080" Authenticated ] + Nothing -> [ HH.slot _af unit AF.component unit OutputAuthComponent ] Just current_token -> [ Bulma.p ("Token is: " <> current_token) ] render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad @@ -75,4 +100,19 @@ render state handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit handleAction = case _ of - Authenticated (AF.AuthToken (Tuple uid token)) -> H.modify_ _ { uid = Just uid, token = Just token } + OutputAuthComponent ev -> case ev of + AF.AuthToken (Tuple uid token) -> H.modify_ _ { uid = Just uid, token = Just token } + AF.MessageToSend message -> do + H.tell _ws_auth unit (WS.ToSend message) + + 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 } + + DNSManagerDEvent ev -> case ev of + WS.MessageReceived (Tuple _ _) -> pure unit -- TODO + WS.WSJustConnected -> H.modify_ _ { dns_ws_connected = true } + WS.WSJustClosed -> H.modify_ _ { dns_ws_connected = false } + diff --git a/src/App/WS.purs b/src/App/WS.purs index 7196413..7ca5764 100644 --- a/src/App/WS.purs +++ b/src/App/WS.purs @@ -22,8 +22,9 @@ import App.Utils import Data.ArrayBuffer.Types (ArrayBuffer) import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) --- Input = url +-- Input is the WS url. type Input = String + -- MessageReceived (Tuple URL message) data Output = MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent. @@ -31,14 +32,11 @@ data Output | WSJustClosed -- Inform the parent the connection is down. --| AppendSystemMessage String -- System message to print. --| AppendMessage String -- Basic message to print. ---type Slot = H.Slot Query Output ---type Query :: forall k. k -> Type -data Query a = ToSend ArrayBuffer a +type Slot = H.Slot Query Output -data NewDomainFormAction - = INP_newdomain String - | UpdateSelectedDomain String +data Query a + = ToSend ArrayBuffer a data Action = Initialize @@ -70,6 +68,7 @@ component = , eval: H.mkEval $ H.defaultEval { initialize = Just Initialize , handleAction = handleAction + , handleQuery = handleQuery , finalize = Just Finalize } } @@ -147,7 +146,7 @@ handleAction action = do HandleWebSocket wsEvent -> do case wsEvent of WebSocketMessage received_message -> do - appendMessage $ "[😈] Received a message, ignored for now" + appendMessage $ "[😈] Received a message" H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message WebSocketOpen -> do @@ -216,6 +215,3 @@ handleQuery = case _ of H.liftEffect $ do sendArrayBuffer webSocket message pure (Just a) - --- Request reply -> --- pure (Just (reply true))