-- | `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 (Unit, bind, comparing, discard, map, max, otherwise, pure, show, ($), (+), (/=), (<<<), (<>), (==)) import Data.Array as A import Data.Int (fromString) import Data.ArrayBuffer.Types (ArrayBuffer) import Data.Array.NonEmpty as NonEmpty import Data.Either (Either(..)) import Data.Foldable as Foldable import Data.Maybe (Maybe(..), fromMaybe) import Data.String.Regex as Regex import Data.String.Regex.Flags as RegexFlags import Data.String.Regex.Unsafe as RegexUnsafe import Effect.Aff.Class (class MonadAff) import Halogen as H import Halogen.HTML as HH import Halogen.HTML.Events as HE 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.RR import App.LogMessage (LogMessage(..)) import App.Messages.DNSManagerDaemon as DNSManager -- | `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 Update_SRR_Form = Update_SRR_Type Int | Update_SRR_Domain RecordDomain | Update_SRR_TTL TTL | Update_SRR_Value RecordValue data Update_MX_Form = Update_MX_Domain RecordDomain | Update_MX_TTL TTL | Update_MX_Value RecordValue | Update_MX_Priority Priority data Update_SRV_Form = Update_SRV_Domain RecordDomain | Update_SRV_TTL TTL | Update_SRV_Value RecordValue | Update_SRV_Priority Priority | Update_SRV_Weight Weight | Update_SRV_Port Port data Action = DeleteRRModal RRId | CancelModal | Initialize | Finalize -- New entries. | UpdateNewSRRForm Update_SRR_Form | UpdateNewMXForm Update_MX_Form | UpdateNewSRVForm Update_SRV_Form -- Add new entries. | AddSRR | AddMX | AddSRV -- Entry already in our zone. | UpdateLocalSRRForm RRId Update_SRR_Form | UpdateLocalMXForm RRId Update_MX_Form | UpdateLocalSRVForm RRId Update_SRV_Form | SyncRR RRId | RemoveRR RRId | TellSomethingWentWrong RRId String -- | type State = { _current_domain :: RecordDomain , _srr :: Array (SimpleRR ()) , _mxrr :: Array (MXRR ()) , _srvrr :: Array (SRVRR ()) , _current_entry :: (SimpleRR ()) , _current_entry_mx :: (MXRR ()) , _current_entry_srv :: (SRVRR ()) , wsUp :: Boolean , active_modal :: Maybe Int } 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 domain = { wsUp: true , active_modal: Nothing , _current_domain: domain , _srr: [] , _mxrr: [] , _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 rr_id -> modal_rr_delete rr_id true, Nothing -> HH.div_ [ Bulma.h1 state._current_domain , Bulma.hr , render_records sorted , render_mx_records state._mxrr , render_srv_records state._srvrr , render_new_records state ] ] where sorted = Foldable.foldl (<>) [] $ map (A.sortBy (comparing (_.domain))) $ map NonEmpty.toArray $ A.groupAllBy (comparing (_.t)) state._srr modal_rr_delete :: forall w. Int -> HH.HTML w Action modal_rr_delete rr_id = 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) , HE.onClick \_ -> RemoveRR rr_id ] [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 } DeleteRRModal rr_id -> do H.modify_ _ { active_modal = Just rr_id } Initialize -> do { _current_domain } <- H.get H.raise $ Log $ SimpleLog $ "Asking the server for the zone" <> _current_domain message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _current_domain } H.raise $ MessageToSend message Finalize -> do H.raise $ Log $ SimpleLog "Finalized!" UpdateNewSRRForm rr_update -> case rr_update of Update_SRR_Type val -> do let new_type = fromMaybe "unknown" (baseRecords A.!! val) H.raise $ Log $ SimpleLog ("Update new entry type: " <> new_type) state <- H.get H.modify_ _ { _current_entry = changeType state._current_entry (baseRecords A.!! val) } Update_SRR_Domain val -> do H.raise $ Log $ SimpleLog ("Update new entry domain: " <> val) H.modify_ _ { _current_entry { domain = val } } Update_SRR_TTL val -> do H.raise $ Log $ SimpleLog ("Update new entry ttl: " <> val) H.modify_ _ { _current_entry { ttl = val, valid = isInteger val } } Update_SRR_Value val -> do H.raise $ Log $ SimpleLog ("Update new entry value: " <> val) H.modify_ _ { _current_entry { value = val } } UpdateNewMXForm rr_update -> case rr_update of -- TODO: FIXME: test all inputs Update_MX_Domain val -> do H.raise $ Log $ SimpleLog ("Update new MX entry domain: " <> val) state <- H.get H.modify_ _ { _current_entry_mx = state._current_entry_mx { domain = val } } -- TODO: FIXME: test all inputs Update_MX_TTL val -> do H.raise $ Log $ SimpleLog ("Update new MX entry ttl: " <> val) state <- H.get H.modify_ _ { _current_entry_mx = state._current_entry_mx {ttl = val, valid = isInteger val} } -- TODO: FIXME: test all inputs Update_MX_Value val -> do H.raise $ Log $ SimpleLog ("Update new MX entry value: " <> val) state <- H.get H.modify_ _ { _current_entry_mx = state._current_entry_mx { value = val } } Update_MX_Priority val -> do H.raise $ Log $ SimpleLog ("Update new MX entry priority: " <> val) state <- H.get H.modify_ _ { _current_entry_mx = state._current_entry_mx { priority = val } } UpdateNewSRVForm rr_update -> case rr_update of Update_SRV_Domain val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry domain: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv { domain = val } } Update_SRV_Value val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry value: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv { value = val } } -- TODO: FIXME: test all inputs Update_SRV_TTL val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry ttl: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv {ttl = val, valid = isInteger val}} Update_SRV_Priority val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry priority: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv { priority = val } } Update_SRV_Weight val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry weight: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv { weight = val } } Update_SRV_Port val -> do H.raise $ Log $ SimpleLog ("Update new SRV entry port: " <> val) state <- H.get H.modify_ _ { _current_entry_srv = state._current_entry_srv { port = val } } -- This action only is possible if inputs are correct. AddSRR -> 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 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 } 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 } H.raise $ MessageToSend message 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 UpdateLocalSRRForm rr_id rr_update -> case rr_update of Update_SRR_Type val -> do let new_type = fromMaybe "unknown" (baseRecords A.!! val) H.raise $ Log $ SimpleLog ("TODO: Update local RR " <> show rr_id <> " type: " <> new_type) -- state <- H.get -- H.modify_ _ { _srr = changeType state._current_entry (baseRecords A.!! val) } Update_SRR_Domain val -> do H.raise $ Log $ SimpleLog ("Update local RR " <> show rr_id <> " domain: " <> val) state <- H.get H.modify_ _ { _srr = (update_domain rr_id val state._srr) } Update_SRR_TTL val -> do H.raise $ Log $ SimpleLog ("Update local RR " <> show rr_id <> " TTL: " <> val) state <- H.get H.modify_ _ { _srr = (update_ttl rr_id val state._srr) } Update_SRR_Value val -> do H.raise $ Log $ SimpleLog ("Update local RR " <> show rr_id <> " value: " <> val) state <- H.get H.modify_ _ { _srr = (update_value rr_id val state._srr) } UpdateLocalMXForm rr_id rr_update -> case rr_update of -- TODO: FIXME: test all inputs Update_MX_Domain val -> do H.raise $ Log $ SimpleLog ("Update local MX RR " <> show rr_id <> " domain: " <> val) state <- H.get H.modify_ _ { _mxrr = (update_domain rr_id val state._mxrr) } -- TODO: FIXME: test all inputs Update_MX_TTL val -> do H.raise $ Log $ SimpleLog ("Update local MX " <> show rr_id <> " entry ttl: " <> val) state <- H.get H.modify_ _ { _mxrr = (update_ttl rr_id val state._mxrr) } -- TODO: FIXME: test all inputs Update_MX_Value val -> do H.raise $ Log $ SimpleLog ("Update local MX " <> show rr_id <> " entry value: " <> val) state <- H.get H.modify_ _ { _mxrr = (update_value rr_id val state._mxrr) } Update_MX_Priority val -> do H.raise $ Log $ SimpleLog ("Update local MX " <> show rr_id <> " entry priority: " <> val) state <- H.get H.modify_ _ { _mxrr = (update_priority rr_id val state._mxrr) } UpdateLocalSRVForm rr_id rr_update -> case rr_update of Update_SRV_Domain val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry domain: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_domain rr_id val state._srvrr) } Update_SRV_Value val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry value: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_value rr_id val state._srvrr) } -- TODO: FIXME: test all inputs Update_SRV_TTL val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry ttl: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_ttl rr_id val state._srvrr) } Update_SRV_Priority val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry priority: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_priority rr_id val state._srvrr) } Update_SRV_Weight val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry weight: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_weight rr_id val state._srvrr) } Update_SRV_Port val -> do H.raise $ Log $ SimpleLog ("Update local SRV " <> show rr_id <> " entry port: " <> val) state <- H.get H.modify_ _ { _srvrr = (update_port rr_id val state._srvrr) } -- TODO: network operations SyncRR rr_id -> do H.raise $ Log $ SimpleLog ("TODO: SyncRR: " <> show rr_id) RemoveRR rr_id -> do { _current_domain } <- H.get H.raise $ Log $ SimpleLog $ "Ask to remove rr (id: " <> show rr_id <> ")" message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteRR { domain: _current_domain, rrid: rr_id } H.raise $ MessageToSend message H.modify_ _ { active_modal = Nothing } -- TODO: change the state to indicate problems? TellSomethingWentWrong rr_id val -> do H.raise $ Log $ SimpleLog ("Sorry, your record " <> show rr_id <> " has problems: ") -- H.raise $ Log $ SimpleLog (show rr) H.raise $ Log $ SimpleLog (" => " <> val) -- 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 err -> do --H.raise $ Log $ SimpleLog $ "[🤖] received a message that couldn't be decoded..., reason: " <> show err case err of (DNSManager.JSONERROR jerr) -> do H.raise $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr (DNSManager.UnknownError unerr) -> H.raise $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr) (DNSManager.UnknownNumber ) -> H.raise $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber" 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 _) -> 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.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 H.modify_ _ { _srr = A.filter (\rr -> rr.id /= response.rrid) state._srr , _mxrr = A.filter (\rr -> rr.id /= response.rrid) state._mxrr , _srvrr = A.filter (\rr -> rr.id /= response.rrid) state._srvrr } (DNSManager.MkZone response) -> do H.raise $ Log $ SimpleLog $ "[🎉] Got the zone!" H.raise $ Log $ SimpleLog $ "DEBUG: the zone has domain: " <> response.zone.domain H.raise $ Log $ SimpleLog $ "DEBUG: zone: " <> show_zone response.zone (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) where show_zone zone = "domain: " <> zone.domain <> " | " <> resource_list zone.resources where resource_list [] = "" resource_list arr = case A.uncons arr of Just { head: x, tail: xs } -> "(" <> x.rrtype <> ": " <> show x.rrid <> ") " <> resource_list xs Nothing -> "" -- 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 [] = Bulma.columns [] [ left_block, right_block ] where left_block = Bulma.column class_title_size [ Bulma.zone_rr_title "NS, A, AAAA, CNAME" , Bulma.subtitle "and TXT records" ] right_block = Bulma.column_ [ Bulma.subtitle "No records for now" ] render_records records = Bulma.columns [] [ Bulma.column class_title_size [Bulma.zone_rr_title title_txt, Bulma.subtitle subtitle_txt ] , Bulma.column_ [ Bulma.tile [ 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 [] [ Bulma.simple_table_header, table_content ] table_content = HH.tbody_ $ map row records row rr = HH.tr_ $ [ Bulma.txt_name rr.t , HH.td_ [ Bulma.input_domain ((UpdateLocalSRRForm rr.id) <<< Update_SRR_Domain) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl ((UpdateLocalSRRForm rr.id) <<< Update_SRR_TTL ) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_value ((UpdateLocalSRRForm rr.id) <<< Update_SRR_Value) rr.value rr.valid ] , HH.td_ [ Bulma.btn_change (SyncRR rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ] , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.id) ] ] render_mx_records :: forall (w :: Type) (l :: Row Type) . Array (MXRR l) -> HH.HTML w Action render_mx_records [] = Bulma.columns [] [ left_block, right_block ] where left_block = Bulma.column class_title_size [ Bulma.zone_rr_title "MX records" ] right_block = Bulma.column_ [ Bulma.subtitle "No records for now" ] render_mx_records records = Bulma.columns [] [ Bulma.column class_title_size [ Bulma.zone_rr_title title_txt ] , Bulma.column_ [ Bulma.tile [ table_rr ] ] ] where title_txt = "MX records" table_rr = HH.table [] [ Bulma.mx_table_header, table_content ] table_content = HH.tbody_ $ map row records row rr = HH.tr_ $ [ HH.td_ [ Bulma.input_domain ((UpdateLocalMXForm rr.id) <<< Update_MX_Domain) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl ((UpdateLocalMXForm rr.id) <<< Update_MX_TTL) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_priority ((UpdateLocalMXForm rr.id) <<< Update_MX_Priority) rr.priority rr.valid ] , HH.td_ [ Bulma.input_value ((UpdateLocalMXForm rr.id) <<< Update_MX_Value) rr.value rr.valid ] , HH.td_ [ Bulma.btn_change (SyncRR rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ] , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal rr.id) ] ] render_srv_records :: forall (w :: Type) (l :: Row Type) . Array (SRVRR l) -> HH.HTML w Action render_srv_records [] = Bulma.columns [] [ left_block, right_block ] where left_block = Bulma.column class_title_size [ Bulma.zone_rr_title "SRV records" ] right_block = Bulma.column_ [ Bulma.subtitle "No records for now" ] render_srv_records records = Bulma.columns [] [ Bulma.column class_title_size [ Bulma.zone_rr_title title_txt] , Bulma.column_ [ Bulma.tile [ table_rr ] ] ] where title_txt = "SRV records" table_rr = HH.table [] [ Bulma.srv_table_header, table_content ] table_content = HH.tbody_ $ map row records row rr = HH.tr_ $ [ HH.td_ [ Bulma.input_domain ((UpdateLocalSRVForm rr.id) <<< Update_SRV_Domain ) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl ((UpdateLocalSRVForm rr.id) <<< Update_SRV_TTL ) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_priority ((UpdateLocalSRVForm rr.id) <<< Update_SRV_Priority) rr.priority rr.valid ] , HH.td_ [ Bulma.input_weight ((UpdateLocalSRVForm rr.id) <<< Update_SRV_Weight ) rr.weight rr.valid ] , HH.td_ [ Bulma.input_port ((UpdateLocalSRVForm rr.id) <<< Update_SRV_Port ) rr.port rr.valid ] , HH.td_ [ Bulma.input_value ((UpdateLocalSRVForm rr.id) <<< Update_SRV_Value ) rr.value rr.valid ] , HH.td_ [ Bulma.btn_change (SyncRR rr.id) (TellSomethingWentWrong rr.id "cannot update") rr.modified rr.valid ] , HH.td_ [ Bulma.btn_delete (\_ -> DeleteRRModal 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 = Bulma.hdiv [ Bulma.zone_rr_title "New record (NS, A, AAAA, CNAME, TXT)", table ] where table = HH.table [] [ Bulma.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_ [ Bulma.input_domain (UpdateNewSRRForm <<< Update_SRR_Domain) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl (UpdateNewSRRForm <<< Update_SRR_TTL) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_value (UpdateNewSRRForm <<< Update_SRR_Value) rr.value rr.valid ] , HH.td_ [ Bulma.btn_add AddSRR (TellSomethingWentWrong rr.id "cannot add") rr.valid ] ] -- type_selection :: forall w i. HH.HTML w i type_selection = HH.select [ HE.onSelectedIndexChange (UpdateNewSRRForm <<< Update_SRR_Type) ] $ 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 = Bulma.hdiv [ Bulma.zone_rr_title "New MX record", table ] where table = HH.table [] [ Bulma.mx_table_header, render_record_builder ] -- render_record_builder :: forall w. HH.HTML w Action render_record_builder = HH.tr_ [ HH.td_ [ Bulma.input_domain (UpdateNewMXForm <<< Update_MX_Domain) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl (UpdateNewMXForm <<< Update_MX_TTL) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_priority (UpdateNewMXForm <<< Update_MX_Priority) rr.priority rr.valid ] , HH.td_ [ Bulma.input_value (UpdateNewMXForm <<< Update_MX_Value) rr.value rr.valid ] , HH.td_ [ Bulma.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 = Bulma.hdiv [ Bulma.zone_rr_title "New SRV record", table ] where table = HH.table [] [ Bulma.srv_table_header, render_record_builder ] -- render_record_builder :: forall w. HH.HTML w Action render_record_builder = HH.tr_ [ HH.td_ [ Bulma.input_domain (UpdateNewSRVForm <<< Update_SRV_Domain) rr.domain rr.valid ] , HH.td_ [ Bulma.input_ttl (UpdateNewSRVForm <<< Update_SRV_TTL) rr.ttl rr.valid ] , HH.td_ [ Bulma.input_priority (UpdateNewSRVForm <<< Update_SRV_Priority) rr.priority rr.valid ] , HH.td_ [ Bulma.input_weight (UpdateNewSRVForm <<< Update_SRV_Weight) rr.weight rr.valid ] , HH.td_ [ Bulma.input_port (UpdateNewSRVForm <<< Update_SRV_Port) rr.port rr.valid ] , HH.td_ [ Bulma.input_value (UpdateNewSRVForm <<< Update_SRV_Value) rr.value rr.valid ] , HH.td_ [ Bulma.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 = Bulma.hdiv [ Bulma.h1 "Adding new records" , Bulma.hr , Bulma.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 = Bulma.column_ $ [ Bulma.box [ Bulma.zone_rr_title "NS, A, AAAA, CNAME, TXT" , type_selection , Bulma.box_input_domain (UpdateNewSRRForm <<< Update_SRR_Domain) rr.domain rr.valid , Bulma.box_input_ttl (UpdateNewSRRForm <<< Update_SRR_TTL) rr.ttl rr.valid , Bulma.box_input_value (UpdateNewSRRForm <<< Update_SRR_Value) rr.value rr.valid , Bulma.btn_add AddSRR (TellSomethingWentWrong rr.id "cannot add") rr.valid ] ] where -- type_selection :: forall w i. HH.HTML w i type_selection = HH.select [ HE.onSelectedIndexChange (UpdateNewSRRForm <<< Update_SRR_Type) ] $ 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 = Bulma.column_ $ [ Bulma.box [ Bulma.zone_rr_title "MX" , Bulma.box_input_domain (UpdateNewMXForm <<< Update_MX_Domain) rr.domain rr.valid , Bulma.box_input_ttl (UpdateNewMXForm <<< Update_MX_TTL) rr.ttl rr.valid , Bulma.box_input_priority (UpdateNewMXForm <<< Update_MX_Priority) rr.priority rr.valid , Bulma.box_input_value (UpdateNewMXForm <<< Update_MX_Value) rr.value rr.valid , Bulma.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 = Bulma.column_ $ [ Bulma.box [ Bulma.zone_rr_title "SRV" , Bulma.box_input_domain (UpdateNewSRVForm <<< Update_SRV_Domain) rr.domain rr.valid , Bulma.box_input_ttl (UpdateNewSRVForm <<< Update_SRV_TTL) rr.ttl rr.valid , Bulma.box_input_priority (UpdateNewSRVForm <<< Update_SRV_Priority) rr.priority rr.valid , Bulma.box_input_weight (UpdateNewSRVForm <<< Update_SRV_Weight) rr.weight rr.valid , Bulma.box_input_port (UpdateNewSRVForm <<< Update_SRV_Port) rr.port rr.valid , Bulma.box_input_value (UpdateNewSRVForm <<< Update_SRV_Value) rr.value rr.valid , Bulma.btn_add AddSRV (TellSomethingWentWrong rr.id "cannot add") rr.valid ] ] -- 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 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_domain :: forall (l :: Row Type). Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l) update_domain rr_id val = update (\rr -> rr { modified = true, domain = val }) rr_id update_value :: forall (l :: Row Type). Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l) update_value rr_id val = update (\rr -> rr { modified = true, value = val }) rr_id update_ttl :: forall (l :: Row Type). Int -> String -> Array (SimpleRR l) -> Array (SimpleRR l) update_ttl rr_id val = update (\rr -> rr { modified = true, ttl = val, valid = isInteger val }) rr_id update_priority :: forall (l :: Row Type). Int -> Priority -> Array (MXRR l) -> Array (MXRR l) update_priority rr_id val = update (\rr -> rr { modified = true, priority = val}) rr_id update_weight :: forall (l :: Row Type). Int -> Priority -> Array (SRVRR l) -> Array (SRVRR l) update_weight rr_id val = update (\rr -> rr { modified = true, weight = val}) rr_id update_port :: Int -> Priority -> Array (SRVRR ()) -> Array (SRVRR ()) update_port rr_id val = update (\rr -> rr { modified = true, port = val}) rr_id isIntRegex :: Regex.Regex isIntRegex = RegexUnsafe.unsafeRegex "^[0-9]*$" RegexFlags.noFlags isInteger :: String -> Boolean isInteger = Regex.test isIntRegex update :: forall (l :: Row Type). (SimpleRR l -> SimpleRR l) -> Int -> Array (SimpleRR l) -> Array (SimpleRR l) update f rr_id records = map doSmth records where doSmth rr | rr_id == rr.id = f rr | otherwise = rr getNewID :: State -> Int getNewID state = (_ + 1) $ Foldable.foldl max 0 [ maxIDrr , maxIDmxrr , maxIDsrvrr ] where maxIDrr = Foldable.foldl max 0 $ map _.id state._srr maxIDmxrr = Foldable.foldl max 0 $ map _.id state._mxrr maxIDsrvrr = Foldable.foldl max 0 $ map _.id state._srvrr