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

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

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 }
  = 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