From 408f8da669ccfcf9815e877773e226f60de3696f Mon Sep 17 00:00:00 2001 From: Philippe Pittoli Date: Sat, 9 Nov 2024 00:12:40 +0100 Subject: [PATCH] Protocol isn't a simple string anymore, but still WIP. --- src/App/DisplayErrors.purs | 7 ------- src/App/Page/Zone.purs | 26 ++++++++++++++++++-------- src/App/Text/Explanations.purs | 2 +- src/App/Type/ResourceRecord.purs | 30 +++++++++++++++++++++++++++--- src/App/Validation/DNS.purs | 12 +----------- 5 files changed, 47 insertions(+), 30 deletions(-) diff --git a/src/App/DisplayErrors.purs b/src/App/DisplayErrors.purs index 0d38095..8fa0273 100644 --- a/src/App/DisplayErrors.purs +++ b/src/App/DisplayErrors.purs @@ -40,7 +40,6 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v) ValidationDNS.VEPriority min max n -> Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max <> ", current value: " <> show n <> "." ValidationDNS.VESRV err -> maybe default_error show_error_domain err.error - ValidationDNS.VEProtocol err -> maybe protocol_error show_error_protocol err.error ValidationDNS.VEPort min max n -> Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max <> ", current value: " <> show n <> "." ValidationDNS.VEWeight min max n -> Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max @@ -58,7 +57,6 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v) ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max ) where default_error = Bulma.p "" - protocol_error = Bulma.p "Accepted protocols are: tcp, udp. You need more? Contact us." show_error_key_sizes :: forall w i. Int -> Int -> HH.HTML w i show_error_key_sizes min max @@ -81,7 +79,6 @@ show_error_title v = case v of ValidationDNS.VEMX _ -> "Invalid MX Target" ValidationDNS.VEPriority _ _ _ -> "Invalid Priority" ValidationDNS.VESRV _ -> "Invalid SRV Target" - ValidationDNS.VEProtocol _ -> "Invalid Protocol" ValidationDNS.VEPort _ _ _ -> "Invalid Port" ValidationDNS.VEWeight _ _ _ -> "Invalid Weight" ValidationDNS.VECAAflag _ _ _ -> "Invalid CAA Flag" @@ -109,10 +106,6 @@ show_error_domain e = case e of and must finish with either a letter or a digit. """ -show_error_protocol :: forall w i. ValidationDNS.ProtocolError -> HH.HTML w i -show_error_protocol e = case e of - ValidationDNS.InvalidProtocol -> Bulma.p "Protocol should be a value as 'tcp' or 'udp'." - show_error_ip6 :: forall w i. IPAddress.IPv6Error -> HH.HTML w i show_error_ip6 e = case e of IPAddress.IP6TooManyHexaDecimalCharacters -> diff --git a/src/App/Page/Zone.purs b/src/App/Page/Zone.purs index 91e0730..ac00862 100644 --- a/src/App/Page/Zone.purs +++ b/src/App/Page/Zone.purs @@ -58,7 +58,8 @@ import App.Type.ResourceRecord (ResourceRecord, emptyRR , show_modifier_type, show_modifier, to_modifier , qualifiers , mechanism_types, qualifier_types, modifier_types) -import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..)) as RR +import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..), SRVProtocol(..) + , srv_protocols_txt, str_to_srv_protocol) as RR import App.Type.DKIM as DKIM import App.Type.DMARC as DMARC @@ -99,7 +100,6 @@ data Field | Field_TTL String | Field_Target String | Field_Priority String - | Field_Protocol String | Field_Weight String | Field_Port String | Field_SPF_v String @@ -173,6 +173,8 @@ data Action | CAA_tag Int + | SRV_Protocol Int + | SPF_Mechanism_q Int | SPF_Mechanism_t Int | SPF_Mechanism_v String @@ -250,6 +252,8 @@ type State = , _currentRR_errors :: Array Validation.Error , _dmarc_mail_errors :: Array Email.Error + , srv_protocol :: String -- :: RR.SRVProtocol + -- SPF details. , spf_mechanism_q :: String , spf_mechanism_t :: String @@ -310,6 +314,8 @@ initialState domain = , _dmarc_mail_errors: [] , _zonefile: Nothing + , srv_protocol: "tcp" -- RR.TCP + , spf_mechanism_q: "pass" , spf_mechanism_t: "a" , spf_mechanism_v: "" @@ -478,9 +484,7 @@ render state , Bulma.box_input "domainSRV" "Service name" "service name" (updateForm Field_Domain) state._currentRR.name - , Bulma.box_input ("protocolSRV") "Protocol" "tcp" - (updateForm Field_Protocol) - (fromMaybe "tcp" state._currentRR.protocol) + , Bulma.selection_field "protocolSRV" "Protocol" SRV_Protocol RR.srv_protocols_txt state.srv_protocol , Bulma.box_input ("targetSRV") "Where the server is" "www" (updateForm Field_Target) state._currentRR.target @@ -698,7 +702,8 @@ handleAction = case _ of default_rr_MX = emptyRR { rrtype = "MX", name = "mail", target = "server1", priority = Just 10 } default_rr_CAA = emptyRR { rrtype = "CAA", name = "", caa = Just default_caa } default_rr_SRV = emptyRR { rrtype = "SRV", name = "voip", target = "server1" - , port = Just 5061, weight = Just 100, priority = Just 10, protocol = Just "tcp" } + , port = Just 5061, weight = Just 100, priority = Just 10 + , protocol = Just RR.TCP } default_mechanisms = maybe [] (\x -> [x]) $ to_mechanism "pass" "mx" "" default_rr_SPF = emptyRR { rrtype = "SPF", name = "", target = "" , mechanisms = Just default_mechanisms @@ -746,6 +751,7 @@ handleAction = case _ of -- TODO: should the code design change? Would the code be simplified by working only on _currentRR.dkim? -- Since _currentRR.dkim isn't modified directly, it is copied from `State`. _ <- case t of + SRV -> H.modify_ \state -> state { _currentRR { protocol = RR.str_to_srv_protocol state.srv_protocol }} DKIM -> H.modify_ \state -> state { _currentRR { dkim = Just state.dkim } } DMARC -> H.modify_ \state -> state { _currentRR { dmarc = Just state.dmarc } } _ -> pure unit @@ -759,6 +765,7 @@ handleAction = case _ of Right newrr -> do H.modify_ _ { _currentRR_errors = [] , _dmarc_mail_errors = [] + , srv_protocol = "tcp" , dkim = DKIM.emptyDKIMRR , dmarc = DMARC.emptyDMARCRR } @@ -790,6 +797,7 @@ handleAction = case _ of -- Since _currentRR.dkim isn't modified directly, it is copied from `State`. state0 <- H.get _ <- case state0._currentRR.rrtype of + "SRV" -> H.modify_ _ { _currentRR { protocol = RR.str_to_srv_protocol state0.srv_protocol }} "DKIM" -> H.modify_ _ { _currentRR { dkim = Just state0.dkim } } "DMARC" -> H.modify_ _ { _currentRR { dmarc = Just state0.dmarc } } _ -> pure unit @@ -806,6 +814,7 @@ handleAction = case _ of H.modify_ _ { spf_mechanism_q = "pass" , spf_mechanism_t = "a" , spf_mechanism_v = "" + , srv_protocol = "tcp" , spf_modifier_t = "redirect" , spf_modifier_v = "" , dmarc_mail = "" @@ -857,6 +866,8 @@ handleAction = case _ of let new_caa = (fromMaybe default_caa state._currentRR.caa) { tag = fromMaybe CAA.Issue $ CAA.tags A.!! v } H.modify_ _ { _currentRR { caa = Just new_caa } } + SRV_Protocol v -> H.modify_ _ { srv_protocol = maybe "tcp" id $ RR.srv_protocols_txt A.!! v } + SPF_Mechanism_q v -> H.modify_ _ { spf_mechanism_q = maybe "pass" id $ qualifier_types A.!! v } SPF_Mechanism_t v -> H.modify_ _ { spf_mechanism_t = maybe "a" id $ mechanism_types A.!! v } SPF_Mechanism_v v -> H.modify_ _ { spf_mechanism_v = v } @@ -1100,7 +1111,7 @@ render_resources records ] "SRV" -> [ HH.td_ [ Bulma.p rr.name ] - , HH.td_ [ Bulma.p $ maybe "" id rr.protocol ] + , HH.td_ [ Bulma.p $ maybe "tcp" show rr.protocol ] , HH.td_ [ Bulma.p rr.target ] , HH.td_ [ Bulma.p $ maybe "" show rr.port ] , HH.td_ [ Bulma.p $ show rr.ttl ] @@ -1299,7 +1310,6 @@ update_field rr updated_field = case updated_field of Field_Target val -> rr { target = val } Field_TTL val -> rr { ttl = fromMaybe 0 (fromString val) } Field_Priority val -> rr { priority = fromString val } - Field_Protocol val -> rr { protocol = Just val } Field_Weight val -> rr { weight = fromString val } Field_Port val -> rr { port = fromString val } Field_SPF_v val -> rr { v = Just val } diff --git a/src/App/Text/Explanations.purs b/src/App/Text/Explanations.purs index 6ba251c..4fa53e2 100644 --- a/src/App/Text/Explanations.purs +++ b/src/App/Text/Explanations.purs @@ -457,7 +457,7 @@ srv_introduction = , HH.p_ [ HH.text "For example, for a service named " , HH.u_ [HH.text "voip"] , HH.text " and given that this service uses the TCP protocol, the target " - , HH.u_ [HH.text "server1.example.com."] + , HH.u_ [HH.text "\"server1.example.com.\""] , HH.text " could be specified." ] ] diff --git a/src/App/Type/ResourceRecord.purs b/src/App/Type/ResourceRecord.purs index 17166bd..beeb367 100644 --- a/src/App/Type/ResourceRecord.purs +++ b/src/App/Type/ResourceRecord.purs @@ -1,6 +1,10 @@ module App.Type.ResourceRecord where -import Prelude ((<>), map, bind, pure) +import Prelude ((<>), map, bind, pure, class Show) +-- import Data.String (toLower) +import Data.Generic.Rep (class Generic) +import App.Type.GenericSerialization (generic_serialization) +import Data.Show.Generic (genericShow) import Data.Maybe (Maybe(..), maybe) @@ -25,7 +29,7 @@ type ResourceRecord -- SRV specific entries. , port :: Maybe Int - , protocol :: Maybe String + , protocol :: Maybe SRVProtocol , weight :: Maybe Int -- SOA specific entries. @@ -65,7 +69,7 @@ codec = CA.object "ResourceRecord" -- SRV specific entries. , port: CAR.optional CA.int - , protocol: CAR.optional CA.string + , protocol: CAR.optional codecSRVProtocol , weight: CAR.optional CA.int -- SOA specific entries. @@ -257,3 +261,23 @@ show_qualifier = case _ of Neutral -> "neutral" SoftFail -> "soft_fail" HardFail -> "hard_fail" + +data SRVProtocol = TCP | UDP +-- srv_protocols :: Array SRVProtocol +-- srv_protocols = [TCP, UDP] +srv_protocols_txt :: Array String +srv_protocols_txt = ["tcp", "udp"] + +derive instance genericSRVProtocol :: Generic SRVProtocol _ +instance showSRVProtocol :: Show SRVProtocol where + show = genericShow + +-- | Codec for just encoding a single value of type `Qualifier`. +codecSRVProtocol :: CA.JsonCodec SRVProtocol +codecSRVProtocol = CA.prismaticCodec "SRVProtocol" str_to_srv_protocol generic_serialization CA.string + +str_to_srv_protocol :: String -> Maybe SRVProtocol +str_to_srv_protocol = case _ of + "tcp" -> Just TCP + "udp" -> Just UDP + _ -> Nothing diff --git a/src/App/Validation/DNS.purs b/src/App/Validation/DNS.purs index 637c6bd..8a1429a 100644 --- a/src/App/Validation/DNS.purs +++ b/src/App/Validation/DNS.purs @@ -50,7 +50,6 @@ data Error | VEMX (G.Error DomainParser.DomainError) | VEPriority Int Int Int | VESRV (G.Error DomainParser.DomainError) - | VEProtocol (G.Error ProtocolError) | VEPort Int Int Int | VEWeight Int Int Int | VEDMARCpct Int Int Int @@ -84,7 +83,6 @@ max_weight = 65535 :: Int type RRPriority = Maybe Int type RRPort = Maybe Int -type RRProtocol = Maybe String type RRWeight = Maybe Int type RRMname = Maybe String type RRRname = Maybe String @@ -156,13 +154,6 @@ validationNS form = ado target <- parse DomainParser.sub_eof form.target VENS in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS", name = name, ttl = ttl, target = target } -data ProtocolError - = InvalidProtocol - -protocol_parser :: G.Parser ProtocolError String -protocol_parser = do - G.string "tcp" <|> G.string "udp" G.<:> \_ -> InvalidProtocol - is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> Error) -> V (Array Error) Int is_between min max n ve = if between min max n then pure n @@ -183,12 +174,11 @@ validationSRV form = ado ttl <- is_between min_ttl max_ttl form.ttl VETTL target <- parse DomainParser.sub_eof form.target VESRV priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority - protocol <- parse protocol_parser (maybe "" id form.protocol) VEProtocol port <- is_between min_port max_port (maybe 0 id form.port) VEPort weight <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV" , name = name, ttl = ttl, target = target - , priority = Just priority, port = Just port, protocol = Just protocol, weight = Just weight } + , priority = Just priority, port = Just port, protocol = form.protocol, weight = Just weight } -- My version of "map" lol. verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a)