462 lines
18 KiB
Text
462 lines
18 KiB
Text
-- | `App.DomainListInterface` is a simple component with the list of own domains
|
|
-- | and a form to add a new domain.
|
|
-- |
|
|
-- | This interface enables to:
|
|
-- | - display the list of own domains
|
|
-- | - show and select accepted domains (TLDs)
|
|
-- | - create new domains
|
|
-- | - delete a domain
|
|
-- | - ask for confirmation
|
|
-- | - switch to the interface to show and modify the content of a Zone
|
|
-- | - validate the domain before sending a message to `dnsmanagerd`
|
|
-- | - manage ownership of a domain: give, share, take back exclusive ownership.
|
|
module App.Page.DomainList where
|
|
|
|
import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>), (>), (==))
|
|
|
|
import Data.Array as A
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
import Data.Either (Either(..))
|
|
import Data.String (toLower)
|
|
import Data.Maybe (Maybe(..), maybe, fromMaybe)
|
|
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 Web.Event.Event as Event
|
|
import Web.Event.Event (Event)
|
|
import Bulma as Bulma
|
|
|
|
import App.DisplayErrors (error_to_paragraph_label)
|
|
|
|
import App.Validation.Label as Validation
|
|
|
|
import CSSClasses as C
|
|
import App.Type.DomainInfo
|
|
import App.Type.LogMessage (LogMessage(..))
|
|
import App.Message.DNSManagerDaemon as DNSManager
|
|
|
|
-- | `App.DomainListInterface` 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`.
|
|
-- |
|
|
-- | Finally, the component can ask its state to its parent.
|
|
-- | The reason is quite simple.
|
|
-- | The component can be deleted, meaning that it loses its state.
|
|
-- | Instead of asking `dnsmanagerd` the list of available domains and the list of owned domains
|
|
-- | each time the component is instanciated, the parent stores the component's state when the
|
|
-- | component is removed. This way, the data is conserved.
|
|
|
|
data Output
|
|
= MessageToSend ArrayBuffer
|
|
| Log LogMessage
|
|
| ChangePageZoneInterface String
|
|
| AskState
|
|
| StoreState State
|
|
|
|
-- | `App.DomainListInterface` can receive messages from `dnsmanagerd`.
|
|
-- |
|
|
-- | The component is also informed when the connection is lost or up again.
|
|
-- |
|
|
-- | Finally, its entire state can be provided by its parent.
|
|
-- | See the explanation for the `Output` data type.
|
|
|
|
data Query a
|
|
= MessageReceived DNSManager.AnswerMessage a
|
|
| ProvideState (Maybe State) a
|
|
|
|
type Slot = H.Slot Query Output
|
|
|
|
-- | `App.DomainListInterface` has no input.
|
|
|
|
type Input = Unit
|
|
|
|
-- | `App.DomainListInterface` has a single form to add a new domain.
|
|
-- | Only two possible inputs: the (sub)domain name and the selection of the TLD.
|
|
|
|
data NewDomainFormAction
|
|
= INP_newdomain String
|
|
| UpdateSelectedDomain String
|
|
|
|
-- | Possible component's actions are:
|
|
-- | - update the accepted domains (examples: netlib.re, codelib.re and example.com)
|
|
-- | - update the list of own domains
|
|
-- | - handle user inputs
|
|
-- | - add a new domain
|
|
-- | - delete a domain you exclusively own
|
|
-- | - share or transfer a domain (through dedicated tokens)
|
|
-- | - gain ownership over a domain (through dedicated tokens)
|
|
-- | - gain exclusive ownership of a shared domain (if the user is currently the only owner)
|
|
-- | - show the zone content (in another page)
|
|
|
|
data Action
|
|
= UpdateAcceptedDomains (Array String)
|
|
| UpdateMyDomains (Array DomainInfo)
|
|
|
|
| HandleNewDomainInput NewDomainFormAction
|
|
| AskDomainTransferUUIDInput String
|
|
|
|
| NewDomainAttempt Event
|
|
| AskDomainTransferAttempt Event
|
|
| RemoveDomain String
|
|
| EnterDomain String
|
|
| ShareDomain String
|
|
| UnShareDomain String
|
|
| TransferDomain String
|
|
|
|
| DeleteDomainModal String
|
|
| CancelModal
|
|
|
|
| Initialize
|
|
| Finalize
|
|
|
|
-- | The form only has two visible elements:
|
|
-- | the subdomain name input and the selected TLD.
|
|
-- | The type also includes validation errors.
|
|
|
|
type NewDomainFormState
|
|
= { new_domain :: String
|
|
, _errors :: Array Validation.Error
|
|
, selected_domain :: String
|
|
}
|
|
|
|
-- | The form "askDomainTransfer" is simple enough: an input for the UUID and a button.
|
|
-- | The type also includes validation errors.
|
|
|
|
type AskDomainTransferState = { uuid :: String, _errors :: Array Validation.Error }
|
|
|
|
-- | The entire component's state contains the form, accepted domains,
|
|
-- | the list of own domains and a boolean to know if the connection is up.
|
|
|
|
type State =
|
|
{ newDomainForm :: NewDomainFormState
|
|
, askDomainTransferForm :: AskDomainTransferState
|
|
, accepted_domains :: Array String
|
|
, my_domains :: Array DomainInfo
|
|
|
|
, deletion_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"
|
|
|
|
--debug_domains :: Array DomainInfo
|
|
--debug_domains
|
|
-- = [ emptyDomainInfo { name = "test.example.com"
|
|
-- , share_key = Just "UUID"
|
|
-- , owners = ["myself", "you"] }
|
|
-- , emptyDomainInfo { name = "my-domain.example.com" }
|
|
-- , emptyDomainInfo { name = "my-other-domain.example.com" }
|
|
-- ]
|
|
|
|
initialState :: Input -> State
|
|
initialState _ =
|
|
{ newDomainForm: { new_domain: "", _errors: [], selected_domain: default_domain }
|
|
, askDomainTransferForm: { uuid: "", _errors: [] }
|
|
, accepted_domains: [ default_domain ]
|
|
, my_domains: []
|
|
, deletion_modal: Nothing
|
|
}
|
|
|
|
render :: forall m. State -> H.ComponentHTML Action () m
|
|
render { accepted_domains, my_domains, newDomainForm, askDomainTransferForm, deletion_modal }
|
|
= Bulma.section_small
|
|
[ case deletion_modal of
|
|
Nothing -> HH.div_ [ Bulma.columns_ domain_line
|
|
, Bulma.hr
|
|
, Bulma.columns_ new_domain_line
|
|
, Bulma.hr
|
|
, Bulma.columns_ explanations_line
|
|
]
|
|
Just domain -> Bulma.modal "Deleting a domain"
|
|
[warning_message domain] [modal_delete_button domain, modal_cancel_button]
|
|
]
|
|
where
|
|
c = Bulma.column_
|
|
|
|
domain_line = [ c render_my_domains, c render_my_shared_domains ]
|
|
new_domain_line = [ c render_new_domain, c render_gain_ownership ]
|
|
explanations_line = [ c render_share_ownership_explanation, c render_transfer_ownership_explanation ]
|
|
|
|
render_my_domains =
|
|
[ Bulma.h3 "My domains"
|
|
, Bulma.simple_quote "You are the exclusive owner of the following domains."
|
|
, if A.length domains_i_exclusively_own > 0
|
|
then Bulma.table [] [ Bulma.table_header_owned_domains
|
|
, HH.tbody_ $ map owned_domain_row domains_i_exclusively_own
|
|
]
|
|
else Bulma.p "No domain yet."
|
|
]
|
|
render_my_shared_domains =
|
|
[ Bulma.h3 "Shared domains"
|
|
, Bulma.simple_quote """
|
|
The following domains are shared with other users.
|
|
In case you are the last owner, you can "unshare" it and gain exclusive ownership.
|
|
"""
|
|
, if A.length domains_i_share > 0
|
|
then Bulma.table [] [ Bulma.table_header_shared_domains
|
|
, HH.tbody_ $ map shared_domain_row domains_i_share
|
|
]
|
|
else Bulma.p "No domain yet."
|
|
]
|
|
render_new_domain =
|
|
[ Bulma.h3 "New domain"
|
|
, Bulma.quote [ Bulma.p "The heart of dnsmanager! 🎉"
|
|
, Bulma.p "You can reserve a domain name, right here."
|
|
, HH.text """
|
|
Later you will be able to change the content, share, transfer or even delete the domain.
|
|
"""
|
|
]
|
|
, render_add_domain_form
|
|
]
|
|
|
|
render_gain_ownership =
|
|
[ Bulma.h3 "Get the ownership of a domain"
|
|
, Bulma.simple_quote """
|
|
Someone wants to give you (or share with you) the ownership of a domain.
|
|
Please enter the UUID of the transfer.
|
|
"""
|
|
, render_ask_domain_transfer_form
|
|
]
|
|
render_share_ownership_explanation =
|
|
[ Bulma.h3 "Share the ownership of a domain"
|
|
, Bulma.simple_quote """
|
|
Ask for a "share token" for your domain and give it to other users.
|
|
All the owners can make modifications to the domain.
|
|
Don't let the administration of a domain be the burden of a single person!
|
|
"""
|
|
]
|
|
|
|
render_transfer_ownership_explanation =
|
|
[ Bulma.h3 "Transfer the ownership of a domain"
|
|
, Bulma.simple_quote """
|
|
Ask for a transfer token for your domain and give it to the new owner.
|
|
"""
|
|
]
|
|
|
|
modal_delete_button domain = Bulma.alert_btn "Delete the domain" (RemoveDomain domain)
|
|
modal_cancel_button = Bulma.cancel_button CancelModal
|
|
|
|
-- I own all domain without a "share key".
|
|
domains_i_exclusively_own = A.sort $ A.filter (\domain -> domain.share_key == Nothing) my_domains
|
|
-- Shared domains are all domains with a share_key.
|
|
domains_i_share = A.sort $ A.filter (\domain -> domain.share_key /= Nothing) my_domains
|
|
|
|
warning_message domain
|
|
= HH.p [] [ HH.text $ "You are about to delete your domain \""
|
|
<> domain
|
|
<> "\". Are you sure you want to do this? This is "
|
|
, HH.strong_ [ HH.text "irreversible" ]
|
|
, HH.text "."
|
|
, Bulma.notification_warning' """
|
|
In case this domain is shared, it will just be removed from your domains.
|
|
"""
|
|
]
|
|
|
|
shared_domain_row domain = HH.tr_
|
|
[ HH.td_ [ Bulma.btn domain.name (EnterDomain domain.name) ]
|
|
, HH.td_ [ HH.text $ fromMaybe "" domain.share_key ]
|
|
, if A.length domain.owners == 1
|
|
then HH.td_ [ Bulma.alert_btn_abbr "Unshare the domain by removing the \"share\" token." "Unshare" (UnShareDomain domain.name) ]
|
|
else HH.td_ [ Bulma.btn_ro [C.is_warning] "Cannot unshare it" ]
|
|
, HH.td_ [ Bulma.alert_btn_abbr "Delete the domain from your list of owned domains. In case you are the only owner, this will also remove all zone data and the domain won't be served anymore." "Delete" (DeleteDomainModal domain.name) ]
|
|
]
|
|
|
|
owned_domain_row domain = HH.tr_
|
|
[ HH.td_ [ Bulma.btn domain.name (EnterDomain domain.name) ]
|
|
, case domain.transfer_key of
|
|
Just key -> HH.td_ [ Bulma.p "Token key:", Bulma.p key ]
|
|
Nothing -> HH.td_ [ Bulma.btn_abbr "Generate a token to transfer the ownership of a domain." "Transfer" (TransferDomain domain.name) ]
|
|
, HH.td_ [ Bulma.btn_abbr "Generate a token to share the ownership of a domain." "Share" (ShareDomain domain.name) ]
|
|
, HH.td_ [ Bulma.alert_btn_abbr "Delete the domain. This will remove all zone data and the domain won't be served anymore." "Delete" (DeleteDomainModal domain.name) ]
|
|
]
|
|
|
|
render_add_domain_form = HH.form
|
|
[ HE.onSubmit NewDomainAttempt ]
|
|
[ Bulma.new_domain_field
|
|
(HandleNewDomainInput <<< INP_newdomain)
|
|
newDomainForm.new_domain
|
|
[ HHE.onSelectedIndexChange domain_choice ]
|
|
(map (\v -> "." <> v) accepted_domains)
|
|
, Bulma.btn_validation_ "add a new domain"
|
|
, if A.length newDomainForm._errors > 0
|
|
then HH.div_ $ map error_to_paragraph_label newDomainForm._errors
|
|
else HH.div_ [ ]
|
|
]
|
|
|
|
render_ask_domain_transfer_form = HH.form
|
|
[ HE.onSubmit AskDomainTransferAttempt ]
|
|
[ Bulma.box_input "idTransferToken" "Token" "UUID of the domain"
|
|
AskDomainTransferUUIDInput
|
|
askDomainTransferForm.uuid
|
|
, Bulma.btn_validation_ "ask for a domain transfer"
|
|
, if A.length askDomainTransferForm._errors > 0
|
|
then HH.div_ $ map error_to_paragraph_label askDomainTransferForm._errors
|
|
else HH.div_ [ ]
|
|
]
|
|
|
|
domain_choice :: Int -> Action
|
|
domain_choice i
|
|
= HandleNewDomainInput <<< UpdateSelectedDomain $ maybe default_domain (\x -> x) $ accepted_domains A.!! i
|
|
|
|
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
|
handleAction = case _ of
|
|
Initialize -> do
|
|
H.raise $ AskState
|
|
|
|
Finalize -> do
|
|
state <- H.get
|
|
H.raise $ StoreState state
|
|
|
|
CancelModal -> do
|
|
H.modify_ _ { deletion_modal = Nothing }
|
|
|
|
UpdateAcceptedDomains domains -> do
|
|
H.modify_ _ { accepted_domains = domains }
|
|
|
|
UpdateMyDomains domains -> do
|
|
H.modify_ _ { my_domains = domains }
|
|
|
|
HandleNewDomainInput adduserinp -> do
|
|
case adduserinp of
|
|
INP_newdomain v -> do
|
|
H.modify_ _ { newDomainForm { new_domain = toLower v } }
|
|
case v of
|
|
"" -> H.modify_ _ { newDomainForm { _errors = [] } }
|
|
_ -> case Validation.label v of
|
|
Left arr -> H.modify_ _ { newDomainForm { _errors = arr } }
|
|
Right _ -> H.modify_ _ { newDomainForm { _errors = [] } }
|
|
UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } }
|
|
|
|
AskDomainTransferUUIDInput str -> do
|
|
H.modify_ _ { askDomainTransferForm { uuid = toLower str } }
|
|
|
|
EnterDomain domain -> do
|
|
H.raise $ ChangePageZoneInterface domain
|
|
|
|
ShareDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskShareToken { domain: domain }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Ask a \"share token\" for domain " <> domain <> "."
|
|
|
|
TransferDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskTransferToken { domain: domain }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Ask a \"transfer token\" for domain " <> domain <> "."
|
|
|
|
UnShareDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkAskUnShareDomain { domain: domain }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Ask for exclusive ownership for domain " <> domain <> "."
|
|
|
|
DeleteDomainModal domain -> do
|
|
H.modify_ _ { deletion_modal = Just domain }
|
|
|
|
RemoveDomain domain -> do
|
|
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Remove domain: " <> domain
|
|
H.modify_ _ { deletion_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 newDomainForm.new_domain, newDomainForm._errors, new_domain of
|
|
"", _, _ ->
|
|
H.raise $ Log $ UnableToSend "Please enter the new domain."
|
|
_, [], _ -> do
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkNewDomain { domain: new_domain }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")"
|
|
handleAction $ HandleNewDomainInput $ INP_newdomain ""
|
|
_, _, _ ->
|
|
H.raise $ Log $ UnableToSend $ "The new domain name is invalid."
|
|
|
|
AskDomainTransferAttempt ev -> do
|
|
H.liftEffect $ Event.preventDefault ev
|
|
|
|
{ askDomainTransferForm } <- H.get
|
|
case askDomainTransferForm.uuid, askDomainTransferForm._errors of
|
|
"", _ ->
|
|
H.raise $ Log $ UnableToSend "Please enter the UUID of the transfer."
|
|
uuid, [] -> do
|
|
message <- H.liftEffect
|
|
$ DNSManager.serialize
|
|
$ DNSManager.MkGainOwnership { uuid: uuid }
|
|
H.raise $ MessageToSend message
|
|
H.raise $ Log $ SystemLog $ "Gain ownership of a domain (" <> uuid <> ")."
|
|
handleAction $ AskDomainTransferUUIDInput ""
|
|
_, _ ->
|
|
H.raise $ Log $ UnableToSend $ "The UUID is invalid."
|
|
|
|
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
|
handleQuery = case _ of
|
|
|
|
ProvideState maybe_state a -> do
|
|
case maybe_state of
|
|
Nothing -> pure Nothing
|
|
Just s -> do
|
|
H.put s
|
|
pure (Just a)
|
|
|
|
MessageReceived message a -> do
|
|
case message of
|
|
-- The authentication failed.
|
|
(DNSManager.MkAcceptedDomains response) -> do
|
|
handleAction $ UpdateAcceptedDomains response.domains
|
|
(DNSManager.MkLogged response) -> do
|
|
handleAction $ UpdateAcceptedDomains response.accepted_domains
|
|
handleAction $ UpdateMyDomains response.my_domains
|
|
(DNSManager.MkDomainAdded response) -> do
|
|
{ my_domains } <- H.get
|
|
handleAction $ UpdateMyDomains (my_domains <> [ emptyDomainInfo { name = response.domain } ])
|
|
(DNSManager.MkDomainChanged response) -> do
|
|
{ my_domains } <- H.get
|
|
let replaced_domains = map (\d -> if d.name == response.domain.name then response.domain else d) my_domains
|
|
new_domains = if A.elem response.domain replaced_domains
|
|
then replaced_domains
|
|
else replaced_domains <> [response.domain]
|
|
handleAction $ UpdateMyDomains new_domains
|
|
(DNSManager.MkDomainDeleted response) -> do
|
|
{ my_domains } <- H.get
|
|
handleAction $ UpdateMyDomains $ A.filter (\d -> d.name /= response.domain) my_domains
|
|
_ -> H.raise $ Log $ ErrorLog $ "Message not handled in DomainListInterface."
|
|
pure (Just a)
|
|
|
|
page_reload :: State -> DNSManager.AnswerMessage -> State
|
|
page_reload s1 message =
|
|
case message of
|
|
DNSManager.MkLogged response ->
|
|
s1 { accepted_domains = response.accepted_domains
|
|
, my_domains = A.sort response.my_domains
|
|
}
|
|
_ -> s1
|
|
|
|
build_new_domain :: String -> String -> String
|
|
build_new_domain sub tld
|
|
| endsWith "." sub = sub <> tld
|
|
| otherwise = sub <> "." <> tld
|