diff --git a/src/App/AuthenticationDaemonAdminInterface.purs b/src/App/AuthenticationDaemonAdminInterface.purs index b21bd95..b07f95c 100644 --- a/src/App/AuthenticationDaemonAdminInterface.purs +++ b/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.String as String +import Data.Maybe (Maybe(..), maybe) 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) -import Web.Socket.BinaryType (BinaryType(ArrayBuffer)) +data Output + = MessageToSend ArrayBuffer + | AppendMessage String + | SystemMessage String + | UnableToSend String --------------------------------------------------------------------------------- --- Root component module --------------------------------------------------------------------------------- - -data Output = Void +data Query a = MessageReceived ArrayBuffer a type Slot = H.Slot Query Output -type Query :: forall k. k -> Type -type Query = Const Void -type Input = String +type Input = Unit data AddUserInput = ADDUSER_INP_login String @@ -57,32 +46,19 @@ data AddUserInput | ADDUSER_INP_pass String data Action - = Initialize - | WebSocketParseError String - | ConnectWebSocket + = WebSocketParseError String | 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 - , messageHistoryLength :: Int - - , addUserForm :: StateAddUserForm - - , wsInfo :: WSInfo + { addUserForm :: StateAddUserForm + , wsUp :: Boolean } 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 = - { messages: [] - , messageHistoryLength: 10 - - , addUserForm: { login: "", admin: false, email: "", pass: "" } - - , wsInfo: { url: input - , connection: Nothing - , reconnect: false - } - } +initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }, wsUp: true } render :: forall m. State -> H.ComponentHTML Action () m -render { - messages, - wsInfo, - addUserForm } +render { addUserForm, wsUp } = 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) - - 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) + H.raise $ SystemMessage $ renderError (UnknownError error) 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 - Nothing, _, _, _ -> - unableToSend "Not connected to server." + case login, email, pass of + "", _, _ -> + 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 _, _, _, "" -> - unableToSend "Write the user's password!" + _, _, _ -> do + 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 -> - unableToSend "Connection to server is closing." +handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) +handleQuery = case _ of - Closed -> do - unableToSend "Connection to server has been closed." - maybeCurrentConnection <- H.gets _.wsInfo.connection - when (isJust maybeCurrentConnection) do - H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } } + MessageReceived message a -> do + receivedMessage <- H.liftEffect $ AuthD.deserialize message + case receivedMessage of + -- Cases where we didn't understand the message. + 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 - H.liftEffect $ do - ab <- AuthD.serialize $ AuthD.MkAddUser { login: login - , admin: addUserForm.admin - , email: Just (Email.Email email) - , password: pass } - sendArrayBuffer webSocket ab - appendMessage "[😇] Trying to add a user" + -- Cases where we understood the message. + Right response -> do + case response of + (AuthD.GotError errmsg) -> do + H.raise $ AppendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason + pure (Just a) + (AuthD.GotUserAdded msg) -> do + 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 -> - 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 - { 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 +----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 +-- H.raise $ 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/Container.purs b/src/App/Container.purs index 1927235..ab7e5e8 100644 --- a/src/App/Container.purs +++ b/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. - | AuthDEvent WS.Output -- Events from authd. - | DNSManagerDEvent WS.Output -- Events from dnsmanagerd. + = OutputAuthComponent AF.Output + | OutputAuthAdminComponent AAI.Output -- Admin interface. + | 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