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.LogMessage import App.Messages.AuthenticationDaemon as AuthD import Data.ArrayBuffer.Types (ArrayBuffer) data Output = AuthToken (Tuple Int String) | MessageToSend ArrayBuffer | Log LogMessage data Query a = MessageReceived ArrayBuffer a | ConnectionIsDown a | ConnectionIsUp 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 = HandleAuthenticationInput AuthenticationInput | HandleRegisterInput RegisterInput -- | AuthenticationAttempt Event | RegisterAttempt Event 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 { handleAction = handleAction , handleQuery = handleQuery } } 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 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 $ Log $ UnableToSend "Write your login!" _, "", _ -> H.raise $ Log $ UnableToSend "Write your email!" _, _, "" -> H.raise $ Log $ 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 $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")" AuthenticationAttempt ev -> do H.liftEffect $ Event.preventDefault ev { authenticationForm } <- H.get case authenticationForm.login, authenticationForm.pass of "" , _ -> H.raise $ Log $ UnableToSend "Write your login!" _ , "" -> H.raise $ Log $ UnableToSend "Write your password!" login, pass -> do message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login: login, password: pass } H.raise $ MessageToSend message H.raise $ Log $ SimpleLog $ "[😇] Trying to authenticate (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 $ Log $ SimpleLog $ "[😈] 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 $ Log $ SimpleLog $ "[🎉] Authenticated to authd!" H.raise $ AuthToken (Tuple msg.uid msg.token) pure (Just a) -- WTH?! _ -> do H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message." pure Nothing ConnectionIsDown a -> do H.modify_ _ { wsUp = false } pure (Just a) ConnectionIsUp a -> do H.modify_ _ { wsUp = true } pure (Just a) --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 $ Log $ SimpleLog $ case (value) of -- Left _ -> "Cannot even fromTypedIPC the message." -- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string