From 0cc1fec90b08481f871cb819505315b2050e6a0f Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Mon, 5 Feb 2024 19:32:02 +0100 Subject: [PATCH] WIP: switching to ResourceRecord everywhere. Cannot compile ATM. --- src/App/Validation.purs | 2 +- src/App/ZoneInterface.purs | 381 ++++++++++++++++++++++++++++--------- 2 files changed, 293 insertions(+), 90 deletions(-) diff --git a/src/App/Validation.purs b/src/App/Validation.purs index d9d5bc7..cdbbcab 100644 --- a/src/App/Validation.purs +++ b/src/App/Validation.purs @@ -559,7 +559,7 @@ validationSRV form = ado weight <- parse weight_parser form.weight VEWeight in toRR_srv form.rrid form.readonly "SRV" name ttl target priority port protocol weight -validation :: forall l. SRVRR (|l) -> AcceptedRRTypes -> Either AVErrors ResourceRecord +validation :: ResourceRecord -> AcceptedRRTypes -> Either AVErrors ResourceRecord validation entry t = case t of A -> toEither $ validationA entry AAAA -> toEither $ validationAAAA entry diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs index d15e1c8..f536e0e 100644 --- a/src/App/ZoneInterface.purs +++ b/src/App/ZoneInterface.purs @@ -219,7 +219,7 @@ type State = -- TODO: get all the resources in a single entry. -- Better that way: simpler code. - , _resources :: Array (SRVRR ()) + , _resources :: Array ResourceRecord , _local_errors :: Hash.HashMap RRId (Array Validation.ValidationError) -- current entries @@ -230,7 +230,7 @@ type State = , _errors :: Hash.HashMap RRId Validation.Errors -- Unique RR form. - , _currentRR :: (SRVRR ()) -- SRVRR contains all relevant information for every RR. + , _currentRR :: ResourceRecord , _currentRR_errors :: Array Validation.ValidationError -- potential future entries @@ -259,6 +259,32 @@ component = default_domain :: String default_domain = "netlib.re" +default_empty_rr + = { rrtype: "A" + , rrid: "0" + , name: "www" + , ttl: 1800 + , target: "10.0.0.1" + , readonly: false + + -- MX (and SRV) specific entry. + , priority: Nothing + + -- SRV specific entries. + , port: Nothing + , protocol: Nothing + , weight: Nothing + + -- SOA specific entries. + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + initialState :: Input -> State initialState domain = { wsUp: true @@ -276,7 +302,7 @@ initialState domain = , _errors: Hash.empty -- This is the state for the new RR modal. - , _currentRR: defaultResourceSRV + , _currentRR: default_empty_rr -- List of errors within the form in new RR modal. , _currentRR_errors: [] @@ -359,17 +385,17 @@ render state , Bulma.box_input ("domain" <> state._currentRR.rrtype) "Name" "www" -- id, title, placeholder (updateForm Field_Domain) -- action state._currentRR.name -- value - state._currentRR.valid -- validity (TODO) + true -- state._currentRR.valid -- validity (TODO) should_be_disabled -- condition , Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600" (updateForm Field_TTL) - state._currentRR.ttl - state._currentRR.valid + (show state._currentRR.ttl) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5" (updateForm Field_Target) state._currentRR.target - state._currentRR.valid + true -- state._currentRR.valid should_be_disabled ] content_mx :: Array (HH.HTML w Action) @@ -378,22 +404,22 @@ render state , Bulma.box_input ("domainMX") "Name" "mail" -- id, title, placeholder (updateForm Field_Domain) -- action state._currentRR.name -- value - state._currentRR.valid -- validity (TODO) + true -- state._currentRR.valid -- validity (TODO) should_be_disabled -- condition , Bulma.box_input ("ttlMX") "TTL" "600" (updateForm Field_TTL) - state._currentRR.ttl - state._currentRR.valid + (show state._currentRR.ttl) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("targetMX") "Target" "www" (updateForm Field_Target) state._currentRR.target - state._currentRR.valid + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("priorityMX") "Priority" "10" (updateForm Field_Priority) - state._currentRR.priority - state._currentRR.valid + (maybe "" show state._currentRR.priority) + true -- state._currentRR.valid should_be_disabled ] content_srv :: Array (HH.HTML w Action) @@ -402,37 +428,37 @@ render state , Bulma.box_input ("domainSRV") "Name" "_sip._tcp" -- id, title, placeholder (updateForm Field_Domain) -- action state._currentRR.name -- value - state._currentRR.valid -- validity (TODO) + true -- state._currentRR.valid -- validity (TODO) should_be_disabled -- condition , Bulma.box_input ("ttlSRV") "TTL" "600" (updateForm Field_TTL) - state._currentRR.ttl - state._currentRR.valid + (show state._currentRR.ttl) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("targetSRV") "Target" "www" (updateForm Field_Target) state._currentRR.target - state._currentRR.valid + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("prioritySRV") "Priority" "10" (updateForm Field_Priority) - state._currentRR.priority - state._currentRR.valid + (maybe "" show state._currentRR.priority) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("portSRV") "Port" "5061" (updateForm Field_Port) - state._currentRR.port - state._currentRR.valid + (maybe "" show state._currentRR.port) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("weightSRV") "Weight" "100" (updateForm Field_Weight) - state._currentRR.weight - state._currentRR.valid + (maybe "" show state._currentRR.weight) + true -- state._currentRR.valid should_be_disabled , Bulma.box_input ("protocolSRV") "Protocol" "tcp" (updateForm Field_Protocol) state._currentRR.protocol - state._currentRR.valid + true -- state._currentRR.valid should_be_disabled ] @@ -474,34 +500,132 @@ handleAction = case _ of CreateNewRRModal t -> do state <- H.get H.modify_ _ { rr_modal = NewRRModal t } - let defaultA = { rrtype: "A", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "www" - , target: "192.0.2.1" - , port: "", weight: "", priority: "", protocol: ""} - defaultAAAA = { rrtype: "AAAA", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "www" - , target: "2001:db8::1" - , port: "", weight: "", priority: "", protocol: ""} - defaultTXT = { rrtype: "TXT", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "txt" - , target: "some text" - , port: "", weight: "", priority: "", protocol: ""} - defaultCNAME = { rrtype: "CNAME", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "blog" - , target: "www" - , port: "", weight: "", priority: "", protocol: ""} - defaultNS = { rrtype: "NS", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: (state._domain <> ".") - , target: "ns0.example.com." - , port: "", weight: "", priority: "", protocol: ""} - defaultMX = { rrtype: "MX", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "mail" - , target: "www" - , port: "", weight: "", priority: "10", protocol: ""} - defaultSRV = { rrtype: "SRV", rrid: 0, modified: false, valid: true, ttl: "600", readonly: false - , name: "_sip._tcp" - , target: "www" - , port: "5061", weight: "100", priority: "10", protocol: "tcp"} + let defaultA = { rrtype: "A" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "www" + , target: "192.0.2.1" + , port: Nothing + , weight: Nothing + , priority: Nothing + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultAAAA = { rrtype: "AAAA" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "www" + , target: "2001:db8::1" + , port: Nothing + , weight: Nothing + , priority: Nothing + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultTXT = { rrtype: "TXT" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "txt" + , target: "some text" + , port: Nothing + , weight: Nothing + , priority: Nothing + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultCNAME = { rrtype: "CNAME" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "blog" + , target: "www" + , port: Nothing + , weight: Nothing + , priority: Nothing + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultNS = { rrtype: "NS" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: (state._domain <> ".") + , target: "ns0.example.com." + , port: Nothing + , weight: Nothing + , priority: Nothing + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultMX = { rrtype: "MX" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "mail" + , target: "www" + , port: Nothing + , weight: Nothing + , priority: Just 10 + , protocol: Nothing + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } + defaultSRV = { rrtype: "SRV" + , rrid: 0 + , ttl: 600 + , readonly: false + , name: "_sip._tcp" + , target: "www" + , port: Just 5061 + , weight: Just 100 + , priority: Just 10 + , protocol: Just "tcp" + , mname: Nothing + , rname: Nothing + , serial: Nothing + , refresh: Nothing + , retry: Nothing + , expire: Nothing + , minttl: Nothing + } case t of A -> H.modify_ _ { _currentRR = defaultA } AAAA -> H.modify_ _ { _currentRR = defaultAAAA } @@ -688,8 +812,7 @@ handleAction = case _ of where try_update_entry :: forall r . String - -> (AtLeastRRID r - -> Either Validation.Errors ResourceRecord) + -> (AtLeastRRID r -> Either Validation.Errors ResourceRecord) -> Maybe (AtLeastRRID r) -> String -> H.HalogenM State Action () Output m Unit @@ -728,6 +851,8 @@ handleQuery = case _ of case add_entry state new_rr of Left error_message -> H.raise $ Log $ SimpleLog $ "Error while adding new entry: " <> error_message Right new_state -> H.put new_state + nstate <- H.get + H.put $ add_RR nstate new_rr (DNSManager.MkRRDeleted response) -> do -- Remove the resource record. state <- H.get @@ -765,6 +890,8 @@ handleQuery = case _ of case add_entry new_state new_rr of Left errmsg -> H.raise $ Log $ SimpleLog $ "Error while replacing a resource record: " <> errmsg Right s -> H.put s + new_state2 <- H.get + H.put $ add_RR new_state2 new_rr add_entries [] = H.raise $ Log $ SimpleLog "[🎉] Zone fully loaded!" add_entries arr = do @@ -775,10 +902,29 @@ handleQuery = case _ of Left error_message -> do H.raise $ Log $ SimpleLog $ "Error while adding new entry: " <> error_message add_entries $ fromMaybe [] tail - Right new_state -> do - H.put new_state + Right new_state -> do + H.put $ add_RR new_state new_rr -- TODO: add to `_resources` add_entries $ fromMaybe [] tail + add_RR :: State -> ResourceRecord -> State + add_RR state new_rr = state { _resources = (state._resources <> [ fromRRToSRVRR new_rr ]) } + + fromRRToSRVRR :: ResourceRecord -> SRVRR () + fromRRToSRVRR new_rr = do + { rrtype: new_rr.rrtype + , rrid: new_rr.rrid + , modified: false + , valid: true + , readonly: new_rr.readonly + , ttl: show new_rr.ttl + , name: new_rr.name + , target: new_rr.target + , port: maybe "" show new_rr.port + , weight: maybe "" show new_rr.weight + , priority: maybe "" show new_rr.priority + , protocol: maybe "" id new_rr.protocol + } + add_entry :: State -> ResourceRecord -> Either String State add_entry state new_rr = do case new_rr.rrtype, (A.elem new_rr.rrtype baseRecords) of @@ -789,6 +935,42 @@ handleQuery = case _ of _, _ -> Left $ "TODO: cannot add '" <> new_rr.rrtype <> "' resource records at the moment." -- Rendering +render_soa2 :: forall (w :: Type). Maybe ResourceRecord -> HH.HTML w Action +render_soa2 Nothing = Bulma.box [ HH.text "SOA not loaded, yet" ] +render_soa2 (Just soa) = Bulma.box [ Bulma.zone_rr_title "Start Of Authority (SOA)" + , table_rr + ] + where table_rr = Bulma.table [] [ simple_SOA_table_header, table_content ] + simple_SOA_table_header + = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "name"] + , HH.th_ [ HH.text "ttl"] + , HH.th_ [ HH.text "target"] + , HH.th_ [ HH.text "mname"] + , HH.th_ [ HH.text "rname"] + , HH.th_ [ HH.text "serial"] + , HH.th_ [ HH.text "refresh"] + , HH.th_ [ HH.text "retry"] + , HH.th_ [ HH.text "expire"] + , HH.th_ [ HH.text "minttl"] + ] + ] + table_content + = HH.tbody_ $ [ HH.tr_ $ [ + --, Bulma.p $ "rrtype: " <> soa.rrtype + --, Bulma.p $ "rrid: " <> show soa.rrid + HH.td_ [ HH.text soa.name ] + , HH.td_ [ HH.text $ show soa.ttl ] + , HH.td_ [ HH.text soa.target ] + , HH.td_ [ HH.text $ maybe "" id soa.mname ] + , HH.td_ [ HH.text $ maybe "" id soa.rname ] + , HH.td_ [ HH.text $ maybe "" show soa.serial ] + , HH.td_ [ HH.text $ maybe "" show soa.refresh ] + , HH.td_ [ HH.text $ maybe "" show soa.retry ] + , HH.td_ [ HH.text $ maybe "" show soa.expire ] + , HH.td_ [ HH.text $ maybe "" show soa.minttl ] + ] + ] + render_soa :: forall (w :: Type). Maybe (SOARR ()) -> HH.HTML w Action render_soa Nothing = Bulma.box [ HH.text "SOA not loaded, yet" ] render_soa (Just soa) = Bulma.box [ Bulma.zone_rr_title "Start Of Authority (SOA)" @@ -826,47 +1008,68 @@ render_soa (Just soa) = Bulma.box [ Bulma.zone_rr_title "Start Of Authority (SOA ] -- | Render all Resource Records. -render_resources :: forall (w :: Type). Hash.HashMap RRId (Array Validation.ValidationError) -> Array (SRVRR ()) -> HH.HTML w Action +render_resources :: forall w + . Hash.HashMap RRId (Array Validation.ValidationError) + -> Array (ResourceRecord) + -> HH.HTML w Action render_resources _ [] = Bulma.box [ Bulma.zone_rr_title "All records (TEST)" , Bulma.subtitle "No records for now" ] render_resources errors records = Bulma.box [ Bulma.zone_rr_title "All records (TEST)" - , Bulma.subtitle "TODO: display the records." + , render_soa2 $ A.head $ A.filter (\rr -> rr.rrtype == "SOA") records + , table_rr ] ---render_resources errors records --- = Bulma.box [ Bulma.zone_rr_title "All records (TEST)" --- , table_rr --- ] --- where --- table_rr = Bulma.table [] [ Bulma.zone_rr_title "XXX", table_content ] --- table_content = HH.tbody_ $ A.concat $ map rows records --- rows rr --- = [ HH.tr_ $ --- [ Bulma.txt_name rr.rrtype --- , HH.td_ [ Bulma.input_domain (update_simple rr.rrid Update_SRR_Domain) rr.name rr.valid ] --- , HH.td_ [ Bulma.input_ttl (update_simple rr.rrid Update_SRR_TTL ) rr.ttl rr.valid ] --- , HH.td_ [ case rr.rrtype of --- "TXT" -> Bulma.textarea (update_simple rr.rrid Update_SRR_Target) rr.target rr.valid --- _ -> Bulma.input_target (update_simple rr.rrid Update_SRR_Target) rr.target rr.valid --- ] --- , HH.td_ [ Bulma.btn_change (SaveSRR rr.rrid) (TellSomethingWentWrong rr.rrid "cannot update") rr.modified rr.valid ] --- , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.rrid) ] --- ] --- ] <> error_row rr --- update_simple rrid v = (UpdateLocalRR rrid) <<< Update_Local_Form_SRR <<< v --- error_row rr = case Hash.lookup rr.rrid errors of --- Nothing -> [] --- Just error_array -> [ HH.tr_ $ --- [ Bulma.txt_name "" --- , HH.td_ $ from_error_array_to_td error_array Validation.Name --- , HH.td_ $ from_error_array_to_td error_array Validation.TTL --- , HH.td_ $ from_error_array_to_td error_array Validation.Target --- , HH.td_ [] --- , HH.td_ [] --- ] + where + table_rr = Bulma.table [] [ table_content ] + table_content = HH.tbody_ $ A.concat $ map rows records + rows rr = [ HH.tr_ $ render_row rr ] -- <> error_row rr + +-- error_row rr = case Hash.lookup rr.rrid errors of +-- Nothing -> [] +-- Just error_array -> [ HH.tr_ $ +-- [ Bulma.txt_name "" +-- , HH.td_ $ from_error_array_to_td error_array Validation.Name +-- , HH.td_ $ from_error_array_to_td error_array Validation.TTL +-- , HH.td_ $ from_error_array_to_td error_array Validation.Target +-- , HH.td_ [] +-- , HH.td_ [] -- ] +-- ] + + render_row :: ResourceRecord -> Array (HH.HTML w Action) + render_row rr = + case rr.rrtype of + "SRV" -> + [ Bulma.txt_name rr.rrtype + , HH.td_ [ Bulma.p rr.name] + , HH.td_ [ Bulma.p $ show rr.ttl ] + , HH.td_ [ Bulma.p $ maybe "" show rr.priority ] + , HH.td_ [ Bulma.p $ maybe "" id rr.protocol ] + , HH.td_ [ Bulma.p $ maybe "" show rr.weight ] + , HH.td_ [ Bulma.p $ maybe "" show rr.port ] + , HH.td_ [ Bulma.p rr.target ] + , HH.td_ [ Bulma.btn_change (CreateUpdateRRModal rr.rrid) (TellSomethingWentWrong rr.rrid "cannot update") true true ] + , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.rrid) ] + ] + "MX" -> + [ Bulma.txt_name rr.rrtype + , HH.td_ [ Bulma.p rr.name] + , HH.td_ [ Bulma.p $ show rr.ttl ] + , HH.td_ [ Bulma.p $ maybe "" show rr.priority ] + , HH.td_ [ Bulma.p rr.target ] + , HH.td_ [ Bulma.btn_change (CreateUpdateRRModal rr.rrid) (TellSomethingWentWrong rr.rrid "cannot update") true true ] + , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.rrid) ] + ] + _ -> + [ Bulma.txt_name rr.rrtype + , HH.td_ [ Bulma.p rr.name] + , HH.td_ [ Bulma.p $ show rr.ttl ] + , HH.td_ [ Bulma.p rr.target ] + , HH.td_ [ Bulma.btn_change (CreateUpdateRRModal rr.rrid) (TellSomethingWentWrong rr.rrid "cannot update") true true ] + , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.rrid) ] + ] render_records :: forall (w :: Type). Hash.HashMap RRId Validation.Errors -> Array (SimpleRR ()) -> HH.HTML w Action render_records _ []