dnsmanager-webclient/src/App/Page/Zone.purs

-- | `App.Page.Zone` provides an interface to display and modify a DNS zone.
-- |
-- | This interface enables to:
-- |   - display all resource records of a zone (SOA, NS, A, AAAA, CNAME, TXT, MX, SRV)
-- |   - provide dedicated interfaces for SPF, DKIM and DMARC
-- |   - add, modify, remove resource records
-- |
-- | TODO: display errors not only for a record but for the whole zone.
-- | A DNS zone is bound by a set of rules, the whole zone must be consistent.
-- | For example, a CNAME `target` has to point to the `name` of an existing record.
-- |
-- | TODO: move all serialization code to a single module.
module App.Page.Zone where

import Prelude (class Show, Unit, bind, comparing, discard, map, pure, show, unit, void, (#), ($), (/=), (<<<), (<>), (=<<), (==))

import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)

import App.Templates.Modal as Modal
import Web.HTML (window) as HTML
import Web.HTML.Window (sessionStorage) as Window
import Web.Storage.Storage as Storage

import Data.Eq (class Eq)
import Data.Array as A
import Data.Int (fromString)
import Data.Array.NonEmpty as NonEmpty
import Data.Either (Either(..))
import Data.String (toLower)
-- import Data.Foldable as Foldable
import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Effect.Aff.Class (class MonadAff)
import Halogen as H
import Halogen.HTML as HH

import App.Templates.Table as Table
import Web as Web
import CSSClasses as C

import App.Text.Explanations as Explanations

import App.Type.RRId (RRId)
import App.Type.Field as Field
import App.Type.Delegation (mkEmptyDelegationForm, update_delegation_field, Form, Field) as Delegation
import App.Type.RRModal (RRModal(..))
import App.Type.AcceptedRRTypes (AcceptedRRTypes(..))
import App.Type.ResourceRecord (ResourceRecord)
import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC

import App.Type.LogMessage (LogMessage(..))
import App.Message.DNSManagerDaemon as DNSManager
import App.Validation.DNS as Validation
import App.Validation.Delegation as ValidationDelegation

import App.Type.RRForm (RRForm, RRUpdateValue(..), default_caa, default_rr, mkEmptyRRForm, update_form)

-- | `App.Page.Zone` 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
  = Log LogMessage
  | ToDomainList

  | AskZoneFile String
  | AskNewToken String Int
  | AskDeleteRR String Int
  | AskSaveRR String ResourceRecord
  | AskAddRR String ResourceRecord
  | AskGetZone String

-- | `App.Page.Zone` can receive messages from `dnsmanagerd`.

data Query a
  = MessageReceived DNSManager.AnswerMessage a

type Slot = H.Slot Query Output

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

type Input = String

-- | Steps to create a new RR:
-- | 1. `CreateNewRRModal AcceptedRRTypes`: create a modal with default values based on selected accepted type.
-- | 2. `UpdateCurrentRR Field`: modify the fields of the future new RR.
-- | 3. `ValidateRR AcceptedRRTypes`: validate the new RR stored in `_currentRR`.
-- |    In case it works, automatically call `AddRR` then `CancelModal`.
-- | 4. `AddRR AcceptedRRTypes ResourceRecord`: send a message to `dnsmanagerd`.
-- |
-- | Steps to update an entry:
-- | 1. `CreateUpdateRRModal RRId`: create a modal from the values of the RR in `_resources` to update.
-- | 2. `UpdateCurrentRR Field`: modify the currently displayed RR.
-- | 3. `ValidateLocal RRId AcceptedRRTypes`: validate the RR.
-- | 4. `SaveRR ResourceRecord`: save the _validated_ RR by sending a message to `dnsmanagerd`.

data Action
  -- | Initiate the component. This means asking the content of the zone to `dnsmanagerd`.
  = Initialize

  -- | Cancel the current displayed modal.
  | CancelModal

  -- | Create a new resource record modal (a form) for a certain type of component.
  | CreateNewRRModal AcceptedRRTypes

  -- | Delegation modal.
  | CreateDelegationModal

  -- | Create modal (a form) for a resource record to update.
  | CreateUpdateRRModal RRId

  -- | Create a modal to ask confirmation before deleting a resource record.
  | DeleteRRModal RRId

  -- | Change the current tab.
  | ChangeTab Tab

  -- | Return to the domain list.
  | ReturnToDomainList

  -- | Update new entry form (in the `rr_modal` modal).
  | UpdateCurrentRR Field.Field

  -- | Update a delegation form field (new nameservers for the domain).
  | UpdateDelegationForm Delegation.Field

  -- | Validate the delegation.
  | ValidateDelegation

  -- | Save the delegation.
  | SaveDelegation

  -- | Validate a new resource record before adding it.
  | ValidateRR AcceptedRRTypes

  -- | Validate the entries in an already existing resource record.
  -- | Automatically calls for `SaveRR` once record is verified.
  | ValidateLocal

  -- | Add a new resource record to the zone.
  | AddRR AcceptedRRTypes ResourceRecord

  -- | Reset the different temporary values, such as SPF mechanisms or DMARC mail entry.
  | ResetTemporaryValues

  -- | Save the changes done in an already existing resource record.
  | SaveRR ResourceRecord

  -- | Send a message to remove a resource record.
  -- | Automatically closes the modal.
  | RemoveRR RRId

  -- | Ask `dnsmanagerd` for the generated zone file.
  | AskGeneratedZoneFile

  -- | Modification of any attribute of the current RR.
  | RRUpdate RRUpdateValue

  -- | Ask a (new) token for a resource record.
  | NewToken RRId

data Tab = Zone | TheBasics | TokenExplanation
derive instance eqTab :: Eq Tab
derive instance genericTab :: Generic Tab _
instance showTab :: Show Tab where
  show = genericShow

-- FIXME: this state is a mess.
type State =
  { _domain :: String

  -- A modal to present a form for adding a new RR.
  , rr_modal :: RRModal

  -- | All resource records.
  , _resources :: Array ResourceRecord
  --, _local_errors :: Hash.HashMap RRId (Array Validation.Error)

  -- Unique RR form.
  , _rr_form :: RRForm

  -- DelegationForm
  , _delegation_form :: Delegation.Form

  , current_tab :: Tab
  }

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

-- | Default available domain: netlib.re.

default_domain :: String
default_domain = "netlib.re"

initialState :: Input -> State
initialState domain =
  { rr_modal: NoModal

  , _domain: domain

  , _resources: []
  --, _local_errors: Hash.empty

  , _rr_form: mkEmptyRRForm

  , _delegation_form: Delegation.mkEmptyDelegationForm

  , current_tab: Zone
  }

type SortableRecord l = Record (rrtype :: String, rrid :: Int | l)

render :: forall m. State -> H.ComponentHTML Action () m
render state
  = Web.section_small
      [ fancy_tab
      , case state.current_tab of
          Zone -> render_zone
          TheBasics        -> Explanations.basics
          TokenExplanation -> Explanations.tokens
      ]
  where
    fancy_tab =
      Web.fancy_tabs
        [ Web.tab_entry (is_tab_active Zone)             "Zone"          (ChangeTab Zone)
        , Web.tab_entry (is_tab_active TheBasics)        "The basics 🧠" (ChangeTab TheBasics)
        , Web.tab_entry (is_tab_active TokenExplanation) "Tokens? 🤨"    (ChangeTab TokenExplanation)
        ]
    is_tab_active tab = state.current_tab == tab

    call_to_current_rr_modal
      = Modal.current_rr_modal state._domain state._rr_form state.rr_modal
          UpdateCurrentRR NewToken RRUpdate ValidateRR ValidateLocal CancelModal

    delegation_modal
      = Modal.delegation_modal state._domain state._delegation_form
          UpdateDelegationForm ValidateDelegation CancelModal

    render_zone =
      case state.rr_modal of
          RemoveRRModal rr_id -> Modal.modal_rr_delete rr_id RemoveRR CancelModal
          NewRRModal _        -> call_to_current_rr_modal
          UpdateRRModal       -> call_to_current_rr_modal
          DelegationModal     -> delegation_modal
          NoModal -> HH.div_
            [ Web.level [ Web.btn_ [C.is_large, C.is_info]  "Back to the domain list" ReturnToDomainList
                        , Web.h1 state._domain
                        ] []
            , Web.hr
            , Table.resource_records (sorted state._resources) CreateUpdateRRModal DeleteRRModal NewToken
            , Web.hr
            , render_new_records state
            , render_zonefile state._rr_form._zonefile
            ]

    sorted :: forall l. Array (SortableRecord (l)) -> Array (SortableRecord (l))
    sorted array =
      A.groupAllBy (comparing (_.rrtype)) array    -- [x2 z2 x1 y z1 z3] -> [ NE[x2x1] NE[y] NE[z2z1z3] ]
      # map NonEmpty.toArray                       -- -> [[x2x1][y][z2z1z3]]
      # map (A.sortBy (comparing (_.rrid)))        -- -> [[x1x2][y][z1z2z3]]
      # A.concat                                   -- -> [x1 x2 y z1 z2 z3]


handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
  -- | Cancel the current modal being presented.
  -- | Works for both "new RR", "update RR" and "remove RR" modals.
  CancelModal -> do
    H.modify_ _ { rr_modal = NoModal
                , _rr_form { _errors = []
                           , _dmarc_mail_errors = []
                           }
                }
    handleAction $ ResetTemporaryValues

  -- | Create the RR modal.
  DeleteRRModal rr_id -> do
    H.modify_ _ { rr_modal = RemoveRRModal rr_id }

  -- | Return to the domain list.
  ReturnToDomainList -> do
    H.raise ToDomainList

  -- | Change the current tab.
  ChangeTab new_tab -> do
    -- Store the current tab we are on and restore it when we reload.
    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
    H.liftEffect $ Storage.setItem "current-zone-tab" (show new_tab) sessionstorage
    H.modify_ _ { current_tab = new_tab }

  -- | Create modal (a form) for a resource record to update.
  CreateUpdateRRModal rr_id -> do
    state <- H.get
    case first (\rr -> rr.rrid == rr_id) state._resources of
      Nothing -> H.raise $ Log $ ErrorLog $ "Resource Record " <> show rr_id <> " not found"
      Just rr -> do
        H.modify_ _ { _rr_form { _rr = rr } }
        _ <- case rr.rrtype of
          "DKIM"  -> H.modify_ _ { _rr_form { tmp { dkim  = fromMaybe DKIM.emptyDKIMRR   rr.dkim  } }}
          "DMARC" -> H.modify_ _ { _rr_form { tmp { dmarc = fromMaybe DMARC.emptyDMARCRR rr.dmarc } }}
          _      -> pure unit
        H.modify_ _ { rr_modal = UpdateRRModal }

  -- | Each time a "new RR" button is clicked, the form resets.
  CreateNewRRModal t -> do
    state <- H.get
    H.modify_ _ { rr_modal = NewRRModal t, _rr_form { _rr = default_rr t state._domain } }

  -- | Delegation modal presents a simple form with two entries (chosen nameservers).
  CreateDelegationModal -> do
    H.modify_ _ { rr_modal = DelegationModal, _delegation_form = Delegation.mkEmptyDelegationForm }

  -- | Initialize the Zone component: ask for the domain zone to `dnsmanagerd`.
  Initialize -> do
    { _domain } <- H.get
    H.raise $ Log $ SystemLog $ "Asking the domain " <> _domain
    H.raise $ AskGetZone _domain

    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
    old_tab <- H.liftEffect $ Storage.getItem "current-zone-tab" sessionstorage
    case old_tab of
      Nothing -> pure unit
      Just current_tab -> case current_tab of
        "Zone"             -> handleAction $ ChangeTab Zone
        "TheBasics"        -> handleAction $ ChangeTab TheBasics
        "TokenExplanation" -> handleAction $ ChangeTab TokenExplanation
        _  -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab

  -- | Perform validation. In case the record is valid, it is added to the zone then the modal is closed.
  -- | Else, the different errors are added to the state.
  ValidateRR t -> do
    -- In case the `name` part of the resource record is empty, consider the name to be the domain itself.
    H.modify_ \s -> s { _rr_form { _rr = replace_name s._domain s._rr_form._rr } }

    -- TODO: should the code design change? Would the code be simplified by working only on _rr_form._rr.dkim?
    -- Since _rr_form._rr.dkim isn't modified directly, it is copied from `State`.
    _ <- case t of
           DKIM  -> H.modify_ \state -> state { _rr_form { _rr { dkim  = Just state._rr_form.tmp.dkim  } } }
           DMARC -> H.modify_ \state -> state { _rr_form { _rr { dmarc = Just state._rr_form.tmp.dmarc } } }
           _ -> pure unit

    state <- H.get
    case Validation.validation state._rr_form._rr of
      Left actual_errors -> do
        -- H.raise $ Log $ ErrorLog $ "Cannot add this " <> show t <> " resource record, some errors occured in the record:"
        -- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
        H.modify_ _ { _rr_form { _errors = actual_errors } }
      Right newrr -> do
        H.modify_ _ { _rr_form { _errors = []
                               , _dmarc_mail_errors = []
                               , tmp { dkim = DKIM.emptyDKIMRR
                                     , dmarc = DMARC.emptyDMARCRR
                                     }
                               }
                    }
        handleAction $ AddRR t newrr
        handleAction CancelModal

  -- | Try to add a resource record to the zone.
  -- | Can fail if the content of the form isn't valid.
  AddRR t newrr -> do
    { _domain } <- H.get
    H.raise $ Log $ SystemLog $ "Add new " <> show t
    H.modify_ _ { _rr_form { _zonefile = Nothing } }
    H.raise $ AskAddRR _domain newrr

  -- | Update the currently displayed RR form (new or update RR).
  UpdateCurrentRR field -> do
    state <- H.get
    let newRR = update_field state._rr_form._rr field
    H.modify_ _ { _rr_form { _rr = newRR } }

  -- | Update the delegation form.
  UpdateDelegationForm field -> do
    state <- H.get
    let newDelegationForm = Delegation.update_delegation_field state._delegation_form field
    H.modify_ _ { _delegation_form = newDelegationForm }

  -- | Validate any local RR with the new `_resources` and `_local_errors`.
  ValidateLocal -> do
    -- In case the `name` part of the resource record is empty, consider the name to be the domain itself.
    H.modify_ \s -> s { _rr_form { _rr = replace_name s._domain s._rr_form._rr } }

    -- Since _rr_form._rr.dkim isn't modified directly, it is copied from `State`.
    state0 <- H.get
    _ <- case state0._rr_form._rr.rrtype of
           "DKIM"  -> H.modify_ _ { _rr_form { _rr { dkim  = Just state0._rr_form.tmp.dkim  } } }
           "DMARC" -> H.modify_ _ { _rr_form { _rr { dmarc = Just state0._rr_form.tmp.dmarc } } }
           _      -> pure unit

    state <- H.get
    case Validation.validation state._rr_form._rr of
      Left actual_errors -> do
        H.modify_ _ { _rr_form { _errors = actual_errors } }
      Right rr -> do
        H.modify_ _ { _rr_form { _errors = [], _dmarc_mail_errors = [] } }
        handleAction $ SaveRR rr

  ResetTemporaryValues -> do
    H.modify_ _ { _rr_form { tmp { spf { mechanism_q = "pass"
                                       , mechanism_t = "a"
                                       , mechanism_v = ""
                                       , modifier_t = "redirect"
                                       , modifier_v = ""
                                       }
                                 , dmarc_mail = ""
                                 , dmarc_mail_limit = Nothing
                                 }
                           , _dmarc_mail_errors = []
                           }
                }

  SaveRR rr -> do
    { _domain } <- H.get
    H.raise $ Log $ SystemLog $ "Updating resource record " <> show rr.rrid
    H.modify_ _ { _rr_form { _zonefile = Nothing } }
    H.raise $ AskSaveRR _domain rr
    handleAction $ ResetTemporaryValues

  RemoveRR rr_id -> do
    { _domain } <- H.get
    H.modify_ _ { _rr_form { _zonefile = Nothing } }
    H.raise $ Log $ SystemLog $ "Ask to remove a RR " <> show rr_id
    H.raise $ AskDeleteRR _domain rr_id
    -- Modal doesn't need to be active anymore.
    handleAction CancelModal

  -- | Validate the delegation of the domain.
  ValidateDelegation -> do
    H.raise $ Log $ SystemLog "Validate the delegation"

    state <- H.get

    case ValidationDelegation.validation state._delegation_form of
      Left delegation_errors -> do
        H.modify_ _ { _delegation_form { errors = delegation_errors } }
      Right _ -> do
        H.modify_ _ { _delegation_form { errors = [] } }
        handleAction $ SaveDelegation

  -- | Save the delegation of the domain.
  SaveDelegation -> do
    H.raise $ Log $ SystemLog "Save the delegation"

  NewToken rr_id -> do
    { _domain } <- H.get
    H.raise $ Log $ SystemLog $ "Ask a token for rrid " <> show rr_id
    H.raise $ AskNewToken _domain rr_id

  AskGeneratedZoneFile -> do
    { _domain } <- H.get
    H.raise $ Log $ SystemLog $ "Asking for the '" <> _domain <> "' zonefile"
    H.raise $ AskZoneFile _domain

  RRUpdate value_to_update -> do
    state <- H.get
    H.modify_ _ { _rr_form = update_form state._rr_form value_to_update }
    case value_to_update of
      SPF_Mechanism_Add -> handleAction $ ResetTemporaryValues
      SPF_Modifier_Add  -> handleAction $ ResetTemporaryValues
      DMARC_rua_Add     -> handleAction $ ResetTemporaryValues
      DMARC_ruf_Add     -> handleAction $ ResetTemporaryValues
      _                 -> pure unit

  where
  -- In case the `name` part of the resource record is empty replace it with the domain name.
  replace_name domain rr = case rr.name of
                         "" -> rr { name = domain <> "." }
                         _  -> rr

handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of

  MessageReceived message a -> do
    case message of
      (DNSManager.MkRRUpdated response) -> do
        replace_entry response.rr
        -- When an update is received for a record, it means
        -- the update request has been accepted, the current modal can be closed.
        H.modify_ _ { rr_modal = NoModal }
      (DNSManager.MkRRAdded response) -> do
        state <- H.get
        H.put $ add_RR state response.rr
      (DNSManager.MkRRDeleted response) -> do
        -- Remove the resource record.
        state <- H.get
        H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= response.rrid) state._resources }
      (DNSManager.MkGeneratedZoneFile response) -> do
        H.modify_ _ { _rr_form { _zonefile = Just response.zonefile } }
      (DNSManager.MkZone response) -> do
        add_entries response.zone.resources

      _ -> H.raise $ Log $ ErrorLog $ "Message not handled in Page.Zone."
    pure (Just a)

  where
    -- replace_entry :: ResourceRecord
    replace_entry new_rr = do
      state <- H.get
      H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= new_rr.rrid) state._resources }

      new_state <- H.get
      H.put $ add_RR new_state new_rr

    add_entries []  = pure unit
    add_entries arr = do
      case A.head arr, A.tail arr of
        Nothing, _ -> pure unit
        Just new_rr, tail -> do
            state <- H.get
            H.put $ add_RR state new_rr
            add_entries $ fromMaybe [] tail

    add_RR :: State -> ResourceRecord -> State
    add_RR state new_rr = state { _resources = (state._resources <> [ new_rr ]) }

