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

Compiles again, but not everything will work (still validations to do!)

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-14 01:04:38 +02:00
parent 15eb7d9acb
commit 418f6d74cd
2 changed files with 68 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/App/Validation.purs
View File

@ -102,7 +102,7 @@ validateA form = ado
name <- validate_name form.name name <- validate_name form.name
ttl <- validate_ttl form.ttl ttl <- validate_ttl form.ttl
target <- validate_target form.target target <- validate_target form.target
in pure $ toRR_basic form.rrid form.readonly "A" name ttl target in toRR_basic form.rrid form.readonly "A" name ttl target
validateAAAA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord validateAAAA :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateAAAA _ = invalid [Tuple NotAnAttribute "validation not implemented"] validateAAAA _ = invalid [Tuple NotAnAttribute "validation not implemented"]
@ -117,8 +117,8 @@ validateMX _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateSRV :: forall l. SRVRR (|l) -> V Errors ResourceRecord validateSRV :: forall l. SRVRR (|l) -> V Errors ResourceRecord
validateSRV _ = invalid [Tuple NotAnAttribute "validation not implemented"] validateSRV _ = invalid [Tuple NotAnAttribute "validation not implemented"]
validateSRR :: forall l. SimpleRR (|l) -> V Errors ResourceRecord validateSRR_ :: forall l. SimpleRR (|l) -> V Errors ResourceRecord
validateSRR form = case form.rrtype of validateSRR_ form = case form.rrtype of
"A" -> validateA form "A" -> validateA form
"AAAA" -> validateAAAA form "AAAA" -> validateAAAA form
"TXT" -> validateTXT form "TXT" -> validateTXT form
@ -126,19 +126,30 @@ validateSRR form = case form.rrtype of
"NS" -> validateNS form "NS" -> validateNS form
_ -> invalid [Tuple NotAnAttribute $ "invalid type: " <> form.rrtype] _ -> invalid [Tuple NotAnAttribute $ "invalid type: " <> form.rrtype]
validateMXRR :: forall l. MXRR (|l) -> V Errors ResourceRecord validateMXRR_ :: forall l. MXRR (|l) -> V Errors ResourceRecord
validateMXRR form = case form.rrtype of validateMXRR_ form = case form.rrtype of
"MX" -> validateMX form "MX" -> validateMX form
_ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: MX): " <> form.rrtype] _ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: MX): " <> form.rrtype]
validateSRVRR :: forall l. SRVRR (|l) -> V Errors ResourceRecord validateSRVRR_ :: forall l. SRVRR (|l) -> V Errors ResourceRecord
validateSRVRR form = case form.rrtype of validateSRVRR_ form = case form.rrtype of
"SRV" -> validateSRV form "SRV" -> validateSRV form
_ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: SRV): " <> form.rrtype] _ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: SRV): " <> form.rrtype]
-- TODO: whole zone validations. validateSRR :: forall l. SimpleRR (|l) -> Either Errors ResourceRecord
validateSRR = toEither <<< validateSRR_
validateMXRR :: forall l. MXRR (|l) -> Either Errors ResourceRecord
validateMXRR = toEither <<< validateMXRR_
validateSRVRR :: forall l. SRVRR (|l) -> Either Errors ResourceRecord
validateSRVRR = toEither <<< validateSRVRR_
-- type ZoneErrors = Array (Tuple Errors RRId)
-- type Zone l = String -> Array (SimpleRR (|l)) -> Array (MXRR (|l)) -> Array (SRVRR (|l))
-- validateZone :: forall l. Zone l -> Either Errors
-- Functions handling network-related structures (ResourceRecord). -- Functions handling network-related structures (ResourceRecord).

33
src/App/ZoneInterface.purs
View File

