From 418f6d74cd0eb2e0a411d0be2016578ecd17a421 Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Fri, 14 Jul 2023 01:04:38 +0200 Subject: [PATCH] Compiles again, but not everything will work (still validations to do!) --- src/App/Validation.purs | 27 ++++++++---- src/App/ZoneInterface.purs | 85 ++++++++++++++++++++++---------------- 2 files changed, 68 insertions(+), 44 deletions(-) diff --git a/src/App/Validation.purs b/src/App/Validation.purs index 9ec3549..f379c50 100644 --- a/src/App/Validation.purs +++ b/src/App/Validation.purs @@ -102,7 +102,7 @@ validateA form = ado name <- validate_name form.name ttl <- validate_ttl form.ttl 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 _ = 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 _ = invalid [Tuple NotAnAttribute "validation not implemented"] -validateSRR :: forall l. SimpleRR (|l) -> V Errors ResourceRecord -validateSRR form = case form.rrtype of +validateSRR_ :: forall l. SimpleRR (|l) -> V Errors ResourceRecord +validateSRR_ form = case form.rrtype of "A" -> validateA form "AAAA" -> validateAAAA form "TXT" -> validateTXT form @@ -126,19 +126,30 @@ validateSRR form = case form.rrtype of "NS" -> validateNS form _ -> invalid [Tuple NotAnAttribute $ "invalid type: " <> form.rrtype] -validateMXRR :: forall l. MXRR (|l) -> V Errors ResourceRecord -validateMXRR form = case form.rrtype of +validateMXRR_ :: forall l. MXRR (|l) -> V Errors ResourceRecord +validateMXRR_ form = case form.rrtype of "MX" -> validateMX form _ -> invalid [Tuple NotAnAttribute $ "invalid type (expected: MX): " <> form.rrtype] -validateSRVRR :: forall l. SRVRR (|l) -> V Errors ResourceRecord -validateSRVRR form = case form.rrtype of +validateSRVRR_ :: forall l. SRVRR (|l) -> V Errors ResourceRecord +validateSRVRR_ form = case form.rrtype of "SRV" -> validateSRV form _ -> 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). diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs index 84f07b0..3e6c051 100644 --- a/src/App/ZoneInterface.purs +++ b/src/App/ZoneInterface.purs @@ -42,6 +42,7 @@ import App.ResourceRecord (ResourceRecord) import App.LogMessage (LogMessage(..)) import App.Messages.DNSManagerDaemon as DNSManager +import App.Validation as Validation -- | `App.ZoneInterface` can send messages through websocket interface -- | connected to dnsmanagerd. See `App.WS`. @@ -324,30 +325,36 @@ handleAction = case _ of AddRR form -> case form of Add_SRR -> do state <- H.get - let newrr = fromLocalSimpleRRRepresentationToResourceRecord state._current_entry - -- H.raise $ Log $ SimpleLog $ "Add new simple RR: " <> show state._current_entry.rrtype - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } - H.raise $ MessageToSend message + case Validation.validateSRR state._current_entry of + 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 + $ DNSManager.serialize + $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } + H.raise $ MessageToSend message Add_MXRR -> do state <- H.get - let newrr = fromLocalMXRRRepresentationToResourceRecord state._current_entry_mx - -- H.raise $ Log $ SimpleLog "Add new MX" - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } - H.raise $ MessageToSend message + case Validation.validateMXRR state._current_entry_mx of + 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 + $ DNSManager.serialize + $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } + H.raise $ MessageToSend message Add_SRVRR -> do state <- H.get - let newrr = fromLocalSRVRRepresentationToResourceRecord state._current_entry_srv - -- H.raise $ Log $ SimpleLog "Add new SRV" - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } - H.raise $ MessageToSend message + case Validation.validateSRVRR state._current_entry_srv of + 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 + $ DNSManager.serialize + $ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr } + H.raise $ MessageToSend message UpdateLocalForm rr_id form -> case form of Update_Local_Form_SRR rr_update -> case rr_update of @@ -427,12 +434,14 @@ handleAction = case _ of case maybe_local_rr of Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find simple RR rrid: " <> show local_rr_id Just local_rr -> do - let rr = fromLocalSimpleRRRepresentationToResourceRecord local_rr - -- H.raise $ Log $ SimpleLog $ "Save a simple RR: " <> show local_rr_id - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } - H.raise $ MessageToSend message + case Validation.validateSRR local_rr of + 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 + $ DNSManager.serialize + $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } + H.raise $ MessageToSend message SyncMXRR local_rr_id -> do state <- H.get @@ -440,12 +449,14 @@ handleAction = case _ of case maybe_local_rr of Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find MX RR rrid: " <> show local_rr_id Just local_rr -> do - let rr = fromLocalMXRRRepresentationToResourceRecord local_rr - -- H.raise $ Log $ SimpleLog $ "Save a MX RR: " <> show local_rr_id - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } - H.raise $ MessageToSend message + 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 + message <- H.liftEffect + $ DNSManager.serialize + $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } + H.raise $ MessageToSend message SyncSRVRR local_rr_id -> do state <- H.get @@ -453,12 +464,14 @@ handleAction = case _ of case maybe_local_rr of Nothing -> H.raise $ Log $ SimpleLog $ "Cannot find SRV RR rrid: " <> show local_rr_id Just local_rr -> do - let rr = fromLocalSRVRRepresentationToResourceRecord local_rr - -- H.raise $ Log $ SimpleLog $ "Save a SRV RR: " <> show local_rr_id - message <- H.liftEffect - $ DNSManager.serialize - $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } - H.raise $ MessageToSend message + 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 + message <- H.liftEffect + $ DNSManager.serialize + $ DNSManager.MkUpdateRR { domain: state._current_domain, rr: rr } + H.raise $ MessageToSend message RemoveRR rr_id -> do { _current_domain } <- H.get