From 2352d2a3bbacf87b8ab06df01dacd4e26615760a Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Sat, 17 Jun 2023 20:22:37 +0200 Subject: [PATCH] DNSManager interface: WIP. --- src/App/DNSManagerDomainsInterface.purs | 471 ++++++++++++++++++++++++ 1 file changed, 471 insertions(+) create mode 100644 src/App/DNSManagerDomainsInterface.purs diff --git a/src/App/DNSManagerDomainsInterface.purs b/src/App/DNSManagerDomainsInterface.purs new file mode 100644 index 0000000..b16ba90 --- /dev/null +++ b/src/App/DNSManagerDomainsInterface.purs @@ -0,0 +1,471 @@ +module App.AuthenticationDaemonAdminInterface where + +{- Administration interface for the authentication daemon. + This interface should allow to: + - TODO: add, remove, search, validate users + - TODO: raise a user to admin +-} + +import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=), not) + +import Bulma as Bulma + +import Control.Monad.Except (runExcept) +import Control.Monad.State (class MonadState) +import Data.Array as A +import Data.Tuple (Tuple(..)) +import Data.Bifunctor (lmap) +import Data.Const (Const) +import Data.Either (Either(..)) +import Data.Maybe (Maybe(..), isJust, isNothing, maybe) +import Data.String as String +import Effect (Effect) +import Effect.Aff.Class (class MonadAff) +import Foreign (Foreign) +import Foreign as F +import Halogen as H +import Halogen.HTML as HH +import Halogen.HTML.Events as HE +import Halogen.HTML.Properties as HP +import Halogen.Query.Event as HQE +import Halogen.Subscription as HS +import Web.Event.Event (Event) +import Web.Event.Event as Event +import Web.Socket.Event.CloseEvent as WSCE +import Web.Socket.Event.EventTypes as WSET +import Web.Socket.Event.MessageEvent as WSME +import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed)) +import Web.Socket.WebSocket as WS + +import Effect.Class (class MonadEffect) + +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)) + +-------------------------------------------------------------------------------- +-- WebSocketEvent type +-------------------------------------------------------------------------------- + +data WebSocketEvent :: Type -> Type +data WebSocketEvent msg + = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String } + | WebSocketOpen + | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean } + | WebSocketError ErrorType + +webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType) +webSocketEmitter socket = do + + HS.makeEmitter \push -> do + + openId <- HS.subscribe openEmitter push + errorId <- HS.subscribe errorEmitter push + closeId <- HS.subscribe closeEmitter push + messageId <- HS.subscribe messageEmitter push + + pure do + HS.unsubscribe openId + HS.unsubscribe errorId + HS.unsubscribe closeId + HS.unsubscribe messageId + + where + target = WS.toEventTarget socket + + openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) + openEmitter = + HQE.eventListener WSET.onOpen target \_ -> + Just WebSocketOpen + + errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) + errorEmitter = + HQE.eventListener WSET.onError target \_ -> + Just (WebSocketError UnknownWebSocketError) + + closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) + closeEmitter = + HQE.eventListener WSET.onClose target \event -> + WSCE.fromEvent event >>= \closeEvent -> + Just $ WebSocketClose { code: WSCE.code closeEvent + , reason: WSCE.reason closeEvent + , wasClean: WSCE.wasClean closeEvent + } + + messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType) + messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent) + +decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType) +decodeMessageEvent = \msgEvent -> do + let + foreign' :: Foreign + foreign' = WSME.data_ msgEvent + case foreignToArrayBuffer foreign' of + Left errs -> pure $ WebSocketError $ UnknownError errs + Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent } + +--------------------------- +-- Errors +--------------------------- + +data ErrorType + = UnknownError String + | UnknownWebSocketError + +renderError :: ErrorType -> String +renderError = case _ of + UnknownError str -> + "Unknown error: " <> str + UnknownWebSocketError -> + "Unknown 'error' event has been fired by WebSocket event listener" + +-------------------------------------------------------------------------------- +-- WebSocket message type +-------------------------------------------------------------------------------- + +type WebSocketMessageType = ArrayBuffer + +-------------------------------------------------------------------------------- +-- Root component module +-------------------------------------------------------------------------------- + +data Output = Void +type Slot = H.Slot Query Output + +type Query :: forall k. k -> Type +type Query = Const Void +type Input = String + +data NewDomainForm + = INP_newdomain String + +data Action + = Initialize + | WebSocketParseError String + | ConnectWebSocket + + | HandleNewDomainInput NewDomainForm + + | AddUserAttempt Event + -- | Finalize + | HandleWebSocket (WebSocketEvent WebSocketMessageType) + +type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String } + +type State = + { messages :: Array String + , messageHistoryLength :: Int + + , newDomainForm :: StateAddUserForm + + -- TODO: put network stuff in a record. + , wsUrl :: String + , wsConnection :: Maybe WS.WebSocket + , canReconnect :: Boolean + } + +component :: forall m. MonadAff m => H.Component Query Input Output m +component = + H.mkComponent + { initialState + , render + , eval: H.mkEval $ H.defaultEval + { initialize = Just Initialize + , handleAction = handleAction + -- , finalize = Just Finalize + } + } + +initialState :: Input -> State +initialState input = + { messages: [] + , messageHistoryLength: 10 + + , newDomainForm: { new_domain: "" } + + -- TODO: put network stuff in a record. + , wsUrl: input + , wsConnection: Nothing + , canReconnect: false + } + +render :: forall m. State -> H.ComponentHTML Action () m +render { + messages, + wsConnection, + canReconnect, + newDomainForm } + = HH.div_ + [ Bulma.columns_ [ Bulma.column_ adduser_form ] + , render_messages + --, renderMaxHistoryLength messageHistoryLength + , renderReconnectButton (isNothing wsConnection && canReconnect) + ] + where + + adduser_form + = [ Bulma.h3 "Add a new user" + , render_adduser_form + ] + + should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) + + render_adduser_form = HH.form + [ HE.onSubmit AddUserAttempt ] + [ Bulma.box_input "Your new domain" "awesomewebsite" -- title, placeholder + (HandleNewDomainInput <<< INP_newdomain) -- action + newDomainForm.new_domain -- value + true -- validity (TODO) + should_be_disabled -- condition + , Bulma.btn + (show newDomainForm.admin) -- value + (HandleNewDomainInput ADDUSER_toggle_admin) -- action1 + (HandleNewDomainInput ADDUSER_toggle_admin) -- action2 + true -- validity (TODO) + -- should_be_disabled -- condition + , Bulma.box_input "User email" "email" -- title, placeholder + (HandleNewDomainInput <<< ADDUSER_INP_email) -- action + newDomainForm.email -- value + true -- validity (TODO) + should_be_disabled -- condition + , Bulma.box_password "User password" "password" -- title, placeholder + (HandleNewDomainInput <<< ADDUSER_INP_pass) -- action + newDomainForm.pass -- value + true -- validity (TODO) + should_be_disabled -- condition + , HH.div_ + [ HH.button + [ HP.style "padding: 0.5rem 1.25rem;" + , HP.type_ HP.ButtonSubmit + , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection + ] + [ 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 + + -- Finalize -> do + -- { wsConnection } <- H.get + -- systemMessage "Finalize" + -- case wsConnection 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 + { wsUrl } <- H.get + systemMessage ("Connecting to \"" <> wsUrl <> "\"...") + webSocket <- H.liftEffect $ WS.create wsUrl [] + H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer + H.modify_ _ { wsConnection = Just webSocket } + void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) + + HandleNewDomainInput adduserinp -> do + { newDomainForm } <- H.get + case adduserinp of + ADDUSER_INP_login v -> H.modify_ _ { newDomainForm { login = v } } + ADDUSER_INP_email v -> H.modify_ _ { newDomainForm { email = v } } + ADDUSER_toggle_admin -> H.modify_ _ { newDomainForm { admin = not newDomainForm.admin } } + ADDUSER_INP_pass v -> H.modify_ _ { newDomainForm { pass = v } } + + AddUserAttempt ev -> do + H.liftEffect $ Event.preventDefault ev + + { wsConnection, newDomainForm } <- H.get + let login = newDomainForm.login + email = newDomainForm.email + pass = newDomainForm.pass + + case wsConnection, login, email, pass of + Nothing, _, _, _ -> + unableToSend "Not connected to server." + + Just _, "", _, _ -> + unableToSend "Write the user's login!" + + Just _, _, "", _ -> + unableToSend "Write the user's email!" + + Just _, _, _, "" -> + unableToSend "Write the user's 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 _.wsConnection + when (isJust maybeCurrentConnection) do + H.modify_ _ { wsConnection = Nothing, canReconnect = true } + + Open -> do + H.liftEffect $ do + ab <- AuthD.serialize $ AuthD.MkAddUser { login: login + , admin: newDomainForm.admin + , email: Just (Email.Email email) + , password: pass } + sendArrayBuffer webSocket ab + appendMessageReset "[😇] Trying to add a user" + + 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 + (AuthD.GotUserAdded msg) -> do + appendMessage $ "[😈] Success! Server added user: " <> show msg.user + -- WTH?! + _ -> do + appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." + + WebSocketOpen -> do + { wsUrl } <- H.get + systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉") + + WebSocketClose { code, reason, wasClean } -> do + systemMessage $ renderCloseMessage code wasClean reason + maybeCurrentConnection <- H.gets _.wsConnection + when (isJust maybeCurrentConnection) do + H.modify_ _ { wsConnection = Nothing, canReconnect = 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" + , "]" + ] + +sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit +sendArrayBuffer = WS.sendArrayBuffer + +-------------------------------------------------------------------------------- +-- Helpers for updating the array of messages sent/received +-------------------------------------------------------------------------------- +-- Append a new message to the chat history, with a boolean that allows you to +-- clear the text input field or not. The number of displayed `messages` in the +-- chat history (including system) is controlled by the `messageHistoryLength` +-- field in the component `State`. +appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit +appendMessageGeneric clearField msg = do + histSize <- H.gets _.messageHistoryLength + if clearField + then H.modify_ \st -> + st { messages = appendSingle histSize msg st.messages, newDomainForm { login = "" }} + else H.modify_ \st -> + st { messages = appendSingle histSize msg st.messages } + where + -- Limits the nnumber of recent messages to `maxHist` + appendSingle :: Int -> String -> Array String -> Array String + appendSingle maxHist x xs + | A.length xs < maxHist = xs `A.snoc` x + | otherwise = (A.takeEnd (maxHist-1) xs) `A.snoc` x + +-- Append a new message to the chat history, while not clearing +-- the user input field +appendMessage :: forall m. MonadState State m => String -> m Unit +appendMessage = appendMessageGeneric false + +-- Append a new message to the chat history and also clear +-- the user input field +appendMessageReset :: forall m. MonadState State m => String -> m Unit +appendMessageReset = appendMessageGeneric true + +-- Append a system message to the chat log. +systemMessage :: forall m. MonadState State m => String -> m Unit +systemMessage msg = appendMessage ("[🤖] System: " <> msg) + +-- As above, but also clears the user input field. e.g. in +-- the case of a "/disconnect" command +systemMessageReset :: forall m. MonadState State m => String -> m Unit +systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg) + +-- A system message to use when a message cannot be sent. +unableToSend :: forall m. MonadState State m => String -> m Unit +unableToSend reason = systemMessage ("Unable to send. " <> reason) + +foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer +foreignToArrayBuffer + = lmap renderForeignErrors + <<< runExcept + <<< F.unsafeReadTagged "ArrayBuffer" + where + renderForeignErrors :: F.MultipleErrors -> String + renderForeignErrors = + String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError + +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