263 lines
9.6 KiB
Plaintext
263 lines
9.6 KiB
Plaintext
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
|
|
]
|
|
|
|
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)
|
|
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
|
|
, Bulma.box_password "Password" "password" -- title, placeholder
|
|
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action
|
|
authenticationForm.pass -- value
|
|
true -- validity (TODO)
|
|
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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)
|
|
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
|
|
, Bulma.box_input "Email" "email@example.com" -- title, placeholder
|
|
(HandleRegisterInput <<< REG_INP_email) -- action
|
|
registrationForm.email -- value
|
|
true -- validity (TODO)
|
|
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- condition
|
|
, Bulma.box_password "Password" "password" -- title, placeholder
|
|
(HandleRegisterInput <<< REG_INP_pass) -- action
|
|
registrationForm.pass -- value
|
|
true -- validity (TODO)
|
|
(if wsUp then (HP.enabled true) else (HP.disabled true)) -- 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
|