Administrative interface for authd now in a new container.

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

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,
+  registrationForm }
-  addUserForm }
     = 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
 

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