From 3831b275b43a0a848b98d88cd08990fcb94f6283 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Thu, 8 Jun 2023 18:13:59 +0200 Subject: [PATCH] Administrative interface for authd now in a new container. --- .../AuthenticationDaemonAdminInterface.purs | 505 ++++++++++++++++++ src/App/AuthenticationForm.purs | 126 +---- src/App/Container.purs | 16 +- 3 files changed, 521 insertions(+), 126 deletions(-) create mode 100644 src/App/AuthenticationDaemonAdminInterface.purs diff --git a/src/App/AuthenticationDaemonAdminInterface.purs b/src/App/AuthenticationDaemonAdminInterface.purs new file mode 100644 index 0000000..c9b68cd --- /dev/null +++ b/src/App/AuthenticationDaemonAdminInterface.purs @@ -0,0 +1,505 @@ +module App.AuthenticationDaemonAdminInterface where + +{- Administration interface for the authentication daemon. + This interface should allow to: + - TODO: add, remove, search, validate users + - TODO: raise a user to admin +-} + +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 = Void +type Slot = H.Slot Query Output + +type Query :: forall k. k -> Type +type Query = Const Void +type Input = 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 + + | HandleAddUserInput AddUserInput + + | 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 + + , 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 + + , 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, + addUserForm } + = HH.div + [ HP.style wrapperStyle ] + [ render_adduser_form + , render_messages + --, renderMaxHistoryLength messageHistoryLength + , renderReconnectButton (isNothing wsConnection && canReconnect) + ] + where + + 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 ] ] + + 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) + + 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 } } + + 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" + + 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 + (AuthD.GotUserAdded msg) -> do + appendMessage $ "[😈] Success! Server added user: " <> show msg.user + -- 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, 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 + +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 diff --git a/src/App/AuthenticationForm.purs b/src/App/AuthenticationForm.purs index a4d4266..1bfdcb6 100644 --- a/src/App/AuthenticationForm.purs +++ b/src/App/AuthenticationForm.purs @@ -141,12 +141,6 @@ data RegisterInput | 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 @@ -154,17 +148,14 @@ data Action | 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 @@ -172,7 +163,6 @@ type State = , authenticationForm :: StateAuthenticationForm , registrationForm :: StateRegistrationForm - , addUserForm :: StateAddUserForm -- TODO: put network stuff in a record. , wsUrl :: String @@ -199,7 +189,6 @@ initialState input = , authenticationForm: { login: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" } - , addUserForm: { secretKey: "", login: "", email: "", pass: "" } -- TODO: put network stuff in a record. , wsUrl: input @@ -227,13 +216,11 @@ render { canReconnect, authenticationForm, - registrationForm, - addUserForm } + registrationForm } = HH.div [ HP.style wrapperStyle ] [ render_auth_form , render_register_form - , render_adduser_form , render_messages --, renderMaxHistoryLength messageHistoryLength , renderReconnectButton (isNothing wsConnection && canReconnect) @@ -315,67 +302,12 @@ render { ] ] - 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 @@ -426,13 +358,6 @@ handleAction = case _ of 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 @@ -477,55 +402,6 @@ handleAction = case _ of 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 diff --git a/src/App/Container.purs b/src/App/Container.purs index d9701ab..0cc998f 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -4,6 +4,7 @@ import Prelude import Data.Maybe (Maybe(..)) import App.AuthenticationForm as AF +import App.AuthenticationDaemonAdminInterface as AAI import Halogen as H import Halogen.HTML as HH -- import Halogen.HTML.Events as HE @@ -17,10 +18,12 @@ data Action type State = { token :: Maybe String } type ChildSlots = - ( af :: AF.Slot Unit + ( af :: AF.Slot Unit + , aai :: AAI.Slot Unit ) _af = Proxy :: Proxy "af" +_aai = Proxy :: Proxy "aai" component :: forall q i o m. MonadAff m => H.Component q i o m component = @@ -37,6 +40,7 @@ render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m render state = HH.div_ $ [ render_auth_form + , render_authd_admin_interface , div_token ] where @@ -57,6 +61,16 @@ render state [ HP.class_ (H.ClassName "box") ] [ HH.p_ [ HH.text ("Token is: " <> current_token) ] ] + render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + render_authd_admin_interface = case state.token of + Just _ -> HH.div + [ HP.class_ (H.ClassName "box") ] + [ HH.h1_ [ HH.text "Administrative interface for authd" ] + , HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8081" + ] + Nothing -> HH.div + [ HP.class_ (H.ClassName "box") ] + [ HH.p_ [ HH.text ("Here will be the administrative box.") ] ] handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit handleAction = case _ of