From 6ccc1846df5f061565addcc506f84db30d519e70 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Sun, 9 Jul 2023 05:14:29 +0200 Subject: [PATCH] Adding a WIP zone interface. Not even showable ATM. --- spago.dhall | 1 + src/App/DomainListInterface.purs | 2 +- src/App/RR.purs | 137 +++++ src/App/Style.purs | 290 +++++++++++ src/App/ZoneInterface.purs | 847 +++++++++++++++++++++++++++++++ 5 files changed, 1276 insertions(+), 1 deletion(-) create mode 100644 src/App/RR.purs create mode 100644 src/App/Style.purs create mode 100644 src/App/ZoneInterface.purs diff --git a/spago.dhall b/spago.dhall index ba24387..f047f80 100644 --- a/spago.dhall +++ b/spago.dhall @@ -14,6 +14,7 @@ , "effect" , "either" , "exceptions" + , "foldable-traversable" , "foreign" , "halogen" , "halogen-subscriptions" diff --git a/src/App/DomainListInterface.purs b/src/App/DomainListInterface.purs index 0b930d0..998e551 100644 --- a/src/App/DomainListInterface.purs +++ b/src/App/DomainListInterface.purs @@ -6,7 +6,7 @@ -- | - show and select accepted domains (TLDs) -- | - create new domains -- | - delete a domain --- | - TODO: ask for confirmation +-- | - ask for confirmation -- | - TODO: switch to the interface to show and modify the content of a Zone module App.DomainListInterface where diff --git a/src/App/RR.purs b/src/App/RR.purs new file mode 100644 index 0000000..897f58f --- /dev/null +++ b/src/App/RR.purs @@ -0,0 +1,137 @@ +module App.RR where + +type InputParameter + = { valid :: Boolean + , value :: String + } + +type RecordType = String +type RecordValue = String +type RecordDomain = String + +-- These should be integers, but I use these values in user inputs. +type TTL = String +type Weight = String +type Priority = String +type Port = String + +type RRId = Int + +type Modified = Boolean +type Valid = Boolean + +type RecordBase l + = { t :: RecordType + , id :: RRId + , modified :: Boolean + , valid :: Boolean + , ttl :: TTL + , domain :: RecordDomain + , value :: RecordValue | l + } + +-- CNAME A AAAA NS TXT +type SimpleRR l = RecordBase (|l) + +type MXRR l = RecordBase ( priority :: Priority | l) +type SRVRR l = RecordBase ( priority :: Priority + , weight :: Weight + , port :: Port + | l) + +--data Status +-- = Synchronized +-- | UnSynchronized +-- +--type Reason = String +--data Validity +-- = Valid +-- | Invalid (Maybe Reason) +-- +---- TODO: add smart constructors. +--data Domain = Domain String +--data RRAValue = RRAValue String +--data RRAAAAValue = RRAAAAValue String +--data RRCNAMEValue = RRCNAMEValue String +--data RRNSValue = RRNSValue String +--data RRTXTValue = RRTXTValue String +--data RRMXValue = RRMXValue String +--data RRSRVValue = RRSRVValue String +--data Priority = Priority String +--data Weight = Weight String +--data Port = Port String +-- +--data RR +-- = A RRId Status Validity TTL Domain RRAValue +-- | AAAA RRId Status Validity TTL Domain RRAAAAValue +-- | CNAME RRId Status Validity TTL Domain RRCNAMEValue +-- | NS RRId Status Validity TTL Domain RRNSValue +-- | TXT RRId Status Validity TTL Domain RRTXTValue +-- | MX RRId Status Validity TTL Domain RRMXValue Priority +-- | SRV RRId Status Validity TTL Domain RRSRVValue Priority Weight Port + +mkNS :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> RecordBase () +mkNS i c ok t d v + = { id: i, t: "NS", modified: c, valid: ok + , ttl: t, domain: d, value: v } +mkA :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> RecordBase () +mkA i c ok t d v + = { id: i, t: "A", modified: c, valid: ok + , ttl: t, domain: d, value: v } +mkAAAA :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> RecordBase () +mkAAAA i c ok t d v + = { id: i, t: "AAAA", modified: c, valid: ok + , ttl: t, domain: d, value: v } +mkCNAME :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> RecordBase () +mkCNAME i c ok t d v + = { id: i, t: "CNAME", modified: c, valid: ok + , ttl: t, domain: d, value: v } +mkTXT :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> RecordBase () +mkTXT i c ok t d v + = { id: i, t: "TXT", modified: c, valid: ok + , ttl: t, domain: d, value: v } + +mkMX :: RRId -> Modified -> Valid + -> TTL -> RecordDomain -> RecordValue -> Priority -> MXRR () +mkMX i c ok t d v p + = { id: i, t: "MX", modified: c, valid: ok + , ttl: t, priority: p, domain: d, value: v } + +mkSRV :: RRId -> Modified -> Valid + -> Priority -> Weight -> Port + -> TTL -> RecordDomain -> RecordValue -> SRVRR () +mkSRV i c ok p w prt t d v + = { id: i, t: "SRV", modified: c + , valid: ok, priority: p, weight: w, port: prt + , ttl: t, domain: d, value: v + } + +defaultResourceRecords :: Array (SimpleRR ()) +defaultResourceRecords + = [ mkNS 0 false true "3600" "@" "ns0.truc.fr" + , mkA 1 false true "200" "www" "192.168.10.2" + , mkAAAA 2 false true "610" "www" "fe80::1" + , mkCNAME 3 false true "630" "nom" "autrenom" + , mkTXT 4 false true "600" "txtme" "Ceci est un texte." + ] + +defaultMXResourceRecords :: Array (MXRR ()) +defaultMXResourceRecords + = [ mkMX 5 false true "600" "www" "192.168.10.2" "200" + , mkMX 6 false true "3600" "www" "192.168.10.2" "200" + ] + +defaultResourceA :: SimpleRR () +defaultResourceA = mkA 0 false true "200" "www" "192.168.10.2" + +defaultResourceMX :: MXRR () +defaultResourceMX = mkMX 0 false true "500" "www" "192.168.10.2" "200" + +defaultResourceSRV :: SRVRR () +-- RRId Modified Valid Priority Weight Port TTL Domain Value +defaultResourceSRV = mkSRV 0 false true "10" "100" "80" "200" "www" "192.168.10.2" diff --git a/src/App/Style.purs b/src/App/Style.purs new file mode 100644 index 0000000..6f0cccc --- /dev/null +++ b/src/App/Style.purs @@ -0,0 +1,290 @@ +module App.Style where + +import Prelude + +import Halogen.HTML as HH +import Halogen.HTML.Properties as HP +import Halogen.HTML.Events as HE + +-- HTML PropName used with HP.prop +import Halogen.HTML.Core (PropName(..)) +-- import Web.Event.Event (type_, Event, EventType(..)) +import Web.UIEvent.MouseEvent (MouseEvent) + +-- This file is mostly a wrapper around BULMA. + +class_columns :: Array (HH.ClassName) +class_columns = [HH.ClassName "columns" ] +class_column :: Array (HH.ClassName) +class_column = [HH.ClassName "column" ] +class_title :: Array (HH.ClassName) +class_title = [HH.ClassName "title" ] +class_subtitle :: Array (HH.ClassName) +class_subtitle = [HH.ClassName "subtitle" ] +class_is5 :: Array (HH.ClassName) +class_is5 = [HH.ClassName "is-5" ] +class_is4 :: Array (HH.ClassName) +class_is4 = [HH.ClassName "is-4" ] +class_box :: Array (HH.ClassName) +class_box = [HH.ClassName "box" ] +class_label :: Array (HH.ClassName) +class_label = [HH.ClassName "label" ] +class_control :: Array (HH.ClassName) +class_control = [HH.ClassName "control" ] + + +columns :: forall (w :: Type) (i :: Type). + Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i +columns classes = HH.div [ HP.classes (class_columns <> classes) ] + +columns_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i +columns_ = columns [] + +column :: forall (w :: Type) (i :: Type). + Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i +column classes = HH.div [ HP.classes (class_column <> classes) ] + +column_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i +column_ = column [] + +h1 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a +h1 title = HH.h1 [ HP.classes (class_title) ] [ HH.text title ] + +h3 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a +h3 title = HH.h1 [ HP.classes (class_title <> class_is5) ] [ HH.text title ] + +subtitle :: forall (w :: Type) (a :: Type). String -> HH.HTML w a +subtitle title = HH.h2 [ HP.classes (class_subtitle <> class_is4) ] [ HH.text title ] + +hdiv :: forall (w :: Type) (a :: Type). Array (HH.HTML w a) -> HH.HTML w a +hdiv = HH.div [ HP.classes [HH.ClassName "mt-5"] ] + +offcolumn :: forall (w :: Type) (a :: Type). + Int -> Int -> Array (HH.HTML w a) -> HH.HTML w a +offcolumn 0 size = HH.div [ HP.classes [HH.ClassName ("mt-"<>show size)] ] +offcolumn offset size + = column [ HH.ClassName ("is-offset-" <> (show offset) <> " is-" <> (show size)) ] + +input_classes :: forall (r :: Row Type) (i :: Type) + . Boolean -> HP.IProp ( class :: String | r ) i +input_classes true = HP.classes [ HH.ClassName "input is-small is-info" ] +input_classes false = HP.classes [ HH.ClassName "input is-small is-danger" ] + +btn_classes :: forall (r :: Row Type) (i :: Type) + . Boolean -> HP.IProp ( class :: String | r ) i +btn_classes true = HP.classes [ HH.ClassName "button is-small is-info" ] +btn_classes false = HP.classes [ HH.ClassName "button is-small is-danger" ] + +simple_table_header :: forall w i. HH.HTML w i +simple_table_header + = HH.thead_ [ HH.tr_ [ HH.th [ HP.style "width: 50px;" ] [ HH.text "Type" ] + , HH.th_ [ HH.text "Domain" ] + , HH.th_ [ HH.text "TTL" ] + , HH.th_ [ HH.text "Value" ] + ] + ] + +mx_table_header :: forall w i. HH.HTML w i +mx_table_header + = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Domain" ] + , HH.th_ [ HH.text "TTL" ] + , HH.th_ [ HH.text "Priority" ] + , HH.th_ [ HH.text "Value" ] + ] + ] + +srv_table_header :: forall w i. HH.HTML w i +srv_table_header + = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Domain" ] + , HH.th_ [ HH.text "TTL" ] + , HH.th_ [ HH.text "Priority" ] + , HH.th_ [ HH.text "Weight" ] + , HH.th_ [ HH.text "Port" ] + , HH.th_ [ HH.text "Value" ] + ] + ] + +txt_name :: forall w i. String -> HH.HTML w i +txt_name t + = HH.td [ rr_name_style ] [ rr_name_text ] + where + rr_name_style = HP.style "width: 80px;" + rr_name_text = HH.text t + +input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_email action "" validity + = HH.input [ HE.onValueInput action, HP.placeholder "email", input_classes validity ] +input_email action email validity + = HH.input + [ HE.onValueInput action + , HP.value email + , HP.placeholder "email" + , input_classes validity + ] + +box_input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_email action email validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Email" ] + , HH.div [HP.classes class_control ] [ input_email action email validity ] + ] + + +input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_password action "" validity + = HH.input [ HE.onValueInput action, HP.placeholder "password", input_classes validity ] +input_password action password validity + = HH.input + [ HE.onValueInput action + , HP.value password + , HP.placeholder "password" + , input_classes validity + ] + +box_input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_password action password validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Password" ] + , HH.div [HP.classes class_control ] [ input_password action password validity ] + ] + + +-- TODO: right types +-- input_domain :: forall a w i +-- . (String -> a) +-- -> String +-- -> Boolean +-- -> HH.HTML w i +input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_domain action domain validity + = HH.input + [ HE.onValueInput action + , HP.value domain + , HP.placeholder "domain" + , input_classes validity + ] + +box_input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_domain action domain validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Domain" ] + , HH.div [HP.classes class_control ] [ input_domain action domain validity ] + ] + +input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_ttl action ttl validity + = HH.input + [ HE.onValueInput action + , HP.value ttl + , HP.prop (PropName "size") 6.0 + , HP.placeholder "ttl" + , input_classes validity + ] + +box_input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_ttl action value validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "TTL" ] + , HH.div [HP.classes class_control ] [ input_ttl action value validity ] + ] + + +input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_priority action priority validity + = HH.input + [ HE.onValueInput action + , HP.value priority + , HP.prop (PropName "size") 6.0 + , HP.placeholder "priority" + , input_classes validity + ] + +box_input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_priority action value validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Priority" ] + , HH.div [HP.classes class_control ] [ input_priority action value validity ] + ] + + +input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_value action value validity + = HH.input + [ HE.onValueInput action + , HP.value value + , HP.placeholder "value" + , input_classes validity + ] + +box_input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_value action value validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Value" ] + , HH.div [HP.classes class_control ] [ input_value action value validity ] + ] + + +input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_weight action weight validity + = HH.input + [ HE.onValueInput action + , HP.value weight + , HP.prop (PropName "size") 6.0 + , HP.placeholder "weight" + , input_classes validity + ] + +box_input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_weight action weight validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Weight" ] + , HH.div [HP.classes class_control ] [ input_weight action weight validity ] + ] + + +input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +input_port action port validity + = HH.input + [ HE.onValueInput action + , HP.value port + , HP.prop (PropName "size") 6.0 + , HP.placeholder "port" + , input_classes validity + ] + +box_input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i +box_input_port action port validity = HH.label [ ] + [ HH.label [HP.classes class_label ] [ HH.text "Port" ] + , HH.div [HP.classes class_control ] [ input_port action port validity ] + ] + + +btn_change :: forall w i. i -> i -> Boolean -> Boolean -> HH.HTML w i +btn_change action1 action2 modified validity + = HH.button + [ HP.disabled (not modified) + , btn_change_action validity + , btn_classes validity + ] [ HH.text "fix" ] + where + + btn_change_action = case _ of + true -> HE.onClick \_ -> action1 + _ -> HE.onClick \_ -> action2 + + +btn_delete :: forall w i. (MouseEvent -> i) -> HH.HTML w i +btn_delete action + = HH.button + [ HE.onClick action + , HP.classes [ HH.ClassName "button is-small is-danger" ] + ] [ HH.text "X" ] + + +btn_add :: forall w i. i -> i -> Boolean -> HH.HTML w i +btn_add action1 action2 validity + = HH.button + [ btn_add_action validity + , btn_classes validity + ] [ HH.text "Add" ] + where + + btn_add_action = case _ of + true -> HE.onClick \_ -> action1 + _ -> HE.onClick \_ -> action2 + +box :: forall w i. Array (HH.HTML w i) -> HH.HTML w i +box = HH.div [HP.classes class_box] diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs new file mode 100644 index 0000000..da4a4d0 --- /dev/null +++ b/src/App/ZoneInterface.purs @@ -0,0 +1,847 @@ +-- | `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 +