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

module App.AuthenticationForm where

import Prelude (Unit, Void, bind, discard, map, show, void, when, ($), (&&), (<$>), (<<<), (<>), (>>=))

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 Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
import Web.Socket.WebSocket as WS

import Effect.Class (class MonadEffect)

import App.Utils

import App.IPC as IPC
import App.Email as Email

import App.Messages.AuthenticationDaemon as AuthD

import Data.ArrayBuffer.Types (ArrayBuffer)
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))

--------------------------------------------------------------------------------
-- Root component module
--------------------------------------------------------------------------------

data Output = AuthToken (Tuple Int String)
type Slot = H.Slot Query Output

type Query :: forall k. k -> Type
type Query = Const Void
type Input = String

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 WSInfo
  = { url        :: String
    , connection :: Maybe WS.WebSocket
    , reconnect  :: Boolean
    }

type State =
  { messages               :: Array String
  , messageHistoryLength   :: Int

  , authenticationForm     :: StateAuthenticationForm
  , registrationForm       :: StateRegistrationForm

  , wsInfo                 :: WSInfo
  }

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
        , finalize = Just Finalize
        }
    }

initialState :: Input -> State
initialState input =
  { messages: []
  , messageHistoryLength: 10

  , authenticationForm: { login:     "", pass:  "" }
  , registrationForm:   { login:     "", email: "", pass: "" }

  , wsInfo: { url: input
            , connection: Nothing
            , reconnect: false
            }
  }

