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

-- | `App.ZoneInterface` provides an interface to display and modify a DNS zone.
-- |
-- | This interface allows to:
-- |   - TODO: display all resource records of a zone
-- |   - TODO: add new resource records
-- |   - TODO: remove resource records
-- |   - TODO: ask for confirmation on deletion

module App.ZoneInterface where


import Prelude

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 CSSClasses as C

import App.Style as S
import App.RR

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

-- IMPORTED
import Data.Array (groupAllBy, sortBy, filter, (!!))
import Data.Array.NonEmpty (toArray)
import Data.Maybe (Maybe(..), maybe, fromMaybe)

import Data.String.Regex (Regex, test)
import Data.String.Regex.Unsafe (unsafeRegex)
import Data.String.Regex.Flags (noFlags)

import Data.Foldable (foldl)

import Effect.Class (class MonadEffect)
import Halogen as H
-- import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.HTML.Events as HE

import Halogen.HTML.Properties.ARIA as Aria

-- HTML PropName used with HP.prop
-- import Halogen.HTML.Core (PropName(..))
import Halogen.HTML.Core (AttrName(..))

-- | `App.ZoneInterface` can send messages through websocket interface
-- | connected to dnsmanagerd. See `App.WS`.
-- |
-- | Also, this component can log messages and ask its parent (`App.Container`) to
-- | reconnect the websocket to `dnsmanagerd`.

data Output
  = MessageToSend ArrayBuffer
  | Log LogMessage
  | DNSManagerReconnect

-- | `App.ZoneInterface` can receive messages from `dnsmanagerd`.
-- |
-- | The component is also informed when the connection is lost or up again.

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

type Slot = H.Slot Query Output

-- | `App.ZoneInterface` has a single input: the domain name.

type Input = String

-- | Possible component's actions are:
-- | - TODO: update the list of resource records
-- | - TODO: add a resource record
-- | - TODO: modify a resource record
-- | - TODO: remove a resource record
-- | - TODO: handle user inputs

data Action
  = DeleteRRModal String
  | CancelModal

  | Initialize
  | Finalize

  | DoNothing String

  -- New entries.
  | UpdateNewType Int

  | UpdateNewDomainSimple RecordDomain
  | UpdateNewDomainMX     RecordDomain
  | UpdateNewDomainSRV    RecordDomain

  | UpdateNewTTLSimple TTL
  | UpdateNewTTLMX    TTL
  | UpdateNewTTLSRV   TTL

  | UpdateNewEntryValue RecordValue
  | UpdateNewMXValue    RecordValue
  | UpdateNewSRVValue   RecordValue

  | UpdateNewMXPriority  Priority
  | UpdateNewSRVPriority Priority

  | UpdateNewSRVWeight Weight
  | UpdateNewSRVPort   Port

  | AddSimple
  | AddMX
  | AddSRV

  -- Entry already in our zone.
  | UpdateLocalTTL          RRId TTL
  | UpdateLocalTTLMX        RRId TTL
  | UpdateLocalTTLSRV       RRId TTL

  | UpdateLocalValue        RRId RecordValue
  | UpdateLocalValueMX      RRId RecordValue
  | UpdateLocalValueSRV     RRId RecordValue

  | UpdateLocalPriorityMX   RRId Priority
  | UpdateLocalPrioritySRV  RRId Priority

  | UpdateLocalWeight       RRId Weight
  | UpdateLocalPort         RRId Port
  | UpdateOnServer          RRId

  | DeleteSimple            RRId
  | DeleteMX                RRId
  | DeleteSRV               RRId


  | TellSomethingWentWrong RRId String

-- |

type State =
  { _current_domain :: RecordDomain
  , _rr    :: Array (SimpleRR ())
  , _mxrr  :: Array (MXRR ())
  , _srvrr :: Array (SRVRR ())
  , _current_entry :: (SimpleRR ())
  , _current_entry_mx  :: (MXRR ())
  , _current_entry_srv :: (SRVRR ())

  , wsUp :: Boolean
  , active_modal :: Maybe String
  }

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

-- | Default available domain: netlib.re.

default_domain :: String
default_domain = "netlib.re"

