Adding a WIP zone interface. Not even showable ATM.
This commit is contained in:
parent
2072347df0
commit
6ccc1846df
@ -14,6 +14,7 @@
|
||||
, "effect"
|
||||
, "either"
|
||||
, "exceptions"
|
||||
, "foldable-traversable"
|
||||
, "foreign"
|
||||
, "halogen"
|
||||
, "halogen-subscriptions"
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- | - show and select accepted domains (TLDs)
|
||||
-- | - create new domains
|
||||
-- | - delete a domain
|
||||
-- | - TODO: ask for confirmation
|
||||
-- | - ask for confirmation
|
||||
-- | - TODO: switch to the interface to show and modify the content of a Zone
|
||||
|
||||
module App.DomainListInterface where
|
||||
|
||||
137
src/App/RR.purs
Normal file
137
src/App/RR.purs
Normal file
@ -0,0 +1,137 @@
|
||||
module App.RR where
|
||||
|
||||
type InputParameter
|
||||
= { valid :: Boolean
|
||||
, value :: String
|
||||
}
|
||||
|
||||
type RecordType = String
|
||||
type RecordValue = String
|
||||
type RecordDomain = String
|
||||
|
||||
-- These should be integers, but I use these values in user inputs.
|
||||
type TTL = String
|
||||
type Weight = String
|
||||
type Priority = String
|
||||
type Port = String
|
||||
|
||||
type RRId = Int
|
||||
|
||||
type Modified = Boolean
|
||||
type Valid = Boolean
|
||||
|
||||
type RecordBase l
|
||||
= { t :: RecordType
|
||||
, id :: RRId
|
||||
, modified :: Boolean
|
||||
, valid :: Boolean
|
||||
, ttl :: TTL
|
||||
, domain :: RecordDomain
|
||||
, value :: RecordValue | l
|
||||
}
|
||||
|
||||
-- CNAME A AAAA NS TXT
|
||||
type SimpleRR l = RecordBase (|l)
|
||||
|
||||
type MXRR l = RecordBase ( priority :: Priority | l)
|
||||
type SRVRR l = RecordBase ( priority :: Priority
|
||||
, weight :: Weight
|
||||
, port :: Port
|
||||
| l)
|
||||
|
||||
--data Status
|
||||
-- = Synchronized
|
||||
-- | UnSynchronized
|
||||
--
|
||||
--type Reason = String
|
||||
--data Validity
|
||||
-- = Valid
|
||||
-- | Invalid (Maybe Reason)
|
||||
--
|
||||
---- TODO: add smart constructors.
|
||||
--data Domain = Domain String
|
||||
--data RRAValue = RRAValue String
|
||||
--data RRAAAAValue = RRAAAAValue String
|
||||
--data RRCNAMEValue = RRCNAMEValue String
|
||||
--data RRNSValue = RRNSValue String
|
||||
--data RRTXTValue = RRTXTValue String
|
||||
--data RRMXValue = RRMXValue String
|
||||
--data RRSRVValue = RRSRVValue String
|
||||
--data Priority = Priority String
|
||||
--data Weight = Weight String
|
||||
--data Port = Port String
|
||||
--
|
||||
--data RR
|
||||
-- = A RRId Status Validity TTL Domain RRAValue
|
||||
-- | AAAA RRId Status Validity TTL Domain RRAAAAValue
|
||||
-- | CNAME RRId Status Validity TTL Domain RRCNAMEValue
|
||||
-- | NS RRId Status Validity TTL Domain RRNSValue
|
||||
-- | TXT RRId Status Validity TTL Domain RRTXTValue
|
||||
-- | MX RRId Status Validity TTL Domain RRMXValue Priority
|
||||
-- | SRV RRId Status Validity TTL Domain RRSRVValue Priority Weight Port
|
||||
|
||||
mkNS :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> RecordBase ()
|
||||
mkNS i c ok t d v
|
||||
= { id: i, t: "NS", modified: c, valid: ok
|
||||
, ttl: t, domain: d, value: v }
|
||||
mkA :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> RecordBase ()
|
||||
mkA i c ok t d v
|
||||
= { id: i, t: "A", modified: c, valid: ok
|
||||
, ttl: t, domain: d, value: v }
|
||||
mkAAAA :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> RecordBase ()
|
||||
mkAAAA i c ok t d v
|
||||
= { id: i, t: "AAAA", modified: c, valid: ok
|
||||
, ttl: t, domain: d, value: v }
|
||||
mkCNAME :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> RecordBase ()
|
||||
mkCNAME i c ok t d v
|
||||
= { id: i, t: "CNAME", modified: c, valid: ok
|
||||
, ttl: t, domain: d, value: v }
|
||||
mkTXT :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> RecordBase ()
|
||||
mkTXT i c ok t d v
|
||||
= { id: i, t: "TXT", modified: c, valid: ok
|
||||
, ttl: t, domain: d, value: v }
|
||||
|
||||
mkMX :: RRId -> Modified -> Valid
|
||||
-> TTL -> RecordDomain -> RecordValue -> Priority -> MXRR ()
|
||||
mkMX i c ok t d v p
|
||||
= { id: i, t: "MX", modified: c, valid: ok
|
||||
, ttl: t, priority: p, domain: d, value: v }
|
||||
|
||||
mkSRV :: RRId -> Modified -> Valid
|
||||
-> Priority -> Weight -> Port
|
||||
-> TTL -> RecordDomain -> RecordValue -> SRVRR ()
|
||||
mkSRV i c ok p w prt t d v
|
||||
= { id: i, t: "SRV", modified: c
|
||||
, valid: ok, priority: p, weight: w, port: prt
|
||||
, ttl: t, domain: d, value: v
|
||||
}
|
||||
|
||||
defaultResourceRecords :: Array (SimpleRR ())
|
||||
defaultResourceRecords
|
||||
= [ mkNS 0 false true "3600" "@" "ns0.truc.fr"
|
||||
, mkA 1 false true "200" "www" "192.168.10.2"
|
||||
, mkAAAA 2 false true "610" "www" "fe80::1"
|
||||
, mkCNAME 3 false true "630" "nom" "autrenom"
|
||||
, mkTXT 4 false true "600" "txtme" "Ceci est un texte."
|
||||
]
|
||||
|
||||
defaultMXResourceRecords :: Array (MXRR ())
|
||||
defaultMXResourceRecords
|
||||
= [ mkMX 5 false true "600" "www" "192.168.10.2" "200"
|
||||
, mkMX 6 false true "3600" "www" "192.168.10.2" "200"
|
||||
]
|
||||
|
||||
defaultResourceA :: SimpleRR ()
|
||||
defaultResourceA = mkA 0 false true "200" "www" "192.168.10.2"
|
||||
|
||||
defaultResourceMX :: MXRR ()
|
||||
defaultResourceMX = mkMX 0 false true "500" "www" "192.168.10.2" "200"
|
||||
|
||||
defaultResourceSRV :: SRVRR ()
|
||||
-- RRId Modified Valid Priority Weight Port TTL Domain Value
|
||||
defaultResourceSRV = mkSRV 0 false true "10" "100" "80" "200" "www" "192.168.10.2"
|
||||
290
src/App/Style.purs
Normal file
290
src/App/Style.purs
Normal file
@ -0,0 +1,290 @@
|
||||
module App.Style where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.HTML.Events as HE
|
||||
|
||||
-- HTML PropName used with HP.prop
|
||||
import Halogen.HTML.Core (PropName(..))
|
||||
-- import Web.Event.Event (type_, Event, EventType(..))
|
||||
import Web.UIEvent.MouseEvent (MouseEvent)
|
||||
|
||||
-- This file is mostly a wrapper around BULMA.
|
||||
|
||||
class_columns :: Array (HH.ClassName)
|
||||
class_columns = [HH.ClassName "columns" ]
|
||||
class_column :: Array (HH.ClassName)
|
||||
class_column = [HH.ClassName "column" ]
|
||||
class_title :: Array (HH.ClassName)
|
||||
class_title = [HH.ClassName "title" ]
|
||||
class_subtitle :: Array (HH.ClassName)
|
||||
class_subtitle = [HH.ClassName "subtitle" ]
|
||||
class_is5 :: Array (HH.ClassName)
|
||||
class_is5 = [HH.ClassName "is-5" ]
|
||||
class_is4 :: Array (HH.ClassName)
|
||||
class_is4 = [HH.ClassName "is-4" ]
|
||||
class_box :: Array (HH.ClassName)
|
||||
class_box = [HH.ClassName "box" ]
|
||||
class_label :: Array (HH.ClassName)
|
||||
class_label = [HH.ClassName "label" ]
|
||||
class_control :: Array (HH.ClassName)
|
||||
class_control = [HH.ClassName "control" ]
|
||||
|
||||
|
||||
columns :: forall (w :: Type) (i :: Type).
|
||||
Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
columns classes = HH.div [ HP.classes (class_columns <> classes) ]
|
||||
|
||||
columns_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||
columns_ = columns []
|
||||
|
||||
column :: forall (w :: Type) (i :: Type).
|
||||
Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
column classes = HH.div [ HP.classes (class_column <> classes) ]
|
||||
|
||||
column_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||
column_ = column []
|
||||
|
||||
h1 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
h1 title = HH.h1 [ HP.classes (class_title) ] [ HH.text title ]
|
||||
|
||||
h3 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
h3 title = HH.h1 [ HP.classes (class_title <> class_is5) ] [ HH.text title ]
|
||||
|
||||
subtitle :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
subtitle title = HH.h2 [ HP.classes (class_subtitle <> class_is4) ] [ HH.text title ]
|
||||
|
||||
hdiv :: forall (w :: Type) (a :: Type). Array (HH.HTML w a) -> HH.HTML w a
|
||||
hdiv = HH.div [ HP.classes [HH.ClassName "mt-5"] ]
|
||||
|
||||
offcolumn :: forall (w :: Type) (a :: Type).
|
||||
Int -> Int -> Array (HH.HTML w a) -> HH.HTML w a
|
||||
offcolumn 0 size = HH.div [ HP.classes [HH.ClassName ("mt-"<>show size)] ]
|
||||
offcolumn offset size
|
||||
= column [ HH.ClassName ("is-offset-" <> (show offset) <> " is-" <> (show size)) ]
|
||||
|
||||
input_classes :: forall (r :: Row Type) (i :: Type)
|
||||
. Boolean -> HP.IProp ( class :: String | r ) i
|
||||
input_classes true = HP.classes [ HH.ClassName "input is-small is-info" ]
|
||||
input_classes false = HP.classes [ HH.ClassName "input is-small is-danger" ]
|
||||
|
||||
btn_classes :: forall (r :: Row Type) (i :: Type)
|
||||
. Boolean -> HP.IProp ( class :: String | r ) i
|
||||
btn_classes true = HP.classes [ HH.ClassName "button is-small is-info" ]
|
||||
btn_classes false = HP.classes [ HH.ClassName "button is-small is-danger" ]
|
||||
|
||||
simple_table_header :: forall w i. HH.HTML w i
|
||||
simple_table_header
|
||||
= HH.thead_ [ HH.tr_ [ HH.th [ HP.style "width: 50px;" ] [ HH.text "Type" ]
|
||||
, HH.th_ [ HH.text "Domain" ]
|
||||
, HH.th_ [ HH.text "TTL" ]
|
||||
, HH.th_ [ HH.text "Value" ]
|
||||
]
|
||||
]
|
||||
|
||||
mx_table_header :: forall w i. HH.HTML w i
|
||||
mx_table_header
|
||||
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Domain" ]
|
||||
, HH.th_ [ HH.text "TTL" ]
|
||||
, HH.th_ [ HH.text "Priority" ]
|
||||
, HH.th_ [ HH.text "Value" ]
|
||||
]
|
||||
]
|
||||
|
||||
srv_table_header :: forall w i. HH.HTML w i
|
||||
srv_table_header
|
||||
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Domain" ]
|
||||
, HH.th_ [ HH.text "TTL" ]
|
||||
, HH.th_ [ HH.text "Priority" ]
|
||||
, HH.th_ [ HH.text "Weight" ]
|
||||
, HH.th_ [ HH.text "Port" ]
|
||||
, HH.th_ [ HH.text "Value" ]
|
||||
]
|
||||
]
|
||||
|
||||
txt_name :: forall w i. String -> HH.HTML w i
|
||||
txt_name t
|
||||
= HH.td [ rr_name_style ] [ rr_name_text ]
|
||||
where
|
||||
rr_name_style = HP.style "width: 80px;"
|
||||
rr_name_text = HH.text t
|
||||
|
||||
input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_email action "" validity
|
||||
= HH.input [ HE.onValueInput action, HP.placeholder "email", input_classes validity ]
|
||||
input_email action email validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value email
|
||||
, HP.placeholder "email"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_email action email validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Email" ]
|
||||
, HH.div [HP.classes class_control ] [ input_email action email validity ]
|
||||
]
|
||||
|
||||
|
||||
input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_password action "" validity
|
||||
= HH.input [ HE.onValueInput action, HP.placeholder "password", input_classes validity ]
|
||||
input_password action password validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value password
|
||||
, HP.placeholder "password"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_password action password validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Password" ]
|
||||
, HH.div [HP.classes class_control ] [ input_password action password validity ]
|
||||
]
|
||||
|
||||
|
||||
-- TODO: right types
|
||||
-- input_domain :: forall a w i
|
||||
-- . (String -> a)
|
||||
-- -> String
|
||||
-- -> Boolean
|
||||
-- -> HH.HTML w i
|
||||
input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_domain action domain validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value domain
|
||||
, HP.placeholder "domain"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_domain action domain validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Domain" ]
|
||||
, HH.div [HP.classes class_control ] [ input_domain action domain validity ]
|
||||
]
|
||||
|
||||
input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_ttl action ttl validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value ttl
|
||||
, HP.prop (PropName "size") 6.0
|
||||
, HP.placeholder "ttl"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_ttl action value validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "TTL" ]
|
||||
, HH.div [HP.classes class_control ] [ input_ttl action value validity ]
|
||||
]
|
||||
|
||||
|
||||
input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_priority action priority validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value priority
|
||||
, HP.prop (PropName "size") 6.0
|
||||
, HP.placeholder "priority"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_priority action value validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Priority" ]
|
||||
, HH.div [HP.classes class_control ] [ input_priority action value validity ]
|
||||
]
|
||||
|
||||
|
||||
input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_value action value validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value value
|
||||
, HP.placeholder "value"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_value action value validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Value" ]
|
||||
, HH.div [HP.classes class_control ] [ input_value action value validity ]
|
||||
]
|
||||
|
||||
|
||||
input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_weight action weight validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value weight
|
||||
, HP.prop (PropName "size") 6.0
|
||||
, HP.placeholder "weight"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_weight action weight validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Weight" ]
|
||||
, HH.div [HP.classes class_control ] [ input_weight action weight validity ]
|
||||
]
|
||||
|
||||
|
||||
input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
input_port action port validity
|
||||
= HH.input
|
||||
[ HE.onValueInput action
|
||||
, HP.value port
|
||||
, HP.prop (PropName "size") 6.0
|
||||
, HP.placeholder "port"
|
||||
, input_classes validity
|
||||
]
|
||||
|
||||
box_input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||
box_input_port action port validity = HH.label [ ]
|
||||
[ HH.label [HP.classes class_label ] [ HH.text "Port" ]
|
||||
, HH.div [HP.classes class_control ] [ input_port action port validity ]
|
||||
]
|
||||
|
||||
|
||||
btn_change :: forall w i. i -> i -> Boolean -> Boolean -> HH.HTML w i
|
||||
btn_change action1 action2 modified validity
|
||||
= HH.button
|
||||
[ HP.disabled (not modified)
|
||||
, btn_change_action validity
|
||||
, btn_classes validity
|
||||
] [ HH.text "fix" ]
|
||||
where
|
||||
|
||||
btn_change_action = case _ of
|
||||
true -> HE.onClick \_ -> action1
|
||||
_ -> HE.onClick \_ -> action2
|
||||
|
||||
|
||||
btn_delete :: forall w i. (MouseEvent -> i) -> HH.HTML w i
|
||||
btn_delete action
|
||||
= HH.button
|
||||
[ HE.onClick action
|
||||
, HP.classes [ HH.ClassName "button is-small is-danger" ]
|
||||
] [ HH.text "X" ]
|
||||
|
||||
|
||||
btn_add :: forall w i. i -> i -> Boolean -> HH.HTML w i
|
||||
btn_add action1 action2 validity
|
||||
= HH.button
|
||||
[ btn_add_action validity
|
||||
, btn_classes validity
|
||||
] [ HH.text "Add" ]
|
||||
where
|
||||
|
||||
btn_add_action = case _ of
|
||||
true -> HE.onClick \_ -> action1
|
||||
_ -> HE.onClick \_ -> action2
|
||||
|
||||
box :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
box = HH.div [HP.classes class_box]
|
||||
847
src/App/ZoneInterface.purs
Normal file
847
src/App/ZoneInterface.purs
Normal file
@ -0,0 +1,847 @@
|
||||
-- | `App.ZoneInterface` provides an interface to display and modify a DNS zone.
|
||||
-- |
|
||||
-- | This interface allows to:
|
||||
-- | - TODO: display all resource records of a zone
|
||||
-- | - TODO: add new resource records
|
||||
-- | - TODO: remove resource records
|
||||
-- | - TODO: ask for confirmation on deletion
|
||||
|
||||
module App.ZoneInterface where
|
||||
|
||||
|
||||
import Prelude
|
||||
|
||||
import CSSClasses as CSSClasses
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.String.Utils (endsWith)
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Events as HHE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
import Bulma as Bulma
|
||||
import CSSClasses as C
|
||||
|
||||
import App.Style as S
|
||||
import App.RR
|
||||
|
||||
import App.LogMessage
|
||||
import App.Messages.DNSManagerDaemon as DNSManager
|
||||
|
||||
-- IMPORTED
|
||||
import Data.Array (groupAllBy, sortBy, filter, (!!))
|
||||
import Data.Array.NonEmpty (toArray)
|
||||
import Data.Maybe (Maybe(..), maybe, fromMaybe)
|
||||
|
||||
import Data.String.Regex (Regex, test)
|
||||
import Data.String.Regex.Unsafe (unsafeRegex)
|
||||
import Data.String.Regex.Flags (noFlags)
|
||||
|
||||
import Data.Foldable (foldl)
|
||||
|
||||
import Effect.Class (class MonadEffect)
|
||||
import Halogen as H
|
||||
-- import Halogen.Aff as HA
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.HTML.Events as HE
|
||||
|
||||
import Halogen.HTML.Properties.ARIA as Aria
|
||||
|
||||
-- HTML PropName used with HP.prop
|
||||
-- import Halogen.HTML.Core (PropName(..))
|
||||
import Halogen.HTML.Core (AttrName(..))
|
||||
|
||||
-- | `App.ZoneInterface` can send messages through websocket interface
|
||||
-- | connected to dnsmanagerd. See `App.WS`.
|
||||
-- |
|
||||
-- | Also, this component can log messages and ask its parent (`App.Container`) to
|
||||
-- | reconnect the websocket to `dnsmanagerd`.
|
||||
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| Log LogMessage
|
||||
| DNSManagerReconnect
|
||||
|
||||
-- | `App.ZoneInterface` can receive messages from `dnsmanagerd`.
|
||||
-- |
|
||||
-- | The component is also informed when the connection is lost or up again.
|
||||
|
||||
data Query a
|
||||
= MessageReceived ArrayBuffer a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
-- | `App.ZoneInterface` has a single input: the domain name.
|
||||
|
||||
type Input = String
|
||||
|
||||
-- | Possible component's actions are:
|
||||
-- | - TODO: update the list of resource records
|
||||
-- | - TODO: add a resource record
|
||||
-- | - TODO: modify a resource record
|
||||
-- | - TODO: remove a resource record
|
||||
-- | - TODO: handle user inputs
|
||||
|
||||
data Action
|
||||
= DeleteRRModal String
|
||||
| CancelModal
|
||||
|
||||
| Initialize
|
||||
| Finalize
|
||||
|
||||
| DoNothing String
|
||||
|
||||
-- New entries.
|
||||
| UpdateNewType Int
|
||||
|
||||
| UpdateNewDomainSimple RecordDomain
|
||||
| UpdateNewDomainMX RecordDomain
|
||||
| UpdateNewDomainSRV RecordDomain
|
||||
|
||||
| UpdateNewTTLSimple TTL
|
||||
| UpdateNewTTLMX TTL
|
||||
| UpdateNewTTLSRV TTL
|
||||
|
||||
| UpdateNewEntryValue RecordValue
|
||||
| UpdateNewMXValue RecordValue
|
||||
| UpdateNewSRVValue RecordValue
|
||||
|
||||
| UpdateNewMXPriority Priority
|
||||
| UpdateNewSRVPriority Priority
|
||||
|
||||
| UpdateNewSRVWeight Weight
|
||||
| UpdateNewSRVPort Port
|
||||
|
||||
| AddSimple
|
||||
| AddMX
|
||||
| AddSRV
|
||||
|
||||
-- Entry already in our zone.
|
||||
| UpdateLocalTTL RRId TTL
|
||||
| UpdateLocalTTLMX RRId TTL
|
||||
| UpdateLocalTTLSRV RRId TTL
|
||||
|
||||
| UpdateLocalValue RRId RecordValue
|
||||
| UpdateLocalValueMX RRId RecordValue
|
||||
| UpdateLocalValueSRV RRId RecordValue
|
||||
|
||||
| UpdateLocalPriorityMX RRId Priority
|
||||
| UpdateLocalPrioritySRV RRId Priority
|
||||
|
||||
| UpdateLocalWeight RRId Weight
|
||||
| UpdateLocalPort RRId Port
|
||||
| UpdateOnServer RRId
|
||||
|
||||
| DeleteSimple RRId
|
||||
| DeleteMX RRId
|
||||
| DeleteSRV RRId
|
||||
|
||||
|
||||
| TellSomethingWentWrong RRId String
|
||||
|
||||
-- |
|
||||
|
||||
type State =
|
||||
{ _current_domain :: RecordDomain
|
||||
, _rr :: Array (SimpleRR ())
|
||||
, _mxrr :: Array (MXRR ())
|
||||
, _srvrr :: Array (SRVRR ())
|
||||
, _current_entry :: (SimpleRR ())
|
||||
, _current_entry_mx :: (MXRR ())
|
||||
, _current_entry_srv :: (SRVRR ())
|
||||
|
||||
, wsUp :: Boolean
|
||||
, active_modal :: Maybe String
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ initialize = Just Initialize
|
||||
, handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
, finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
-- | Default available domain: netlib.re.
|
||||
|
||||
default_domain :: String
|
||||
default_domain = "netlib.re"
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ wsUp: true
|
||||
, active_modal: Nothing
|
||||
|
||||
, _current_domain: "hello.example.com"
|
||||
, _rr: defaultResourceRecords
|
||||
, _mxrr: defaultMXResourceRecords
|
||||
, _srvrr: []
|
||||
, _current_entry: defaultResourceA
|
||||
, _current_entry_mx: defaultResourceMX
|
||||
, _current_entry_srv: defaultResourceSRV
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render state
|
||||
= Bulma.section_small
|
||||
[ case state.wsUp, state.active_modal of
|
||||
false, _ -> Bulma.p "You are disconnected."
|
||||
true, Just domain -> modal_rr_delete domain
|
||||
true, Nothing -> HH.div_ [ nav_bar state._current_domain
|
||||
, render_records sorted
|
||||
, render_mx_records state._mxrr
|
||||
, render_srv_records state._srvrr
|
||||
, render_new_records state
|
||||
]
|
||||
]
|
||||
where
|
||||
sorted = foldl (<>) []
|
||||
$ map (sortBy (comparing (_.domain)))
|
||||
$ map toArray
|
||||
$ groupAllBy (comparing (_.t)) state._rr
|
||||
|
||||
modal_rr_delete :: forall w. String -> HH.HTML w Action
|
||||
modal_rr_delete domain =
|
||||
modal
|
||||
[ modal_background
|
||||
, modal_card [modal_header, modal_body]
|
||||
, modal_foot [modal_delete_button, modal_cancel_button]
|
||||
]
|
||||
where
|
||||
modal = HH.div [HP.classes (C.modal <> C.is_active)]
|
||||
modal_background = HH.div [HP.classes C.modal_background] []
|
||||
modal_card = HH.div [HP.classes C.modal_card]
|
||||
modal_header = HH.header [HP.classes C.modal_card_head]
|
||||
[ HH.p [HP.classes C.modal_card_title] [HH.text "Deleting a resource record"]
|
||||
]
|
||||
modal_body = HH.section [HP.classes C.modal_card_body] [ warning_message ]
|
||||
modal_foot = HH.div [HP.classes C.modal_card_foot]
|
||||
modal_delete_button
|
||||
= HH.button [ HP.classes (C.button <> C.is_success)
|
||||
-- TODO: , HE.onClick \_ -> RemoveRR domain
|
||||
] [HH.text "Delete the resource record."]
|
||||
modal_cancel_button
|
||||
= HH.button [ HP.classes C.button
|
||||
, HE.onClick \_ -> CancelModal
|
||||
] [HH.text "Cancel"]
|
||||
warning_message
|
||||
= HH.p [] [ HH.text $ "You are about to delete a resource record, this actions is "
|
||||
, HH.strong_ [ HH.text "irreversible" ]
|
||||
, HH.text "."
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
CancelModal -> do
|
||||
H.modify_ _ { active_modal = Nothing }
|
||||
|
||||
-- IMPORTED
|
||||
Initialize -> do
|
||||
H.raise $ Log $ SimpleLog "Initialized"
|
||||
|
||||
Finalize -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog "Finalized!"
|
||||
|
||||
DoNothing _ -> do
|
||||
H.raise $ Log $ SimpleLog "This action does nothing (at least for now)"
|
||||
|
||||
UpdateNewType val -> do
|
||||
let new_type = fromMaybe "unknown" (baseRecords !! val)
|
||||
H.raise $ Log $ SimpleLog ("Update new entry type: " <> new_type)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry = changeType state._current_entry (baseRecords !! val) }
|
||||
-- TODO: FIXME: test all inputs
|
||||
|
||||
UpdateNewTTLSimple val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new entry ttl: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry = state._current_entry { ttl = val, valid = isInteger val } }
|
||||
-- TODO: FIXME: test all inputs
|
||||
UpdateNewTTLMX val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new MX entry ttl: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_mx = state._current_entry_mx {ttl = val, valid = isInteger val} }
|
||||
UpdateNewTTLSRV val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry ttl: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv {ttl = val, valid = isInteger val}}
|
||||
|
||||
UpdateNewDomainSimple val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new entry domain: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry = state._current_entry { domain = val } }
|
||||
-- TODO: FIXME: test all inputs
|
||||
UpdateNewDomainMX val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new MX entry domain: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_mx = state._current_entry_mx { domain = val } }
|
||||
UpdateNewDomainSRV val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry domain: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv { domain = val } }
|
||||
|
||||
UpdateNewEntryValue val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new entry value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry = state._current_entry { value = val } }
|
||||
-- TODO: FIXME: test all inputs
|
||||
UpdateNewMXValue val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new MX entry value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_mx = state._current_entry_mx { value = val } }
|
||||
UpdateNewSRVValue val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv { value = val } }
|
||||
|
||||
UpdateNewMXPriority val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new MX entry priority: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_mx = state._current_entry_mx { priority = val } }
|
||||
UpdateNewSRVPriority val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry priority: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv { priority = val } }
|
||||
|
||||
UpdateNewSRVWeight val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry weight: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv { weight = val } }
|
||||
|
||||
UpdateNewSRVPort val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update new SRV entry port: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _current_entry_srv = state._current_entry_srv { port = val } }
|
||||
|
||||
|
||||
|
||||
-- This action only is possible if inputs are correct.
|
||||
AddSimple -> do
|
||||
H.raise $ Log $ SimpleLog ("Add simple entry")
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog ("Add simple entry: " <> show state._current_entry)
|
||||
H.put $ add_new_entry state state._current_entry
|
||||
AddMX -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog ("Add new MX: " <> show state._current_entry_mx)
|
||||
H.put $ add_new_mx state state._current_entry_mx
|
||||
AddSRV -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog ("Add new SRV: " <> show state._current_entry_srv)
|
||||
H.put $ add_new_srv state state._current_entry_srv
|
||||
|
||||
|
||||
UpdateLocalValue rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _rr = (update_value rrid val state._rr) }
|
||||
UpdateLocalValueMX rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _mxrr = (update_value rrid val state._mxrr) }
|
||||
UpdateLocalValueSRV rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " value: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = (update_value rrid val state._srvrr) }
|
||||
|
||||
UpdateLocalTTL rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " TTL: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _rr = (update_ttl rrid val state._rr) }
|
||||
UpdateLocalTTLMX rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " TTL: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _mxrr = (update_ttl rrid val state._mxrr) }
|
||||
UpdateLocalTTLSRV rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " TTL: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = (update_ttl rrid val state._srvrr) }
|
||||
|
||||
UpdateLocalPriorityMX rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update MX RR " <> show rrid <> " priority: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _mxrr = (update_priority rrid val state._mxrr) }
|
||||
UpdateLocalPrioritySRV rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update SRV RR " <> show rrid <> " priority: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = (update_priority rrid val state._srvrr) }
|
||||
|
||||
UpdateLocalWeight rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " weight: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = (update_weight rrid val state._srvrr) }
|
||||
|
||||
UpdateLocalPort rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Update RR " <> show rrid <> " port: " <> val)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = (update_port rrid val state._srvrr) }
|
||||
|
||||
|
||||
DeleteSimple rrid -> do
|
||||
H.raise $ Log $ SimpleLog ("Delete SimpleRR: " <> show rrid)
|
||||
state <- H.get
|
||||
H.put $ state { _rr = filter (\rr -> rr.id /= rrid) state._rr }
|
||||
H.raise $ Log $ SimpleLog ("TODO: remove from server")
|
||||
DeleteMX rrid -> do
|
||||
H.raise $ Log $ SimpleLog ("Delete MX: " <> show rrid)
|
||||
state <- H.get
|
||||
H.put $ state { _mxrr = filter (\rr -> rr.id /= rrid) state._mxrr }
|
||||
H.raise $ Log $ SimpleLog ("TODO: remove from server")
|
||||
DeleteSRV rrid -> do
|
||||
H.raise $ Log $ SimpleLog ("Delete SRV: " <> show rrid)
|
||||
state <- H.get
|
||||
H.put $ state { _srvrr = filter (\rr -> rr.id /= rrid) state._srvrr }
|
||||
H.raise $ Log $ SimpleLog ("TODO: remove from server")
|
||||
|
||||
|
||||
-- TODO: network operations
|
||||
UpdateOnServer rrid -> do
|
||||
H.raise $ Log $ SimpleLog ("TODO: UpdateOnServer: " <> show rrid)
|
||||
|
||||
-- TODO: change the state to indicate problems?
|
||||
TellSomethingWentWrong rrid val -> do
|
||||
H.raise $ Log $ SimpleLog ("Sorry, your record " <> show rrid <> " has problems: ")
|
||||
-- H.raise $ Log $ SimpleLog (show rr)
|
||||
H.raise $ Log $ SimpleLog (" => " <> val)
|
||||
|
||||
DeleteRRModal domain -> do
|
||||
H.modify_ _ { active_modal = Just domain }
|
||||
|
||||
-- HandleNewDomainInput adduserinp -> do
|
||||
-- case adduserinp of
|
||||
-- INP_newdomain v -> H.modify_ _ { newDomainForm { new_domain = v } }
|
||||
-- UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } }
|
||||
--
|
||||
-- EnterDomain domain -> do
|
||||
-- H.raise $ Log $ SimpleLog $ "[???] trying to enter domain: " <> domain
|
||||
--
|
||||
-- RemoveRR domain -> do
|
||||
-- message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
|
||||
-- H.raise $ MessageToSend message
|
||||
-- H.raise $ Log $ SimpleLog $ "[😇] Removing domain: " <> domain
|
||||
-- H.modify_ _ { active_modal = Nothing }
|
||||
--
|
||||
-- NewDomainAttempt ev -> do
|
||||
-- H.liftEffect $ Event.preventDefault ev
|
||||
--
|
||||
-- { newDomainForm } <- H.get
|
||||
-- let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain
|
||||
--
|
||||
-- case new_domain of
|
||||
-- "" ->
|
||||
-- H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
|
||||
-- _ -> do
|
||||
-- message <- H.liftEffect
|
||||
-- $ DNSManager.serialize
|
||||
-- $ DNSManager.MkNewDomain { domain: new_domain }
|
||||
-- H.raise $ MessageToSend message
|
||||
-- H.raise $ Log $ SimpleLog $ "[😇] Trying to add a new domain (" <> new_domain <> ")"
|
||||
-- handleAction $ HandleNewDomainInput $ INP_newdomain ""
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
|
||||
MessageReceived message a -> do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize message
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left _ -> do
|
||||
pure Nothing
|
||||
|
||||
-- Cases where we understood the message.
|
||||
Right received_msg -> do
|
||||
case received_msg of
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkError errmsg) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
|
||||
(DNSManager.MkErrorUserNotLogged _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
|
||||
H.raise $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
|
||||
H.raise $ DNSManagerReconnect
|
||||
(DNSManager.MkErrorInvalidToken _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Failed connection! Invalid token!"
|
||||
(DNSManager.MkDomainAlreadyExists _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Failed! The domain already exists."
|
||||
(DNSManager.MkUnacceptableDomain _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Failed! The domain is not acceptable (not in the list of accepted domains)."
|
||||
|
||||
(DNSManager.MkAcceptedDomains response) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Received the list of accepted domains!"
|
||||
-- handleAction $ UpdateAcceptedDomains response.domains
|
||||
|
||||
(DNSManager.MkLogged response) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Authenticated to dnsmanagerd!"
|
||||
-- handleAction $ UpdateAcceptedDomains response.accepted_domains
|
||||
-- handleAction $ UpdateMyDomains response.my_domains
|
||||
|
||||
(DNSManager.MkDomainAdded response) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] Domain added: " <> response.domain
|
||||
-- handleAction $ UpdateMyDomains (my_domains <> [response.domain])
|
||||
|
||||
(DNSManager.MkInvalidDomainName _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"
|
||||
|
||||
(DNSManager.MkDomainDeleted response) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[TODO] The domain '" <> response.domain <> "' has been deleted!"
|
||||
-- handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains
|
||||
|
||||
(DNSManager.MkSuccess _) -> do
|
||||
H.raise $ Log $ SimpleLog $ "[🎉] Success!"
|
||||
-- WTH?!
|
||||
_ -> do
|
||||
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message."
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
|
||||
-- Rendering
|
||||
class_title_size :: Array (HH.ClassName)
|
||||
class_title_size = [HH.ClassName "is-4"]
|
||||
|
||||
render_records :: forall (w :: Type). Array (SimpleRR ()) -> HH.HTML w Action
|
||||
render_records []
|
||||
= S.columns [] [ left_block, right_block ]
|
||||
where left_block = S.column class_title_size
|
||||
[ S.h1 "NS, A, AAAA, CNAME"
|
||||
, S.subtitle "and TXT records" ]
|
||||
right_block = S.column_ [ S.subtitle "No records for now" ]
|
||||
|
||||
render_records records
|
||||
= S.columns [] [ S.column class_title_size [S.h1 title_txt, S.subtitle subtitle_txt ]
|
||||
, S.column_ [ table_rr ]
|
||||
]
|
||||
where
|
||||
title_txt = "NS, A, AAAA, CNAME"
|
||||
subtitle_txt = "and TXT records"
|
||||
-- subtitle_txt = "Each line is a resource record from your DNS zone."
|
||||
-- <> " You can edit them, then click on the \"fix\" button to synchronize with the server."
|
||||
table_rr = HH.table [] [ S.simple_table_header, table_content ]
|
||||
table_content = HH.tbody_ $ map row records
|
||||
|
||||
row rr = HH.tr_ $
|
||||
[ S.txt_name rr.t
|
||||
, HH.td_ [ S.input_domain DoNothing rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl (UpdateLocalTTL rr.id) rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_value (UpdateLocalValue rr.id) rr.value rr.valid ]
|
||||
, HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
|
||||
, HH.td_ [ S.btn_delete (\_ -> DeleteSimple rr.id) ]
|
||||
]
|
||||
|
||||
|
||||
render_mx_records :: forall (w :: Type) (l :: Row Type)
|
||||
. Array (MXRR l) -> HH.HTML w Action
|
||||
render_mx_records []
|
||||
= S.columns [] [ left_block, right_block ]
|
||||
where left_block = S.column class_title_size [ S.h1 "MX records" ]
|
||||
right_block = S.column_ [ S.subtitle "No records for now" ]
|
||||
render_mx_records records
|
||||
= S.columns [] [ S.column class_title_size [ S.h1 title_txt ]
|
||||
, S.column_ [ table_rr ]
|
||||
]
|
||||
where
|
||||
title_txt = "MX records"
|
||||
table_rr = HH.table [] [ S.mx_table_header, table_content ]
|
||||
table_content = HH.tbody_ $ map row records
|
||||
|
||||
row rr = HH.tr_ $
|
||||
[ HH.td_ [ S.input_domain DoNothing rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl (UpdateLocalTTLMX rr.id) rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_value (UpdateLocalValueMX rr.id) rr.value rr.valid ]
|
||||
, HH.td_ [ S.input_priority (UpdateLocalPriorityMX rr.id) rr.priority rr.valid ]
|
||||
, HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
|
||||
, HH.td_ [ S.btn_delete (\_ -> DeleteMX rr.id) ]
|
||||
]
|
||||
|
||||
|
||||
render_srv_records :: forall (w :: Type) (l :: Row Type)
|
||||
. Array (SRVRR l) -> HH.HTML w Action
|
||||
render_srv_records []
|
||||
= S.columns [] [ left_block, right_block ]
|
||||
where left_block = S.column class_title_size [ S.h1 "SRV records" ]
|
||||
right_block = S.column_ [ S.subtitle "No records for now" ]
|
||||
render_srv_records records
|
||||
= S.columns [] [ S.column class_title_size [ S.h1 title_txt]
|
||||
, S.column_ [ table_rr ] ]
|
||||
where
|
||||
title_txt = "SRV records"
|
||||
table_rr = HH.table [] [ S.srv_table_header, table_content ]
|
||||
table_content = HH.tbody_ $ map row records
|
||||
|
||||
row rr = HH.tr_ $
|
||||
[ HH.td_ [ S.input_domain DoNothing rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl (UpdateLocalTTLSRV rr.id) rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_priority (UpdateLocalPrioritySRV rr.id) rr.priority rr.valid ]
|
||||
, HH.td_ [ S.input_weight (UpdateLocalWeight rr.id) rr.weight rr.valid ]
|
||||
, HH.td_ [ S.input_port (UpdateLocalPort rr.id) rr.port rr.valid ]
|
||||
, HH.td_ [ S.input_value (UpdateLocalValueSRV rr.id) rr.value rr.valid ]
|
||||
, HH.td_ [ S.btn_change (UpdateOnServer rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ]
|
||||
, HH.td_ [ S.btn_delete (\_ -> DeleteSRV rr.id) ]
|
||||
]
|
||||
|
||||
|
||||
baseRecords :: Array String
|
||||
baseRecords = [ "NS", "A", "AAAA", "CNAME", "TXT" ]
|
||||
|
||||
render_new_record :: forall (w :: Type). (SimpleRR ()) -> HH.HTML w Action
|
||||
render_new_record rr
|
||||
= S.hdiv [ S.h3 "New record (NS, A, AAAA, CNAME, TXT)", table ]
|
||||
|
||||
where
|
||||
table = HH.table [] [ S.simple_table_header, render_record_builder ]
|
||||
|
||||
-- render_record_builder :: forall w. HH.HTML w Action
|
||||
render_record_builder
|
||||
= HH.tr_
|
||||
[ HH.td_ [ type_selection ]
|
||||
, HH.td_ [ S.input_domain UpdateNewDomainSimple rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl UpdateNewTTLSimple rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_value UpdateNewEntryValue rr.value rr.valid ]
|
||||
, HH.td_ [ S.btn_add AddSimple (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
|
||||
]
|
||||
|
||||
-- type_selection :: forall w i. HH.HTML w i
|
||||
type_selection = HH.select
|
||||
[ HE.onSelectedIndexChange UpdateNewType ]
|
||||
$ map type_option baseRecords
|
||||
type_option n
|
||||
= HH.option
|
||||
[ HP.value n
|
||||
, HP.selected (n == rr.t)
|
||||
] [ HH.text n ]
|
||||
|
||||
|
||||
render_mx_new_record :: forall (w :: Type). (MXRR ()) -> HH.HTML w Action
|
||||
render_mx_new_record rr
|
||||
= S.hdiv [ S.h3 "New MX record", table ]
|
||||
|
||||
where
|
||||
table = HH.table [] [ S.mx_table_header, render_record_builder ]
|
||||
|
||||
-- render_record_builder :: forall w. HH.HTML w Action
|
||||
render_record_builder
|
||||
= HH.tr_
|
||||
[ HH.td_ [ S.input_domain UpdateNewDomainMX rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl UpdateNewTTLMX rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_priority UpdateNewMXPriority rr.priority rr.valid ]
|
||||
, HH.td_ [ S.input_value UpdateNewMXValue rr.value rr.valid ]
|
||||
, HH.td_ [ S.btn_add AddMX (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
|
||||
]
|
||||
|
||||
|
||||
render_srv_new_record :: forall (w :: Type). (SRVRR ()) -> HH.HTML w Action
|
||||
render_srv_new_record rr
|
||||
= S.hdiv [ S.h3 "New SRV record", table ]
|
||||
where
|
||||
table = HH.table [] [ S.srv_table_header, render_record_builder ]
|
||||
|
||||
-- render_record_builder :: forall w. HH.HTML w Action
|
||||
render_record_builder
|
||||
= HH.tr_
|
||||
[ HH.td_ [ S.input_domain UpdateNewDomainSRV rr.domain rr.valid ]
|
||||
, HH.td_ [ S.input_ttl UpdateNewTTLSRV rr.ttl rr.valid ]
|
||||
, HH.td_ [ S.input_priority UpdateNewSRVPriority rr.priority rr.valid ]
|
||||
, HH.td_ [ S.input_weight UpdateNewSRVWeight rr.weight rr.valid ]
|
||||
, HH.td_ [ S.input_port UpdateNewSRVPort rr.port rr.valid ]
|
||||
, HH.td_ [ S.input_value UpdateNewSRVValue rr.value rr.valid ]
|
||||
, HH.td_ [ S.btn_add AddSRV (TellSomethingWentWrong rr.id "cannot add") rr.valid ]
|
||||
]
|
||||
|
||||
|
||||
-- Component definition and initial state
|
||||
|
||||
render_new_records :: forall (w :: Type). State -> HH.HTML w Action
|
||||
render_new_records state
|
||||
= S.hdiv
|
||||
[ S.h1 "Adding new records"
|
||||
, S.columns []
|
||||
[ render_new_record_column_simple state._current_entry
|
||||
, render_new_record_colunm_mx state._current_entry_mx
|
||||
, render_new_record_colunm_srv state._current_entry_srv
|
||||
-- , render_current_value state._current_entry
|
||||
-- , render_mx_current_value state._current_entry_mx
|
||||
-- , render_srv_current_value state._current_entry_srv
|
||||
]
|
||||
]
|
||||
|
||||
render_new_record_column_simple :: forall (w :: Type).
|
||||
(SimpleRR ()) -> HH.HTML w Action
|
||||
render_new_record_column_simple rr
|
||||
= S.column_ $ [ S.box
|
||||
[ S.h3 "NS, A, AAAA, CNAME, TXT"
|
||||
, type_selection
|
||||
, S.box_input_domain UpdateNewDomainSimple rr.domain rr.valid
|
||||
, S.box_input_ttl UpdateNewTTLSimple rr.ttl rr.valid
|
||||
, S.box_input_value UpdateNewEntryValue rr.value rr.valid
|
||||
, S.btn_add AddSimple (TellSomethingWentWrong rr.id "cannot add") rr.valid
|
||||
]
|
||||
]
|
||||
where
|
||||
-- type_selection :: forall w i. HH.HTML w i
|
||||
type_selection = HH.select
|
||||
[ HE.onSelectedIndexChange UpdateNewType ]
|
||||
$ map type_option baseRecords
|
||||
type_option n
|
||||
= HH.option
|
||||
[ HP.value n
|
||||
, HP.selected (n == rr.t)
|
||||
] [ HH.text n ]
|
||||
|
||||
|
||||
render_new_record_colunm_mx :: forall (w :: Type). (MXRR ()) -> HH.HTML w Action
|
||||
render_new_record_colunm_mx rr
|
||||
= S.column_ $ [ S.box
|
||||
[ S.h3 "MX"
|
||||
, S.box_input_domain UpdateNewDomainMX rr.domain rr.valid
|
||||
, S.box_input_ttl UpdateNewTTLMX rr.ttl rr.valid
|
||||
, S.box_input_priority UpdateNewMXPriority rr.priority rr.valid
|
||||
, S.box_input_value UpdateNewMXValue rr.value rr.valid
|
||||
, S.btn_add AddMX (TellSomethingWentWrong rr.id "cannot add") rr.valid
|
||||
]
|
||||
]
|
||||
|
||||
render_new_record_colunm_srv :: forall (w :: Type). (SRVRR ()) -> HH.HTML w Action
|
||||
render_new_record_colunm_srv rr
|
||||
= S.column_ $ [ S.box
|
||||
[ S.h3 "SRV"
|
||||
, S.box_input_domain UpdateNewDomainSRV rr.domain rr.valid
|
||||
, S.box_input_ttl UpdateNewTTLSRV rr.ttl rr.valid
|
||||
, S.box_input_priority UpdateNewSRVPriority rr.priority rr.valid
|
||||
, S.box_input_weight UpdateNewSRVWeight rr.weight rr.valid
|
||||
, S.box_input_port UpdateNewSRVPort rr.port rr.valid
|
||||
, S.box_input_value UpdateNewSRVValue rr.value rr.valid
|
||||
, S.btn_add AddSRV (TellSomethingWentWrong rr.id "cannot add") rr.valid
|
||||
]
|
||||
]
|
||||
|
||||
classes_nav :: Array (HH.ClassName)
|
||||
classes_nav = class_breadcrumb <> class_centered <> class_succeeds_sep
|
||||
class_succeeds_sep :: Array (HH.ClassName)
|
||||
class_succeeds_sep = [HH.ClassName "has-succeeds-separator" ]
|
||||
class_breadcrumb :: Array (HH.ClassName)
|
||||
class_breadcrumb = [HH.ClassName "breadcrumb"]
|
||||
class_centered :: Array (HH.ClassName)
|
||||
class_centered = [HH.ClassName "is-centered"]
|
||||
|
||||
-- TODO: wrong type
|
||||
--home_icon :: forall r w i. Array (HP.IProp r i) -> HH.HTML w i
|
||||
--home_icon = HH.span
|
||||
-- [HP.classes [HH.ClassName "icon is-small"]]
|
||||
-- [HH.i ([HP.classes [HH.ClassName "fas fa-home"]] <> aria) []]
|
||||
-- where aria = [Aria.hidden "true"]
|
||||
|
||||
aria_current :: forall r i. String -> HP.IProp r i
|
||||
aria_current = HP.attr (AttrName "aria-current")
|
||||
|
||||
nav_bar :: forall w i. String -> HH.HTML w i
|
||||
nav_bar domain
|
||||
= HH.nav
|
||||
[ HP.classes classes_nav
|
||||
, Aria.label "breadcrumbs"
|
||||
] [ HH.ul_
|
||||
[ HH.li_ [ HH.a [HP.href "/"] [ HH.text "Home"] ]
|
||||
, HH.li []
|
||||
[ HH.a
|
||||
[HP.href "/", aria_current "page"]
|
||||
[HH.text ("Domain: " <> domain)]
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
-- ACTIONS
|
||||
|
||||
-- add a new record and get a new placeholter
|
||||
add_new_entry :: State -> (SimpleRR ()) -> State
|
||||
add_new_entry state rr
|
||||
= state { _rr = new_rr_list, _current_entry = new_placeholder }
|
||||
where new_placeholder = defaultResourceA
|
||||
new_rr_list = state._rr <> [ new_rr ]
|
||||
new_rr = rr { id = getNewID state }
|
||||
|
||||
-- add a new record and get a new placeholter
|
||||
add_new_mx :: State -> (MXRR ()) -> State
|
||||
add_new_mx state rr
|
||||
= state { _mxrr = new_rr_list, _current_entry_mx = new_placeholder }
|
||||
where new_placeholder = defaultResourceMX
|
||||
new_rr_list = state._mxrr <> [ new_rr ]
|
||||
new_rr = rr { id = getNewID state }
|
||||
|
||||
-- add a new record and get a new placeholter
|
||||
add_new_srv :: State -> (SRVRR ()) -> State
|
||||
add_new_srv state rr
|
||||
= state { _srvrr = new_rr_list, _current_entry_srv = new_placeholder }
|
||||
where new_placeholder = defaultResourceSRV
|
||||
new_rr_list = state._srvrr <> [ new_rr ]
|
||||
new_rr = rr { id = getNewID state }
|
||||
|
||||
changeType :: forall (l :: Row Type). (SimpleRR l) -> Maybe String -> (SimpleRR l)
|
||||
changeType rr Nothing = rr
|
||||
changeType rr (Just s) = rr { t = s }
|
||||
|
||||
update_value :: forall (l :: Row Type).
|
||||
Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l)
|
||||
update_value rrid val
|
||||
= update (\rr -> rr { modified = true, value = val }) rrid
|
||||
|
||||
update_ttl :: forall (l :: Row Type).
|
||||
Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l)
|
||||
update_ttl rrid val
|
||||
= update (\rr -> rr { modified = true, ttl = val, valid = isInteger val }) rrid
|
||||
|
||||
update_priority :: forall (l :: Row Type). Int -> Priority -> Array (MXRR l) -> Array (MXRR l)
|
||||
update_priority rrid val = update (\rr -> rr { modified = true, priority = val}) rrid
|
||||
|
||||
update_weight :: forall (l :: Row Type). Int -> Priority -> Array (SRVRR l) -> Array (SRVRR l)
|
||||
update_weight rrid val = update (\rr -> rr { modified = true, weight = val}) rrid
|
||||
|
||||
update_port :: Int -> Priority -> Array (SRVRR ()) -> Array (SRVRR ())
|
||||
update_port rrid val = update (\rr -> rr { modified = true, port = val}) rrid
|
||||
|
||||
|
||||
isIntRegex :: Regex
|
||||
isIntRegex = unsafeRegex "^[0-9]*$" noFlags
|
||||
|
||||
isInteger :: String -> Boolean
|
||||
isInteger = test isIntRegex
|
||||
|
||||
update :: forall (l :: Row Type).
|
||||
(SimpleRR l -> SimpleRR l) -> Int -> Array (SimpleRR l) -> Array (SimpleRR l)
|
||||
update f rrid records = map doSmth records
|
||||
where
|
||||
doSmth rr
|
||||
| rrid == rr.id = f rr
|
||||
| otherwise = rr
|
||||
|
||||
|
||||
getNewID :: State -> Int
|
||||
getNewID state = (_ + 1) $ foldl max 0 [ maxIDrr
|
||||
, maxIDmxrr
|
||||
, maxIDsrvrr
|
||||
]
|
||||
|
||||
where
|
||||
maxIDrr = foldl max 0 $ map _.id state._rr
|
||||
maxIDmxrr = foldl max 0 $ map _.id state._mxrr
|
||||
maxIDsrvrr = foldl max 0 $ map _.id state._srvrr
|
||||
|
||||
Loading…
Reference in New Issue
Block a user