render_new_records :: forall (w :: Type). State -> HH.HTML w Action
render_new_records _
  = Web.hdiv
      [ Web.h1 "Adding new records"
      -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
      , Web.level [
            Web.btn     "A" (CreateNewRRModal A)
          , Web.btn  "AAAA" (CreateNewRRModal AAAA)
          , Web.btn   "TXT" (CreateNewRRModal TXT)
          , Web.btn "CNAME" (CreateNewRRModal CNAME)
          , Web.btn    "NS" (CreateNewRRModal NS)
          , Web.btn    "MX" (CreateNewRRModal MX)
          , Web.btn   "SRV" (CreateNewRRModal SRV)
          ] []
      , Web.hr
      , Web.h1 "Special records about certifications and the mail system"
      -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
      , Web.level [
            Web.btn "CAA"   (CreateNewRRModal CAA)
          , Web.btn "SPF"   (CreateNewRRModal SPF)
          , Web.btn "DKIM"  (CreateNewRRModal DKIM)
          , Web.btn "DMARC" (CreateNewRRModal DMARC)
          ] []
      , Web.hr
      , Web.h1 "Delegation"
      -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
      , Web.level [
            Web.btn "Delegate your domain to different name servers" CreateDelegationModal
          ] []
      , Web.hr
      , Web.level [
            Web.btn "Get the final zone file" AskGeneratedZoneFile
          ] [HH.text "For debug purposes. ⚠"]
      ]

