From 778a51604b60778e2d9eb895cbc28c3b5eede90b Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Mon, 22 May 2023 02:11:40 +0200 Subject: [PATCH] Authentication form: improved. --- src/App/AuthenticationForm.purs | 428 +++++++++++++++++++++ src/App/Messages/AuthenticationDaemon.purs | 87 ++--- 2 files changed, 470 insertions(+), 45 deletions(-) create mode 100644 src/App/AuthenticationForm.purs diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs new file mode 100644 index 0000000..d68b101 --- /dev/null +++ b/src/App/AuthenticationForm.purs @@ -0,0 +1,428 @@ +module App.AuthenticationForm where + +import Prelude + +import Control.Monad.Except (runExcept) +import Control.Monad.State (class MonadState) +import Data.Array as A +import Data.Bifunctor (lmap) +-- import Data.Codec.Argonaut (JsonCodec, JsonDecodeError) +-- import Data.Codec.Argonaut as CA +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.Aff (awaitBody, runHalogenAff) as HA +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 Halogen.VDom.Driver (runUI) +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 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 + = MessageIsServerAdvertisement String + | UnknownError String + | UnknownWebSocketError + +renderError :: ErrorType -> String +renderError = case _ of + UnknownError str -> + "Unknown error: " <> str + MessageIsServerAdvertisement str -> + "Received following advertisment from server: " <> str + UnknownWebSocketError -> + "Unknown 'error' event has been fired by WebSocket event listener" + +-------------------------------------------------------------------------------- +-- `Main` function +-------------------------------------------------------------------------------- + +main :: Effect Unit +main = do + HA.runHalogenAff do + body <- HA.awaitBody + let url = "ws://localhost:8080" + runUI rootComponent url body + +-------------------------------------------------------------------------------- +-- WebSocket message type +-------------------------------------------------------------------------------- + +type WebSocketMessageType = ArrayBuffer + +-------------------------------------------------------------------------------- +-- Root component module +-------------------------------------------------------------------------------- + +type Query :: forall k. k -> Type +type Query = Const Void +type Input = String +type Output = Void + +data Action + = Initialize + | WebSocketParseError String + | ConnectWebSocket + | HandleLoginInputUpdate String + | HandlePassInputUpdate String + | AuthenticationAttempt Event + | HandleWebSocket (WebSocketEvent WebSocketMessageType) + +type State = + { messages :: Array String + , messageHistoryLength :: Int + , loginInputText :: String + , passInputText :: String + , wsUrl :: String + , wsConnection :: Maybe WS.WebSocket + , canReconnect :: Boolean + } + +rootComponent :: forall m. MonadAff m => H.Component Query Input Output m +rootComponent = + H.mkComponent + { initialState + , render + , eval: H.mkEval $ H.defaultEval + { initialize = Just Initialize + , handleAction = handleAction + } + } + +initialState :: Input -> State +initialState input = + { messages: [] + , messageHistoryLength: 10 + , loginInputText: "" + , passInputText: "" + , 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, loginInputText, passInputText, wsConnection, canReconnect, messageHistoryLength } = + HH.div + [ HP.style wrapperStyle ] + [ HH.h2_ [ HH.text "Authentication!" ] + , HH.form + [ HE.onSubmit AuthenticationAttempt ] + [ HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages + , HH.p_ + [ HH.div_ + [ HH.input + [ HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;" + , HP.type_ HP.InputText + , HP.value loginInputText + , HE.onValueInput HandleLoginInputUpdate + , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection + ] + ] + , HH.div_ + [ HH.input + [ HP.style "padding: 0.5rem 0.75rem; margin-bottom: 0.25rem;" + , HP.type_ HP.InputText + , HP.value passInputText + , HE.onValueInput HandlePassInputUpdate + , 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" ] + ] + ] + , renderMaxHistoryLength messageHistoryLength + , renderReconnectButton (isNothing wsConnection && canReconnect) + ] + ] + where + 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" + , renderFootnote "NOTE: You can type /disconnect to manually disconnect" + ] + +handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit +handleAction = case _ of + Initialize -> + handleAction ConnectWebSocket + + 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) + + HandleLoginInputUpdate text -> do + H.modify_ _ { loginInputText = text } + + HandlePassInputUpdate text -> do + H.modify_ _ { passInputText = text } + + AuthenticationAttempt ev -> do + H.liftEffect $ Event.preventDefault ev + + { wsConnection, loginInputText, passInputText } <- H.get + + case wsConnection, loginInputText, passInputText 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 + Left _ -> do + handleAction $ WebSocketParseError "Generic parsing error, TODO." + Right response -> do + case response of + (AuthD.GotError _) -> do + appendMessage $ "[😈] Failed! (TODO: put the reason)" + (AuthD.GotToken msg) -> + appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token + _ -> do + appendMessage $ "[😈] Failed! Don't understand the answer received!" + + 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, loginInputText = "" } + 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 diff --git a/src/App/Messages/AuthenticationDaemon.purs b/src/App/Messages/AuthenticationDaemon.purs index 63849e2..9a24a6f 100644 --- a/src/App/Messages/AuthenticationDaemon.purs +++ b/src/App/Messages/AuthenticationDaemon.purs @@ -30,7 +30,7 @@ import App.IPC as IPC - 7 type UpdatePassword = { login :: String, old_password :: String, new_password :: String } - 8 type ListUsers = { token :: Maybe String, key :: Maybe String } - 9 type CheckPermission = { shared_key :: Maybe String, token :: Maybe String, user :: Int32 | String, service :: String, resource :: String } - - 10 type SetPermission = { shared_key :: String, user :: Int32 | String, service :: String, resource :: String, permission :: ::AuthD::User::PermissionLevel } + - 10 type SetPermission = { shared_key :: String, user :: Int32 | String, service :: String, resource :: String, permission :: AuthD::User::PermissionLevel } - 11 type PasswordRecovery = { user :: Int32 | String, password_renew_key :: String, new_password :: String } - 12 type AskPasswordRecovery = { user :: Int32 | String, email :: String } - 13 type SearchUser = { user :: String } @@ -43,17 +43,15 @@ import App.IPC as IPC -- Deletion can be triggered by either an admin or the user. Possible answers: - - 0 type Error = { reason :: Maybe String } - - 1 type Token = { uid :: Int32, token :: String } - - 2 type User = { user :: ::AuthD::User::Public } - - 3 type UserAdded = { user :: ::AuthD::User::Public } + - 2 type User = { user :: AuthD::User::Public } + - 3 type UserAdded = { user :: AuthD::User::Public } - 4 type UserEdited = { uid :: Int32 } - - 5 type UserValidated = { user :: ::AuthD::User::Public } + - 5 type UserValidated = { user :: AuthD::User::Public } - 6 type UsersList = { users :: Array(::AuthD::User::Public) } - - 7 type PermissionCheck = { user :: Int32, service :: String, resource :: String, permission :: ::AuthD::User::PermissionLevel } - - 8 type PermissionSet = { user :: Int32, service :: String, resource :: String, permission :: ::AuthD::User::PermissionLevel } - - 9 type PasswordRecoverySent = { user :: ::AuthD::User::Public } - - 10 type PasswordRecovered = { user :: ::AuthD::User::Public } + - 7 type PermissionCheck = { user :: Int32, service :: String, resource :: String, permission :: AuthD::User::PermissionLevel } + - 8 type PermissionSet = { user :: Int32, service :: String, resource :: String, permission :: AuthD::User::PermissionLevel } + - 9 type PasswordRecoverySent = { user :: AuthD::User::Public } + - 10 type PasswordRecovered = { user :: AuthD::User::Public } - 11 type MatchingUsers = { users :: Array(::AuthD::User::Public) } - 12 type Contacts = { user :: Int32, email :: Maybe String, phone :: Maybe String } @@ -71,38 +69,38 @@ type GetToken = { login :: String, password :: String } -- All possible requests. data RequestMessage = MkGetToken GetToken -- 0 - --| MkAddUser -- 1 - --| MkValidateUser -- 2 - --| MkGetUser -- 3 - --| MkGetUserByCredentials -- 4 - --| MkRegister -- 6 - --| MkUpdatePassword -- 7 - --| MkListUsers -- 8 - --| MkCheckPermission -- 9 - --| MkSetPermission -- 10 - --| MkPasswordRecovery -- 11 - --| MkAskPasswordRecovery -- 12 - --| MkSearchUser -- 13 - --| MkEditProfile -- 14 - --| MkEditProfileContent -- 15 - --| MkEditContacts -- 16 - --| MkDelete -- 17 - --| MkGetContacts -- 18 + --| MkAddUser AddUser -- 1 + --| MkValidateUser ValidateUser -- 2 + --| MkGetUser GetUser -- 3 + --| MkGetUserByCredentials GetUserByCredentials -- 4 + --| MkRegister Register -- 6 + --| MkUpdatePassword UpdatePassword -- 7 + --| MkListUsers ListUsers -- 8 + --| MkCheckPermission CheckPermission -- 9 + --| MkSetPermission SetPermission -- 10 + --| MkPasswordRecovery PasswordRecovery -- 11 + --| MkAskPasswordRecovery AskPasswordRecovery -- 12 + --| MkSearchUser SearchUser -- 13 + --| MkEditProfile EditProfile -- 14 + --| MkEditProfileContent EditProfileContent -- 15 + --| MkEditContacts EditContacts -- 16 + --| MkDelete Delete -- 17 + --| MkGetContacts GetContacts -- 18 -- All possible answers from the authentication daemon (authd). data AnswerMessage = GotError Error -- 0 | GotToken Token -- 1 - -- | GotUser -- 2 - -- | GotUserAdded -- 3 - -- | GotUserEdited -- 4 - -- | GotUserValidated -- 5 - -- | GotUsersList -- 6 - -- | GotPermissionCheck -- 7 - -- | GotPermissionSet -- 8 - -- | GotPasswordRecoverySent -- 9 - -- | GotPasswordRecovered -- 10 - -- | GotMatchingUsers -- 11 + -- | GotUser User -- 2 + -- | GotUserAdded UserAdded -- 3 + -- | GotUserEdited UserEdited -- 4 + -- | GotUserValidated UserValidated -- 5 + -- | GotUsersList UsersList -- 6 + -- | GotPermissionCheck PermissionCheck -- 7 + -- | GotPermissionSet PermissionSet -- 8 + -- | GotPasswordRecoverySent PasswordRecoverySent-- 9 + -- | GotPasswordRecovered PasswordRecovered -- 10 + -- | GotMatchingUsers MatchingUsers -- 11 | GotContacts Contacts -- 12 encode ∷ RequestMessage -> Tuple UInt String @@ -142,16 +140,15 @@ decode number json 1 -> error_management codecGotToken GotToken 12 -> error_management codecGotContacts GotContacts _ -> Left UnknownNumber - -- 1 type Token = { uid :: Int32, token :: String } - -- 2 type User = { user :: ::AuthD::User::Public } - -- 3 type UserAdded = { user :: ::AuthD::User::Public } + -- 2 type User = { user :: AuthD::User::Public } + -- 3 type UserAdded = { user :: AuthD::User::Public } -- 4 type UserEdited = { uid :: Int32 } - -- 5 type UserValidated = { user :: ::AuthD::User::Public } + -- 5 type UserValidated = { user :: AuthD::User::Public } -- 6 type UsersList = { users :: Array(::AuthD::User::Public) } - -- 7 type PermissionCheck = { user :: Int32, service :: String, resource :: String, permission :: ::AuthD::User::PermissionLevel } - -- 8 type PermissionSet = { user :: Int32, service :: String, resource :: String, permission :: ::AuthD::User::PermissionLevel } - -- 9 type PasswordRecoverySent = { user :: ::AuthD::User::Public } - -- 10 type PasswordRecovered = { user :: ::AuthD::User::Public } + -- 7 type PermissionCheck = { user :: Int32, service :: String, resource :: String, permission :: AuthD::User::PermissionLevel } + -- 8 type PermissionSet = { user :: Int32, service :: String, resource :: String, permission :: AuthD::User::PermissionLevel } + -- 9 type PasswordRecoverySent = { user :: AuthD::User::Public } + -- 10 type PasswordRecovered = { user :: AuthD::User::Public } -- 11 type MatchingUsers = { users :: Array(::AuthD::User::Public) } where -- Signature is required since the compiler's guess is wrong.