@ -42,6 +42,7 @@ import App.ResourceRecord (ResourceRecord)
import App.LogMessage (LogMessage(..)) import App.LogMessage (LogMessage(..))
import App.Messages.DNSManagerDaemon as DNSManager import App.Messages.DNSManagerDaemon as DNSManager
import App.Validation as Validation
-- | `App.ZoneInterface` can send messages through websocket interface -- | `App.ZoneInterface` can send messages through websocket interface
-- | connected to dnsmanagerd. See `App.WS`. -- | connected to dnsmanagerd. See `App.WS`.
@ -324,8 +325,10 @@ handleAction = case _ of
AddRR form -> case form of AddRR form -> case form of
Add_SRR -> do Add_SRR -> do
state <- H.get state <- H.get
let newrr = fromLocalSimpleRRRepresentationToResourceRecord state._current_entry case Validation.validateSRR state._current_entry of
-- H.raise $ Log $ SimpleLog $ "Add new simple RR: " <> show state._current_entry.rrtype Left _ -> H.raise $ Log $ SimpleLog "Cannot add this simple RR, some errors occured in the record"
Right newrr -> do
H.raise $ Log $ SimpleLog "Add new simple RR"
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
@ -333,8 +336,10 @@ handleAction = case _ of
Add_MXRR -> do Add_MXRR -> do
state <- H.get state <- H.get
let newrr = fromLocalMXRRRepresentationToResourceRecord state._current_entry_mx case Validation.validateMXRR state._current_entry_mx of
-- H.raise $ Log $ SimpleLog "Add new MX" Left _ -> H.raise $ Log $ SimpleLog "Cannot add this MX RR, some errors occured in the record"
Right newrr -> do
H.raise $ Log $ SimpleLog "Add new MX"
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
@ -342,8 +347,10 @@ handleAction = case _ of
Add_SRVRR -> do Add_SRVRR -> do
state <- H.get state <- H.get
let newrr = fromLocalSRVRRepresentationToResourceRecord state._current_entry_srv case Validation.validateSRVRR state._current_entry_srv of
-- H.raise $ Log $ SimpleLog "Add new SRV" Left _ -> H.raise $ Log $ SimpleLog "Cannot add this SRV RR, some errors occured in the record"
Right newrr -> do
H.raise $ Log $ SimpleLog "Add new SRV"
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
@ -427,8 +434,10 @@ handleAction = case _ of
case maybe_local_rr of case maybe_local_rr of
Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find simple RR rrid: " <> show local_rr_id Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find simple RR rrid: " <> show local_rr_id
Just local_rr -> do Just local_rr -> do
let rr = fromLocalSimpleRRRepresentationToResourceRecord local_rr case Validation.validateSRR local_rr of
-- H.raise $ Log $ SimpleLog $ "Save a simple RR: " <> show local_rr_id Left _ -> H.raise $ Log $ SimpleLog "Cannot update this simple RR, some errors occured in the record"
Right rr -> do
H.raise $ Log $ SimpleLog $ "Save a simple RR: " <> show local_rr_id
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr }
@ -440,7 +449,9 @@ handleAction = case _ of
case maybe_local_rr of case maybe_local_rr of
Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find MX RR rrid: " <> show local_rr_id Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find MX RR rrid: " <> show local_rr_id
Just local_rr -> do Just local_rr -> do
let rr = fromLocalMXRRRepresentationToResourceRecord local_rr case Validation.validateMXRR local_rr of
Left _ -> H.raise $ Log $ SimpleLog "Cannot update this MX RR, some errors occured in the record"
Right rr -> do
-- H.raise $ Log $ SimpleLog $ "Save a MX RR: " <> show local_rr_id -- H.raise $ Log $ SimpleLog $ "Save a MX RR: " <> show local_rr_id
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
@ -453,7 +464,9 @@ handleAction = case _ of
case maybe_local_rr of case maybe_local_rr of
Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find SRV RR rrid: " <> show local_rr_id Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find SRV RR rrid: " <> show local_rr_id
Just local_rr -> do Just local_rr -> do
let rr = fromLocalSRVRRepresentationToResourceRecord local_rr case Validation.validateSRVRR local_rr of
Left _ -> H.raise $ Log $ SimpleLog "Cannot update this SRV RR, some errors occured in the record"
Right rr -> do
-- H.raise $ Log $ SimpleLog $ "Save a SRV RR: " <> show local_rr_id -- H.raise $ Log $ SimpleLog $ "Save a SRV RR: " <> show local_rr_id
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize