karchnu/halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

WIP: switching to ResourceRecord everywhere. Cannot compile ATM.

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-05 19:32:02 +01:00
parent 0838c962f0
commit 0cc1fec90b
2 changed files with 293 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/App/Validation.purs
View File

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

381
src/App/ZoneInterface.purs
View File

@ -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 _ []