initialState :: Input -> State
initialState _ =
  { wsUp: true
  , active_modal: Nothing

  , _current_domain: "hello.example.com"
  , _rr: defaultResourceRecords
  , _mxrr: defaultMXResourceRecords
  , _srvrr: []
  , _current_entry: defaultResourceA
  , _current_entry_mx: defaultResourceMX
  , _current_entry_srv: defaultResourceSRV
  }

render :: forall m. State -> H.ComponentHTML Action () m
render state
  = Bulma.section_small
      [ case state.wsUp, state.active_modal of
          false, _           -> Bulma.p "You are disconnected."
          true,  Just domain -> modal_rr_delete domain
          true,  Nothing     -> HH.div_ [ nav_bar state._current_domain
                                        , render_records sorted
                                        , render_mx_records state._mxrr
                                        , render_srv_records state._srvrr
                                        , render_new_records state
                                        ]
      ]
  where
    sorted = foldl (<>) []
      $ map (sortBy (comparing (_.domain)))
      $ map toArray
      $ groupAllBy (comparing (_.t)) state._rr

    modal_rr_delete :: forall w. String -> HH.HTML w Action
    modal_rr_delete domain =
      modal
        [ modal_background
        , modal_card [modal_header, modal_body]
        , modal_foot [modal_delete_button, modal_cancel_button]
        ]
        where
          modal = HH.div [HP.classes (C.modal <> C.is_active)]
          modal_background = HH.div [HP.classes C.modal_background] []
          modal_card = HH.div [HP.classes C.modal_card]
          modal_header = HH.header [HP.classes C.modal_card_head]
            [ HH.p [HP.classes C.modal_card_title] [HH.text "Deleting a resource record"]
            ]
          modal_body = HH.section [HP.classes C.modal_card_body] [ warning_message ]
          modal_foot = HH.div [HP.classes C.modal_card_foot]
          modal_delete_button
            = HH.button [ HP.classes (C.button <> C.is_success)
                        -- TODO: , HE.onClick \_ -> RemoveRR domain
                        ] [HH.text "Delete the resource record."]
          modal_cancel_button
            = HH.button [ HP.classes C.button
                        , HE.onClick \_ -> CancelModal
                        ] [HH.text "Cancel"]
          warning_message
            = HH.p [] [ HH.text $ "You are about to delete a resource record, this actions is "
                      , HH.strong_ [ HH.text "irreversible" ]
                      , HH.text "."
                      ]

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

  -- IMPORTED
  Initialize -> do
    H.raise $ Log $ SimpleLog "Initialized"

  Finalize -> do
    state <- H.get
    H.raise $ Log $ SimpleLog "Finalized!"

  DoNothing _ -> do
    H.raise $ Log $ SimpleLog "This action does nothing (at least for now)"

  UpdateNewType val -> do
    let new_type = fromMaybe "unknown" (baseRecords !! val)
    H.raise $ Log $ SimpleLog ("Update new entry type: " <> new_type)
    state <- H.get
    H.put $ state { _current_entry = changeType state._current_entry (baseRecords !! val) }
    -- TODO: FIXME: test all inputs

  UpdateNewTTLSimple val -> do
    H.raise $ Log $ SimpleLog ("Update new entry ttl: " <> val)
    state <- H.get
    H.put $ state { _current_entry = state._current_entry { ttl = val, valid = isInteger val } }
    -- TODO: FIXME: test all inputs
  UpdateNewTTLMX val -> do
    H.raise $ Log $ SimpleLog ("Update new MX entry ttl: " <> val)
    state <- H.get
    H.put $ state { _current_entry_mx = state._current_entry_mx {ttl = val, valid = isInteger val} }
  UpdateNewTTLSRV val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry ttl: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv {ttl = val, valid = isInteger val}}

  UpdateNewDomainSimple val -> do
    H.raise $ Log $ SimpleLog ("Update new entry domain: " <> val)
    state <- H.get
    H.put $ state { _current_entry = state._current_entry { domain = val } }
    -- TODO: FIXME: test all inputs
  UpdateNewDomainMX val -> do
    H.raise $ Log $ SimpleLog ("Update new MX entry domain: " <> val)
    state <- H.get
    H.put $ state { _current_entry_mx = state._current_entry_mx { domain = val } }
  UpdateNewDomainSRV val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry domain: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv { domain = val } }

  UpdateNewEntryValue val -> do
    H.raise $ Log $ SimpleLog ("Update new entry value: " <> val)
    state <- H.get
    H.put $ state { _current_entry = state._current_entry { value = val } }
    -- TODO: FIXME: test all inputs
  UpdateNewMXValue val -> do
    H.raise $ Log $ SimpleLog ("Update new MX entry value: " <> val)
    state <- H.get
    H.put $ state { _current_entry_mx = state._current_entry_mx { value = val } }
  UpdateNewSRVValue val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry value: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv { value = val } }

  UpdateNewMXPriority val -> do
    H.raise $ Log $ SimpleLog ("Update new MX entry priority: " <> val)
    state <- H.get
    H.put $ state { _current_entry_mx = state._current_entry_mx { priority = val } }
  UpdateNewSRVPriority val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry priority: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv { priority = val } }

  UpdateNewSRVWeight val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry weight: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv { weight = val } }

  UpdateNewSRVPort val -> do
    H.raise $ Log $ SimpleLog ("Update new SRV entry port: " <> val)
    state <- H.get
    H.put $ state { _current_entry_srv = state._current_entry_srv { port = val } }



  -- This action only is possible if inputs are correct.
  AddSimple -> do
    H.raise $ Log $ SimpleLog ("Add simple entry")
    state <- H.get
    H.raise $ Log $ SimpleLog ("Add simple entry: " <> show state._current_entry)
    H.put $ add_new_entry state state._current_entry
  AddMX -> do
    state <- H.get
    H.raise $ Log $ SimpleLog ("Add new MX: " <> show state._current_entry_mx)
    H.put $ add_new_mx state state._current_entry_mx
  AddSRV -> do
    state <- H.get
    H.raise $ Log $ SimpleLog ("Add new SRV: " <> show state._current_entry_srv)
    H.put $ add_new_srv state state._current_entry_srv


  UpdateLocalValue rrid val -> do
    H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " value: " <> val)
    state <- H.get
    H.put $ state { _rr = (update_value rrid val state._rr) }
  UpdateLocalValueMX rrid val -> do
    H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " value: " <> val)
    state <- H.get
    H.put $ state { _mxrr = (update_value rrid val state._mxrr) }
  UpdateLocalValueSRV rrid val -> do
    H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " value: " <> val)
    state <- H.get
    H.put $ state { _srvrr = (update_value rrid val state._srvrr) }

  UpdateLocalTTL rrid val -> do
    H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " TTL: " <> val)
    state <- H.get
    H.put $ state { _rr = (update_ttl rrid val state._rr) }
  UpdateLocalTTLMX rrid val -> do
    H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " TTL: " <> val)
    state <- H.get
    H.put $ state { _mxrr = (update_ttl rrid val state._mxrr) }
  UpdateLocalTTLSRV rrid val -> do
    H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " TTL: " <> val)
    state <- H.get
    H.put $ state { _srvrr = (update_ttl rrid val state._srvrr) }

  UpdateLocalPriorityMX rrid val -> do
    H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " priority: " <> val)
    state <- H.get
    H.put $ state { _mxrr = (update_priority rrid val state._mxrr) }
  UpdateLocalPrioritySRV rrid val -> do
    H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " priority: " <> val)
    state <- H.get
    H.put $ state { _srvrr = (update_priority rrid val state._srvrr) }

  UpdateLocalWeight rrid val -> do
    H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " weight: " <> val)
    state <- H.get
    H.put $ state { _srvrr = (update_weight rrid val state._srvrr) }

  UpdateLocalPort rrid val -> do
    H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " port: " <> val)
    state <- H.get
    H.put $ state { _srvrr = (update_port rrid val state._srvrr) }


  DeleteSimple rrid -> do
    H.raise $ Log $ SimpleLog ("Delete SimpleRR: " <> show rrid)
    state <- H.get
    H.put $ state { _rr = filter (\rr -> rr.id /= rrid) state._rr }
    H.raise $ Log $ SimpleLog ("TODO: remove from server")
  DeleteMX rrid -> do
    H.raise $ Log $ SimpleLog ("Delete MX: " <> show rrid)
    state <- H.get
    H.put $ state { _mxrr = filter (\rr -> rr.id /= rrid) state._mxrr }
    H.raise $ Log $ SimpleLog ("TODO: remove from server")
  DeleteSRV rrid -> do
    H.raise $ Log $ SimpleLog ("Delete SRV: " <> show rrid)
    state <- H.get
    H.put $ state { _srvrr = filter (\rr -> rr.id /= rrid) state._srvrr }
    H.raise $ Log $ SimpleLog ("TODO: remove from server")


  -- TODO: network operations
  UpdateOnServer rrid -> do
    H.raise $ Log $ SimpleLog ("TODO: UpdateOnServer: " <> show rrid)

  -- TODO: change the state to indicate problems?
  TellSomethingWentWrong rrid val -> do
    H.raise $ Log $ SimpleLog ("Sorry, your record " <> show rrid <> " has problems: ")
    -- H.raise $ Log $ SimpleLog (show rr)
    H.raise $ Log $ SimpleLog (" => " <> val)

  DeleteRRModal domain -> do
    H.modify_ _ { active_modal = Just domain }

