diff --git a/src/App/Validation.purs b/src/App/Validation.purs index af17afc..5f4c15f 100644 --- a/src/App/Validation.purs +++ b/src/App/Validation.purs @@ -16,7 +16,10 @@ import URI.Host.IPv4Address as IPv4 import URI.Host.IPv6Address as IPv6 import App.RR +import App.AcceptedRRTypes (AcceptedRRTypes(..)) import App.ResourceRecord (ResourceRecord) +import GenericParser.Parser as G +import GenericParser.IPAddress as IPAddress --andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b -- andThenDrop f1 f2 = f1 !> (\ _ -> f2) @@ -38,6 +41,14 @@ data Attribute derive instance eqAttribute :: Eq Attribute +data ValidationError + = UNKNOWN + | VEIPv4 (G.Error IPAddress.IPv4Error) + | VEIPv6 (G.Error IPAddress.IPv6Error) + +type AVErrors = Array ValidationError + +type NErrors v = Array (Tuple Attribute v) type Errors = Array (Tuple Attribute String) -- | Totally garbage values at the moment. Please fix. **TODO** @@ -398,3 +409,23 @@ toRR_srv :: Int -> Boolean -> String -> String -> Int -> String -> Int -> Int -> toRR_srv rrid readonly rrtype rrname ttl target priority port protocol weight = toRR rrid readonly rrtype rrname ttl target (Just priority) (Just port) (Just protocol) (Just weight) Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | `parse` allows to run any parser based on `GenericParser` and provide a validation error. +-- | The actual validation error contains the parser's error including the position. +parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> ValidationError) -> V AVErrors v +parse (G.Parser p) str c = case p { string: str, position: 0 } of + Left x -> invalid $ [c x] + Right x -> pure x.result + +validationA :: forall l. SimpleRR (|l) -> V AVErrors ResourceRecord +validationA form = ado + -- name <- validate_name form.name + -- ttl <- validate_ttl form.ttl + target <- parse IPAddress.ipv4 form.target VEIPv4 + -- in toRR_basic form.rrid form.readonly "A" name ttl target + in toRR_basic form.rrid form.readonly "A" form.name form.ttl target + +validation :: forall l. SRVRR (|l) -> AcceptedRRTypes -> Either AVErrors ResourceRecord +validation entry t = case t of + A -> toEither <<< validationA entry + _ -> invalid $ UNKNOWN diff --git a/src/App/ZoneInterface.purs b/src/App/ZoneInterface.purs index ea78819..328f7d1 100644 --- a/src/App/ZoneInterface.purs +++ b/src/App/ZoneInterface.purs @@ -47,6 +47,7 @@ import Halogen.HTML.Properties as HP import Bulma as Bulma import CSSClasses as C +import App.AcceptedRRTypes (AcceptedRRTypes(..)) import App.RR (MXRR, Port, Priority, Protocol, RRId, RecordName, RecordTarget, SOARR, SRVRR, SimpleRR, TTL, Weight , defaultResourceA, defaultResourceMX, defaultResourceSRV) import App.ResourceRecord (ResourceRecord) @@ -55,16 +56,8 @@ import App.LogMessage (LogMessage(..)) import App.Messages.DNSManagerDaemon as DNSManager import App.Validation as Validation --- | `App.ZoneInterface` accepts to add a few new entry types. --- | Each entry type has a specific form in a modal, with relevant and dedicated information. -data AcceptedRRTypes - = A - | AAAA - | TXT - | CNAME - | NS - | MX - | SRV +id :: forall a. a -> a +id x = x -- | `App.ZoneInterface` can send messages through websocket interface -- | connected to dnsmanagerd. See `App.WS`. @@ -176,6 +169,7 @@ type State = -- Unique RR form. , _newRR :: (SRVRR ()) -- SRVRR contains all relevant information for every RR. + -- , _newRR_errors :: Hash.HashMap RRId Validation.Errors -- potential future entries , _newSRR :: (SimpleRR ()) @@ -474,7 +468,7 @@ handleAction = case _ of case form of A -> do state <- H.get - try_add_new_entry state._domain (Validation.validateSRR state._newRR) "A" + try_add_new_entry2 state._domain (Validation.validateSRR state._newRR) id A AAAA -> do state <- H.get try_add_new_entry state._domain (Validation.validateSRR state._newRR) "AAAA" @@ -595,6 +589,27 @@ handleAction = case _ of H.raise $ Log $ SimpleLog (" => " <> val) where + try_add_new_entry2 + :: forall v. + String + -> Either (Validation.NErrors v) ResourceRecord + -> (v -> String) + -> AcceptedRRTypes + -> H.HalogenM State Action () Output m Unit + try_add_new_entry2 d v e t = case v of + Left actual_errors -> do + H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:" + -- TODO: FIXME: currently this just prints the errors in the logs (page footer). + -- Soon, this will have to be in the form directly. + loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> e v) $ map snd actual_errors + + Right newrr -> do + H.raise $ Log $ SimpleLog $ "Add new " <> show t + message <- H.liftEffect + $ DNSManager.serialize + $ DNSManager.MkAddRR { domain: d, rr: newrr } + H.raise $ MessageToSend message + try_add_new_entry :: String -> Either Validation.Errors ResourceRecord