Remove printing messages in AuthenticationDaemonAdminInterface.

src/App/AuthenticationDaemonAdminInterface.purs

@@ -4,20 +4,14 @@ module App.AuthenticationDaemonAdminInterface where
    This interface should allow to:
      - TODO: add, remove, search, validate users
      - TODO: raise a user to admin
-
-   TODO: authenticate
 -}
 
-import Prelude (Unit, Void, bind, discard, map, not, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=))
+import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>))
 
 import Bulma as Bulma
 
-import Control.Monad.State (class MonadState)
-import Data.Tuple (Tuple(..))
-import Data.Const (Const)
 import Data.Either (Either(..))
-import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
+import Data.Maybe (Maybe(..), maybe)
-import Data.String as String
 import Effect.Aff.Class (class MonadAff)
 import Halogen as H
 import Halogen.HTML as HH
@@ -25,30 +19,25 @@ import Halogen.HTML.Events as HE
 import Halogen.HTML.Properties as HP
 import Web.Event.Event (Event)
 import Web.Event.Event as Event
-import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
-import Web.Socket.WebSocket as WS
 
-import Effect.Class (class MonadEffect)
+import Data.ArrayBuffer.Types (ArrayBuffer)
 
 import App.Utils
-import App.IPC as IPC
+-- import App.IPC as IPC
 import App.Email as Email
 
 import App.Messages.AuthenticationDaemon as AuthD
 
-import Data.ArrayBuffer.Types (ArrayBuffer)
+data Output
-import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
+  = MessageToSend ArrayBuffer
+  | AppendMessage String
+  | SystemMessage String
+  | UnableToSend String
 
---------------------------------------------------------------------------------
+data Query a = MessageReceived ArrayBuffer a
--- Root component module
---------------------------------------------------------------------------------
-
-data Output = Void
 type Slot = H.Slot Query Output
 
-type Query :: forall k. k -> Type
+type Input = Unit
-type Query = Const Void
-type Input = String
 
 data AddUserInput
   = ADDUSER_INP_login String
@@ -57,32 +46,19 @@ data AddUserInput
   | ADDUSER_INP_pass String
 
 data Action
-  = Initialize
+  = WebSocketParseError String
-  | WebSocketParseError String
-  | ConnectWebSocket
 
   | HandleAddUserInput AddUserInput
 
   | AddUserAttempt
   -- | Finalize
-  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
   | PreventSubmit Event
 
 type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
 
-type WSInfo
-  = { url        :: String
-    , connection :: Maybe WS.WebSocket
-    , reconnect  :: Boolean
-    }
-
 type State =
-  { messages               :: Array String
+  { addUserForm  :: StateAddUserForm
-  , messageHistoryLength   :: Int
+  , wsUp         :: Boolean
-
-  , addUserForm            :: StateAddUserForm
-
-  , wsInfo                 :: WSInfo
   }
 
 component :: forall m. MonadAff m => H.Component Query Input Output m
@@ -91,35 +67,19 @@ component =
     { initialState
     , render
     , eval: H.mkEval $ H.defaultEval
-        { initialize = Just Initialize
+        { handleAction = handleAction
-        , handleAction = handleAction
+        , handleQuery = handleQuery
         -- , finalize = Just Finalize
         }
     }
 
 initialState :: Input -> State
-initialState input =
+initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }, wsUp: true }
-  { messages: []
-  , messageHistoryLength: 10
-
-  , addUserForm: { login: "", admin: false, email: "", pass: "" }
-
-  , wsInfo: { url: input
-            , connection: Nothing
-            , reconnect: false
-            }
-  }
 
 render :: forall m. State -> H.ComponentHTML Action () m
-render {
+render { addUserForm, wsUp }
-  messages,
-  wsInfo,
-  addUserForm }
     = HH.div_
        [ Bulma.columns_ [ Bulma.column_ adduser_form ]
-       , render_messages
-       --, renderMaxHistoryLength messageHistoryLength
-       , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
        ]
     where
 
@@ -128,7 +88,7 @@ render {
           , render_adduser_form
           ]
 
-      should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection)
+      should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
 
       render_adduser_form = HH.form
         [ HE.onSubmit PreventSubmit ]
