module App.AuthenticationForm where import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=), pure, unit) 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 Effect.Aff.Class (class MonadAff) import Halogen as H import Halogen.HTML as HH import Halogen.HTML.Events as HE import Halogen.HTML.Properties as HP import Web.Event.Event (Event) import Web.Event.Event as Event 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) data Output = AuthToken (Tuple Int String) | MessageToSend ArrayBuffer | AppendMessage String | SystemMessage String | UnableToSend String data Query a = MessageReceived ArrayBuffer a type Slot = H.Slot Query Output type Input = Unit data AuthenticationInput = AUTH_INP_login String | AUTH_INP_pass String data RegisterInput = REG_INP_login String | REG_INP_email String | REG_INP_pass String data Action = Initialize -- | WebSocketParseError String -- | ConnectWebSocket | HandleAuthenticationInput AuthenticationInput | HandleRegisterInput RegisterInput | AuthenticationAttempt Event | RegisterAttempt Event | Finalize --| HandleWebSocket (WebSocketEvent WebSocketMessageType) type StateAuthenticationForm = { login :: String, pass :: String } type StateRegistrationForm = { login :: String, email :: String, pass :: String } type State = { authenticationForm :: StateAuthenticationForm , registrationForm :: StateRegistrationForm , wsUp :: 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 , handleQuery = handleQuery , finalize = Just Finalize } } initialState :: Input -> State initialState _ = { authenticationForm: { login: "", pass: "" } , registrationForm: { login: "", email: "", pass: "" } , wsUp: true } render :: forall m. State -> H.ComponentHTML Action () m render { wsUp, authenticationForm, registrationForm } = HH.div_ [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ] ] where auth_form = [ Bulma.h3 "Authentication" , render_auth_form ] register_form = [ Bulma.h3 "Register!" , render_register_form ] should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true)) render_auth_form = HH.form [ HE.onSubmit AuthenticationAttempt ] [ Bulma.box_input "Login" "login" -- title, placeholder (HandleAuthenticationInput <<< AUTH_INP_login) -- action authenticationForm.login -- value true -- validity (TODO) should_be_disabled -- condition , Bulma.box_password "Password" "password" -- title, placeholder (HandleAuthenticationInput <<< AUTH_INP_pass) -- action authenticationForm.pass -- value true -- validity (TODO) should_be_disabled -- condition , HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , (if wsUp then (HP.enabled true) else (HP.disabled true)) ] [ HH.text "Send Message to Server" ] ] render_register_form = HH.form [ HE.onSubmit RegisterAttempt ] [ Bulma.box_input "Login" "login" -- title, placeholder (HandleRegisterInput <<< REG_INP_login) -- action registrationForm.login -- value true -- validity (TODO) should_be_disabled -- condition , Bulma.box_input "Email" "email@example.com" -- title, placeholder (HandleRegisterInput <<< REG_INP_email) -- action registrationForm.email -- value true -- validity (TODO) should_be_disabled -- condition , Bulma.box_password "Password" "password" -- title, placeholder (HandleRegisterInput <<< REG_INP_pass) -- action registrationForm.pass -- value true -- validity (TODO) should_be_disabled -- condition , HH.div_ [ HH.button [ HP.style "padding: 0.5rem 1.25rem;" , HP.type_ HP.ButtonSubmit , (if wsUp then (HP.enabled true) else (HP.disabled true)) ] [ HH.text "Send Message to Server" ] ] ] handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit handleAction = case _ of Initialize -> H.raise $ SystemMessage "Authentication form initialized." Finalize -> H.raise $ SystemMessage "Removing the authentication form." HandleAuthenticationInput authinp -> do case authinp of AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } } AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = v } } HandleRegisterInput reginp -> do case reginp of REG_INP_login v -> H.modify_ _ { registrationForm { login = v } } REG_INP_email v -> H.modify_ _ { registrationForm { email = v } } REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } } RegisterAttempt ev -> do H.liftEffect $ Event.preventDefault ev { registrationForm } <- H.get let login = registrationForm.login email = registrationForm.email pass = registrationForm.pass case login, email, pass of "", _, _ -> H.raise $ UnableToSend "Write your login!" _, "", _ -> H.raise $ UnableToSend "Write your email!" _, _, "" -> H.raise $ UnableToSend "Write your password!" _, _, _ -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkRegister { login: login , email: Just (Email.Email email) , password: pass } H.raise $ MessageToSend message H.raise $ AppendMessage "[😇] Trying to register" AuthenticationAttempt ev -> do H.liftEffect $ Event.preventDefault ev { authenticationForm } <- H.get case authenticationForm.login, authenticationForm.pass of "" , _ -> H.raise $ UnableToSend "Write your login!" _ , "" -> H.raise $ UnableToSend "Write your password!" login, pass -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass } H.raise $ MessageToSend message H.raise $ AppendMessage $ "[😇] Trying to connect with login: " <> login handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery = case _ of MessageReceived message a -> do receivedMessage <- H.liftEffect $ AuthD.deserialize message case receivedMessage of -- Cases where we didn't understand the message. Left _ -> 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") -- Cases where we understood the message. Right response -> do case response of -- The authentication failed. (AuthD.GotError errmsg) -> do H.raise $ AppendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason pure (Just a) -- The authentication was a success! (AuthD.GotToken msg) -> do H.raise $ AppendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token H.raise $ AuthToken (Tuple msg.uid msg.token) pure (Just a) -- WTH?! _ -> do H.raise $ AppendMessage $ "[😈] Failed! Authentication server didn't send a valid message." pure Nothing --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