App.Utils.
parent
3dddbf6990
commit
771573ec5c
|
|
@ -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))
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
Loading…
Reference in New Issue