halogen-websocket-ipc-playzone/src/App/AuthenticationForm.purs

261 lines
9.5 KiB
Plaintext

-- | `App.AuthenticationForm` is both the authentication and registration interface.
module App.AuthenticationForm where
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>))
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple (Tuple(..))
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 as Event
import Web.Event.Event (Event)
import Bulma as Bulma
import App.Email as Email
import App.LogMessage
import App.Messages.AuthenticationDaemon as AuthD
-- | The component can inform the parent (`App.Container`) that the authentication is complete,
-- | and share both the uid and token. The token is useful to authenticate the user to the
-- | dnsmanager daemon.
-- |
-- | Also, the component can send a message to a websocket and log messages.
data Output
= AuthToken (Tuple Int String)
| MessageToSend ArrayBuffer
| Log LogMessage
-- | The component's parent provides received messages.
-- |
-- | Also, the component is informed when the connection went up or down.
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 }
= Bulma.section_small
[ case wsUp of
false -> Bulma.p "You are disconnected."
true -> 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