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

WIP: SPF. Display mechanisms.

Browse Source
This commit is contained in:
Philippe Pittoli 2024-02-29 20:30:45 +01:00
parent bf97e0bc60
commit 82bf6b57b4
2 changed files with 89 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
src/App/ResourceRecord.purs
View File

@ -1,6 +1,6 @@
module App.ResourceRecord where module App.ResourceRecord where
import Prelude ((<>), map) import Prelude ((<>), map, bind, pure)
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
@ -91,28 +91,48 @@ codecMechanism = CA.object "Mechanism"
, v: CA.string , v: CA.string
}) })
-- TODO: this is debug code, before actual validation.
to_mechanism :: String -> String -> String -> Maybe Mechanism
to_mechanism q t v = do
mechanism_type <- str_to_mechanism_type t
pure { q: str_to_qualifier q, t: mechanism_type, v }
show_mechanism :: Mechanism -> String
show_mechanism m =
let qualifier = case maybe "" show_qualifier_char m.q of
"+" -> ""
v -> v
mtype = show_mechanism_type m.t
value = case m.v of
"" -> ""
_ -> "=" <> m.v
in qualifier <> mtype <> value
show_qualifier_char :: Qualifier -> String
show_qualifier_char = case _ of
Pass -> "+"
None -> "?"
SoftFail -> "~"
HardFail -> "-"
data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE
mechanism_types :: Array String mechanism_types :: Array String
mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ] mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ]
show_mechanism :: Mechanism -> String
show_mechanism m = maybe "" show_qualifier m.q <> show_mechanism_type m.t <> "=" <> m.v
-- | Codec for just encoding a single value of type `MechanismType`. -- | Codec for just encoding a single value of type `MechanismType`.
codecMechanismType :: CA.JsonCodec MechanismType codecMechanismType :: CA.JsonCodec MechanismType
codecMechanismType = codecMechanismType = CA.prismaticCodec "MechanismType" str_to_mechanism_type show_mechanism_type CA.string
CA.prismaticCodec "MechanismType" from show_mechanism_type CA.string
where str_to_mechanism_type :: String -> Maybe MechanismType
from :: String -> Maybe MechanismType str_to_mechanism_type = case _ of
from = case _ of "a" -> Just A
"a" -> Just A "ip4" -> Just IP4
"ip4" -> Just IP4 "ip6" -> Just IP6
"ip6" -> Just IP6 "mx" -> Just MX
"mx" -> Just MX "ptr" -> Just PTR
"ptr" -> Just PTR "exists" -> Just EXISTS
"exists" -> Just EXISTS "include" -> Just INCLUDE
"include" -> Just INCLUDE _ -> Nothing
_ -> Nothing
show_mechanism_type :: MechanismType -> String show_mechanism_type :: MechanismType -> String
show_mechanism_type = case _ of show_mechanism_type = case _ of
@ -187,16 +207,15 @@ qualifier_types = ["pass", "none", "soft_fail", "hard_fail"]
-- | Codec for just encoding a single value of type `Qualifier`. -- | Codec for just encoding a single value of type `Qualifier`.
codecQualifier :: CA.JsonCodec Qualifier codecQualifier :: CA.JsonCodec Qualifier
codecQualifier = codecQualifier = CA.prismaticCodec "Qualifier" str_to_qualifier show_qualifier CA.string
CA.prismaticCodec "Qualifier" from show_qualifier CA.string
where str_to_qualifier :: String -> Maybe Qualifier
from :: String -> Maybe Qualifier str_to_qualifier = case _ of
from = case _ of "pass" -> Just Pass -- +
"pass" -> Just Pass -- + "none" -> Just None -- ?
"none" -> Just None -- ? "soft_fail" -> Just SoftFail -- ~
"soft_fail" -> Just SoftFail -- ~ "hard_fail" -> Just HardFail -- -
"hard_fail" -> Just HardFail -- - _ -> Nothing
_ -> Nothing
show_qualifier :: Qualifier -> String show_qualifier :: Qualifier -> String
show_qualifier = case _ of show_qualifier = case _ of

68
src/App/ZoneInterface.purs
View File

@ -40,7 +40,7 @@ import CSSClasses as C
import App.AcceptedRRTypes (AcceptedRRTypes(..)) import App.AcceptedRRTypes (AcceptedRRTypes(..))
import App.ResourceRecord (ResourceRecord, emptyRR import App.ResourceRecord (ResourceRecord, emptyRR
, show_qualifier, show_mechanism_type , show_qualifier, show_mechanism_type, show_mechanism, to_mechanism
, mechanism_types, qualifier_types, modifier_types) , mechanism_types, qualifier_types, modifier_types)
import App.ResourceRecord (Mechanism, Modifier, Qualifier) as RR import App.ResourceRecord (Mechanism, Modifier, Qualifier) as RR
@ -147,9 +147,12 @@ data Action
| SPF_Mechanism_q Int | SPF_Mechanism_q Int
| SPF_Mechanism_t Int | SPF_Mechanism_t Int
| SPF_Mechanism_v String
| SPF_Modifier Int | SPF_Modifier Int
| SPF_Qualifier Int | SPF_Qualifier Int
| SPF_Mechanism_Add
data RRModal data RRModal
= NoModal = NoModal
| NewRRModal AcceptedRRTypes | NewRRModal AcceptedRRTypes
@ -195,6 +198,7 @@ type State =
, _currentRR_errors :: Array Validation.Error , _currentRR_errors :: Array Validation.Error
, spf_mechanism_q :: String , spf_mechanism_q :: String
, spf_mechanism_t :: String , spf_mechanism_t :: String
, spf_mechanism_v :: String
, spf_modifier :: String , spf_modifier :: String
, spf_qualifier :: String , spf_qualifier :: String
@ -242,6 +246,7 @@ initialState domain =
, spf_mechanism_q: "pass" , spf_mechanism_q: "pass"
, spf_mechanism_t: "a" , spf_mechanism_t: "a"
, spf_mechanism_v: ""
, spf_modifier: "redirect" , spf_modifier: "redirect"
, spf_qualifier: "none" , spf_qualifier: "none"
} }
@ -305,14 +310,10 @@ render state
content_simple :: Array (HH.HTML w Action) content_simple :: Array (HH.HTML w Action)
content_simple = content_simple =
[ render_errors [ render_errors
--, Bulma.box_input ("domain" <> state._currentRR.rrtype) "Name" "www" -- id, title, placeholder , Bulma.input_with_side_text ("domain" <> state._currentRR.rrtype) "Name" "www"
-- (updateForm Field_Domain) -- action (updateForm Field_Domain)
-- state._currentRR.name -- value state._currentRR.name
-- should_be_disabled -- condition ("." <> state._domain)
, Bulma.input_with_side_text ("domain" <> state._currentRR.rrtype) "Name" "www" -- id, title, placeholder
(updateForm Field_Domain) -- action
state._currentRR.name -- value
("." <> state._domain) -- sidetext
, Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600" , Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
@ -325,10 +326,10 @@ render state
content_mx :: Array (HH.HTML w Action) content_mx :: Array (HH.HTML w Action)
content_mx = content_mx =
[ render_errors [ render_errors
, Bulma.input_with_side_text "domainMX" "Name" "www" -- id, title, placeholder , Bulma.input_with_side_text "domainMX" "Name" "www"
(updateForm Field_Domain) -- action (updateForm Field_Domain)
state._currentRR.name -- value state._currentRR.name
("." <> state._domain) -- sidetext ("." <> state._domain)
, Bulma.box_input ("ttlMX") "TTL" "600" , Bulma.box_input ("ttlMX") "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
@ -345,10 +346,10 @@ render state
content_srv :: Array (HH.HTML w Action) content_srv :: Array (HH.HTML w Action)
content_srv = content_srv =
[ render_errors [ render_errors
, Bulma.input_with_side_text "domainSRV" "Name" "www" -- id, title, placeholder , Bulma.input_with_side_text "domainSRV" "Name" "www"
(updateForm Field_Domain) -- action (updateForm Field_Domain)
state._currentRR.name -- value state._currentRR.name
("." <> state._domain) -- sidetext ("." <> state._domain)
, Bulma.box_input ("ttlSRV") "TTL" "600" , Bulma.box_input ("ttlSRV") "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
@ -377,27 +378,32 @@ render state
content_spf :: Array (HH.HTML w Action) content_spf :: Array (HH.HTML w Action)
content_spf = content_spf =
[ render_errors [ render_errors
, Bulma.input_with_side_text "domainSPF" "Name" "www" -- id, title, placeholder , Bulma.input_with_side_text "domainSPF" "Name" "www"
(updateForm Field_Domain) -- action (updateForm Field_Domain)
state._currentRR.name -- value state._currentRR.name
("." <> state._domain) -- sidetext ("." <> state._domain)
, Bulma.box_input ("ttlSPF") "TTL" "600" , Bulma.box_input "ttlSPF" "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
should_be_disabled should_be_disabled
, Bulma.box_input ("targetSPF") "Target" "www" , Bulma.box_input "targetSPF" "Target" "www"
(updateForm Field_Target) (updateForm Field_Target)
state._currentRR.target state._currentRR.target
should_be_disabled should_be_disabled
, case state._currentRR.v of , case state._currentRR.v of
Nothing -> Bulma.p "default value for the version (spf1)" Nothing -> Bulma.p "default value for the version (spf1)"
Just v -> Bulma.box_input ("vSPF") "Version" "spf1" (updateForm Field_SPF_v) v should_be_disabled Just v -> Bulma.box_input "vSPF" "Version" "spf1" (updateForm Field_SPF_v) v should_be_disabled
, Bulma.hr , Bulma.hr
, maybe (Bulma.p "no mechanism") display_mechanisms state._currentRR.mechanisms , maybe (Bulma.p "no mechanism") display_mechanisms state._currentRR.mechanisms
, Bulma.box , Bulma.box
[ Bulma.h3 "New mechanism" [ Bulma.h3 "New mechanism"
, Bulma.selection SPF_Mechanism_q qualifier_types state.spf_mechanism_q , Bulma.selection SPF_Mechanism_q qualifier_types state.spf_mechanism_q
, Bulma.selection SPF_Mechanism_t mechanism_types state.spf_mechanism_t , Bulma.selection SPF_Mechanism_t mechanism_types state.spf_mechanism_t
, Bulma.box_input "valueNewMechanismSPF" "Value" ""
SPF_Mechanism_v
state.spf_mechanism_v
should_be_disabled
, Bulma.btn "Add" SPF_Mechanism_Add
] ]
, Bulma.hr , Bulma.hr
, Bulma.box , Bulma.box
@ -545,8 +551,20 @@ handleAction = case _ of
SPF_Mechanism_q v -> H.modify_ _ { spf_mechanism_q = maybe "pass" id $ qualifier_types 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_t v -> H.modify_ _ { spf_mechanism_t = maybe "a" id $ mechanism_types A.!! v }
SPF_Mechanism_v v -> H.modify_ _ { spf_mechanism_v = v }
SPF_Modifier v -> H.modify_ _ { spf_modifier = maybe "redirect" id $ modifier_types A.!! v } SPF_Modifier v -> H.modify_ _ { spf_modifier = maybe "redirect" id $ modifier_types A.!! v }
SPF_Qualifier v -> H.modify_ _ { spf_qualifier = maybe "none" id $ qualifier_types A.!! v } SPF_Qualifier v -> H.modify_ _ { spf_qualifier = maybe "none" id $ qualifier_types A.!! v }
SPF_Mechanism_Add -> do
state <- H.get
let m = state._currentRR.mechanisms
m_q = state.spf_mechanism_q
m_t = state.spf_mechanism_t
m_v = state.spf_mechanism_v
new_list_of_mechanisms = maybe [] id m <> maybe [] (\x -> [x]) (to_mechanism m_q m_t m_v)
new_value = case new_list_of_mechanisms of
[] -> Nothing
v -> Just v
H.modify_ _ { _currentRR { mechanisms = new_value }}
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of handleQuery = case _ of
@ -719,7 +737,7 @@ render_resources records
, HH.td_ [ Bulma.p $ show rr.ttl ] , HH.td_ [ Bulma.p $ show rr.ttl ]
, HH.td_ [ Bulma.p rr.target ] , HH.td_ [ Bulma.p rr.target ]
, HH.td_ [ Bulma.p $ maybe "spf1 (default)" id rr.v ] , HH.td_ [ Bulma.p $ maybe "spf1 (default)" id rr.v ]
, HH.td_ [ Bulma.p $ maybe "" (\ _ -> "TODO: mechanisms") rr.mechanisms ] , HH.td_ [ Bulma.p $ maybe "" (A.fold <<< A.intersperse " " <<< map show_mechanism) rr.mechanisms ]
, HH.td_ [ Bulma.p $ maybe "" (\ _ -> "TODO: modifiers") rr.modifiers ] , HH.td_ [ Bulma.p $ maybe "" (\ _ -> "TODO: modifiers") rr.modifiers ]
, HH.td_ [ Bulma.p $ maybe "qualifier" (\ _ -> "qualifier") rr.q ] , HH.td_ [ Bulma.p $ maybe "qualifier" (\ _ -> "qualifier") rr.q ]
, if rr.readonly , if rr.readonly