App.Utils.

beta
Philippe Pittoli 2023-07-03 03:23:02 +02:00
parent 3dddbf6990
commit 771573ec5c
2 changed files with 195 additions and 147 deletions

View File

@ -1,14 +1,14 @@
module App.DNSManagerDomainsInterface where module App.DNSManagerDomainsInterface where
{- Simple component with the list of own domains and a form to add a new domain. {- Simple component with the list of own domains and a form to add a new domain.
This interface should allow to: This interface allows to:
- TODO: display the list of own domains - display the list of own domains
- TODO: create new domains (with different TLDs) - 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: Authentication is automatic with the token.
- TODO: get the list of TLDs (netlib.re, codelib.re, etc.)
Also: must log user!
-} -}
import Prelude import Prelude
@ -48,94 +48,14 @@ import Web.Socket.WebSocket as WS
import Effect.Class (class MonadEffect) import Effect.Class (class MonadEffect)
import App.Utils
import App.IPC as IPC import App.IPC as IPC
import App.Messages.DNSManagerDaemon as DNSManager import App.Messages.DNSManagerDaemon as DNSManager
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(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 -- Root component module
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -468,64 +388,6 @@ build_new_domain sub tld
| endsWith "." sub = sub <> tld | endsWith "." sub = sub <> tld
| otherwise = 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 :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
print_json_string arraybuffer = do print_json_string arraybuffer = do
-- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String)) -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))

186
src/App/Utils.purs Normal file
View File

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