render_zonefile :: forall (w :: Type). Maybe String -> HH.HTML w Action
render_zonefile zonefile = Web.box [ maybe (HH.text "") (\x -> HH.pre_ [HH.text x]) zonefile ]

-- ACTIONS

first :: forall a. (a -> Boolean) -> Array a -> Maybe a
first condition = A.head <<< (A.filter condition)

loopE :: forall state action input output m a b
  .  (a -> H.HalogenM state action input output m b)
  -> Array a
  -> H.HalogenM state action input output m Unit
loopE f a = case (A.head a) of
  Nothing -> pure unit
  Just x  -> do void $ f x
                case (A.tail a) of
                  Nothing -> pure unit
                  Just xs -> loopE f xs

update_field :: ResourceRecord -> Field.Field -> ResourceRecord
update_field rr updated_field = case updated_field of
  Field.Domain val           -> rr { name       = toLower val }
  Field.Target val           -> rr { target     = val }
  Field.TTL val              -> rr { ttl        = fromMaybe 0 (fromString val) }
  Field.Priority val         -> rr { priority   = fromString val }
  Field.Weight val           -> rr { weight     = fromString val }
  Field.Port val             -> rr { port       = fromString val }
  Field.SPF_v val            -> rr { v          = Just val }
  Field.SPF_mechanisms val   -> rr { mechanisms = Just val }
  Field.SPF_modifiers val    -> rr { modifiers  = Just val }
  Field.SPF_q val            -> rr { q          = Just val }

  Field.CAA_flag val ->
    let new_caa = (fromMaybe default_caa rr.caa) { flag = fromMaybe 0 $ fromString val }
    in rr { caa = Just new_caa }

  Field.CAA_value val ->
    let new_caa = (fromMaybe default_caa rr.caa) { value = val }
    in rr { caa = Just new_caa }