module App.AuthenticationForm where import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=)) 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.IPC as IPC import App.Email as Email 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 -------------------------------------------------------------------------------- data Output = AuthToken String type Slot = H.Slot Query Output type Query :: forall k. k -> Type type Query = Const Void type Input = String data AuthenticationInput = AUTH_INP_login String | AUTH_INP_pass String data RegisterInput = REG_INP_login String | REG_INP_email String | REG_INP_pass String data AddUserInput = ADDUSER_INP_secret String | ADDUSER_INP_login String | ADDUSER_INP_email String | ADDUSER_INP_pass String data Action = Initialize | WebSocketParseError String | ConnectWebSocket | HandleAuthenticationInput AuthenticationInput | HandleRegisterInput RegisterInput | HandleAddUserInput AddUserInput -- admin operation | AuthenticationAttempt Event | RegisterAttempt Event | AddUserAttempt Event | Finalize | HandleWebSocket (WebSocketEvent WebSocketMessageType) type StateAuthenticationForm = { login :: String, pass :: String } type StateRegistrationForm = { login :: String, email :: String, pass :: String } type StateAddUserForm = { secretKey :: String, login :: String, email :: String, pass :: String } type State = { messages :: Array String , messageHistoryLength :: Int , authenticationForm :: StateAuthenticationForm , registrationForm :: StateRegistrationForm , addUserForm :: StateAddUserForm -- TODO: put network stuff in a record. , wsUrl :: String , wsConnection :: Maybe WS.WebSocket , canReconnect :: Boolean } component :: forall m. MonadAff m => H.Component Query Input Output m component = H.mkComponent { initialState , render , eval: H.mkEval $ H.defaultEval { initialize = Just Initialize , handleAction = handleAction , finalize = Just Finalize } } initialState :: Input -> State initialState input = { messages: [] , messageHistoryLength: 10 , authenticationForm: { login: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" } , addUserForm: { secretKey: "", login: "", email: "", pass: "" } -- TODO: put network stuff in a record. , wsUrl: input , wsConnection: Nothing , canReconnect: false } wrapperStyle :: String wrapperStyle = """ display: block; flex-direction: column; justify-content: space-between; height: calc(100vh - 30px); background: #282c34; color: #e06c75; font-family: 'Consolas'; padding: 5px 20px 5px 20px; """ render :: forall m. State -> H.ComponentHTML Action () m render { messages, wsConnection, canReconnect, authenticationForm, registrationForm, addUserForm } = HH.div [ HP.style wrapperStyle ] [ render_auth_form , render_register_form , render_adduser_form , render_messages --, renderMaxHistoryLength messageHistoryLength , renderReconnectButton (isNothing wsConnection && canReconnect) ] where render_auth_form = HH.form [ HE.onSubmit AuthenticationAttempt ] [ HH.h2_ [ HH.text "Authentication!" ] , HH.p_ [ HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value authenticationForm.login , HE.onValueInput $ HandleAuthenticationInput <<< AUTH_INP_login , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputPassword , HP.value authenticationForm.pass , HE.onValueInput $ HandleAuthenticationInput <<< AUTH_INP_pass , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] [ HH.text "Send Message to Server" ] ] ] ] render_register_form = HH.form [ HE.onSubmit RegisterAttempt ] [ HH.h2_ [ HH.text "Register!" ] , HH.p_ [ HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value registrationForm.login , HE.onValueInput $ HandleRegisterInput <<< REG_INP_login , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value registrationForm.email , HE.onValueInput $ HandleRegisterInput <<< REG_INP_email , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputPassword , HP.value registrationForm.pass , HE.onValueInput $ HandleRegisterInput <<< REG_INP_pass , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] [ HH.text "Send Message to Server" ] ] ] ] render_adduser_form = HH.form [ HE.onSubmit AddUserAttempt ] [ HH.h2_ [ HH.text "(admin) Add User!" ] , HH.p_ [ HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value addUserForm.secretKey , HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_secret , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value addUserForm.login , HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_login , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputText , HP.value addUserForm.email , HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_email , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.input [ inputCSS , HP.type_ HP.InputPassword , HP.value addUserForm.pass , HE.onValueInput $ HandleAddUserInput <<< ADDUSER_INP_pass , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] ] , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection ] [ HH.text "Send Message to Server" ] ] ] ] render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote txt = HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ] -- renderMaxHistoryLength :: Int -> H.ComponentHTML Action () m -- renderMaxHistoryLength len = -- renderFootnote ("NOTE: Maximum chat history length is " <> show len <> " messages") renderReconnectButton :: Boolean -> H.ComponentHTML Action () m renderReconnectButton cond = if cond then HH.p_ [ HH.button [ HP.type_ HP.ButtonButton , HE.onClick \_ -> ConnectWebSocket ] [ HH.text "Reconnect?" ] ] else HH.p_ [ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops" ] handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction = case _ of Initialize -> handleAction ConnectWebSocket Finalize -> do { wsConnection } <- H.get systemMessage "Finalize" case wsConnection of Nothing -> systemMessage "No socket? How is that even possible?" Just socket -> H.liftEffect $ WS.close socket WebSocketParseError error -> systemMessage $ renderError (UnknownError error) ConnectWebSocket -> do { wsUrl } <- H.get systemMessage ("Connecting to \"" <> wsUrl <> "\"...") webSocket <- H.liftEffect $ WS.create wsUrl [] H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer H.modify_ _ { wsConnection = Just webSocket } void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket) HandleAuthenticationInput authinp -> do case authinp of AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } } AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = v } } HandleRegisterInput reginp -> do case reginp of REG_INP_login v -> H.modify_ _ { registrationForm { login = v } } REG_INP_email v -> H.modify_ _ { registrationForm { email = v } } REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } } HandleAddUserInput adduserinp -> do case adduserinp of ADDUSER_INP_secret v -> H.modify_ _ { addUserForm { secretKey = v } } ADDUSER_INP_login v -> H.modify_ _ { addUserForm { login = v } } ADDUSER_INP_email v -> H.modify_ _ { addUserForm { email = v } } ADDUSER_INP_pass v -> H.modify_ _ { addUserForm { pass = v } } RegisterAttempt ev -> do H.liftEffect $ Event.preventDefault ev { wsConnection, registrationForm } <- H.get let login = registrationForm.login email = registrationForm.email pass = registrationForm.pass case wsConnection, login, email, pass of Nothing, _, _, _ -> unableToSend "Not connected to server." Just _, "", _, _ -> unableToSend "Write your login!" Just _, _, "", _ -> unableToSend "Write your email!" Just _, _, _, "" -> unableToSend "Write your password!" Just webSocket, _, _, _ -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> unableToSend "Still connecting to server." Closing -> unableToSend "Connection to server is closing." Closed -> do unableToSend "Connection to server has been closed." maybeCurrentConnection <- H.gets _.wsConnection when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } Open -> do H.liftEffect $ do ab <- AuthD.serialize $ AuthD.MkRegister { login: login , email: Just (Email.Email email) , password: pass , phone: Nothing} sendArrayBuffer webSocket ab appendMessageReset "[😇] Trying to register" AddUserAttempt ev -> do H.liftEffect $ Event.preventDefault ev { wsConnection, addUserForm } <- H.get let secret = addUserForm.secretKey login = addUserForm.login email = addUserForm.email pass = addUserForm.pass case wsConnection, secret, login, email, pass of Nothing, _, _, _, _ -> unableToSend "Not connected to server." Just _, "", _, _, _ -> unableToSend "Write your secret key!" Just _, _, "", _, _ -> unableToSend "Write your login!" Just _, _, _, "", _ -> unableToSend "Write your email!" Just _, _, _, _, "" -> unableToSend "Write your password!" Just webSocket, _, _, _, _ -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> unableToSend "Still connecting to server." Closing -> unableToSend "Connection to server is closing." Closed -> do unableToSend "Connection to server has been closed." maybeCurrentConnection <- H.gets _.wsConnection when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } Open -> do H.liftEffect $ do ab <- AuthD.serialize $ AuthD.MkAddUser { shared_key: secret , login: login , email: Just (Email.Email email) , password: pass , phone: Nothing} sendArrayBuffer webSocket ab appendMessageReset "[😇] Trying to add a user" AuthenticationAttempt ev -> do H.liftEffect $ Event.preventDefault ev { wsConnection, authenticationForm } <- H.get case wsConnection, authenticationForm.login, authenticationForm.pass of Nothing, _, _ -> unableToSend "Not connected to server." Just _ , "" , _ -> unableToSend "Write your login!" Just _ , _ , "" -> unableToSend "Write your password!" Just webSocket, login, pass -> do H.liftEffect (WS.readyState webSocket) >>= case _ of Connecting -> unableToSend "Still connecting to server." Closing -> unableToSend "Connection to server is closing." Closed -> do unableToSend "Connection to server has been closed." maybeCurrentConnection <- H.gets _.wsConnection when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } Open -> do H.liftEffect $ do ab <- AuthD.serialize (AuthD.MkGetToken { login: login, password: pass }) sendArrayBuffer webSocket ab appendMessageReset $ "[😇] Trying to connect with login: " <> login HandleWebSocket wsEvent -> case wsEvent of WebSocketMessage messageEvent -> do receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message case receivedMessage of -- Cases where we didn't understand the message. Left err -> do case err of (AuthD.JSONERROR jerr) -> do print_json_string messageEvent.message handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr) (AuthD.UnknownError unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr)) (AuthD.UnknownNumber ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber") -- Cases where we understood the message. Right response -> do case response of -- The authentication failed. (AuthD.GotError errmsg) -> do appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason -- The authentication was a success! (AuthD.GotToken msg) -> do appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token H.raise $ AuthToken msg.token -- WTH?! _ -> do appendMessage $ "[😈] Failed! Authentication server didn't send a valid message." WebSocketOpen -> do { wsUrl } <- H.get systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <> "\"!🎉") WebSocketClose { code, reason, wasClean } -> do systemMessage $ renderCloseMessage code wasClean reason maybeCurrentConnection <- H.gets _.wsConnection when (isJust maybeCurrentConnection) do H.modify_ _ { wsConnection = Nothing, canReconnect = true } WebSocketError errorType -> systemMessage $ renderError errorType where renderCloseMessage :: Int -> Boolean -> String -> String renderCloseMessage code wasClean = case _ of "" -> baseCloseMessage reason -> baseCloseMessage <> "Reason: " <> reason where baseCloseMessage :: String baseCloseMessage = String.joinWith " " [ "Connection to WebSocket closed" , "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]" ] 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 inputCSS = HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;" 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)) value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer appendMessage $ case (value) of Left _ -> "Cannot even fromTypedIPC the message." Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string