diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index 46d5d41..d3e7991 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -1,38 +1,29 @@ module App.AuthenticationForm where -import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=)) +import Prelude (Unit, Void, bind, discard, map, 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 @@ -41,88 +32,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 -------------------------------------------------------------------------------- @@ -466,64 +375,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, authenticationForm { 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))