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).

85
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,30 +325,36 @@ 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"
message <- H.liftEffect Right newrr -> do
$ DNSManager.serialize H.raise $ Log $ SimpleLog "Add new simple RR"
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
H.raise $ MessageToSend message
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"
message <- H.liftEffect Right newrr -> do
$ DNSManager.serialize H.raise $ Log $ SimpleLog "Add new MX"
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
H.raise $ MessageToSend message
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"
message <- H.liftEffect Right newrr -> do
$ DNSManager.serialize H.raise $ Log $ SimpleLog "Add new SRV"
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
H.raise $ MessageToSend message
UpdateLocalForm rr_id form -> case form of UpdateLocalForm rr_id form -> case form of
Update_Local_Form_SRR rr_update -> case rr_update of Update_Local_Form_SRR rr_update -> case rr_update of
@ -427,12 +434,14 @@ 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"
message <- H.liftEffect Right rr -> do
$ DNSManager.serialize H.raise $ Log $ SimpleLog $ "Save a simple RR: " <> show local_rr_id
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr }
H.raise $ MessageToSend message
SyncMXRR local_rr_id -> do SyncMXRR local_rr_id -> do
state <- H.get state <- H.get
@ -440,12 +449,14 @@ 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
-- H.raise $ Log $ SimpleLog $ "Save a MX RR: " <> show local_rr_id Left _ -> H.raise $ Log $ SimpleLog "Cannot update this MX RR, some errors occured in the record"
message <- H.liftEffect Right rr -> do
$ DNSManager.serialize -- H.raise $ Log $ SimpleLog $ "Save a MX RR: " <> show local_rr_id
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr }
H.raise $ MessageToSend message
SyncSRVRR local_rr_id -> do SyncSRVRR local_rr_id -> do
state <- H.get state <- H.get
@ -453,12 +464,14 @@ 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
-- H.raise $ Log $ SimpleLog $ "Save a SRV RR: " <> show local_rr_id Left _ -> H.raise $ Log $ SimpleLog "Cannot update this SRV RR, some errors occured in the record"
message <- H.liftEffect Right rr -> do
$ DNSManager.serialize -- H.raise $ Log $ SimpleLog $ "Save a SRV RR: " <> show local_rr_id
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } message <- H.liftEffect
H.raise $ MessageToSend message $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr }
H.raise $ MessageToSend message
RemoveRR rr_id -> do RemoveRR rr_id -> do
{ _current_domain } <- H.get { _current_domain } <- H.get