--  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
--
--  RemoveRR domain -> do
--    message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
--    H.raise $ MessageToSend message
--    H.raise $ Log $ SimpleLog $ "[😇] Removing domain: " <> domain
--    H.modify_ _ { active_modal = Nothing }
--
--  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
          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..."
              H.raise $ DNSManagerReconnect
            (DNSManager.MkErrorInvalidToken _) -> do
              H.raise $ Log $ SimpleLog $ "[TODO] Failed connection! Invalid token!"
            (DNSManager.MkDomainAlreadyExists _) -> do
              H.raise $ Log $ SimpleLog $ "[TODO] Failed! The domain already exists."
            (DNSManager.MkUnacceptableDomain _) -> do
              H.raise $ Log $ SimpleLog $ "[TODO] Failed! The domain is not acceptable (not in the list of accepted domains)."

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

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

            (DNSManager.MkDomainAdded response) -> do
              H.raise $ Log $ SimpleLog $ "[TODO] 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
              H.raise $ Log $ SimpleLog $ "[TODO] 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 }
    pure (Just a)

-- Rendering
class_title_size :: Array (HH.ClassName)
class_title_size = [HH.ClassName "is-4"]

render_records :: forall (w :: Type). Array (SimpleRR ()) -> HH.HTML w Action
render_records []
  = S.columns [] [ left_block, right_block  ]
  where left_block = S.column class_title_size
                       [ S.h1       "NS, A, AAAA, CNAME"
                       , S.subtitle "and TXT records" ]
        right_block = S.column_ [ S.subtitle "No records for now" ]

render_records records
  = S.columns [] [ S.column class_title_size [S.h1 title_txt, S.subtitle subtitle_txt ]
                 , S.column_ [ table_rr ]
                 ]
  where
    title_txt = "NS, A, AAAA, CNAME"
    subtitle_txt = "and TXT records"
    -- subtitle_txt = "Each line is a resource record from your DNS zone."
    --   <> " You can edit them, then click on the \"fix\" button to synchronize with the server."
    table_rr = HH.table [] [ S.simple_table_header, table_content ]
    table_content = HH.tbody_ $ map row records

    row rr = HH.tr_ $
      [ S.txt_name rr.t
      , HH.td_ [ S.input_domain DoNothing               rr.domain rr.valid ]
      , HH.td_ [ S.input_ttl   (UpdateLocalTTL   rr.id) rr.ttl    rr.valid ]
      , HH.td_ [ S.input_value (UpdateLocalValue rr.id) rr.value  rr.valid ]
      , HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
      , HH.td_ [ S.btn_delete (\_ -> DeleteSimple rr.id) ]
      ]


render_mx_records :: forall (w :: Type) (l :: Row Type)
  . Array (MXRR l) -> HH.HTML w Action
render_mx_records []
  = S.columns [] [ left_block, right_block ]
  where left_block = S.column class_title_size [ S.h1 "MX records" ]
        right_block = S.column_ [ S.subtitle "No records for now" ]
render_mx_records records
  = S.columns [] [ S.column class_title_size [ S.h1 title_txt ]
                 , S.column_ [ table_rr ]
                 ]
  where
    title_txt = "MX records"
    table_rr      = HH.table [] [ S.mx_table_header, table_content ]
    table_content = HH.tbody_ $ map row records

    row rr = HH.tr_ $
      [ HH.td_ [ S.input_domain   DoNothing                     rr.domain   rr.valid ]
      , HH.td_ [ S.input_ttl      (UpdateLocalTTLMX      rr.id) rr.ttl      rr.valid ]
      , HH.td_ [ S.input_value    (UpdateLocalValueMX    rr.id) rr.value    rr.valid ]
      , HH.td_ [ S.input_priority (UpdateLocalPriorityMX rr.id) rr.priority rr.valid ]
      , HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
      , HH.td_ [ S.btn_delete (\_ -> DeleteMX rr.id) ]
      ]


render_srv_records :: forall (w :: Type) (l :: Row Type)
  . Array (SRVRR l) -> HH.HTML w Action
render_srv_records []
  = S.columns [] [ left_block, right_block  ]
  where left_block = S.column class_title_size [ S.h1 "SRV records" ]
        right_block = S.column_ [ S.subtitle "No records for now" ]
render_srv_records records
  = S.columns [] [ S.column class_title_size [ S.h1 title_txt]
                 , S.column_ [ table_rr ] ]
  where
    title_txt = "SRV records"
    table_rr      = HH.table [] [ S.srv_table_header, table_content ]
    table_content = HH.tbody_ $ map row records

    row rr = HH.tr_ $
      [ HH.td_ [ S.input_domain   DoNothing                   rr.domain   rr.valid ]
      , HH.td_ [ S.input_ttl      (UpdateLocalTTLSRV   rr.id) rr.ttl      rr.valid ]
      , HH.td_ [ S.input_priority (UpdateLocalPrioritySRV rr.id) rr.priority rr.valid ]
      , HH.td_ [ S.input_weight   (UpdateLocalWeight   rr.id) rr.weight   rr.valid ]
      , HH.td_ [ S.input_port     (UpdateLocalPort     rr.id) rr.port     rr.valid ]
      , HH.td_ [ S.input_value    (UpdateLocalValueSRV rr.id) rr.value    rr.valid ]
      , HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
      , HH.td_ [ S.btn_delete (\_ -> DeleteSRV rr.id) ]
      ]


baseRecords :: Array String
baseRecords = [ "NS", "A", "AAAA", "CNAME", "TXT" ]

