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

module App.DomainListInterface where

{- Simple component with the list of own domains and a form to add a new domain.
   This interface allows to:
     - display the list of own domains
     - show and select accepted domains (TLDs)
     - create new domains
     - delete a domain
     - TODO: ask for confirmation
     - TODO: show and modify the content of a Zone

   Authentication is automatic with the token.
-}

import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>))

import CSSClasses as CSSClasses
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.String.Utils (endsWith)
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Events as HHE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event
import Web.Event.Event (Event)
import Bulma as Bulma

import App.LogMessage
import App.Messages.DNSManagerDaemon as DNSManager

data Output
  = MessageToSend ArrayBuffer
  | Log LogMessage

data Query a
  = MessageReceived ArrayBuffer a
  | ConnectionIsDown a
  | ConnectionIsUp a

type Slot = H.Slot Query Output

type Input = String

data NewDomainFormAction
  = INP_newdomain String
  | UpdateSelectedDomain String

data Action
  = UpdateAcceptedDomains (Array String)
  | UpdateMyDomains (Array String)

  | AuthenticateToDNSManager

  | HandleNewDomainInput NewDomainFormAction

  | NewDomainAttempt Event
  | RemoveDomain String
  | EnterDomain String

type NewDomainFormState
  = { new_domain      :: String
    , selected_domain :: String
    }

type State =
  { newDomainForm          :: NewDomainFormState
  , accepted_domains       :: Array String
  , my_domains             :: Array String

  , wsUp :: Boolean
  , token :: String
  }

component :: forall m. MonadAff m => H.Component Query Input Output m
component =
  H.mkComponent
    { initialState
    , render
    , eval: H.mkEval $ H.defaultEval
        { initialize = Just AuthenticateToDNSManager
        , handleAction = handleAction
        , handleQuery  = handleQuery
        }
    }

default_domain :: String
default_domain = "netlib.re"

initialState :: Input -> State
initialState token =
  { newDomainForm: { new_domain: ""
                   , selected_domain: default_domain
                   }
  , accepted_domains: [ default_domain ]
  , my_domains: [ ]
  , wsUp: true
  , token: token
  }

render :: forall m. State -> H.ComponentHTML Action () m
render { accepted_domains, my_domains, newDomainForm, wsUp }
  = Bulma.section_small
      [ case wsUp of
          false -> Bulma.p "You are disconnected."
          true  -> Bulma.columns_ [ Bulma.column_ newdomain_form, Bulma.column_ list_of_own_domains ]
      ]
  where

    newdomain_form
      = [ Bulma.h3 "Add a domain!"
        , render_adduser_form
        ]

    list_of_own_domains
      = [ Bulma.h3 "My domains"
        , HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains
        ]

    domain_buttons domain
      = [ HH.button
            [ HP.type_ HP.ButtonSubmit
            , HE.onClick \_ -> RemoveDomain domain
            , HP.classes CSSClasses.button
            ]
            [ HH.text "x" ]
        , HH.button
            [ HP.type_ HP.ButtonSubmit
            , HE.onClick \_ -> EnterDomain domain
            , HP.classes CSSClasses.button
            ]
            [ HH.text domain ]
        ]

    render_adduser_form = HH.form
      [ HE.onSubmit NewDomainAttempt ]
      [ Bulma.new_domain_field
          (HandleNewDomainInput <<< INP_newdomain)
          newDomainForm.new_domain
          [ HHE.onSelectedIndexChange domain_choice ]
          accepted_domains
      ]

    domain_choice :: Int -> Action
    domain_choice i
      = HandleNewDomainInput <<< UpdateSelectedDomain $ maybe default_domain (\x -> x) $ accepted_domains A.!! i

handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  UpdateAcceptedDomains domains -> do
    H.modify_ _ { accepted_domains = domains }

  UpdateMyDomains domains -> do
    H.modify_ _ { my_domains = domains }

  AuthenticateToDNSManager -> do
    { token } <- H.get
    message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
    H.raise $ MessageToSend message

  HandleNewDomainInput adduserinp -> do
    case adduserinp of
      INP_newdomain        v      -> H.modify_ _ { newDomainForm { new_domain = v } }
      UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } }

  EnterDomain domain -> do
    H.raise $ Log $ SimpleLog $ "[???] trying to enter domain: " <> domain

  RemoveDomain domain -> do
    message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
    H.raise $ MessageToSend message
    H.raise $ Log $ SimpleLog $ "[😇] Removing domain: " <> domain

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

    { newDomainForm } <- H.get
    let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain

    case new_domain of
      "" ->
        H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
      _ -> do
        message <- H.liftEffect
          $ DNSManager.serialize
          $ DNSManager.MkNewDomain { domain: new_domain }
        H.raise $ MessageToSend message
        H.raise $ Log $ SimpleLog $ "[😇] Trying to add a new domain (" <> new_domain <> ")"
        handleAction $ HandleNewDomainInput $ INP_newdomain ""

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 $ DNSManager.deserialize message
    case receivedMessage of
        -- Cases where we didn't understand the message.
        Left _ -> do
        --  case err of
        --    (DNSManager.JSONERROR jerr) -> do
        --      print_json_string message
        --      handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr)
        --    (DNSManager.UnknownError   unerr) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownError" <> (show unerr))
        --    (DNSManager.UnknownNumber       ) -> handleAction $ WebSocketParseError ("Parsing error: DNSManager.UnknownNumber")
          pure Nothing

        -- Cases where we understood the message.
        Right received_msg -> do
          case received_msg of
            -- The authentication failed.
            (DNSManager.MkError errmsg) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
            (DNSManager.MkErrorUserNotLogged _) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
              H.raise $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
              handleAction AuthenticateToDNSManager
            (DNSManager.MkErrorInvalidToken _) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed connection! Invalid token!"
            (DNSManager.MkDomainAlreadyExists _) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain already exists."
            (DNSManager.MkUnacceptableDomain _) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain is not acceptable (not in the list of accepted domains)."

            (DNSManager.MkAcceptedDomains response) -> do
              H.raise $ Log $ SimpleLog $ "[🎉] Received the list of accepted domains!"
              handleAction $ UpdateAcceptedDomains response.domains

            (DNSManager.MkLogged response) -> do
              H.raise $ Log $ SimpleLog $ "[🎉] Authenticated to dnsmanagerd!"
              handleAction $ UpdateAcceptedDomains response.accepted_domains
              handleAction $ UpdateMyDomains response.my_domains

            (DNSManager.MkDomainAdded response) -> do
              { my_domains } <- H.get
              H.raise $ Log $ SimpleLog $ "[🎉] Domain added: " <> response.domain
              handleAction $ UpdateMyDomains (my_domains <> [response.domain])

            (DNSManager.MkInvalidDomainName _) -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"

            (DNSManager.MkDomainDeleted response) -> do
              { my_domains } <- H.get
              H.raise $ Log $ SimpleLog $ "[🎉] The domain '" <> response.domain <> "' has been deleted!"
              handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains

            (DNSManager.MkSuccess _) -> do
              H.raise $ Log $ SimpleLog $ "[🎉] Success!"
            -- WTH?!
            _ -> do
              H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
          pure (Just a)

  ConnectionIsDown a -> do
    H.modify_ _ { wsUp = false }
    pure (Just a)

  ConnectionIsUp a -> do
    H.modify_ _ { wsUp = true }
    H.raise $ Log $ SimpleLog "Connection with dnsmanagerd was closed, let's re-authenticate"
    handleAction AuthenticateToDNSManager
    pure (Just a)

build_new_domain :: String -> String -> String
build_new_domain sub tld
  | endsWith "." sub = sub <> tld
  | otherwise        = sub <> "." <> tld

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