From 771573ec5c6901ec20b6e72cc2571c6d93051f79 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Mon, 3 Jul 2023 03:23:02 +0200 Subject: [PATCH] App.Utils. --- src/App/DNSManagerDomainsInterface.purs | 156 ++------------------ src/App/Utils.purs | 186 ++++++++++++++++++++++++ 2 files changed, 195 insertions(+), 147 deletions(-) create mode 100644 src/App/Utils.purs diff --git a/src/App/DNSManagerDomainsInterface.purs b/src/App/DNSManagerDomainsInterface.purs index b257013..d957ccf 100644 --- a/src/App/DNSManagerDomainsInterface.purs +++ b/src/App/DNSManagerDomainsInterface.purs @@ -1,14 +1,14 @@ module App.DNSManagerDomainsInterface where {- Simple component with the list of own domains and a form to add a new domain. - This interface should allow to: - - TODO: display the list of own domains - - TODO: create new domains (with different TLDs) + This interface allows to: + - display the list of own domains + - show and select accepted domains (TLDs) + - create new domains + - TODO: delete a domain (+ TODO: ask for confirmation) + - TODO: show and modify the content of a Zone - Some messages are lacking: - - TODO: get the list of TLDs (netlib.re, codelib.re, etc.) - - Also: must log user! + Authentication is automatic with the token. -} import Prelude @@ -48,94 +48,14 @@ import Web.Socket.WebSocket as WS import Effect.Class (class MonadEffect) +import App.Utils + import App.IPC as IPC import App.Messages.DNSManagerDaemon as DNSManager 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 -------------------------------------------------------------------------------- @@ -468,64 +388,6 @@ build_new_domain sub tld | endsWith "." sub = sub <> tld | otherwise = sub <> "." <> tld -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 { new_domain = "" }} - 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)) diff --git a/src/App/Utils.purs b/src/App/Utils.purs new file mode 100644 index 0000000..f30d363 --- /dev/null +++ b/src/App/Utils.purs @@ -0,0 +1,186 @@ +module App.Utils where + +import Prelude + +import Bulma as Bulma + +import Data.String.Utils (endsWith) +-- import Data.String.CodeUnits as DSCU +import Halogen.HTML.Events as HHE +import Control.Monad.Except (runExcept) +import Control.Monad.State (class MonadState) +import Data.Array as A +-- import Data.Array.Partial as DAP +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.Messages.DNSManagerDaemon as DNSManager + +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 + +sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit +sendArrayBuffer = WS.sendArrayBuffer + +type MessageRenderingAndWSState rows + = { messages :: Array String + , messageHistoryLength :: Int + | rows } + +-------------------------------------------------------------------------------- +-- 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`. +-- TODO: first arg (clearField) isn't used anymore. +appendMessageGeneric :: forall r m. MonadState (MessageRenderingAndWSState r) m => Boolean -> String -> m Unit +appendMessageGeneric _ msg = do + histSize <- H.gets _.messageHistoryLength + H.modify_ \st -> st { messages = appendSingle histSize msg st.messages } + where + -- Limits the number 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 r m. MonadState (MessageRenderingAndWSState r) m => String -> m Unit +appendMessage = appendMessageGeneric false + +-- Append a new message to the chat history and also clear +-- the user input field +appendMessageReset :: forall r m. MonadState (MessageRenderingAndWSState r) m => String -> m Unit +appendMessageReset = appendMessageGeneric true + +-- Append a system message to the chat log. +systemMessage :: forall r m. MonadState (MessageRenderingAndWSState r) 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 r m. MonadState (MessageRenderingAndWSState r) m => String -> m Unit +systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg) + +-- A system message to use when a message cannot be sent. +unableToSend :: forall r m. MonadState (MessageRenderingAndWSState r) 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