@@ -156,55 +116,16 @@ render {
             [ HP.style "padding: 0.5rem 1.25rem;"
             , HP.type_ HP.ButtonSubmit
             , HE.onClick \ _ -> AddUserAttempt
-            , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
+            , (if wsUp then (HP.enabled true) else (HP.disabled true))
             ]
             [ 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
-  --   { wsInfo } <- H.get
-  --   systemMessage "Finalize"
-  --   case wsInfo.connection of
-  --     Nothing -> systemMessage "No socket? How is that even possible?"
-  --     Just socket -> H.liftEffect $ WS.close socket
 
   WebSocketParseError error ->
-    systemMessage $ renderError (UnknownError error)
+    H.raise $ SystemMessage $ renderError (UnknownError error)
-
-  ConnectWebSocket -> do
-    { wsInfo } <- H.get
-    systemMessage ("Connecting to \"" <> wsInfo.url <>  "\"...")
-    webSocket <- H.liftEffect $ WS.create wsInfo.url []
-    H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
-    H.modify_ _ { wsInfo { connection = Just webSocket } }
-    void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
 
   HandleAddUserInput adduserinp -> do
     { addUserForm } <- H.get
@@ -217,111 +138,65 @@ handleAction = case _ of
   PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
 
   AddUserAttempt -> do
-    { wsInfo, addUserForm } <- H.get
+    { addUserForm } <- H.get
     let login  = addUserForm.login
         email  = addUserForm.email
         pass   = addUserForm.pass
 
-    case wsInfo.connection, login, email, pass of
+    case login, email, pass of
-      Nothing, _, _,  _ ->
+      "", _, _ ->
-        unableToSend "Not connected to server."
+        H.raise $ UnableToSend "Write the user's login!"
 
-      Just _, "", _, _ ->
+      _, "", _ ->
-        unableToSend "Write the user's login!"
+        H.raise $ UnableToSend "Write the user's email!"
 
-      Just _, _, "", _ ->
+      _, _, "" ->
-        unableToSend "Write the user's email!"
+        H.raise $ UnableToSend "Write the user's password!"
 
-      Just _, _, _, "" ->
+      _, _, _ -> do
-        unableToSend "Write the user's password!"
+        ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkAddUser { login: login
+                                                , admin: addUserForm.admin
+                                                , email: Just (Email.Email email)
+                                                , password: pass }
+        H.raise $ MessageToSend ab
+        H.raise $ AppendMessage "[😇] Trying to add a user"
 
-      Just webSocket, _, _, _ -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
 
-          Closing ->
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
-            unableToSend "Connection to server is closing."
+handleQuery = case _ of
 
-          Closed -> do
+  MessageReceived message a -> do
-            unableToSend "Connection to server has been closed."
+    receivedMessage <- H.liftEffect $ AuthD.deserialize message
-            maybeCurrentConnection <- H.gets _.wsInfo.connection
+    case receivedMessage of
-            when (isJust maybeCurrentConnection) do
+        -- Cases where we didn't understand the message.
-              H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
+        Left _ -> do
+          H.raise $ SystemMessage $ "Received a message that could not be deserialized."
+          pure Nothing
+          --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")
 
-          Open -> do
+        -- Cases where we understood the message.
-            H.liftEffect $ do
+        Right response -> do
-              ab <- AuthD.serialize $ AuthD.MkAddUser { login: login
+          case response of
-                                                      , admin: addUserForm.admin
+            (AuthD.GotError errmsg) -> do
-                                                      , email: Just (Email.Email email)
+              H.raise $ AppendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
-                                                      , password: pass }
+              pure (Just a)
-              sendArrayBuffer webSocket ab
+            (AuthD.GotUserAdded msg) -> do
-            appendMessage "[😇] Trying to add a user"
+              H.raise $ AppendMessage $ "[😈] Success! Server added user: " <> show msg.user
+              pure (Just a)
+            -- WTH?!
+            _ -> do
+              H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
+              pure (Just a)
 
-  HandleWebSocket wsEvent ->
+----print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
-    case wsEvent of
+--print_json_string arraybuffer = do
-      WebSocketMessage messageEvent -> do
+--  -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-        receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
+--  value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-        case receivedMessage of
+--  H.raise $ AppendMessage $ case (value) of
-            -- Cases where we didn't understand the message.
+--    Left _ -> "Cannot even fromTypedIPC the message."
-            Left err -> do
+--    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
-              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
-        { wsInfo } <- H.get
-        systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <>  "\"!🎉")
-
-      WebSocketClose { code, reason, wasClean } -> do
-        systemMessage $ renderCloseMessage code wasClean reason
-        maybeCurrentConnection <- H.gets _.wsInfo.connection
-        when (isJust maybeCurrentConnection) do
-          H.modify_ _ { wsInfo { connection = Nothing, reconnect = 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"
-        , "]"
-        ]
-
-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/Container.purs

@@ -17,9 +17,10 @@ import Type.Proxy (Proxy(..))
 import Effect.Aff.Class (class MonadAff)
 
 data Action
-  = OutputAuthComponent  AF.Output  -- User has been authenticated.
+  = OutputAuthComponent       AF.Output
-  | AuthDEvent           WS.Output  -- Events from authd.
+  | OutputAuthAdminComponent  AAI.Output -- Admin interface.
-  | DNSManagerDEvent     WS.Output  -- Events from dnsmanagerd.
+  | AuthDEvent                WS.Output  -- Events from authd.
+  | DNSManagerDEvent          WS.Output  -- Events from dnsmanagerd.
 
 type State = { token :: Maybe String
              , uid :: Maybe Int
@@ -91,7 +92,7 @@ render state
     render_authd_admin_interface = Bulma.box $ case state.token of
       Just _ ->
         [ Bulma.h1 "Administrative interface for authd"
-        , HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8080"
+        , HH.slot _aai unit AAI.component unit OutputAuthAdminComponent
         ]
       Nothing -> [ Bulma.p "Here will be the administrative box." ]
 
@@ -112,6 +113,12 @@ handleAction = case _ of
    AF.SystemMessage message         -> H.tell _log unit (Log.SystemLog message)
    AF.UnableToSend  message         -> H.tell _log unit (Log.UnableToSend message)
 
+  OutputAuthAdminComponent ev -> case ev of
+   AAI.MessageToSend message        -> H.tell _ws_auth unit (WS.ToSend message)
+   AAI.AppendMessage message        -> H.tell _log unit (Log.SimpleLog message)
+   AAI.SystemMessage message        -> H.tell _log unit (Log.SystemLog message)
+   AAI.UnableToSend  message        -> H.tell _log unit (Log.UnableToSend message)
+
   -- TODO: depending on the current page, we should provide the received message to
   --       different components.
   AuthDEvent ev -> case ev of