render :: forall m. State -> H.ComponentHTML Action () m
render {
  messages,
  wsInfo,

  authenticationForm,
  registrationForm }
    = HH.div_
       [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ]
       , render_messages
       , renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
       ]
    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)
            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
        , Bulma.box_password "Password" "password"                          -- title, placeholder
            (HandleAuthenticationInput <<< AUTH_INP_pass)                   -- action
            authenticationForm.pass                                         -- value
            true                                                            -- validity (TODO)
            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
        , HH.button
           [ HP.style "padding: 0.5rem 1.25rem;"
           , HP.type_ HP.ButtonSubmit
           , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
           ]
           [ 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)
            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
        , Bulma.box_input "Email" "email@example.com"                       -- title, placeholder
            (HandleRegisterInput <<< REG_INP_email)                         -- action
            registrationForm.email                                          -- value
            true                                                            -- validity (TODO)
            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
        , Bulma.box_password "Password" "password"                          -- title, placeholder
            (HandleRegisterInput <<< REG_INP_pass)                          -- action
            registrationForm.pass                                           -- value
            true                                                            -- validity (TODO)
            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection) -- condition
        , HH.div_
            [ HH.button
                [ HP.style "padding: 0.5rem 1.25rem;"
                , HP.type_ HP.ButtonSubmit
                , maybe (HP.disabled true) (\_ -> HP.enabled true) wsInfo.connection
                ]
                [ HH.text "Send Message to Server" ]
            ]
        ]

      render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages

      renderFootnote :: String -> H.ComponentHTML Action () m
      renderFootnote txt =
        HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]

      renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
      renderReconnectButton cond =
        if cond
        then
          HH.p_
            [ HH.button
              [ HP.type_ HP.ButtonButton
              , HE.onClick \_ -> ConnectWebSocket
              ]
              [ HH.text "Reconnect?" ]
            ]
        else
          HH.p_
            [ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops"
            ]

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  Initialize ->
    handleAction ConnectWebSocket

  Finalize -> do
    { wsInfo } <- H.get
    systemMessage "Finalize"
    case wsInfo.connection of
      Nothing -> systemMessage "No socket? How is that even possible?"
      Just socket -> H.liftEffect $ WS.close socket

  WebSocketParseError error ->
    systemMessage $ renderError (UnknownError error)

  ConnectWebSocket -> do
    { wsInfo } <- H.get
    systemMessage ("Connecting to \"" <> wsInfo.url <>  "\"...")
    webSocket <- H.liftEffect $ WS.create wsInfo.url []
    H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
    H.modify_ _ { wsInfo { connection = Just webSocket }}
    void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)

  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

    { wsInfo, registrationForm } <- H.get
    let login = registrationForm.login
        email = registrationForm.email
        pass  = registrationForm.pass

    case wsInfo.connection, login, email, pass of
      Nothing, _, _, _ ->
        unableToSend "Not connected to server."

      Just _, "", _, _ ->
        unableToSend "Write your login!"

      Just _, _, "", _ ->
        unableToSend "Write your email!"

      Just _, _, _, "" ->
        unableToSend "Write your password!"

      Just webSocket, _, _, _ -> do
        H.liftEffect (WS.readyState webSocket) >>= case _ of
          Connecting ->
            unableToSend "Still connecting to server."

          Closing ->
            unableToSend "Connection to server is closing."

          Closed -> do
            unableToSend "Connection to server has been closed."
            maybeCurrentConnection <- H.gets _.wsInfo.connection
            when (isJust maybeCurrentConnection) do
              H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}

          Open -> do
            H.liftEffect $ do
              ab <- AuthD.serialize $ AuthD.MkRegister { login: login
                                                       , email: Just (Email.Email email)
                                                       , password: pass }
              sendArrayBuffer webSocket ab
            appendMessage "[😇] Trying to register"

  AuthenticationAttempt ev -> do
    H.liftEffect $ Event.preventDefault ev

    { wsInfo, authenticationForm } <- H.get

    case wsInfo.connection, authenticationForm.login, authenticationForm.pass of
      Nothing, _, _ ->
        unableToSend "Not connected to server."

      Just _ , "" , _ ->
        unableToSend "Write your login!"

      Just _ , _ , "" ->
        unableToSend "Write your password!"

      Just webSocket, login, pass -> do
        H.liftEffect (WS.readyState webSocket) >>= case _ of
          Connecting ->
            unableToSend "Still connecting to server."

          Closing ->
            unableToSend "Connection to server is closing."

          Closed -> do
            unableToSend "Connection to server has been closed."
            maybeCurrentConnection <- H.gets _.wsInfo.connection
            when (isJust maybeCurrentConnection) do
              H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}

          Open -> do
            H.liftEffect $ do
              ab <- AuthD.serialize (AuthD.MkLogin { login: login, password: pass })
              sendArrayBuffer webSocket ab
            appendMessage $ "[😇] Trying to connect with login: " <> login

  HandleWebSocket wsEvent ->
    case wsEvent of
      WebSocketMessage messageEvent -> do
        receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
        case receivedMessage of
            -- Cases where we didn't understand the message.
            Left err -> do
              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
                  appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
                -- The authentication was a success!
                (AuthD.GotToken msg) -> do
                  appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
                  H.raise $ AuthToken (Tuple msg.uid msg.token)
                -- WTH?!
                _ -> do
                  appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."

      WebSocketOpen -> do
        { wsInfo } <- H.get
        systemMessage ("Successfully connected to WebSocket at \"" <> wsInfo.url <>  "\"!🎉")

      WebSocketClose { code, reason, wasClean } -> do
        systemMessage $ renderCloseMessage code wasClean reason
        maybeCurrentConnection <- H.gets _.wsInfo.connection
        when (isJust maybeCurrentConnection) do
          H.modify_ _ { wsInfo { connection = Nothing, reconnect = true }}

      WebSocketError errorType ->
        systemMessage $ renderError errorType

  where
  renderCloseMessage
    :: Int
    -> Boolean
    -> String
    -> String
  renderCloseMessage code wasClean = case _ of
      ""     -> baseCloseMessage
      reason -> baseCloseMessage <> "Reason: " <> reason
    where
    baseCloseMessage :: String
    baseCloseMessage =
      String.joinWith " "
        [ "Connection to WebSocket closed"
        , "[ CODE:"
        , show code
        , "|"
        , if wasClean then "CLEAN" else "DIRTY"
        , "]"
        ]

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
  appendMessage $ case (value) of
    Left _ -> "Cannot even fromTypedIPC the message."
    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string