render_new_record :: forall (w :: Type). (SimpleRR ()) -> HH.HTML w Action
render_new_record rr
  = S.hdiv [ S.h3 "New record (NS, A, AAAA, CNAME, TXT)", table ]

  where
    table = HH.table [] [ S.simple_table_header, render_record_builder ]

    -- render_record_builder :: forall w. HH.HTML w Action
    render_record_builder
      = HH.tr_
          [ HH.td_ [ type_selection ]
          , HH.td_ [ S.input_domain UpdateNewDomainSimple rr.domain rr.valid ]
          , HH.td_ [ S.input_ttl    UpdateNewTTLSimple   rr.ttl    rr.valid ]
          , HH.td_ [ S.input_value  UpdateNewEntryValue  rr.value  rr.valid ]
          , HH.td_ [ S.btn_add AddSimple (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
          ]

    -- type_selection :: forall w i. HH.HTML w i
    type_selection = HH.select
      [ HE.onSelectedIndexChange UpdateNewType ]
      $ map type_option baseRecords
    type_option n
      = HH.option
          [ HP.value n
          , HP.selected (n == rr.t)
          ] [ HH.text n ]


render_mx_new_record :: forall (w :: Type). (MXRR ()) -> HH.HTML w Action
render_mx_new_record rr
  = S.hdiv [ S.h3 "New MX record", table ]

  where
    table = HH.table [] [ S.mx_table_header, render_record_builder ]

    -- render_record_builder :: forall w. HH.HTML w Action
    render_record_builder
      = HH.tr_
          [ HH.td_ [ S.input_domain   UpdateNewDomainMX   rr.domain   rr.valid ]
          , HH.td_ [ S.input_ttl      UpdateNewTTLMX      rr.ttl      rr.valid ]
          , HH.td_ [ S.input_priority UpdateNewMXPriority rr.priority rr.valid ]
          , HH.td_ [ S.input_value    UpdateNewMXValue    rr.value    rr.valid ]
          , HH.td_ [ S.btn_add AddMX (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
          ]


render_srv_new_record :: forall (w :: Type). (SRVRR ()) -> HH.HTML w Action
render_srv_new_record rr
  = S.hdiv [ S.h3 "New SRV record", table ]
  where
    table = HH.table [] [ S.srv_table_header, render_record_builder ]

    -- render_record_builder :: forall w. HH.HTML w Action
    render_record_builder
      = HH.tr_
          [ HH.td_ [ S.input_domain   UpdateNewDomainSRV   rr.domain   rr.valid ]
          , HH.td_ [ S.input_ttl      UpdateNewTTLSRV      rr.ttl      rr.valid ]
          , HH.td_ [ S.input_priority UpdateNewSRVPriority rr.priority rr.valid ]
          , HH.td_ [ S.input_weight   UpdateNewSRVWeight   rr.weight   rr.valid ]
          , HH.td_ [ S.input_port     UpdateNewSRVPort     rr.port     rr.valid ]
          , HH.td_ [ S.input_value    UpdateNewSRVValue    rr.value    rr.valid ]
          , HH.td_ [ S.btn_add AddSRV (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
          ]


-- Component definition and initial state

render_new_records :: forall (w :: Type). State -> HH.HTML w Action
render_new_records state
  = S.hdiv
      [ S.h1 "Adding new records"
      , S.columns []
          [ render_new_record_column_simple state._current_entry
          , render_new_record_colunm_mx     state._current_entry_mx
          , render_new_record_colunm_srv    state._current_entry_srv
          -- , render_current_value     state._current_entry
          -- , render_mx_current_value  state._current_entry_mx
          -- , render_srv_current_value state._current_entry_srv
          ]
      ]

render_new_record_column_simple :: forall (w :: Type).
  (SimpleRR ()) -> HH.HTML w Action
render_new_record_column_simple rr
  = S.column_ $ [ S.box
      [ S.h3 "NS, A, AAAA, CNAME, TXT"
      , type_selection
      , S.box_input_domain UpdateNewDomainSimple rr.domain rr.valid
      , S.box_input_ttl    UpdateNewTTLSimple    rr.ttl    rr.valid
      , S.box_input_value  UpdateNewEntryValue   rr.value  rr.valid
      , S.btn_add AddSimple (TellSomethingWentWrong rr.id "cannot add") rr.valid
      ]
    ]
  where
    -- type_selection :: forall w i. HH.HTML w i
    type_selection = HH.select
      [ HE.onSelectedIndexChange UpdateNewType ]
      $ map type_option baseRecords
    type_option n
      = HH.option
          [ HP.value n
          , HP.selected (n == rr.t)
          ] [ HH.text n ]


render_new_record_colunm_mx :: forall (w :: Type). (MXRR ()) -> HH.HTML w Action
render_new_record_colunm_mx rr
  = S.column_ $ [ S.box
      [ S.h3 "MX"
      , S.box_input_domain   UpdateNewDomainMX   rr.domain   rr.valid
      , S.box_input_ttl      UpdateNewTTLMX      rr.ttl      rr.valid
      , S.box_input_priority UpdateNewMXPriority rr.priority rr.valid
      , S.box_input_value    UpdateNewMXValue    rr.value    rr.valid
      , S.btn_add AddMX (TellSomethingWentWrong rr.id "cannot add") rr.valid
      ]
    ]

render_new_record_colunm_srv :: forall (w :: Type). (SRVRR ()) -> HH.HTML w Action
render_new_record_colunm_srv rr
  = S.column_ $ [ S.box
      [ S.h3 "SRV"
      , S.box_input_domain   UpdateNewDomainSRV   rr.domain   rr.valid
      , S.box_input_ttl      UpdateNewTTLSRV      rr.ttl      rr.valid
      , S.box_input_priority UpdateNewSRVPriority rr.priority rr.valid
      , S.box_input_weight   UpdateNewSRVWeight   rr.weight   rr.valid
      , S.box_input_port     UpdateNewSRVPort     rr.port     rr.valid
      , S.box_input_value    UpdateNewSRVValue    rr.value    rr.valid
      , S.btn_add AddSRV (TellSomethingWentWrong rr.id "cannot add") rr.valid
      ]
    ]

classes_nav :: Array (HH.ClassName)
classes_nav = class_breadcrumb <> class_centered <> class_succeeds_sep
class_succeeds_sep :: Array (HH.ClassName)
class_succeeds_sep = [HH.ClassName "has-succeeds-separator" ]
class_breadcrumb :: Array (HH.ClassName)
class_breadcrumb = [HH.ClassName "breadcrumb"]
class_centered :: Array (HH.ClassName)
class_centered = [HH.ClassName "is-centered"]

-- TODO: wrong type
--home_icon :: forall r w i. Array (HP.IProp r i) -> HH.HTML w i
--home_icon = HH.span
--              [HP.classes [HH.ClassName "icon is-small"]]
--              [HH.i ([HP.classes [HH.ClassName "fas fa-home"]] <> aria) []]
--  where aria = [Aria.hidden "true"]

aria_current :: forall r i. String -> HP.IProp r i
aria_current = HP.attr (AttrName "aria-current")

nav_bar :: forall w i. String -> HH.HTML w i
nav_bar domain
  = HH.nav
      [ HP.classes classes_nav
      , Aria.label "breadcrumbs"
      ] [ HH.ul_
            [ HH.li_ [ HH.a [HP.href "/"] [ HH.text "Home"] ]
            , HH.li []
                [ HH.a
                    [HP.href "/", aria_current "page"]
                    [HH.text ("Domain: " <> domain)]
                ]
            ]
        ]


-- ACTIONS

-- add a new record and get a new placeholter
add_new_entry :: State -> (SimpleRR ()) -> State
add_new_entry state rr
  = state { _rr = new_rr_list, _current_entry = new_placeholder }
  where new_placeholder = defaultResourceA
        new_rr_list     = state._rr <> [ new_rr ]
        new_rr          = rr { id = getNewID state }

-- add a new record and get a new placeholter
add_new_mx :: State -> (MXRR ()) -> State
add_new_mx state rr
  = state { _mxrr = new_rr_list, _current_entry_mx = new_placeholder }
  where new_placeholder = defaultResourceMX
        new_rr_list     = state._mxrr <> [ new_rr ]
        new_rr          = rr { id = getNewID state }

-- add a new record and get a new placeholter
add_new_srv :: State -> (SRVRR ()) -> State
add_new_srv state rr
  = state { _srvrr = new_rr_list, _current_entry_srv = new_placeholder }
  where new_placeholder = defaultResourceSRV
        new_rr_list     = state._srvrr <> [ new_rr ]
        new_rr          = rr { id = getNewID state }
  
changeType :: forall (l :: Row Type). (SimpleRR l) -> Maybe String -> (SimpleRR l)
changeType rr Nothing = rr
changeType rr (Just s) = rr { t = s }

update_value :: forall (l :: Row Type).
  Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l)
update_value rrid val
  = update (\rr -> rr { modified = true, value = val }) rrid

update_ttl :: forall (l :: Row Type).
  Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l)
update_ttl rrid val
  = update (\rr -> rr { modified = true, ttl = val, valid = isInteger val }) rrid

update_priority :: forall (l :: Row Type). Int -> Priority -> Array (MXRR l) -> Array (MXRR l)
update_priority rrid val = update (\rr -> rr { modified = true, priority = val}) rrid

update_weight :: forall (l :: Row Type). Int -> Priority -> Array (SRVRR l) -> Array (SRVRR l)
update_weight rrid val = update (\rr -> rr { modified = true, weight = val}) rrid

update_port :: Int -> Priority -> Array (SRVRR ()) -> Array (SRVRR ())
update_port rrid val = update (\rr -> rr { modified = true, port = val}) rrid


isIntRegex :: Regex
isIntRegex = unsafeRegex "^[0-9]*$" noFlags

isInteger :: String -> Boolean
isInteger = test isIntRegex

update :: forall (l :: Row Type).
  (SimpleRR l -> SimpleRR l) -> Int -> Array (SimpleRR l) -> Array (SimpleRR l)
update f rrid records = map doSmth records
  where
    doSmth rr
      | rrid == rr.id = f rr
      | otherwise     = rr


getNewID :: State -> Int
getNewID state = (_ + 1) $ foldl max 0 [ maxIDrr
                                       , maxIDmxrr
                                       , maxIDsrvrr
                                       ]

  where
    maxIDrr    = foldl max 0 $ map _.id state._rr
    maxIDmxrr  = foldl max 0 $ map _.id state._mxrr
    maxIDsrvrr = foldl max 0 $ map _.id state._srvrr