Remove another big chunk of code.
parent
026e3f055a
commit
15e407972a
|
|
@ -8,39 +8,29 @@ module App.AuthenticationDaemonAdminInterface where
|
|||
TODO: authenticate
|
||||
-}
|
||||
|
||||
import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=), not)
|
||||
import Prelude (Unit, Void, bind, discard, map, not, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=))
|
||||
|
||||
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.Utils
|
||||
import App.IPC as IPC
|
||||
import App.Email as Email
|
||||
|
||||
|
|
@ -49,88 +39,6 @@ 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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -409,64 +317,6 @@ handleAction = case _ of
|
|||
, "]"
|
||||
]
|
||||
|
||||
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, addUserForm { 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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue