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

Add real data from the server: WIP.

Browse Source
This commit is contained in:
Philippe Pittoli 2023-07-11 03:26:42 +02:00
parent e60ce8f8b4
commit 88226019fd
2 changed files with 113 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/App/Messages/DNSManagerDaemon.purs
View File

@ -182,6 +182,12 @@ type RRDeleted = { rrid :: Int }
codecRRDeleted ∷ CA.JsonCodec RRDeleted
codecRRDeleted = CA.object "RRDeleted" (CAR.record { rrid: CA.int })
{- 19 -}
type RRAdded = { domain :: String, rr :: ResourceRecord.ResourceRecord }
codecRRAdded ∷ CA.JsonCodec RRAdded
codecRRAdded = CA.object "RRAdded" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
{- 50 -}
type UnknownUser = { }
codecUnknownUser ∷ CA.JsonCodec UnknownUser
@ -227,6 +233,7 @@ data AnswerMessage
| MkLogged Logged -- 16
| MkDomainAdded DomainAdded -- 17
| MkRRDeleted RRDeleted -- 18
| MkRRAdded RRAdded -- 19
| MkUnknownUser UnknownUser -- 50
| MkNoOwnership NoOwnership -- 51
@ -274,6 +281,7 @@ decode number string
16 -> error_management codecLogged MkLogged
17 -> error_management codecDomainAdded MkDomainAdded
18 -> error_management codecRRDeleted MkRRDeleted
19 -> error_management codecRRAdded MkRRAdded
50 -> error_management codecUnknownUser MkUnknownUser
51 -> error_management codecNoOwnership MkNoOwnership
_ -> Left UnknownNumber

152
src/App/ZoneInterface.purs
View File

@ -32,6 +32,7 @@ import Bulma as Bulma
import CSSClasses as C
import App.RR
import App.ResourceRecord
import App.LogMessage (LogMessage(..))
import App.Messages.DNSManagerDaemon as DNSManager
@ -300,32 +301,11 @@ handleAction = case _ of
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
-- H.put $ add_new_entry state state._current_entry
AddMX -> do
state <- H.get
let form = state._current_entry_mx
newttl = fromMaybe 3600 $ fromString form.ttl
newpriority = fromMaybe 10 $ fromString form.priority
newrr = { rrtype: form.t
, rrid: 0 -- garbage value anyway
, name: form.domain
, ttl: newttl
, target: form.value
, readonly: false
, priority: Just newpriority
, port: Nothing
, protocol: Nothing
, weight: Nothing
, mname: Nothing
, rname: Nothing
, serial: Nothing
, refresh: Nothing
, retry: Nothing
, expire: Nothing
, minttl: Nothing
}
let newrr = fromLocalMXRRRepresentationToResourceRecord state._current_entry_mx
H.raise $ Log $ SimpleLog ("Add new MX: " <> show state._current_entry_mx)
-- H.put $ add_new_mx state state._current_entry_mx
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._current_domain, rr: newrr }
@ -333,7 +313,7 @@ handleAction = case _ of
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
-- H.put $ add_new_srv state state._current_entry_srv
UpdateLocalSRRForm rr_id rr_update -> case rr_update of
Update_SRR_Type val -> do
@ -489,23 +469,33 @@ handleQuery = case _ of
(DNSManager.MkAcceptedDomains _) -> do
H.raise $ Log $ SimpleLog $ "[TODO] Received the list of accepted domains!"
-- handleAction $ UpdateAcceptedDomains response.domains
(DNSManager.MkLogged _) -> 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.MkRRAdded response) -> do
state <- H.get
let new_rr = response.rr
H.raise $ Log $ SimpleLog
$ "[TODO] Resource Record added: " <> response.domain
<> " rrid: " <> show new_rr.rrid
<> " rrtype: " <> new_rr.rrtype
<> " name: " <> new_rr.name
<> " ttl: " <> show new_rr.ttl
<> " target: " <> new_rr.target
<> " readonly: " <> show new_rr.readonly
case add_entry state new_rr of
Left error_message -> H.raise $ Log $ SimpleLog $ "Error while adding new entry: " <> error_message
Right new_state -> H.put new_state
(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.MkRRDeleted response) -> do
H.raise $ Log $ SimpleLog $ "[🎉] RR (id: '" <> show response.rrid <> "') has been deleted!"
state <- H.get
@ -543,6 +533,14 @@ handleQuery = case _ of
Just { head: x, tail: xs } -> "(" <> x.rrtype <> ": " <> show x.rrid <> ") " <> resource_list xs
Nothing -> ""
add_entry :: State -> ResourceRecord -> Either String State
add_entry state new_rr = do
case new_rr.rrtype, (A.elem new_rr.rrtype baseRecords) of
_, true -> Right $ add_new_entry state $ fromResourceRecordToLocalRepresentationSimpleRR new_rr
"MX", _ -> Right $ add_new_mx state $ fromResourceRecordToLocalRepresentationMXRR new_rr
"SRV", _ -> Right $ add_new_srv state $ fromResourceRecordToLocalRepresentationSRVRR new_rr
_, _ -> Left "TODO: CAN'T ADD THIS KIND OF RR RIGHT NOW"
-- Rendering
class_title_size :: Array (HH.ClassName)
class_title_size = [HH.ClassName "is-4"]
@ -767,28 +765,22 @@ render_new_record_colunm_srv rr
-- ACTIONS
-- add a new record and get a new placeholter
add_new_entry :: State -> (SimpleRR ()) -> State
add_new_entry state rr
= state { _srr = new_rr_list, _current_entry = new_placeholder }
where new_placeholder = defaultResourceA
new_rr_list = state._srr <> [ new_rr ]
new_rr = rr { id = getNewID state }
add_new_entry :: State -> Maybe (SimpleRR ()) -> State
add_new_entry state = case _ of
Nothing -> state
Just rr -> state { _srr = (state._srr <> [ rr ]), _current_entry = defaultResourceA }
-- 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_new_mx :: State -> Maybe (MXRR ()) -> State
add_new_mx state = case _ of
Nothing -> state
Just rr -> state { _mxrr = (state._mxrr <> [ rr ]), _current_entry_mx = defaultResourceMX }
-- 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 }
add_new_srv :: State -> Maybe (SRVRR ()) -> State
add_new_srv state = case _ of
Nothing -> state
Just rr -> state { _srvrr = (state._srvrr <> [ rr ]), _current_entry_srv = defaultResourceSRV }
changeType :: forall (l :: Row Type). (SimpleRR l) -> Maybe String -> (SimpleRR l)
changeType rr Nothing = rr
@ -832,6 +824,72 @@ update f rr_id records = map doSmth records
| rr_id == rr.id = f rr
| otherwise = rr
fromResourceRecordToLocalRepresentationSimpleRR :: ResourceRecord -> Maybe (SimpleRR ())
fromResourceRecordToLocalRepresentationSimpleRR new_rr =
Just { t: new_rr.rrtype
, id: new_rr.rrid
, modified: false
, valid: true
, ttl: show new_rr.ttl
, domain: new_rr.name
, value: new_rr.target
}
fromResourceRecordToLocalRepresentationMXRR :: ResourceRecord -> Maybe (MXRR ())
fromResourceRecordToLocalRepresentationMXRR new_rr = do
priority <- new_rr.priority
Just { t: new_rr.rrtype
, id: new_rr.rrid
, modified: false
, valid: true
, ttl: show new_rr.ttl
, domain: new_rr.name
, value: new_rr.target
, priority: show priority
}
-- TODO: would be nice to have a simpler implementation, something like this:
--fromResourceRecordToLocalRepresentationMXRR new_rr
-- = let simple_rr = fromResourceRecordToLocalRepresentationSimpleRR new_rr
-- simple_rr { priority = show new_rr.priority }
fromResourceRecordToLocalRepresentationSRVRR :: ResourceRecord -> Maybe (SRVRR ())
fromResourceRecordToLocalRepresentationSRVRR new_rr = do
case new_rr.priority, new_rr.weight, new_rr.port of
Just priority, Just weight, Just port ->
Just { t: new_rr.rrtype
, id: new_rr.rrid
, modified: false
, valid: true
, ttl: show new_rr.ttl
, domain: new_rr.name
, value: new_rr.target
, priority: show priority
, port: show port
, weight: show weight
-- , protocol: protocol
}
_, _, _ -> Nothing
fromLocalMXRRRepresentationToResourceRecord :: MXRR () -> ResourceRecord
fromLocalMXRRRepresentationToResourceRecord form
= { rrtype: form.t
, rrid: form.id
, name: form.domain
, ttl: fromMaybe 3600 $ fromString form.ttl
, target: form.value
, readonly: false
, priority: Just $ fromMaybe 10 $ fromString form.priority
, port: Nothing
, protocol: Nothing
, weight: Nothing
, mname: Nothing
, rname: Nothing
, serial: Nothing
, refresh: Nothing
, retry: Nothing
, expire: Nothing
, minttl: Nothing
}
getNewID :: State -> Int
getNewID state = (_ + 1)