Beta URLs.

README.md

@@ -1,91 +1,11 @@
-# Halogen Template
+# dnsmanager interface
 
 ### Quick Start
 ```sh
-git clone https://github.com/purescript-halogen/purescript-halogen-template.git halogen-project
-cd halogen-project
-npm install
-npm run build
-npm run serve
+make
 ```
 
 ### Introduction
 
-This is a template for starting a fresh project with the [Halogen](https://github.com/purescript-halogen/purescript-halogen) library for writing declarative, type-safe user interfaces.
-
-You can learn more about Halogen with these resources:
-
-- The [Halogen documentation](https://github.com/purescript-halogen/purescript-halogen/tree/master/docs), which includes a quick start guide and a concepts reference.
-- The [Learn Halogen](https://github.com/jordanmartinez/learn-halogen) learning repository.
-- The [Real World Halogen](https://github.com/thomashoneyman/purescript-halogen-realworld) application and guide. Note that the published article is written for the older halogen v4, but the code and comments cover the current halogen v5.
-- The [API documentation](https://pursuit.purescript.org/packages/purescript-halogen) on Pursuit
-
-You can chat with other Halogen users on the [PureScript Discourse](https://discourse.purescript.org), or join the [Functional Programming Slack](https://functionalprogramming.slack.com) ([invite link](https://fpchat-invite.herokuapp.com/)) in the `#purescript` and `#purescript-beginners` channels.
-
-If you notice any problems with the below setup instructions, or have suggestions on how to make the new-user experience any smoother, please create an issue or pull-request.
-
-Compatible with PureScript compiler 13.x
-
-### Initial Setup
-
-**Prerequisites:** This template assumes you already have Git and Node.js installed with `npm` somewhere on your path.
-
-First, clone the repository and step into it:
-
-```sh
-git clone https://github.com/purescript-halogen/purescript-halogen-template.git halogen-project
-cd halogen-project
-```
-
-Then, install the PureScript compiler, the [Spago](https://github.com/purescript/spago) package manager and build tool, and the [Parcel](https://github.com/parcel-bundler/parcel) bundler. You may either install PureScript tooling _globally_, to reduce duplicated `node_modules` across projects, or _locally_, so that each project uses specific versions of the tools.
-
-To install the toolchain globally:
-```sh
-npm install -g purescript spago parcel
-```
-
-To install the toolchain locally (reads `devDependencies` from `package.json`):
-```sh
-npm install
-```
-
-### Building
-
-You can now build the PureScript source code with:
-
-```sh
-# An alias for `spago build`
-npm run build
-```
-
-### Launching the App
-
-You can launch your app in the browser with:
-
-```sh
-# An alias for `parcel dev/index.html --out-dir dev-dist --open`
-npm run serve
-```
-
-### Development Cycle
-
-If you're using an [editor](https://github.com/purescript/documentation/blob/master/ecosystem/Editor-and-tool-support.md#editors) that supports [`purs ide`](https://github.com/purescript/purescript/tree/master/psc-ide) or are running [`pscid`](https://github.com/kRITZCREEK/pscid), you simply need to keep the previous `npm run serve` command running in a terminal. Any save to a file will trigger an incremental recompilation, rebundle, and web page refresh, so you can immediately see your changes.
-
-If your workflow does not support automatic recompilation, then you will need to manually re-run `npm run build`. Even with automatic recompilation, a manual rebuild is occasionally required, such as when you add, remove, or modify module names, or notice any other unexpected behavior.
-
-### Production
-
-When you are ready to create a minified bundle for deployment, run the following command:
-```sh
-npm run build-prod
-```
-
-Parcel output appears in the `./dist/` directory.
-
-You can test the production output locally with a tool like [`http-server`](https://github.com/http-party/http-server#installation). It seems that `parcel` should also be able to accomplish this, but it unfortunately will only serve development builds locally.
-```sh
-npm install -g http-server
-http-server dist -o
-```
-
-If everything looks good, you can then upload the contents of `dist` to your preferred static hosting service.
+This code is an alpha version of the official interface for `dnsmanager` (second edition).
+For now, nothing much to see.

drop/APIStuff.purs

@@ -0,0 +1,3 @@
+maybeCurrentConnection <- H.gets _.wsInfo.connection
+when (isJust maybeCurrentConnection) do
+  H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }

drop/ClassName.purs

@@ -0,0 +1,7 @@
+
+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 "remove" ]

drop/DomainParser.purs

@@ -0,0 +1,96 @@
+-- | `DomainParser` is a simple parser for domain names as described in RFC 1035.
+module DomainParser where
+
+import Prelude (bind, discard, pure, show, ($), (<>), (>))
+
+import Control.Alt ((<|>))
+import Control.Lazy (defer)
+import Data.Array.NonEmpty as NonEmpty
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.String as S -- length
+import Data.String.CodeUnits as CU
+-- import Data.String.Regex as R
+-- import Data.String.Regex.Flags as RF
+import Data.Tuple (Tuple(..))
+import Parsing.Combinators.Array (many1)
+import Parsing.Combinators as PC
+import Parsing (Parser, fail, runParser)
+import Parsing.String.Basic (alphaNum, letter)
+import Parsing.String (char, string, eof)
+
+-- | From RFC 1035: <domain> ::= <subdomain> | " "
+-- |
+-- | Accepting an optional '.' at the end of the subdomain doesn't conform
+-- | to the (prefered) syntax of a domain as described in RFC 1035.
+-- | However, this last '.' character should be acceptable in most applications.
+-- | In some cases, a fully qualified domain name (FQDN) such as `example.com.`
+-- | has to be differenciated from a "relative" name (www).
+domain :: Parser String String
+domain = PC.try (string " ") <|> sub_eof
+
+sub_eof :: Parser String String
+sub_eof = do
+  sub <- subdomain
+  maybe_final_point <- PC.optionMaybe (char '.')
+  eof
+  let parsed_domain = did_we_parsed_the_final_point maybe_final_point sub
+  if S.length parsed_domain > 255
+  then fail $ "domain length is > 255 bytes (" <> show (S.length parsed_domain) <> ")"
+  else pure parsed_domain
+  where
+    did_we_parsed_the_final_point Nothing  sub = sub
+    did_we_parsed_the_final_point (Just _) sub = sub <> "."
+
+-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
+subdomain :: Parser String String
+subdomain = do
+  -- First: read a label. This is bare minimum for a subdomain.
+  lab <- label
+  -- Second: the rest is optional.
+  r <- PC.optionMaybe (PC.try point_sub)
+  case r of
+    Nothing  -> pure lab
+    Just sub -> pure $ lab <> sub
+
+  where
+    point_sub :: Parser String String
+    point_sub = do
+      point <- string "."
+      sub <- defer \_ -> subdomain
+      pure $ point <> sub
+
+-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
+label :: Parser String String
+label = let_then_str_then_alpha <|> char_to_string letter
+  where
+    let_then_str_then_alpha :: Parser String String
+    let_then_str_then_alpha = do
+      Tuple whole_label last_char <- PC.try do
+        l <- letter
+        s <- ldhstr
+        pure $ Tuple (CU.singleton l <> (CU.fromCharArray $ NonEmpty.toArray s)) (NonEmpty.last s)
+      case runParser (CU.singleton last_char) let_dig of
+        Left _  -> fail $ "Label is wrong: last char is '" <> (CU.singleton last_char) <> "' which isn't an alphanum"
+        Right _ -> if S.length whole_label > 63 -- Remember: we already did read a letter (l).
+                   then fail $ "Label is larger than expected (max 63 characters, current: " <> show (S.length whole_label) <>  ")"
+                   else pure whole_label
+
+-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
+ldhstr :: Parser String (NonEmpty.NonEmptyArray Char)
+ldhstr = many1 let_dig_hyp
+
+-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
+-- Either a Letter, Digital or an Hyphenation character.
+let_dig_hyp :: Parser String Char
+let_dig_hyp = let_dig <|> char '-' <|> fail "invalid character"
+
+-- From RFC 1035: <let-dig> ::= <letter> | <digit>
+let_dig :: Parser String Char
+let_dig = alphaNum
+
+-- | Converting a single letter parser to a String parser.
+char_to_string :: Parser String Char -> Parser String String
+char_to_string p = do
+  character <- p
+  pure $ CU.singleton character

drop/PlayingWithParsers.purs

@@ -0,0 +1,171 @@
+-- | `App.HomeInterface` presents the website and its features.
+module App.HomeInterface where
+
+import Prelude (Unit, map, show, ($), (<>))
+import DomainParser as DomainParser
+
+--import Data.Either (Either(..))
+-- import Data.Maybe (Maybe(..), maybe)
+-- import Data.Tuple (Tuple(..))
+import Effect.Aff.Class (class MonadAff)
+import Halogen as H
+import Halogen.HTML as HH
+import Parsing
+-- import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties as HP
+
+import Bulma as Bulma
+
+type Input = Unit
+--type Action = Unit
+data Action = UpdateStuff String
+-- type State = Unit
+type State = { stuff :: String }
+
+data Query a = DoNothing a
+type Output = Unit
+type Slot = H.Slot Query Output
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        }
+    }
+
+-- handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+-- handleAction _ = pure unit
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  UpdateStuff val -> H.modify_ _ { stuff = val }
+
+-- initialState :: forall input. input -> State
+-- initialState _ = unit
+
+initialState :: forall input. input -> State
+initialState _ = { stuff: "" }
+
+list_of_domains_to_test :: Array String
+list_of_domains_to_test
+  = [ "ex.net"
+    , "??"
+    , "e-x.net"
+    , "way-too-long--way-too-long--way-too-long--way-too-long--way-too-long.net"
+    , "way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.net"
+    , "e-.net"
+    , "-x.net"
+    , "truc-blah.example.com"
+    , "te.s-t.net"
+    , "example.com"
+    ]
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render state
+  = HH.div_
+      [ Bulma.hero_danger
+          "THIS IS AN ALPHA RELEASE"
+          "Come back later!"
+      , Bulma.section_small
+          [ Bulma.h1 "Welcome to netlib.re"
+          , Bulma.subtitle "Free domain names"
+          , Bulma.hr
+          , render_description
+          , render_second_line
+          , render_why_and_contact
+          , Bulma.hr
+          , render_how_and_code
+          ]
+      , Bulma.hero_danger "A simple input" "Nothing much to see"
+      , Bulma.section_small $
+          [ Bulma.h1 "Examples of domain parsing in Purescript"
+          ] <> test_domains list_of_domains_to_test
+      , Bulma.section_small [ render_stuff ]
+      ]
+  where
+    -- Some helpers.
+    title = Bulma.h3
+    p = Bulma.p
+    b x = Bulma.column_ [ Bulma.box x ]
+
+    render_stuff = Bulma.columns_ [ b [ title "stuff"
+                                      , stuff_input
+                                      ]
+                                  --, b [ title "result"
+                                  --    , p $ case runParser state.stuff DomainParser.parse_stuff of
+                                  --        Left _ -> "NOT OKAY"
+                                  --        Right _ -> "OKAY"
+                                  --    ]
+                                  ]
+
+    stuff_input
+      = Bulma.box_input "stuff" "stuff" "stuff"
+          UpdateStuff
+          state.stuff
+          true
+          should_be_disabled
+    should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
+
+    -- test_domains :: Array String -> _
+    test_domains doms = map tests_on_domain doms
+
+    -- tests_on_domain :: String -> _
+    tests_on_domain d
+      = b [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
+          , p $ d <> " : ldhstr     : " <> (show $ runParser d DomainParser.ldhstr)
+          , p $ d <> " : label      : " <> (show $ runParser d DomainParser.label)
+          , p $ d <> " : subdomain  : " <> (show $ runParser d DomainParser.subdomain)
+          , p $ d <> " : domain     : " <> (show $ runParser d DomainParser.domain)
+          ]
+
+    render_description = Bulma.columns_ [ render_basics, render_no_expert ]
+    render_basics
+      = b [ title "What is provided?"
+          , p "Reserve a domain name in <something>.netlib.re for free."
+          , p "Manage your own DNS zone."
+          ]
+    render_no_expert
+      = b [ title "No need to be an expert!"
+          , p """
+              This website will help you through your configuration, as much as we can.
+              """
+          ]
+    render_second_line = Bulma.columns_ [ render_no_housing, render_updates ]
+    render_no_housing
+      = b [ title "No housing, just a name"
+          , p """
+              We don't provide housing for your services or websites,
+              just a name.
+              """
+          ]
+    render_updates
+      = b [ title "Automatic updates"
+          , p "Update your current address with a simple script."
+          ]
+
+    render_why_and_contact = Bulma.columns_ [ render_why, render_contact ]
+    render_why
+      = b [ title "Why?"
+          , p "Because everyone should be able to have a place on the Internet."
+          , p "We provide you a name, build something meaningful with it."
+          ]
+    render_contact
+      = b [ title "Contact"
+          , p "You have a question, you saw a bug or you just want to chat?"
+          , p "You can contact us: ..."
+          ]
+
+    render_how_and_code = Bulma.columns_ [ render_how, render_code ]
+    render_how
+      = b [ title "How does this work?"
+          , p "We pay for the domain names (netlib.re and codelib.re) and let you have a subdomain."
+          , p "This service helps you manage your domain (a subdomain of netlib.re or codelib.re)."
+          ]
+    render_code
+      = b [ title "I want to see the code!"
+          , p "The project is fully open-source (ISC licence)."
+          , p "There are 3 parts: libipc, micro-services (authentication and dnsmanager) and this website."
+          ]

drop/RR.purs

@@ -0,0 +1,71 @@
+module App.RR where
+
+type InputParameter
+  = { valid :: Boolean
+    , value :: String
+    }
+
+type RecordType   = String
+type RecordTarget = String
+type RecordName   = 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 Protocol = String
+
+type RRId = Int
+
+type Modified = Boolean
+type Valid    = Boolean
+
+type RecordBase l
+  = { rrtype   :: RecordType
+    , rrid     :: RRId
+    , modified :: Boolean
+    , valid    :: Boolean
+    , ttl      :: TTL
+    , name     :: RecordName
+    , target   :: RecordTarget
+    , readonly :: Boolean
+    | l
+    }
+
+-- CNAME A AAAA NS TXT
+type SimpleRR l = RecordBase (|l)
+
+type MXRR  l = RecordBase ( priority :: Priority | l)
+type SRVRR l = MXRR ( protocol :: Protocol
+                    , weight   :: Weight
+                    , port     :: Port
+                    | l)
+
+type SOARR l
+  = RecordBase ( mname   :: String
+               , rname   :: String
+               , serial  :: String -- Int
+               , refresh :: String -- Int
+               , retry   :: String -- Int
+               , expire  :: String -- Int
+               , minttl  :: String -- Int
+               | l)
+
+defaultResourceA :: SimpleRR ()
+defaultResourceA
+  = { rrid: 0, rrtype: "A", modified: false, valid: true, readonly: false
+    , ttl: "200", name  : "www", target: "192.168.10.2" }
+
+defaultResourceMX :: MXRR ()
+defaultResourceMX
+  = { rrid: 0, rrtype: "MX", modified: false, valid: true, readonly: false
+    , ttl: "500", priority: "10", name  : "mail", target: "www" }
+
+defaultResourceSRV :: SRVRR ()
+-- RRId  Modified  Valid  Priority  Protocol Weight  Port  TTL  Domain  Value
+defaultResourceSRV
+  = { rrid: 0, rrtype: "SRV", modified: false, valid: true, readonly: false
+    , priority: "10", protocol: "_tcp", weight: "100"
+    , port: "80", ttl: "200"
+    , name  : "_sip._tcp.example.com.", target: "sip.example.com." }

drop/SimpleInput.purs

@@ -0,0 +1,69 @@
+-- | `App.HomeInterface` presents the website and its features.
+module App.SimpleInput where
+
+import Prelude (Unit, ($))
+
+-- import Data.Either (Either(..))
+-- import Data.Maybe (Maybe(..), maybe)
+-- import Data.Tuple (Tuple(..))
+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 Bulma as Bulma
+
+type Input = Unit
+data Action = UpdateStuff String
+
+data Query a = DoNothing a
+type Output = Unit
+type Slot = H.Slot Query Output
+
+type State = { stuff :: String }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        }
+    }
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  UpdateStuff val -> H.modify_ _ { stuff = val }
+
+initialState :: forall input. input -> State
+initialState _ = { stuff: "" }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render state
+  = HH.div_
+      [ Bulma.hero_danger "A simple input" "Nothing much to see"
+      , Bulma.section_small [ render_stuff ]
+      ]
+  where
+    -- Some helpers.
+    title = Bulma.h3
+    p = Bulma.p
+    b x = Bulma.column_ [ Bulma.box x ]
+
+    render_stuff = Bulma.columns_ [ b [ title "stuff"
+                                      , stuff_input
+                                      ]
+                                  , b [ title "value"
+                                      , p state.stuff
+                                      ]
+                                  ]
+
+    stuff_input
+      = Bulma.box_input "stuff" "stuff" "stuff"
+          UpdateStuff
+          state.stuff
+          true
+          should_be_disabled
+    should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))

drop/UnusedCode.purs

@@ -0,0 +1,44 @@
+
+-- 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"]
+
+nav_bar :: forall w i. String -> HH.HTML w i
+nav_bar domain
+  = HH.nav
+      [ HP.classes $ C.breadcrumb <> C.is_centered <> C.has_succeeds_separator
+      , 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)]
+                ]
+            ]
+        ]
+
+
+  -- type_selection: create a "select" input.
+  -- Get the changes with "onSelectedIndexChange" which provides an index (from `baseRecords`)
+  type_selection :: HH.HTML w Action
+  type_selection = HH.div [HP.classes $ C.select <> C.is_normal]
+    [ HH.select
+        [ HE.onSelectedIndexChange (UpdateNewForm <<< Update_New_Form_SRR <<< Update_SRR_Type) ]
+        $ map type_option baseRecords
+    ]
+  type_option n
+    = HH.option
+        [ HP.value n
+        , HP.selected (n == rr.rrtype)
+        ] [ HH.text n ]
+
+  -- Get the element from the index
+  H.modify_ _ { _newSRR = changeType state._newSRR (baseRecords A.!! val) }
+
+  changeType :: forall (l :: Row Type). (SimpleRR l) -> Maybe String -> (SimpleRR l)
+  changeType rr Nothing = rr
+  changeType rr (Just s) = rr { rrtype = s }

drop/regex-and-validation-examples.purs

@@ -0,0 +1,44 @@
+import Data.String.Regex as R
+import Data.String.Regex.Flags as RF
+import Data.Validation.Semigroup (V, andThen, invalid, toEither)
+
+andThenDrop :: forall errors a b. V errors a -> V errors b -> V errors b
+-- andThenDrop f1 f2 = f1 !> (\ _ -> f2)
+
+infixl 8 andThen as !>
+-- infixl 8 andThenDrop as !<
+
+name_format :: String
+name_format = "[a-zA-Z]+"
+protocol_format :: String
+protocol_format = "^(tcp|udp|sctp)$"
+hostname_format :: String
+hostname_format = "^(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9-]*[a-zA-Z0-9]).)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9-]*[A-Za-z0-9])[.]?$"
+-- Basic tools for validation.
+
+lengthIsBetween :: Attribute -> Int -> Int -> String -> V Errors String
+lengthIsBetween field minlen maxlen value
+  = if valid_condition
+      then pure value
+      else invalid [ Tuple field error_message ]
+  where
+    actual_len = S.length value
+    valid_condition = actual_len >= minlen && actual_len <= maxlen
+    error_message = "acceptable length [" <> show minlen <> "-" <> show maxlen <> "]"
+
+-- | `matches` is a simple format verification based on regex parsing.
+-- | `verify_regex` is a handler to use `matches` with a string regex format.
+-- |
+-- | ```
+-- | verify_regex Name name_format name
+-- | ```
+matches :: Attribute -> String -> R.Regex -> V Errors String
+matches field value regex
+  | R.test regex value = pure value
+  | otherwise          = invalid [Tuple field "unacceptable format"]
+
+verify_regex :: Attribute -> String -> String -> V Errors String
+verify_regex field restr value
+  = case R.regex restr RF.unicode of
+      Left error_string -> invalid [Tuple field $ "error in regex: " <> error_string]
+      Right regex       -> matches field value regex

makefile

@@ -1,6 +1,9 @@
 all: build
 
-build:
+clone-generic-parser:
+	[ ! -d ../parser ] && cd .. && git clone ssh://_gitea@git.baguette.netlib.re:2299/Baguette/parser.git || :
+
+build: clone-generic-parser
 	spago build
 
 bundle: install-esbuild
@@ -13,6 +16,19 @@ repl:
 spagobuild:
 	spago build
 
+docs-with-search:
+	spago docs
+
+docs:
+	spago docs --no-search
+
+DOCS_HTTPD_ACCESS_LOGS ?= /tmp/docs-access.log
+DOCS_HTTPD_ADDR        ?= 127.0.0.1
+DOCS_HTTPD_PORT        ?= 31000
+DOCS_DIR               ?= generated-docs/html
+serve-docs: docs
+	darkhttpd $(DOCS_DIR) --addr $(DOCS_HTTPD_ADDR) --port $(DOCS_HTTPD_PORT) --log $(DOCS_HTTPD_ACCESS_LOGS)
+
 install-esbuild:
 	@echo "install ebbuild"
 	[ -f node_modules/.bin/esbuild ] || npm install esbuild

packages.dhall

@@ -3,3 +3,4 @@ let upstream =
         sha256:8b94a0cd7f86589a6bd06d48cb9a61d69b66a94b668657b2f10c8b14c16e028c
 
 in  upstream
+    with generic-parser = ../parser/spago.dhall as Location

spago.dhall

@@ -1,7 +1,6 @@
-{ name = "halogen-project"
+{ name = "dnsmanager-interface"
 , dependencies =
   [ "aff"
-  , "argonaut-codecs"
   , "argonaut-core"
   , "arraybuffer"
   , "arraybuffer-builder"
@@ -10,13 +9,16 @@
   , "bifunctors"
   , "codec-argonaut"
   , "console"
-  , "const"
+  , "control"
+  , "dom-indexed"
   , "effect"
   , "either"
   , "exceptions"
   , "foreign"
+  , "generic-parser"
   , "halogen"
   , "halogen-subscriptions"
+  , "integers"
   , "maybe"
   , "newtype"
   , "parsing"
@@ -24,14 +26,17 @@
   , "prelude"
   , "profunctor"
   , "strings"
+  , "stringutils"
+  , "tailrec"
   , "transformers"
   , "tuples"
   , "uint"
-  , "variant"
+  , "validation"
   , "web-encoding"
   , "web-events"
+  , "web-html"
   , "web-socket"
-  , "web-uievents"
+  , "web-storage"
   ]
 , packages = ./packages.dhall
 , sources = [ "src/**/*.purs", "test/**/*.purs" ]

src/App/AcceptedRRTypes.purs

@@ -0,0 +1,22 @@
+-- | The application accepts to add a few new entry types in a DNS zone.
+-- | Each resource record has a specific form, with dedicated inputs and
+-- | dedicated validation.
+module App.AcceptedRRTypes where
+
+import Prelude
+import Data.Generic.Rep (class Generic)
+import Data.Show.Generic (genericShow)
+
+data AcceptedRRTypes
+  = A
+  | AAAA
+  | TXT
+  | CNAME
+  | NS
+  | MX
+  | SRV
+
+derive instance genericMyADT :: Generic AcceptedRRTypes _
+
+instance showMyADT :: Show AcceptedRRTypes where
+  show = genericShow

src/App/AdministrationInterface.purs

@@ -0,0 +1,283 @@
+{- Administration interface.
+   Allows to:
+     - add, remove, search users
+     - TODO: validate users
+     - TODO: change user password
+     - TODO: show user details (list of owned domains)
+     - TODO: show user domain details (zone content) and to modify users' zone
+     - TODO: raise a user to admin (and vice versa)
+     - TODO: list users (getting them slowly, otherwise it will cause problems with thousands of logins)
+-}
+module App.AdministrationInterface where
+
+import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=))
+
+import Bulma as Bulma
+
+import Data.Maybe (Maybe(..))
+import Data.Array as A
+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 (Event)
+import Web.Event.Event as Event
+
+import CSSClasses as C
+
+import Web.HTML (window) as HTML
+import Web.HTML.Window (sessionStorage) as Window
+import Web.Storage.Storage as Storage
+
+import App.UserPublic (UserPublic)
+import Data.ArrayBuffer.Types (ArrayBuffer)
+
+import App.LogMessage
+-- import App.IPC as IPC
+import App.Email as Email
+
+-- import App.Messages.DNSManagerDaemon as DNSManager
+import App.Messages.AuthenticationDaemon as AuthD
+
+data Output
+  = MessageToSend ArrayBuffer
+  | Log LogMessage
+  | AskState
+  | StoreState State
+
+data Query a
+  = MessageReceived AuthD.AnswerMessage a
+  | ConnectionIsDown a
+  | ConnectionIsUp a
+  | ProvideState (Maybe State) a
+
+type Slot = H.Slot Query Output
+
+type Input = Unit
+
+data AddUserInput
+  = ADDUSER_INP_login       String
+  | ADDUSER_INP_email       String
+  | ADDUSER_toggle_admin
+  | ADDUSER_INP_pass        String
+  | SEARCHUSER_INP_regex    String
+  --| SEARCHUSER_INP_domain String
+
+data Action
+  = HandleAddUserInput AddUserInput
+
+  | AddUserAttempt
+  | SearchUserAttempt
+  | PreventSubmit Event
+
+  | ShowUser Int
+  | RemoveUser Int
+
+  -- | Change the displayed page.
+  | Routing Page
+
+  | Initialize
+  | Finalize
+
+-- | There are different `sub-pages` in the authentication daemon admin page.
+-- | For example, users can be searched and a list is provided.
+data Page = Home | Search | Add
+
+type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
+type StateSearchUserForm = { regex :: String {-, admin :: Boolean, domain :: String -} }
+
+type State =
+  { addUserForm    :: StateAddUserForm
+  , searchUserForm :: StateSearchUserForm
+  , page           :: Page
+  , wsUp           :: Boolean
+  , matching_users :: Array UserPublic
+  }
+
+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
+        }
+    }
+
+initialState :: Input -> State
+initialState _ = { addUserForm:    { login: "", admin: false, email: "", pass: "" }
+                 , searchUserForm: { regex: "" {-, admin: false, domain: "" -} }
+                 , matching_users: []
+                 , page: Home
+                 , wsUp: true
+                 }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { addUserForm, searchUserForm, matching_users, page, wsUp }
+    = HH.div_ 
+        [ Bulma.box [routing_search_button, routing_add_button]
+        , case page of
+            Home -> Bulma.section_small [Bulma.h3 "Select an action"]
+            Search -> Bulma.columns_
+              [ Bulma.column (C.is 3) [Bulma.article (Bulma.p "Search users") render_searchuser_form]
+              , Bulma.column_ [ Bulma.h3 "Result", show_found_users ]
+              ]
+            Add -> Bulma.columns_
+              [ Bulma.column (C.is 5) [Bulma.article (Bulma.p "Add a new user") render_adduser_form] ]
+        ]
+    where
+      show_found_users = Bulma.box [ HH.ul_ $ map user_card matching_users ]
+      user_card user = HH.li_ [ Bulma.btn user.login (ShowUser user.uid)
+                              , Bulma.alert_btn "remove" (RemoveUser user.uid)
+                              ]
+      up x = HandleAddUserInput <<< x
+      active = (if wsUp then (HP.enabled true) else (HP.disabled true))
+
+      render_adduser_form =
+        HH.form
+          [ HE.onSubmit PreventSubmit ]
+          [ Bulma.box_input "login" "User login" "login" (up ADDUSER_INP_login) addUserForm.login active
+          , Bulma.btn_labeled "adminbtn" "Admin" (show addUserForm.admin) (HandleAddUserInput ADDUSER_toggle_admin)
+          , Bulma.box_input "email" "User email" "email" (up ADDUSER_INP_email) addUserForm.email active
+          , Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass active
+          , Bulma.btn "Send" AddUserAttempt
+          ]
+
+      render_searchuser_form =
+        HH.form
+          [ HE.onSubmit PreventSubmit ]
+          [ Bulma.p """
+                    Following input accepts any regex.
+                    This will be used to search an user based on his login, full name or email address.
+                    """
+          , Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex active
+          --, Bulma.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin)
+          --    (HandleAddUserInput SEARCHUSER_toggle_admin)
+          --, Bulma.box_input "domain" "Domain owned" "blah.netlib.re."
+          --    (up SEARCHUSER_INP_domain) searchUserForm.domain active
+          , Bulma.btn "Send" SearchUserAttempt
+          ]
+
+      routing_search_button = Bulma.btn "Search" $ Routing Search
+      routing_add_button = Bulma.btn "Add" $ Routing Add
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  Initialize -> do
+    H.raise $ AskState
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    old_page <- H.liftEffect $ Storage.getItem "current-ada-page" sessionstorage
+    case old_page of
+      Nothing -> H.raise $ Log $ ErrorLog "We hadn't changed page before reload apparently."
+      Just page -> case page of
+        "Home"    -> handleAction $ Routing Home
+        "Search"  -> handleAction $ Routing Search
+        "Add"     -> handleAction $ Routing Add
+        _         -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old page: " <> page
+
+  Finalize -> do
+    state <- H.get
+    H.raise $ StoreState state
+
+  HandleAddUserInput adduserinp -> do
+    { addUserForm } <- H.get
+    case adduserinp of
+      ADDUSER_INP_login  v -> H.modify_ _ { addUserForm { login     = v } }
+      ADDUSER_INP_email  v -> H.modify_ _ { addUserForm { email     = v } }
+      ADDUSER_toggle_admin -> H.modify_ _ { addUserForm { admin = not addUserForm.admin } }
+      ADDUSER_INP_pass   v -> H.modify_ _ { addUserForm { pass      = v } }
+      SEARCHUSER_INP_regex  v -> H.modify_ _ { searchUserForm { regex = v } }
+
+  PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
+
+  ShowUser uid -> do
+    H.raise $ Log $ SystemLog $ "Show a user details (uid: " <> show uid <> ")"
+
+  RemoveUser uid -> do
+    H.raise $ Log $ SystemLog $ "Remove user " <> show uid
+    ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid }
+    H.raise $ MessageToSend ab
+
+  AddUserAttempt -> do
+    { addUserForm } <- H.get
+    let login  = addUserForm.login
+        email  = addUserForm.email
+        pass   = addUserForm.pass
+
+    case login, email, pass of
+      "", _, _ -> H.raise $ Log $ UnableToSend "Write the user's login!"
+      _, "", _ -> H.raise $ Log $ UnableToSend "Write the user's email!"
+      _, _, "" -> H.raise $ Log $ UnableToSend "Write the user's password!"
+
+      _, _, _ -> do
+        ab <- H.liftEffect $ AuthD.serialize $
+          AuthD.MkAddUser { login: login
+                          , admin: addUserForm.admin
+                          , email: Just (Email.Email email)
+                          , password: pass }
+        H.raise $ MessageToSend ab
+        H.raise $ Log $ SystemLog "Add a user"
+
+  Routing page -> do
+    -- Store the current page we are on and restore it when we reload.
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    _ <- case page of
+      Home           -> H.liftEffect $ Storage.setItem "current-ada-page" "Home"   sessionstorage
+      Search         -> H.liftEffect $ Storage.setItem "current-ada-page" "Search" sessionstorage
+      Add            -> H.liftEffect $ Storage.setItem "current-ada-page" "Add"    sessionstorage
+    H.modify_ _ { page = page }
+
+  SearchUserAttempt -> do
+    { searchUserForm } <- H.get
+    let regex  = searchUserForm.regex
+        -- domain = searchUserForm.domain
+        -- admin  = searchUserForm.admin
+    ab <- H.liftEffect $ AuthD.serialize $
+      AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 }
+    H.raise $ MessageToSend ab
+    H.modify_ _ { matching_users = [] }
+
+not_empty_string :: String -> Maybe String
+not_empty_string "" = Nothing
+not_empty_string v = Just v
+
+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
+      (AuthD.GotUserAdded msg) -> do
+        H.raise $ Log $ SuccessLog $ "Added user: " <> show msg.user
+
+      (AuthD.GotMatchingUsers msg) -> do
+        H.raise $ Log $ SuccessLog "Got list of matched users."
+        H.modify_ _ { matching_users = msg.users }
+
+      (AuthD.GotUserDeleted msg) -> do
+        H.raise $ Log $ SuccessLog $ "User (uid: " <> show msg.uid <> ") got removed."
+        { matching_users } <- H.get
+        H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
+
+      -- Unexpected message.
+      _ -> do
+        H.raise $ Log $ ErrorLog $ "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)

src/App/AuthenticationDaemonAdminInterface.purs

@@ -1,474 +0,0 @@
-module App.AuthenticationDaemonAdminInterface where
-
-{- Administration interface for the authentication daemon.
-   This interface should allow to:
-     - TODO: add, remove, search, validate users
-     - TODO: raise a user to admin
--}
-
-import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=), not)
-
-import Bulma as Bulma
-
-import Control.Monad.Except (runExcept)
-import Control.Monad.State (class MonadState)
-import Data.Array as A
-import Data.Tuple (Tuple(..))
-import Data.Bifunctor (lmap)
-import Data.Const (Const)
-import Data.Either (Either(..))
-import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
-import Data.String as String
-import Effect (Effect)
-import Effect.Aff.Class (class MonadAff)
-import Foreign (Foreign)
-import Foreign as F
-import Halogen as H
-import Halogen.HTML as HH
-import Halogen.HTML.Events as HE
-import Halogen.HTML.Properties as HP
-import Halogen.Query.Event as HQE
-import Halogen.Subscription as HS
-import Web.Event.Event (Event)
-import Web.Event.Event as Event
-import Web.Socket.Event.CloseEvent as WSCE
-import Web.Socket.Event.EventTypes as WSET
-import Web.Socket.Event.MessageEvent as WSME
-import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
-import Web.Socket.WebSocket as WS
-
-import Effect.Class (class MonadEffect)
-
-import App.IPC as IPC
-import App.Email as Email
-
-import App.Messages.AuthenticationDaemon as AuthD
-
-import Data.ArrayBuffer.Types (ArrayBuffer)
-import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
-
---------------------------------------------------------------------------------
--- WebSocketEvent type
---------------------------------------------------------------------------------
-
-data WebSocketEvent :: Type -> Type
-data WebSocketEvent msg
-  = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
-  | WebSocketOpen
-  | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
-  | WebSocketError ErrorType
-
-webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
-webSocketEmitter socket = do
-
-  HS.makeEmitter \push -> do
-
-    openId <- HS.subscribe openEmitter push
-    errorId <- HS.subscribe errorEmitter push
-    closeId <- HS.subscribe closeEmitter push
-    messageId <- HS.subscribe messageEmitter push
-
-    pure do
-      HS.unsubscribe openId
-      HS.unsubscribe errorId
-      HS.unsubscribe closeId
-      HS.unsubscribe messageId
-
-  where
-  target = WS.toEventTarget socket
-
-  openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  openEmitter =
-    HQE.eventListener WSET.onOpen target \_ ->
-      Just WebSocketOpen
-
-  errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  errorEmitter =
-    HQE.eventListener WSET.onError target \_ ->
-      Just (WebSocketError UnknownWebSocketError)
-
-  closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  closeEmitter =
-    HQE.eventListener WSET.onClose target \event ->
-      WSCE.fromEvent event >>= \closeEvent ->
-        Just $ WebSocketClose  { code: WSCE.code closeEvent
-                               , reason: WSCE.reason closeEvent
-                               , wasClean: WSCE.wasClean closeEvent
-                               }
-
-  messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
-
-decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
-decodeMessageEvent = \msgEvent -> do
-  let
-    foreign' :: Foreign
-    foreign' = WSME.data_ msgEvent
-  case foreignToArrayBuffer foreign' of
-    Left errs -> pure $ WebSocketError $ UnknownError errs
-    Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
-
----------------------------
--- Errors
----------------------------
-
-data ErrorType
-  = UnknownError String
-  | UnknownWebSocketError
-
-renderError :: ErrorType -> String
-renderError = case _ of
-  UnknownError str ->
-    "Unknown error: " <> str
-  UnknownWebSocketError ->
-    "Unknown 'error' event has been fired by WebSocket event listener"
-
---------------------------------------------------------------------------------
--- WebSocket message type
---------------------------------------------------------------------------------
-
-type WebSocketMessageType = ArrayBuffer
-
---------------------------------------------------------------------------------
--- Root component module
---------------------------------------------------------------------------------
-
-data Output = Void
-type Slot = H.Slot Query Output
-
-type Query :: forall k. k -> Type
-type Query = Const Void
-type Input = String
-
-data AddUserInput
-  = ADDUSER_INP_login String
-  | ADDUSER_INP_email String
-  | ADDUSER_toggle_admin
-  | ADDUSER_INP_pass String
-
-data Action
-  = Initialize
-  | WebSocketParseError String
-  | ConnectWebSocket
-
-  | HandleAddUserInput AddUserInput
-
-  | AddUserAttempt Event
-  -- | Finalize
-  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
-
-type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
-
-type State =
-  { messages               :: Array String
-  , messageHistoryLength   :: Int
-
-  , addUserForm               :: StateAddUserForm
-
-  -- TODO: put network stuff in a record.
-  , wsUrl                  :: String
-  , wsConnection           :: Maybe WS.WebSocket
-  , canReconnect           :: Boolean
-  }
-
-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
-        -- , finalize = Just Finalize
-        }
-    }
-
-initialState :: Input -> State
-initialState input =
-  { messages: []
-  , messageHistoryLength: 10
-
-  , addUserForm: { login: "", admin: false, email: "", pass: "" }
-
-  -- TODO: put network stuff in a record.
-  , wsUrl: input
-  , wsConnection: Nothing
-  , canReconnect: false
-  }
-
-render :: forall m. State -> H.ComponentHTML Action () m
-render {
-  messages,
-  wsConnection,
-  canReconnect,
-  addUserForm }
-    = HH.div_
-       [ Bulma.columns_ [ Bulma.column_ adduser_form ]
-       , render_messages
-       --, renderMaxHistoryLength messageHistoryLength
-       , renderReconnectButton (isNothing wsConnection && canReconnect)
-       ]
-    where
-
-      adduser_form
-        = [ Bulma.h3 "Add a new user"
-          , render_adduser_form
-          ]
-
-      should_be_disabled = (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection)
-
-      render_adduser_form = HH.form
-        [ HE.onSubmit AddUserAttempt ]
-        [ Bulma.box_input "User login" "login"                 -- title, placeholder
-            (HandleAddUserInput <<< ADDUSER_INP_login)         -- action
-            addUserForm.login                                  -- value
-            true                                               -- validity (TODO)
-            should_be_disabled                                 -- condition
-        , Bulma.btn
-            (show addUserForm.admin)                           -- value
-            (HandleAddUserInput ADDUSER_toggle_admin)          -- action1
-            (HandleAddUserInput ADDUSER_toggle_admin)          -- action2
-            true                                               -- validity (TODO)
-            -- should_be_disabled                                 -- condition
-        , Bulma.box_input "User email" "email"                 -- title, placeholder
-            (HandleAddUserInput <<< ADDUSER_INP_email)         -- action
-            addUserForm.email                                  -- value
-            true                                               -- validity (TODO)
-            should_be_disabled                                 -- condition
-        , Bulma.box_password "User password" "password"        -- title, placeholder
-            (HandleAddUserInput <<< ADDUSER_INP_pass)          -- action
-            addUserForm.pass                                   -- value
-            true                                               -- validity (TODO)
-            should_be_disabled                                 -- condition
-        , HH.div_
-            [ HH.button
-                [ HP.style "padding: 0.5rem 1.25rem;"
-                , HP.type_ HP.ButtonSubmit
-                , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
-                ]
-                [ HH.text "Send Message to Server" ]
-            ]
-        ]
-
-      render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
-
-      renderFootnote :: String -> H.ComponentHTML Action () m
-      renderFootnote txt =
-        HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
-
-      renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
-      renderReconnectButton cond =
-        if cond
-        then
-          HH.p_
-            [ HH.button
-              [ HP.type_ HP.ButtonButton
-              , HE.onClick \_ -> ConnectWebSocket
-              ]
-              [ HH.text "Reconnect?" ]
-            ]
-        else
-          HH.p_
-            [ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops"
-            ]
-
-handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
-handleAction = case _ of
-  Initialize ->
-    handleAction ConnectWebSocket
-
-  -- Finalize -> do
-  --   { wsConnection } <- H.get
-  --   systemMessage "Finalize"
-  --   case wsConnection of
-  --     Nothing -> systemMessage "No socket? How is that even possible?"
-  --     Just socket -> H.liftEffect $ WS.close socket
-
-  WebSocketParseError error ->
-    systemMessage $ renderError (UnknownError error)
-
-  ConnectWebSocket -> do
-    { wsUrl } <- H.get
-    systemMessage ("Connecting to \"" <> wsUrl <>  "\"...")
-    webSocket <- H.liftEffect $ WS.create wsUrl []
-    H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
-    H.modify_ _ { wsConnection = Just webSocket }
-    void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
-
-  HandleAddUserInput adduserinp -> do
-    { addUserForm } <- H.get
-    case adduserinp of
-      ADDUSER_INP_login  v -> H.modify_ _ { addUserForm { login     = v } }
-      ADDUSER_INP_email  v -> H.modify_ _ { addUserForm { email     = v } }
-      ADDUSER_toggle_admin -> H.modify_ _ { addUserForm { admin = not addUserForm.admin } }
-      ADDUSER_INP_pass   v -> H.modify_ _ { addUserForm { pass      = v } }
-
-  AddUserAttempt ev -> do
-    H.liftEffect $ Event.preventDefault ev
-
-    { wsConnection, addUserForm } <- H.get
-    let login  = addUserForm.login
-        email  = addUserForm.email
-        pass   = addUserForm.pass
-
-    case wsConnection, login, email, pass of
-      Nothing, _, _,  _ ->
-        unableToSend "Not connected to server."
-
-      Just _, "", _, _ ->
-        unableToSend "Write the user's login!"
-
-      Just _, _, "", _ ->
-        unableToSend "Write the user's email!"
-
-      Just _, _, _, "" ->
-        unableToSend "Write the user's password!"
-
-      Just webSocket, _, _, _ -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
-
-          Closing ->
-            unableToSend "Connection to server is closing."
-
-          Closed -> do
-            unableToSend "Connection to server has been closed."
-            maybeCurrentConnection <- H.gets _.wsConnection
-            when (isJust maybeCurrentConnection) do
-              H.modify_ _ { wsConnection = Nothing, canReconnect = true }
-
-          Open -> do
-            H.liftEffect $ do
-              ab <- AuthD.serialize $ AuthD.MkAddUser { login: login
-                                                      , admin: addUserForm.admin
-                                                      , email: Just (Email.Email email)
-                                                      , password: pass }
-              sendArrayBuffer webSocket ab
-            appendMessageReset "[😇] Trying to add a user"
-
-  HandleWebSocket wsEvent ->
-    case wsEvent of
-      WebSocketMessage messageEvent -> do
-        receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
-        case receivedMessage of
-            -- Cases where we didn't understand the message.
-            Left err -> do
-              case err of
-                (AuthD.JSONERROR jerr) -> do
-                  print_json_string messageEvent.message
-                  handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
-                (AuthD.UnknownError   unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
-                (AuthD.UnknownNumber       ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
-
-            -- Cases where we understood the message.
-            Right response -> do
-              case response of
-                -- The authentication failed.
-                (AuthD.GotError errmsg) -> do
-                  appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
-                (AuthD.GotUserAdded msg) -> do
-                  appendMessage $ "[😈] Success! Server added user: " <> show msg.user
-                -- WTH?!
-                _ -> do
-                  appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
-
-      WebSocketOpen -> do
-        { wsUrl } <- H.get
-        systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <>  "\"!🎉")
-
-      WebSocketClose { code, reason, wasClean } -> do
-        systemMessage $ renderCloseMessage code wasClean reason
-        maybeCurrentConnection <- H.gets _.wsConnection
-        when (isJust maybeCurrentConnection) do
-          H.modify_ _ { wsConnection = Nothing, canReconnect = true }
-
-      WebSocketError errorType ->
-        systemMessage $ renderError errorType
-
-  where
-  renderCloseMessage
-    :: Int
-    -> Boolean
-    -> String
-    -> String
-  renderCloseMessage code wasClean = case _ of
-      ""     -> baseCloseMessage
-      reason -> baseCloseMessage <> "Reason: " <> reason
-    where
-    baseCloseMessage :: String
-    baseCloseMessage =
-      String.joinWith " "
-        [ "Connection to WebSocket closed"
-        , "[ CODE:"
-        , show code
-        , "|"
-        , if wasClean then "CLEAN" else "DIRTY"
-        , "]"
-        ]
-
-sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
-sendArrayBuffer = WS.sendArrayBuffer
-
---------------------------------------------------------------------------------
--- Helpers for updating the array of messages sent/received
---------------------------------------------------------------------------------
--- Append a new message to the chat history, with a boolean that allows you to
--- clear the text input field or not. The number of displayed `messages` in the
--- chat history (including system) is controlled by the `messageHistoryLength`
--- field in the component `State`.
-appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit
-appendMessageGeneric clearField msg = do
-  histSize <- H.gets _.messageHistoryLength
-  if clearField
-    then H.modify_ \st ->
-           st { messages = appendSingle histSize msg st.messages, addUserForm { login = "" }}
-    else H.modify_ \st ->
-           st { messages = appendSingle histSize msg st.messages }
-  where
-  -- Limits the nnumber of recent messages to `maxHist`
-  appendSingle :: Int -> String -> Array String -> Array String
-  appendSingle maxHist x xs
-    | A.length xs < maxHist = xs `A.snoc` x
-    | otherwise             = (A.takeEnd (maxHist-1) xs) `A.snoc` x
-
--- Append a new message to the chat history, while not clearing
--- the user input field
-appendMessage :: forall m. MonadState State m => String -> m Unit
-appendMessage = appendMessageGeneric false
-
--- Append a new message to the chat history and also clear
--- the user input field
-appendMessageReset :: forall m. MonadState State m => String -> m Unit
-appendMessageReset = appendMessageGeneric true
-
--- Append a system message to the chat log.
-systemMessage :: forall m. MonadState State m => String -> m Unit
-systemMessage msg = appendMessage ("[🤖] System: " <> msg)
-
--- As above, but also clears the user input field. e.g. in
--- the case of a "/disconnect" command
-systemMessageReset :: forall m. MonadState State m => String -> m Unit
-systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
-
--- A system message to use when a message cannot be sent.
-unableToSend :: forall m. MonadState State m => String -> m Unit
-unableToSend reason = systemMessage ("Unable to send. " <> reason)
-
-foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer
-foreignToArrayBuffer
-  = lmap renderForeignErrors
-  <<< runExcept
-  <<< F.unsafeReadTagged "ArrayBuffer"
-  where
-  renderForeignErrors :: F.MultipleErrors -> String
-  renderForeignErrors =
-    String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
-
-print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
-print_json_string arraybuffer = do
-  -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-  value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-  appendMessage $ case (value) of
-    Left _ -> "Cannot even fromTypedIPC the message."
-    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

src/App/AuthenticationForm.purs

@@ -1,533 +0,0 @@
-module App.AuthenticationForm where
-
-import Prelude (Unit, Void, bind, discard, map, otherwise, pure, show, void, when, ($), (&&), (-), (<), (<$>), (<<<), (<>), (>=>), (>>=))
-
-import Bulma as Bulma
-
-import Control.Monad.Except (runExcept)
-import Control.Monad.State (class MonadState)
-import Data.Array as A
-import Data.Tuple (Tuple(..))
-import Data.Bifunctor (lmap)
-import Data.Const (Const)
-import Data.Either (Either(..))
-import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
-import Data.String as String
-import Effect (Effect)
-import Effect.Aff.Class (class MonadAff)
-import Foreign (Foreign)
-import Foreign as F
-import Halogen as H
-import Halogen.HTML as HH
-import Halogen.HTML.Events as HE
-import Halogen.HTML.Properties as HP
-import Halogen.Query.Event as HQE
-import Halogen.Subscription as HS
-import Web.Event.Event (Event)
-import Web.Event.Event as Event
-import Web.Socket.Event.CloseEvent as WSCE
-import Web.Socket.Event.EventTypes as WSET
-import Web.Socket.Event.MessageEvent as WSME
-import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
-import Web.Socket.WebSocket as WS
-
-import Effect.Class (class MonadEffect)
-
-import App.IPC as IPC
-import App.Email as Email
-
-import App.Messages.AuthenticationDaemon as AuthD
-
-import Data.ArrayBuffer.Types (ArrayBuffer)
-import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
-
---------------------------------------------------------------------------------
--- WebSocketEvent type
---------------------------------------------------------------------------------
-
-data WebSocketEvent :: Type -> Type
-data WebSocketEvent msg
-  = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
-  | WebSocketOpen
-  | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
-  | WebSocketError ErrorType
-
-webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
-webSocketEmitter socket = do
-
-  HS.makeEmitter \push -> do
-
-    openId <- HS.subscribe openEmitter push
-    errorId <- HS.subscribe errorEmitter push
-    closeId <- HS.subscribe closeEmitter push
-    messageId <- HS.subscribe messageEmitter push
-
-    pure do
-      HS.unsubscribe openId
-      HS.unsubscribe errorId
-      HS.unsubscribe closeId
-      HS.unsubscribe messageId
-
-  where
-  target = WS.toEventTarget socket
-
-  openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  openEmitter =
-    HQE.eventListener WSET.onOpen target \_ ->
-      Just WebSocketOpen
-
-  errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  errorEmitter =
-    HQE.eventListener WSET.onError target \_ ->
-      Just (WebSocketError UnknownWebSocketError)
-
-  closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  closeEmitter =
-    HQE.eventListener WSET.onClose target \event ->
-      WSCE.fromEvent event >>= \closeEvent ->
-        Just $ WebSocketClose  { code: WSCE.code closeEvent
-                               , reason: WSCE.reason closeEvent
-                               , wasClean: WSCE.wasClean closeEvent
-                               }
-
-  messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
-  messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
-
-decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
-decodeMessageEvent = \msgEvent -> do
-  let
-    foreign' :: Foreign
-    foreign' = WSME.data_ msgEvent
-  case foreignToArrayBuffer foreign' of
-    Left errs -> pure $ WebSocketError $ UnknownError errs
-    Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer, origin: WSME.origin msgEvent, lastEventId: WSME.lastEventId msgEvent }
-
----------------------------
--- Errors
----------------------------
-
-data ErrorType
-  = UnknownError String
-  | UnknownWebSocketError
-
-renderError :: ErrorType -> String
-renderError = case _ of
-  UnknownError str ->
-    "Unknown error: " <> str
-  UnknownWebSocketError ->
-    "Unknown 'error' event has been fired by WebSocket event listener"
-
---------------------------------------------------------------------------------
--- WebSocket message type
---------------------------------------------------------------------------------
-
-type WebSocketMessageType = ArrayBuffer
-
---------------------------------------------------------------------------------
--- Root component module
---------------------------------------------------------------------------------
-
-data Output = AuthToken (Tuple Int String)
-type Slot = H.Slot Query Output
-
-type Query :: forall k. k -> Type
-type Query = Const Void
-type Input = String
-
-data AuthenticationInput
-  = AUTH_INP_login String
-  | AUTH_INP_pass String
-
-data RegisterInput
-  = REG_INP_login String
-  | REG_INP_email String
-  | REG_INP_pass String
-
-data Action
-  = Initialize
-  | WebSocketParseError String
-  | ConnectWebSocket
-
-  | HandleAuthenticationInput AuthenticationInput
-  | HandleRegisterInput       RegisterInput
-
-  | AuthenticationAttempt Event
-  | RegisterAttempt Event
-  | Finalize
-  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
-
-type StateAuthenticationForm = { login :: String, pass :: String }
-type StateRegistrationForm = { login :: String, email :: String, pass :: String }
-
-type State =
-  { messages               :: Array String
-  , messageHistoryLength   :: Int
-
-  , authenticationForm        :: StateAuthenticationForm
-  , registrationForm          :: StateRegistrationForm
-
-  -- TODO: put network stuff in a record.
-  , wsUrl                  :: String
-  , wsConnection           :: Maybe WS.WebSocket
-  , canReconnect           :: Boolean
-  }
-
-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
-        , finalize = Just Finalize
-        }
-    }
-
-initialState :: Input -> State
-initialState input =
-  { messages: []
-  , messageHistoryLength: 10
-
-  , authenticationForm: { login:     "", pass:  "" }
-  , registrationForm:   { login:     "", email: "", pass: "" }
-
-  -- TODO: put network stuff in a record.
-  , wsUrl: input
-  , wsConnection: Nothing
-  , canReconnect: false
-  }
-
-render :: forall m. State -> H.ComponentHTML Action () m
-render {
-  messages,
-  wsConnection,
-  canReconnect,
-
-  authenticationForm,
-  registrationForm }
-    = HH.div_
-       [ Bulma.columns_ [ Bulma.column_ auth_form, Bulma.column_ register_form ]
-       , render_messages
-       , renderReconnectButton (isNothing wsConnection && canReconnect)
-       ]
-    where
-
-      auth_form
-        = [ Bulma.h3 "Authentication"
-          , render_auth_form
-          ]
-
-      register_form
-        = [ Bulma.h3 "Register!"
-          , render_register_form
-          ]
-
-      render_auth_form = HH.form
-        [ HE.onSubmit AuthenticationAttempt ]
-        [ Bulma.box_input "Login" "login"                                   -- title, placeholder
-            (HandleAuthenticationInput <<< AUTH_INP_login)                  -- action
-            authenticationForm.login                                        -- value
-            true                                                            -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition
-        , Bulma.box_password "Password" "password"                          -- title, placeholder
-            (HandleAuthenticationInput <<< AUTH_INP_pass)                   -- action
-            authenticationForm.pass                                         -- value
-            true                                                            -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition
-        , HH.button
-           [ HP.style "padding: 0.5rem 1.25rem;"
-           , HP.type_ HP.ButtonSubmit
-           , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
-           ]
-           [ HH.text "Send Message to Server" ]
-        ]
-
-      render_register_form = HH.form
-        [ HE.onSubmit RegisterAttempt ]
-        [ Bulma.box_input "Login" "login"                                   -- title, placeholder
-            (HandleRegisterInput <<< REG_INP_login)                         -- action
-            registrationForm.login                                          -- value
-            true                                                            -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition
-        , Bulma.box_input "Email" "email@example.com"                       -- title, placeholder
-            (HandleRegisterInput <<< REG_INP_email)                         -- action
-            registrationForm.email                                          -- value
-            true                                                            -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition
-        , Bulma.box_password "Password" "password"                          -- title, placeholder
-            (HandleRegisterInput <<< REG_INP_pass)                          -- action
-            registrationForm.pass                                           -- value
-            true                                                            -- validity (TODO)
-            (maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection) -- condition
-        , HH.div_
-            [ HH.button
-                [ HP.style "padding: 0.5rem 1.25rem;"
-                , HP.type_ HP.ButtonSubmit
-                , maybe (HP.disabled true) (\_ -> HP.enabled true) wsConnection
-                ]
-                [ HH.text "Send Message to Server" ]
-            ]
-        ]
-
-      render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
-
-      renderFootnote :: String -> H.ComponentHTML Action () m
-      renderFootnote txt =
-        HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
-
-      renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
-      renderReconnectButton cond =
-        if cond
-        then
-          HH.p_
-            [ HH.button
-              [ HP.type_ HP.ButtonButton
-              , HE.onClick \_ -> ConnectWebSocket
-              ]
-              [ HH.text "Reconnect?" ]
-            ]
-        else
-          HH.p_
-            [ renderFootnote "NOTE: A 'Reconnect?' button will appear if the connection drops"
-            ]
-
-handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
-handleAction = case _ of
-  Initialize ->
-    handleAction ConnectWebSocket
-
-  Finalize -> do
-    { wsConnection } <- H.get
-    systemMessage "Finalize"
-    case wsConnection of
-      Nothing -> systemMessage "No socket? How is that even possible?"
-      Just socket -> H.liftEffect $ WS.close socket
-
-  WebSocketParseError error ->
-    systemMessage $ renderError (UnknownError error)
-
-  ConnectWebSocket -> do
-    { wsUrl } <- H.get
-    systemMessage ("Connecting to \"" <> wsUrl <>  "\"...")
-    webSocket <- H.liftEffect $ WS.create wsUrl []
-    H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
-    H.modify_ _ { wsConnection = Just webSocket }
-    void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
-
-  HandleAuthenticationInput authinp -> do
-    case authinp of
-      AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
-      AUTH_INP_pass  v -> H.modify_ _ { authenticationForm { pass  = v } }
-
-  HandleRegisterInput reginp -> do
-    case reginp of
-      REG_INP_login v -> H.modify_ _ { registrationForm { login = v } }
-      REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
-      REG_INP_pass  v -> H.modify_ _ { registrationForm { pass  = v } }
-
-  RegisterAttempt ev -> do
-    H.liftEffect $ Event.preventDefault ev
-
-    { wsConnection, registrationForm } <- H.get
-    let login = registrationForm.login
-        email = registrationForm.email
-        pass  = registrationForm.pass
-
-    case wsConnection, login, email, pass of
-      Nothing, _, _, _ ->
-        unableToSend "Not connected to server."
-
-      Just _, "", _, _ ->
-        unableToSend "Write your login!"
-
-      Just _, _, "", _ ->
-        unableToSend "Write your email!"
-
-      Just _, _, _, "" ->
-        unableToSend "Write your password!"
-
-      Just webSocket, _, _, _ -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
-
-          Closing ->
-            unableToSend "Connection to server is closing."
-
-          Closed -> do
-            unableToSend "Connection to server has been closed."
-            maybeCurrentConnection <- H.gets _.wsConnection
-            when (isJust maybeCurrentConnection) do
-              H.modify_ _ { wsConnection = Nothing, canReconnect = true }
-
-          Open -> do
-            H.liftEffect $ do
-              ab <- AuthD.serialize $ AuthD.MkRegister { login: login
-                                                       , email: Just (Email.Email email)
-                                                       , password: pass }
-              sendArrayBuffer webSocket ab
-            appendMessageReset "[😇] Trying to register"
-
-  AuthenticationAttempt ev -> do
-    H.liftEffect $ Event.preventDefault ev
-
-    { wsConnection, authenticationForm } <- H.get
-
-    case wsConnection, authenticationForm.login, authenticationForm.pass of
-      Nothing, _, _ ->
-        unableToSend "Not connected to server."
-
-      Just _ , "" , _ ->
-        unableToSend "Write your login!"
-
-      Just _ , _ , "" ->
-        unableToSend "Write your password!"
-
-      Just webSocket, login, pass -> do
-        H.liftEffect (WS.readyState webSocket) >>= case _ of
-          Connecting ->
-            unableToSend "Still connecting to server."
-
-          Closing ->
-            unableToSend "Connection to server is closing."
-
-          Closed -> do
-            unableToSend "Connection to server has been closed."
-            maybeCurrentConnection <- H.gets _.wsConnection
-            when (isJust maybeCurrentConnection) do
-              H.modify_ _ { wsConnection = Nothing, canReconnect = true }
-
-          Open -> do
-            H.liftEffect $ do
-              ab <- AuthD.serialize (AuthD.MkLogin { login: login, password: pass })
-              sendArrayBuffer webSocket ab
-            appendMessageReset $ "[😇] Trying to connect with login: " <> login
-
-  HandleWebSocket wsEvent ->
-    case wsEvent of
-      WebSocketMessage messageEvent -> do
-        receivedMessage <- H.liftEffect $ AuthD.deserialize messageEvent.message
-        case receivedMessage of
-            -- Cases where we didn't understand the message.
-            Left err -> do
-              case err of
-                (AuthD.JSONERROR jerr) -> do
-                  print_json_string messageEvent.message
-                  handleAction $ WebSocketParseError ("JSON parsing error: " <> jerr <> " JSON is: " <> jerr)
-                (AuthD.UnknownError   unerr) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownError" <> (show unerr))
-                (AuthD.UnknownNumber       ) -> handleAction $ WebSocketParseError ("Parsing error: AuthD.UnknownNumber")
-
-            -- Cases where we understood the message.
-            Right response -> do
-              case response of
-                -- The authentication failed.
-                (AuthD.GotError errmsg) -> do
-                  appendMessage $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
-                -- The authentication was a success!
-                (AuthD.GotToken msg) -> do
-                  appendMessage $ "[😈] Success! user " <> (show msg.uid) <> " has token: " <> msg.token
-                  H.raise $ AuthToken (Tuple msg.uid msg.token)
-                -- WTH?!
-                _ -> do
-                  appendMessage $ "[😈] Failed! Authentication server didn't send a valid message."
-
-      WebSocketOpen -> do
-        { wsUrl } <- H.get
-        systemMessage ("Successfully connected to WebSocket at \"" <> wsUrl <>  "\"!🎉")
-
-      WebSocketClose { code, reason, wasClean } -> do
-        systemMessage $ renderCloseMessage code wasClean reason
-        maybeCurrentConnection <- H.gets _.wsConnection
-        when (isJust maybeCurrentConnection) do
-          H.modify_ _ { wsConnection = Nothing, canReconnect = true }
-
-      WebSocketError errorType ->
-        systemMessage $ renderError errorType
-
-  where
-  renderCloseMessage
-    :: Int
-    -> Boolean
-    -> String
-    -> String
-  renderCloseMessage code wasClean = case _ of
-      ""     -> baseCloseMessage
-      reason -> baseCloseMessage <> "Reason: " <> reason
-    where
-    baseCloseMessage :: String
-    baseCloseMessage =
-      String.joinWith " "
-        [ "Connection to WebSocket closed"
-        , "[ CODE:"
-        , show code
-        , "|"
-        , if wasClean then "CLEAN" else "DIRTY"
-        , "]"
-        ]
-
-  sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
-  sendArrayBuffer = WS.sendArrayBuffer
-
---------------------------------------------------------------------------------
--- Helpers for updating the array of messages sent/received
---------------------------------------------------------------------------------
--- Append a new message to the chat history, with a boolean that allows you to
--- clear the text input field or not. The number of displayed `messages` in the
--- chat history (including system) is controlled by the `messageHistoryLength`
--- field in the component `State`.
-appendMessageGeneric :: forall m. MonadState State m => Boolean -> String -> m Unit
-appendMessageGeneric clearField msg = do
-  histSize <- H.gets _.messageHistoryLength
-  if clearField
-    then H.modify_ \st ->
-           st { messages = appendSingle histSize msg st.messages, authenticationForm { login = "" }}
-    else H.modify_ \st ->
-           st { messages = appendSingle histSize msg st.messages }
-  where
-  -- Limits the nnumber of recent messages to `maxHist`
-  appendSingle :: Int -> String -> Array String -> Array String
-  appendSingle maxHist x xs
-    | A.length xs < maxHist = xs `A.snoc` x
-    | otherwise             = (A.takeEnd (maxHist-1) xs) `A.snoc` x
-
--- Append a new message to the chat history, while not clearing
--- the user input field
-appendMessage :: forall m. MonadState State m => String -> m Unit
-appendMessage = appendMessageGeneric false
-
--- Append a new message to the chat history and also clear
--- the user input field
-appendMessageReset :: forall m. MonadState State m => String -> m Unit
-appendMessageReset = appendMessageGeneric true
-
--- Append a system message to the chat log.
-systemMessage :: forall m. MonadState State m => String -> m Unit
-systemMessage msg = appendMessage ("[🤖] System: " <> msg)
-
--- As above, but also clears the user input field. e.g. in
--- the case of a "/disconnect" command
-systemMessageReset :: forall m. MonadState State m => String -> m Unit
-systemMessageReset msg = appendMessageReset ("[🤖] System: " <> msg)
-
--- A system message to use when a message cannot be sent.
-unableToSend :: forall m. MonadState State m => String -> m Unit
-unableToSend reason = systemMessage ("Unable to send. " <> reason)
-
-foreignToArrayBuffer :: Foreign -> Either String ArrayBuffer
-foreignToArrayBuffer
-  = lmap renderForeignErrors
-  <<< runExcept
-  <<< F.unsafeReadTagged "ArrayBuffer"
-  where
-  renderForeignErrors :: F.MultipleErrors -> String
-  renderForeignErrors =
-    String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
-
-print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
-print_json_string arraybuffer = do
-  -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-  value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-  appendMessage $ case (value) of
-    Left _ -> "Cannot even fromTypedIPC the message."
-    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

src/App/AuthenticationInterface.purs

@@ -0,0 +1,342 @@
+-- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
+-- | TODO: token validation.
+module App.AuthenticationInterface where
+
+import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (>), (==), map, show)
+
+import Data.Array as A
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Either (Either(..))
+import Data.Tuple (Tuple(..))
+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 App.LogMessage
+import App.Messages.AuthenticationDaemon as AuthD
+
+import App.Validation.Login as L
+import App.Validation.Email as E
+import App.Validation.Password as P
+
+type Login = String
+type Email = String
+type Password = String
+type PasswordRecoveryToken = String
+
+data Error
+  = Login (Array L.Error)
+  | Email    (Array E.Error)
+  | Password (Array P.Error)
+
+-- | The component can inform the parent (`App.Container`) that the authentication is complete,
+-- | and share both the uid and token. The token is useful to authenticate the user to the
+-- | dnsmanager daemon.
+-- |
+-- | Also, the component can send a message to a websocket and log messages.
+-- |
+-- | TODO: authentication is performed in `App.Container`.
+data Output
+  = MessageToSend ArrayBuffer
+  | AuthenticateToAuthd (Tuple Login Password)
+  | Log LogMessage
+  | PasswordRecovery Login PasswordRecoveryToken Password
+  | AskPasswordRecovery (Either Email Login)
+
+-- | The component's parent provides received messages.
+-- |
+-- | Also, the component is informed when the connection went up or down.
+data Query a
+  = MessageReceived AuthD.AnswerMessage a
+  | ConnectionIsDown a
+  | ConnectionIsUp a
+
+type Slot = H.Slot Query Output
+
+type Input = Unit
+
+data AuthenticationInput
+  = AUTH_INP_login String
+  | AUTH_INP_pass String
+
+data PasswordRecoveryInput
+  = PASSR_INP_login String
+  | PASSR_INP_email String
+
+data NewPasswordInput
+  = NEWPASS_INP_login String
+  | NEWPASS_INP_token String
+  | NEWPASS_INP_password String
+  | NEWPASS_INP_confirmation String
+
+data Action
+  = HandleAuthenticationInput AuthenticationInput
+  | HandlePasswordRecovery    PasswordRecoveryInput
+  | HandleNewPassword         NewPasswordInput
+  --
+  | AuthenticationAttempt Event
+  | PasswordRecoveryAttempt Event
+  | NewPasswordAttempt Event
+
+type StateAuthenticationForm = { login :: String, pass :: String }
+type StatePasswordRecoveryForm = { login :: String, email :: String }
+type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String }
+
+type State =
+  { authenticationForm     :: StateAuthenticationForm
+  , passwordRecoveryForm   :: StatePasswordRecoveryForm
+  , newPasswordForm        :: StateNewPasswordForm
+  , errors                 :: Array Error
+  , wsUp                   :: Boolean
+  }
+
+initialState :: Input -> State
+initialState _ =
+  { authenticationForm:   { login: "", pass:  "" }
+  , passwordRecoveryForm: { login: "", email: "" }
+  , newPasswordForm: { login: "", token: "", password: "", confirmation: "" }
+  , wsUp: true
+  , errors: []
+  }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        , handleQuery  = handleQuery
+        }
+    }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
+  Bulma.section_small
+    [ case wsUp of
+        false -> Bulma.p "You are disconnected."
+        true  ->
+          if A.length errors > 0
+          then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ]
+                       , Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
+                       ]
+          else Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
+    ]
+
+  where
+    b e = Bulma.column_ [ Bulma.box e ]
+
+    show_error :: Error -> String
+    show_error = case _ of
+      Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr)
+      Email    arr -> "Error with the Email: "    <> (A.fold $ map show_error_email arr)
+      Password arr -> "Error with the Password: " <> (A.fold $ map show_error_password arr)
+
+    show_error_login :: L.Error -> String
+    show_error_login = case _ of
+      L.ParsingError {error, position} ->
+        "position " <> show position <> " " <> maybe "" string_error_login error
+
+    string_error_login :: L.LoginParsingError -> String
+    string_error_login = case _ of
+      L.CannotParse         -> "cannot parse the login"
+      L.CannotEntirelyParse -> "cannot entirely parse the login"
+      L.Size min max n      -> "login size should be between "
+                               <> show min <> " and " <> show max
+                               <> " (currently: " <> show n <> ")"
+    show_error_email :: E.Error -> String
+    show_error_email = case _ of
+      E.ParsingError {error, position} ->
+        "position " <> show position <> " " <> maybe "" string_error_email error
+    
+    string_error_email :: E.EmailParsingError -> String
+    string_error_email = case _ of
+      E.CannotParse         -> "cannot parse the email"
+      E.CannotEntirelyParse -> "cannot entirely parse the email"
+      E.Size min max n      -> "email size should be between "
+                               <> show min <> " and " <> show max
+                               <> " (currently: " <> show n <> ")"
+    
+    show_error_password :: P.Error -> String
+    show_error_password = case _ of
+      P.ParsingError {error, position} ->
+        "position " <> show position <> " " <> maybe "" string_error_password error
+    
+    string_error_password :: P.PasswordParsingError -> String
+    string_error_password = case _ of
+      P.CannotParse         -> "cannot parse the password"
+      P.CannotEntirelyParse -> "cannot entirely parse the password"
+      P.Size min max n      -> "password size should be between "
+                               <> show min <> " and " <> show max
+                               <> " (currently: " <> show n <> ")"
+
+    auth_form         = [ Bulma.h3 "Authentication"   , render_auth_form ]
+    passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
+    newpass_form      = [ Bulma.h3 "New password", render_new_password_form ]
+
+    should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
+
+    render_auth_form = HH.form
+      [ HE.onSubmit AuthenticationAttempt ]
+      [ Bulma.box_input "loginLOGIN" "Login" "login"                    -- title, placeholder
+          (HandleAuthenticationInput <<< AUTH_INP_login)   -- action
+          authenticationForm.login                         -- value
+          should_be_disabled                               -- condition
+      , Bulma.box_password "passwordLOGIN" "Password" "password"           -- title, placeholder
+          (HandleAuthenticationInput <<< AUTH_INP_pass)    -- action
+          authenticationForm.pass                          -- value
+          should_be_disabled                               -- condition
+      , HH.button
+         [ HP.style "padding: 0.5rem 1.25rem;"
+         , HP.type_ HP.ButtonSubmit
+         , (if wsUp then (HP.enabled true) else (HP.disabled true))
+         ]
+         [ HH.text "Send Message to Server" ]
+      ]
+
+    render_password_recovery_form = HH.form
+      [ HE.onSubmit PasswordRecoveryAttempt ]
+      [ Bulma.box_input "loginPASSR" "Login" "login"                    -- title, placeholder
+          (HandlePasswordRecovery <<< PASSR_INP_login)  -- action
+          passwordRecoveryForm.login                       -- value
+          should_be_disabled                               -- condition
+      , Bulma.box_input "emailPASSR" "Email" "email"                    -- title, placeholder
+          (HandlePasswordRecovery <<< PASSR_INP_email)  -- action
+          passwordRecoveryForm.email                       -- value
+          should_be_disabled                               -- condition
+      , HH.button
+         [ HP.style "padding: 0.5rem 1.25rem;"
+         , HP.type_ HP.ButtonSubmit
+         , (if wsUp then (HP.enabled true) else (HP.disabled true))
+         ]
+         [ HH.text "Send Message to Server" ]
+      ]
+
+    render_new_password_form = HH.form
+      [ HE.onSubmit NewPasswordAttempt ]
+      [ Bulma.box_input "loginNEWPASS" "Login" "login"
+          (HandleNewPassword <<< NEWPASS_INP_login)
+          newPasswordForm.login
+          should_be_disabled
+      , Bulma.box_input "tokenNEWPASS" "Token" "token"
+          (HandleNewPassword <<< NEWPASS_INP_token)
+          newPasswordForm.token
+          should_be_disabled
+      , Bulma.box_password "passwordNEWPASS" "Password" "password"
+          (HandleNewPassword <<< NEWPASS_INP_password)
+          newPasswordForm.password
+          should_be_disabled
+      , Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation"
+          (HandleNewPassword <<< NEWPASS_INP_confirmation)
+          newPasswordForm.confirmation
+          should_be_disabled
+      , HH.button
+         [ HP.style "padding: 0.5rem 1.25rem;"
+         , HP.type_ HP.ButtonSubmit
+         , (if wsUp then (HP.enabled true) else (HP.disabled true))
+         ]
+         [ HH.text "Send Message to Server" ]
+      ]
+
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  HandleAuthenticationInput authinp -> do
+    case authinp of
+      AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
+      AUTH_INP_pass  v -> H.modify_ _ { authenticationForm { pass  = v } }
+
+  HandlePasswordRecovery passrecovinp -> do
+    case passrecovinp of
+      PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } }
+      PASSR_INP_email v -> H.modify_ _ { passwordRecoveryForm { email = v } }
+
+  HandleNewPassword newpassinp -> do
+    case newpassinp of
+      NEWPASS_INP_login        v -> H.modify_ _ { newPasswordForm { login = v } }
+      NEWPASS_INP_token        v -> H.modify_ _ { newPasswordForm { token = v } }
+      NEWPASS_INP_password     v -> H.modify_ _ { newPasswordForm { password = v } }
+      NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } }
+
+  AuthenticationAttempt ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { authenticationForm } <- H.get
+    let { login, pass } = authenticationForm
+
+    case login, pass of
+      "" , _ ->
+        H.raise $ Log $ UnableToSend "Write your login!"
+
+      _ , "" ->
+        H.raise $ Log $ UnableToSend "Write your password!"
+
+      _, _ -> do
+        case L.login login, P.password pass of
+          Left errors, _ -> H.modify_ _ { errors = [ Login    errors ] }
+          _, Left errors -> H.modify_ _ { errors = [ Password errors ] }
+          _, _            -> do H.modify_ _ { errors = [] }
+                                H.raise $ AuthenticateToAuthd (Tuple login pass)
+        H.raise $ Log $ SystemLog $ "authenticate (login: " <> login <> ")"
+
+  PasswordRecoveryAttempt ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { passwordRecoveryForm } <- H.get
+    let login = passwordRecoveryForm.login
+        email = passwordRecoveryForm.email
+
+    case login, email of
+      "", "" -> H.raise $ Log $ UnableToSend "Write your login or your email!"
+      _, _ -> do
+        H.raise $ Log $ SystemLog "password recovery"
+        if email == ""
+        then case L.login login of
+               Left errors -> H.modify_ _ { errors = [ Login errors ] }
+               _           -> do H.modify_ _ { errors = [] }
+                                 H.raise $ AskPasswordRecovery (Right login)
+        else case E.email email of
+               Left errors -> H.modify_ _ { errors = [ Email errors ] }
+               _           -> do H.modify_ _ { errors = [] }
+                                 H.raise $ AskPasswordRecovery (Left email)
+
+  -- TODO: verify the login?
+  NewPasswordAttempt ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { newPasswordForm } <- H.get
+    let { login, token, password, confirmation} = newPasswordForm
+
+    if A.any (_ == "") [ login, token, password, confirmation ]
+    then H.raise $ Log $ ErrorLog "All entries are required!"
+    else if password == confirmation
+         then case L.login login of
+                Left errors -> H.modify_ _ { errors = [ Login errors ] }
+                Right _     -> do H.modify_ _ { errors = [] }
+                                  H.raise $ PasswordRecovery login token password
+         else H.raise $ Log $ UnableToSend "Confirmation differs from password!"
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  -- For now, no message actually needs to be handled here.
+  -- Error messages are simply logged (see the code in the Container component).
+  MessageReceived message _ -> do
+    case message of
+      _ -> do
+        H.raise $ Log $ ErrorLog $ "Message not handled in AuthenticationInterface."
+    pure Nothing
+
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    pure (Just a)

src/App/Button.purs

@@ -1,34 +0,0 @@
-module App.Button where
-
-import Prelude
-import Halogen as H
-import Halogen.HTML as HH
-import Halogen.HTML.Events as HE
-
-type State
-  = { count :: Int }
-
-data Action
-  = Increment
-
-component :: forall q i o m. H.Component q i o m
-component =
-  H.mkComponent
-    { initialState: \_ -> { count: 0 }
-    , render
-    , eval: H.mkEval H.defaultEval { handleAction = handleAction }
-    }
-
-render :: forall cs m. State -> H.ComponentHTML Action cs m
-render state =
-  HH.div_
-    [ HH.p_
-        [ HH.text $ "You clicked " <> show state.count <> " times" ]
-    , HH.button
-        [ HE.onClick \_ -> Increment ]
-        [ HH.text "Click me" ]
-    ]
-
-handleAction :: forall cs o m. Action → H.HalogenM State Action cs o m Unit
-handleAction = case _ of
-  Increment -> H.modify_ \st -> st { count = st.count + 1 }

src/App/Container.purs

@@ -1,30 +1,205 @@
+-- | `App.Container` is the parent of all other components of the application.
+-- |
+-- | Each page has its own module and the `App.Container` informs them when the websocket is up or down.
+-- | A module implements Websocket operations and is used twice, once for the connection to `authd`,
+-- | another for the connection to `dnsmanagerd`.
+-- |
+-- | `App.Container` stores the state of different components (domain list and zone interface)
+-- | to avoid useless requests to `dnsmanagerd`.
+-- |
+-- | `App.Container` detects when a page has been reloaded and:
+-- | 1. authenticate the user to `dnsmanagerd` via a stored token in session storage.
+-- | The authentication to `dnsmanagerd` automatically provides own domains and accepted domains (such as `netlib.re`).
+-- | This is enough data for the `DomainList` page.
+-- | 2. go back to that page.
+-- | In case the old page is `Zone`, send a request to `dnsmanagerd` to get the zone content again.
+-- |
+-- | Once a message is received, it is transfered to the module of the current page;
+-- | except for the `App.Messages.DNSManagerDaemon.AnswerMessage` `Logged` which is an hint when the
+-- | page has been reloaded, thus having a special treatment.
+-- |
+-- | TODO:
+-- | Each received message is transfered to the current page module because there is no centralized state.
+-- | This may be a good idea to store the state of the entire application at the same place, avoiding to
+-- | handle messages in the different pages.
+-- | Pages could handle semantic operations directly instead.
+-- |
+-- | Tested features:
+-- | - registration, mail validation, login, disconnection
+-- | - domain registration
+-- | - zone display, RR creation, update and removal
+-- |
+-- | Validation:
+-- | - registration page: login, password, mail
+-- | - login and password recovery page: TODO
+-- | - mail verification: TODO
+-- | - domain list: domain (`label`) is insufficient.
+-- |
+-- | TODO: when reading a RR `name`, always make it an FQDN by adding `<user-domain>.netlib.re.`.
+-- |
+-- | TODO: remove the FQDN when showing RR names.
+-- |
+-- | TODO: application-level heartbeat to avoid disconnections.
+-- |
+-- | Untested features:
+-- | - mail recovery, password change
 module App.Container where
 
-import Prelude
+import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure)
 
 import Bulma as Bulma
 
-import Data.Maybe (Maybe(..))
+import Data.Array as A
+import Data.Maybe (Maybe(..), maybe)
+import Data.Either (Either(..))
 import Data.Tuple (Tuple(..))
-import App.AuthenticationForm as AF
-import App.AuthenticationDaemonAdminInterface as AAI
+import App.AuthenticationInterface as AI
+import App.RegistrationInterface as RI
+import App.MailValidationInterface as MVI
+import App.Log as AppLog
+import App.WS as WS
+import App.AdministrationInterface as AdminInterface
+import App.SetupInterface as SetupInterface
+import App.DomainListInterface as DomainListInterface
+import App.ZoneInterface as ZoneInterface
+import App.HomeInterface as HomeInterface
+import App.NavigationInterface as NavigationInterface
+import App.Messages.DNSManagerDaemon as DNSManager
+import App.Messages.AuthenticationDaemon as AuthD
 import Halogen as H
 import Halogen.HTML as HH
+import Halogen.HTML.Properties as HP
 import Type.Proxy (Proxy(..))
 import Effect.Aff.Class (class MonadAff)
+import Data.ArrayBuffer.Types (ArrayBuffer)
+
+import Web.HTML (window) as HTML
+import Web.HTML.Window (sessionStorage) as Window
+import Web.Storage.Storage as Storage
+
+import App.Email as Email
+
+import App.LogMessage (LogMessage(..))
+
+import App.Pages
+import CSSClasses as C
+
+type Token = String
+type Login = String
+type Password = String
+type LogInfo = Tuple Login Password
 
 data Action
-  = Authenticated AF.Output -- User has been authenticated.
+  -- | Handle events from `AuthenticationInterface`.
+  = AuthenticationInterfaceEvent  AI.Output
 
-type State = { token :: Maybe String, uid :: Maybe Int }
+  -- | Handle events from `RegistrationInterface`.
+  | RegistrationInterfaceEvent    RI.Output
 
+  -- | Handle events from `MailValidationInterface`.
+  | MailValidationInterfaceEvent  MVI.Output
+
+  -- | Handle events from `SetupInterface`.
+  | SetupInterfaceEvent           SetupInterface.Output
+
+  -- | Handle events from `NavigationInterface`.
+  | NavigationInterfaceEvent  NavigationInterface.Output
+
+  -- | Handle events from `AuthenticationDaemonAdminComponent`.
+  | AdministrationEvent           AdminInterface.Output -- Administration interface.
+
+  -- | Handle events from `DomainListComponent`.
+  | DomainListComponentEvent      DomainListInterface.Output
+
+  -- | Handle events from `AuthenticationDaemon` (`authd websocket component`).
+  | AuthenticationDaemonEvent     WS.Output
+
+  -- | Handle events from `DNSManagerDaemon` (`dnsmanagerd websocket component`).
+  | DNSManagerDaemonEvent         WS.Output
+
+  -- | Handle events from `ZoneInterface`.
+  | ZoneInterfaceEvent            ZoneInterface.Output
+
+  -- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
+  -- | then return to the home page.
+  | Disconnection
+
+  -- | Try to authenticate the user to `dnsmanagerd`.
+  | AuthenticateToDNSManager
+
+  | AuthenticateToAuthd (Either Token LogInfo)
+
+  -- | Change the displayed page.
+  | Routing Page
+
+  -- | `DecodeDNSMessage`: decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`,
+  -- | then provide it to `DispatchDNSMessage`.
+  | DecodeDNSMessage ArrayBuffer
+
+  -- | `DispatchDNSMessage`: send the DNS message to the right component.
+  -- | The DNS message (from `dnsmanagerd`) was first received and decoded through the `DecodeDNSMessage` action.
+  | DispatchDNSMessage DNSManager.AnswerMessage
+
+  -- | `DecodeAuthMessage`: decode received `authd` messages into ``, then provide
+  -- | Then, the message is provided to the `DispatchAuthDaemonMessage` action (when needed).
+  | DecodeAuthMessage ArrayBuffer
+
+  -- | DispatchAuthDaemonMessage: an auth daemon message (from `authd`) was received and decoded through the
+  -- | `DecodeAuthMessage` action.
+  -- | The message is provided to the right component.
+  | DispatchAuthDaemonMessage AuthD.AnswerMessage
+
+  -- | Log message (through the Log component).
+  | Log LogMessage
+
+  -- | `KeepAlive` send a keepalive message to either `authd` or `dnsmanagerd`.
+  | KeepAlive (Either Unit Unit)
+
+  -- | `ToggleAuthenticated` performs some actions required when a connection or a disconnection occurs.
+  -- | Currently, this handles the navigation bar.
+  | ToggleAuthenticated (Maybe Token)
+
+-- | The component's state is composed of:
+-- | a potential authentication token,
+-- | the current page,
+-- | the states of both `DomainListInterface` and `AuthenticationDaemonAdmin` modules,
+-- | to avoid many useless network exchanges.
+type State = { token :: Maybe String
+             , current_page :: Page
+             , store_DomainListInterface_state :: Maybe DomainListInterface.State
+             , store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State
+             }
+
+-- | The list of child components: log, `WS` twice (once for each ws connection),
+-- | then all the pages (AuthenticationInterface, RegistrationInterface, MailValidationInterface,
+-- | HomeInterface, DomainListInterface, ZoneInterface and AdministrationInterface).
 type ChildSlots =
-  ( af  :: AF.Slot Unit
-  , aai :: AAI.Slot Unit
+  ( log     :: AppLog.Slot Unit
+  , ho      :: HomeInterface.Slot Unit
+  , ws_auth :: WS.Slot Unit
+  , ws_dns  :: WS.Slot Unit
+  , nav     :: NavigationInterface.Slot Unit
+  , ai      :: AI.Slot Unit
+  , ri      :: RI.Slot Unit
+  , mvi     :: MVI.Slot Unit
+  , admini  :: AdminInterface.Slot Unit
+  , setupi  :: SetupInterface.Slot Unit
+  , dli     :: DomainListInterface.Slot Unit
+  , zi      :: ZoneInterface.Slot Unit
   )
 
-_af = Proxy :: Proxy "af"
-_aai = Proxy :: Proxy "aai"
+_ho      = Proxy :: Proxy "ho"       -- Home Interface
+_log     = Proxy :: Proxy "log"      -- Log
+_ws_auth = Proxy :: Proxy "ws_auth"  -- WS with `authd`
+_ws_dns  = Proxy :: Proxy "ws_dns"   -- WS with `dnsmanagerd`
+_nav     = Proxy :: Proxy "nav"      -- Navigation Interface
+_ai      = Proxy :: Proxy "ai"       -- Authentication Interface
+_ri      = Proxy :: Proxy "ri"       -- Registration Interface
+_mvi     = Proxy :: Proxy "mvi"      -- Mail Validation Interface
+_admini  = Proxy :: Proxy "admini"   -- Administration Interface
+_setupi  = Proxy :: Proxy "setupi"   -- Setup Interface
+_dli     = Proxy :: Proxy "dli"      -- Domain List
+_zi      = Proxy :: Proxy "zi"       -- Zone Interface
 
 component :: forall q i o m. MonadAff m => H.Component q i o m
 component =
@@ -34,33 +209,520 @@ component =
     , eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
     }
 
+-- | Initial state is simple: the user is on the home page, nothing else is stored.
 initialState :: forall i. i -> State
-initialState _ = { token: Nothing, uid: Nothing }
+initialState _ = { token: Nothing
+                 , current_page: Home
+                 , store_DomainListInterface_state: Nothing
+                 , store_AuthenticationDaemonAdmin_state: Nothing
+                 }
 
 render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
 render state
   = HH.div_ $
-    [ render_auth_form
-    , render_authd_admin_interface
-    , div_token
+    [ render_header
+    , render_nav
+    , case state.current_page of
+        Home           -> render_home
+        Authentication -> render_auth_form
+        Registration   -> render_registration
+        MailValidation -> render_mail_validation
+        DomainList     -> render_domainlist_interface
+        Zone domain    -> render_zone domain
+        Setup          -> render_setup
+        Administration -> render_authd_admin_interface
+    -- The footer includes logs and both the WS child components.
+    , Bulma.columns_ [ Bulma.column_ [ render_logs ]
+                     , Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ]
     ]
   where
-    div_token :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
-    div_token = Bulma.box [ Bulma.p ("User [" <> show state.uid <> "] has token: " <> show state.token) ]
 
+    render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_home = HH.slot_ _ho unit HomeInterface.component unit
+    render_domainlist_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_domainlist_interface = HH.slot _dli unit DomainListInterface.component unit DomainListComponentEvent
     render_auth_form :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
-    render_auth_form = Bulma.box $ case state.token of
-      Nothing -> [ HH.slot _af unit AF.component "ws://127.0.0.1:8081" Authenticated ]
-      Just current_token -> [ Bulma.p ("Token is: " <> current_token) ]
-
+    render_auth_form = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent
+    render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent
+    render_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_setup = case state.token of
+                     Just token -> HH.slot _setupi unit SetupInterface.component token SetupInterfaceEvent
+                     Nothing -> Bulma.p "You shouldn't see this page. Reconnect!"
+    render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_mail_validation = HH.slot _mvi unit MVI.component unit MailValidationInterfaceEvent
+    render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent
     render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
-    render_authd_admin_interface = Bulma.box $ case state.token of
-      Just _ ->
-        [ Bulma.h1 "Administrative interface for authd"
-        , HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8081"
+    render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent
+
+    render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent
+
+    render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_header =
+      HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
+        [ HH.div [ HP.classes C.hero_body ]
+            [ HH.div [ HP.classes $ C.container <> C.has_text_centered ]
+                [ HH.p [ HP.classes C.subtitle ]
+                    [ HH.strong_ [ HH.u_ [ HH.text "net libre" ]]
+                    , HH.text ": providing free domains since 2015!"
+                    ]
+                ]
+            ]
         ]
-      Nothing -> [ Bulma.p "Here will be the administrative box." ]
+
+    render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_logs = Bulma.container [ HH.slot_ _log unit AppLog.component unit ]
+
+    render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_auth_WS = HH.slot _ws_auth unit WS.component "wss://beta.netlib.re/ws/authd" AuthenticationDaemonEvent
+
+    render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_dnsmanager_WS = HH.slot _ws_dns unit WS.component "wss://beta.netlib.re/ws/dnsmanagerd" DNSManagerDaemonEvent
 
 handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
 handleAction = case _ of
-  Authenticated (AF.AuthToken (Tuple uid token)) -> H.modify_ _ { uid = Just uid, token = Just token }
+  Routing page -> do
+    -- Store the current page we are on and restore it when we reload.
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    _ <- case page of
+      Home           -> H.liftEffect $ Storage.setItem "current-page" "Home"           sessionstorage
+      Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
+      Registration   -> H.liftEffect $ Storage.setItem "current-page" "Registration"   sessionstorage
+      MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" sessionstorage
+      DomainList     -> H.liftEffect $ Storage.setItem "current-page" "DomainList"     sessionstorage
+      Zone zone      -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone"   sessionstorage
+                           H.liftEffect $ Storage.setItem      "current-zone" zone     sessionstorage
+      Setup          -> H.liftEffect $ Storage.setItem "current-page" "Setup"          sessionstorage
+      Administration -> H.liftEffect $ Storage.setItem "current-page" "Administration" sessionstorage
+    H.modify_ _ { current_page = page }
+
+  Log message -> H.tell _log unit $ AppLog.Log message
+
+  ToggleAuthenticated maybe_token -> case maybe_token of
+    Nothing -> H.tell _nav unit $ NavigationInterface.ToggleLogged false
+    Just _  -> H.tell _nav unit $ NavigationInterface.ToggleLogged true
+
+  KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of
+    Left _ -> do
+      message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {}
+      H.tell _ws_auth unit (WS.ToSend message)
+    Right _ -> do
+      message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkKeepAlive {}
+      H.tell _ws_dns unit (WS.ToSend message)
+
+  AuthenticateToAuthd v -> case v of
+    Left token -> do
+      handleAction $ Log $ SystemLog "Authenticate to authd with a token!"
+      message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
+      H.tell _ws_auth unit (WS.ToSend message)
+    Right (Tuple login password) -> do
+      message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
+      H.tell _ws_auth unit (WS.ToSend message)
+
+  AuthenticateToDNSManager -> do
+    state <- H.get
+    case state.token of
+      Just token -> do
+        message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
+        H.tell _ws_dns unit (WS.ToSend message)
+      Nothing -> do
+        sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+        token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
+        case token of
+          Nothing -> handleAction $ Log $ ErrorLog "no token!"
+          Just t -> do
+            H.modify_ _ { token = Just t }
+            handleAction AuthenticateToDNSManager
+
+  NavigationInterfaceEvent ev -> case ev of
+    NavigationInterface.Log message -> H.tell _log unit (AppLog.Log message)
+    NavigationInterface.Routing page -> handleAction $ Routing page
+    NavigationInterface.Disconnection -> handleAction $ Disconnection
+
+  AuthenticationInterfaceEvent ev -> case ev of
+    AI.MessageToSend message  -> H.tell _ws_auth unit (WS.ToSend message)
+    AI.AskPasswordRecovery e -> case e of
+      Left  email -> do
+        message <- H.liftEffect $ AuthD.serialize $
+          AuthD.MkAskPasswordRecovery { user: Nothing, email: Just (Email.Email email) }
+        H.tell _ws_auth unit (WS.ToSend message)
+      Right login -> do
+        message <- H.liftEffect $ AuthD.serialize $
+          AuthD.MkAskPasswordRecovery { user: (Just login), email: Nothing }
+        H.tell _ws_auth unit (WS.ToSend message)
+    AI.PasswordRecovery login token pass -> do
+      message <- H.liftEffect $ AuthD.serialize $ AuthD.MkPasswordRecovery
+        { user: login
+        , password_renew_key: token
+        , new_password: pass }
+      H.tell _ws_auth unit (WS.ToSend message)
+
+    AI.AuthenticateToAuthd v  -> handleAction $ AuthenticateToAuthd (Right v)
+    AI.Log message            -> H.tell _log unit (AppLog.Log message)
+
+  RegistrationInterfaceEvent ev -> case ev of
+    RI.MessageToSend message  -> H.tell _ws_auth unit (WS.ToSend message)
+    RI.Log message            -> H.tell _log unit (AppLog.Log message)
+
+  MailValidationInterfaceEvent ev -> case ev of
+    MVI.MessageToSend message  -> H.tell _ws_auth unit (WS.ToSend message)
+    MVI.Log message            -> H.tell _log unit (AppLog.Log message)
+
+  SetupInterfaceEvent ev -> case ev of
+    SetupInterface.DeleteUserAccount -> do
+      handleAction $ Log $ ErrorLog "TODO: delete the user account"
+    SetupInterface.ChangePassword pass  -> do
+      message <- H.liftEffect $ AuthD.serialize $ AuthD.MkModUser { user:       Nothing
+                                                                  , admin:      Nothing
+                                                                  , password:   Just pass
+                                                                  , email:      Nothing
+                                                                  }
+
+      H.tell _ws_auth unit (WS.ToSend message)
+    SetupInterface.Log message          -> H.tell _log unit (AppLog.Log message)
+
+  AdministrationEvent ev -> case ev of
+    AdminInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
+    AdminInterface.Log message           -> H.tell _log unit (AppLog.Log message)
+    AdminInterface.StoreState s          -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s }
+    AdminInterface.AskState              -> do
+      state <- H.get
+      H.tell _admini unit (AdminInterface.ProvideState state.store_AuthenticationDaemonAdmin_state)
+
+  ZoneInterfaceEvent ev -> case ev of
+    ZoneInterface.MessageToSend message  -> H.tell _ws_dns unit (WS.ToSend message)
+    ZoneInterface.Log message            -> H.tell _log unit (AppLog.Log message)
+
+  DomainListComponentEvent ev -> case ev of
+    DomainListInterface.MessageToSend message  -> H.tell _ws_dns unit (WS.ToSend message)
+    DomainListInterface.Log message            -> H.tell _log unit (AppLog.Log message)
+    DomainListInterface.StoreState s           -> H.modify_ _ { store_DomainListInterface_state = Just s }
+    DomainListInterface.ChangePageZoneInterface domain -> do
+      handleAction $ Routing $ Zone domain
+
+    DomainListInterface.AskState -> do
+      state <- H.get
+      H.tell _dli unit (DomainListInterface.ProvideState state.store_DomainListInterface_state)
+
+  -- | `authd websocket component` wants to do something.
+  AuthenticationDaemonEvent ev -> case ev of
+    WS.MessageReceived (Tuple _ message) -> do
+      handleAction $ DecodeAuthMessage message
+
+    WS.WSJustConnected -> do
+      H.tell _ai unit AI.ConnectionIsUp
+      H.tell _admini unit AdminInterface.ConnectionIsUp
+      sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+      token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
+      case token of
+        Nothing -> handleAction $ Log $ ErrorLog "no token!"
+        Just t -> do
+          handleAction $ Log $ SystemLog "Let's authenticate to authd"
+          handleAction $ AuthenticateToAuthd (Left t)
+
+    WS.WSJustClosed -> do
+      H.tell _ai unit AI.ConnectionIsDown
+      H.tell _admini unit AdminInterface.ConnectionIsDown
+    WS.Log message -> H.tell _log unit (AppLog.Log message)
+    WS.KeepAlive   -> handleAction $ KeepAlive $ Left unit
+
+  DecodeAuthMessage message -> do
+    receivedMessage <- H.liftEffect $ AuthD.deserialize message
+    case receivedMessage of
+      -- Cases where we didn't understand the message.
+      Left err -> do
+        -- handleAction $ Log $ ErrorLog $
+        --   "received a message that couldn't be decoded. Reason: " <> show err
+        case err of
+          (AuthD.JSONERROR jerr) -> do
+            -- print_json_string messageEvent.message
+            handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
+          (AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
+            "Parsing error: AuthD.UnknownError" <> (show unerr)
+          (AuthD.UnknownNumber     ) -> handleAction $ Log $ ErrorLog
+            "Parsing error: AuthD.UnknownNumber"
+
+      -- Cases where we understood the message.
+      -- TODO: create a modal to show some of these?
+      Right response -> do
+        case response of
+          (AuthD.GotUser _) -> do
+            handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
+          m@(AuthD.GotUserAdded _) -> do
+            { current_page } <- H.get
+            case current_page of
+              Registration -> do
+                handleAction $ Log $ SuccessLog """
+          You are now registered, copy the token we sent you by email to finish your registration.
+                """
+                handleAction $ Routing MailValidation
+              _ -> handleAction $ DispatchAuthDaemonMessage m
+          (AuthD.GotUserEdited u) -> do
+            handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified!"
+          (AuthD.GotUserValidated _) -> do
+            handleAction $ Log $ SuccessLog "User got validated! You can now log in!"
+            handleAction $ Routing Authentication
+          (AuthD.GotUsersList _) -> do
+            handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
+          (AuthD.GotPermissionCheck _) -> do
+            handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
+          (AuthD.GotPermissionSet _) -> do
+            handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
+          (AuthD.GotPasswordRecovered _) -> do
+            handleAction $ Log $ SuccessLog "your new password is now valid!"
+          m@(AuthD.GotMatchingUsers _) -> do
+            { current_page } <- H.get
+            case current_page of
+              Administration -> handleAction $ DispatchAuthDaemonMessage m
+              _ -> handleAction $ Log $ ErrorLog
+                "received a GotMatchingUsers message while not on authd admin page."
+          m@(AuthD.GotUserDeleted _) -> do
+            { current_page } <- H.get
+            case current_page of
+              Administration -> handleAction $ DispatchAuthDaemonMessage m
+              _ -> handleAction $ Log $ ErrorLog
+                "received a GotUserDeleted message while not on authd admin page."
+          (AuthD.GotErrorMustBeAuthenticated _) -> do
+            handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
+          (AuthD.GotErrorAlreadyUsedLogin _) -> do
+            handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
+          (AuthD.GotErrorUserNotFound _) -> do
+            handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
+
+          -- The authentication failed.
+          (AuthD.GotError errmsg) -> do
+            handleAction $ Log $ ErrorLog $ " generic error message: "
+              <> maybe "server didn't tell why" (\v -> v) errmsg.reason
+          (AuthD.GotPasswordRecoverySent _) -> do
+            handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
+          (AuthD.GotErrorPasswordTooShort _) -> do
+            handleAction $ Log $ ErrorLog "Password too short!"
+          (AuthD.GotErrorMailRequired _) -> do
+            handleAction $ Log $ ErrorLog "Email required!"
+          (AuthD.GotErrorInvalidCredentials _) -> do
+            handleAction $ Log $ ErrorLog "Invalid credentials!"
+            handleAction $ ToggleAuthenticated Nothing
+          (AuthD.GotErrorRegistrationsClosed _) -> do
+            handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator."
+          (AuthD.GotErrorInvalidLoginFormat _) -> do
+            handleAction $ Log $ ErrorLog "Invalid login format!"
+          (AuthD.GotErrorInvalidEmailFormat _) -> do
+            handleAction $ Log $ ErrorLog "Invalid email format!"
+          (AuthD.GotErrorAlreadyUsersInDB _) -> do
+            handleAction $ Log $ ErrorLog "Login already taken!"
+          (AuthD.GotErrorReadOnlyProfileKeys _) -> do
+            handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys!"
+          (AuthD.GotErrorInvalidActivationKey _) -> do
+            handleAction $ Log $ ErrorLog "Invalid activation key!"
+          (AuthD.GotErrorUserAlreadyValidated _) -> do
+            handleAction $ Log $ ErrorLog "User already validated!"
+          (AuthD.GotErrorCannotContactUser _) -> do
+            handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
+          (AuthD.GotErrorInvalidRenewKey _) -> do
+            handleAction $ Log $ ErrorLog "Invalid renew key!"
+          -- The authentication was a success!
+          (AuthD.GotToken msg) -> do
+            handleAction $ Log $ SuccessLog $ "Authenticated to authd!"
+            H.modify_ _ { token = Just msg.token }
+            handleAction $ ToggleAuthenticated (Just msg.token)
+
+            sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+            _ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
+
+            handleAction AuthenticateToDNSManager
+          (AuthD.GotKeepAlive _) -> do
+            -- handleAction $ Log $ SystemLog $ "KeepAlive!"
+            pure unit
+    pure unit
+
+  -- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
+  DispatchAuthDaemonMessage message -> do
+    { current_page } <- H.get
+    case current_page of
+      Administration -> H.tell _admini unit (AdminInterface.MessageReceived message)
+      _              -> handleAction $ Log $ SystemLog "unexpected message from authd"
+    pure unit
+
+  Disconnection -> do
+    H.put $ initialState unit
+
+    -- Remove all stored session data.
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    H.liftEffect $ Storage.clear sessionstorage
+
+  -- | `dnsmanagerd websocket component` wants to do something.
+  DNSManagerDaemonEvent ev -> case ev of
+    WS.MessageReceived (Tuple _ message) -> do
+      handleAction $ DecodeDNSMessage message
+    WS.WSJustConnected -> do
+      handleAction $ Log $ SystemLog "Connection with dnsmanagerd was closed, let's re-authenticate"
+      handleAction AuthenticateToDNSManager
+      H.tell _dli unit DomainListInterface.ConnectionIsUp
+    WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
+    WS.Log message -> H.tell _log unit (AppLog.Log message)
+    WS.KeepAlive   -> handleAction $ KeepAlive $ Right unit
+
+  -- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`.
+  DecodeDNSMessage message -> do
+    receivedMessage <- H.liftEffect $ DNSManager.deserialize message
+    case receivedMessage of
+      -- Cases where we didn't understand the message.
+      Left err -> do
+        -- handleAction $ Log $ ErrorLog $
+        --   "received a message that couldn't be decoded. Reason: " <> show err
+        case err of
+          (DNSManager.JSONERROR jerr) -> do
+            handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
+          (DNSManager.UnknownError   unerr) ->
+            handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
+          (DNSManager.UnknownNumber       ) ->
+            handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber"
+
+      -- Cases where we understood the message.
+      Right received_msg -> do
+        case received_msg of
+          (DNSManager.MkDomainNotFound _) -> do
+            handleAction $ Log $ ErrorLog $ "DomainNotFound"
+          (DNSManager.MkRRNotFound _) -> do
+            handleAction $ Log $ ErrorLog $ "RRNotFound"
+          (DNSManager.MkInvalidZone _) -> do
+            handleAction $ Log $ ErrorLog $ "InvalidZone"
+          (DNSManager.MkDomainChanged _) -> do
+            handleAction $ Log $ ErrorLog $ "DomainChanged"
+          (DNSManager.MkUnknownZone _) -> do
+            handleAction $ Log $ ErrorLog $ "UnknownZone"
+          (DNSManager.MkDomainList _) -> do
+            handleAction $ Log $ ErrorLog $ "MkDomainList"
+          (DNSManager.MkUnknownUser _) -> do
+            handleAction $ Log $ ErrorLog $ "MkUnknownUser"
+          (DNSManager.MkNoOwnership _) -> do
+            handleAction $ Log $ ErrorLog $ "MkNoOwnership"
+          (DNSManager.MkInsufficientRights _) -> do
+            handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
+          -- The authentication failed.
+          (DNSManager.MkError errmsg) -> do
+            handleAction $ Log $ ErrorLog $ "reason is: " <> errmsg.reason
+          (DNSManager.MkErrorUserNotLogged _) -> do
+            handleAction $ Log $ ErrorLog $ "The user isn't connected!"
+            handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..."
+            handleAction AuthenticateToDNSManager
+          (DNSManager.MkErrorInvalidToken _) -> do
+            H.modify_ _ { token = Nothing, current_page = Home }
+            handleAction $ Log $ ErrorLog $ "Invalid token! Try re-authenticate."
+            -- TODO: should we disconnect from authd?
+            handleAction $ ToggleAuthenticated Nothing
+          (DNSManager.MkDomainAlreadyExists _) -> do
+            handleAction $ Log $ ErrorLog $ "The domain already exists."
+          m@(DNSManager.MkUnacceptableDomain _) -> do
+            handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkAcceptedDomains _) -> do
+            handleAction $ Log $ SuccessLog $ "Received the list of accepted domains!"
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkLogged _) -> do
+            handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd!"
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkDomainAdded response) -> do
+            handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
+            handleAction $ DispatchDNSMessage m
+          (DNSManager.MkRRReadOnly response) -> do
+            handleAction $ Log $ ErrorLog $ "Trying to modify a read-only resource! "
+                                        <> "domain: " <> response.domain
+                                        <> "resource rrid: " <> show response.rr.rrid
+          m@(DNSManager.MkRRUpdated _) -> do
+            handleAction $ Log $ SuccessLog $ "Resource updated!"
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkRRAdded response) -> do
+            handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkGeneratedZoneFile response) -> do
+            handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
+            handleAction $ DispatchDNSMessage m
+          (DNSManager.MkInvalidDomainName _) -> do
+            handleAction $ Log $ ErrorLog $ "The domain is not valid!"
+          m@(DNSManager.MkDomainDeleted response) -> do
+            handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!"
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkRRDeleted response) -> do
+            handleAction $ Log $ SuccessLog $ "RR (rrid: '" <> show response.rrid <> "') has been deleted!"
+            handleAction $ DispatchDNSMessage m
+          m@(DNSManager.MkZone _) -> do
+            handleAction $ Log $ SuccessLog $ "Zone received!"
+            handleAction $ DispatchDNSMessage m
+          (DNSManager.MkInvalidRR response) -> do
+            handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors
+          (DNSManager.MkSuccess _) -> do
+            handleAction $ Log $ SuccessLog $ "(generic) Success!"
+          (DNSManager.GotKeepAlive _) -> do
+            -- handleAction $ Log $ SystemLog $ "KeepAlive!"
+            pure unit
+    pure unit
+
+  -- | Send a received DNS manager message to a component.
+  -- | TODO: in case the message is a `logged` message, it means that the connection has been reset, and should be
+  -- | handled no matter the actual page we're on.
+  DispatchDNSMessage message -> do
+
+    -- The message `Logged` can be received after a re-connection (typically, after a page reload).
+    -- This is an hint, and the application should do a series of actions based on this.
+    -- First, we should check if there is a "current page", if so, switch page.
+    -- Second, depending on the page, actions have to be undertaken.
+    -- For `DomainList`, send a request to `dnsmanagerd` for the list of own domains and acceptable domains.
+    -- For `Zone`, send a request to `dnsmanagerd` for the zone content.
+    state <- H.get
+    case state.current_page, message of
+      -- Home + Logged = page just reloaded.
+      Home, m@(DNSManager.MkLogged _) -> do
+        update_domain_list state m
+        revert_old_page
+      Authentication, m@(DNSManager.MkLogged _) -> do
+        update_domain_list state m
+        -- handleAction $ Log $ SystemLog "go to domain list!"
+        handleAction $ Routing DomainList
+      -- Logged = page just reloaded, but page already changed, no need to do that again.
+      _, m@(DNSManager.MkLogged _) -> do
+        -- handleAction $ Log $ SystemLog "logged to dnsmanagerd, do not change page"
+        update_domain_list state m
+      DomainList, _             -> H.tell _dli unit (DomainListInterface.MessageReceived message)
+      Zone _    , _             -> H.tell _zi  unit (ZoneInterface.MessageReceived message)
+      _, _                      -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
+    pure unit
+  where
+  update_domain_list state m = do
+    case state.store_DomainListInterface_state of
+      Nothing -> do
+        let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m
+        H.modify_ _ { store_DomainListInterface_state = Just new_value }
+      Just _ -> pure unit
+
+  revert_old_page = do
+    -- Get back to the previous page.
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
+    case page of
+      Nothing -> pure unit
+      Just "Home"           -> handleAction $ Routing Home
+      Just "Authentication" -> handleAction $ Routing Authentication
+      Just "Registration"   -> handleAction $ Routing Registration
+      Just "DomainList"     -> handleAction $ Routing DomainList
+      Just "MailValidation" -> handleAction $ Routing MailValidation
+      Just "Setup"          -> handleAction $ Routing Setup
+      Just "Administration" -> handleAction $ Routing Administration
+      Just "Zone" -> do
+        domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage
+        case domain of
+          Nothing   -> handleAction $ Log $ SystemLog "Zone but no domain recorded!! WEIRD"
+          Just zone -> do handleAction $ Log $ SystemLog $ "zone to display: " <> zone
+                          handleAction $ Routing (Zone zone)
+      Just p  -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p
+
+
+--print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
+--print_json_string arraybuffer = do
+--  -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
+--  value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
+--  H.raise $ Log $ ErrorLog $ case (value) of
+--    Left _ -> "Cannot even fromTypedIPC the message."
+--    Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

src/App/DNSZone.purs

@@ -0,0 +1,24 @@
+module App.DNSZone where
+
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
+import App.ResourceRecord as RR
+
+type DNSZone
+  = { domain        :: String
+
+    -- List of all the zone's resource records.
+    , resources     :: Array RR.ResourceRecord
+
+    -- Each resource record has a number, this is the ID to give to a new RR.
+    , current_rrid  :: Int
+    }
+
+codec :: JsonCodec DNSZone
+codec = CA.object "DNSZone"
+  (CAR.record
+    { domain:        CA.string
+    , resources:     CA.array RR.codec
+    , current_rrid:  CA.int
+    })

src/App/DisplayErrors.purs

@@ -0,0 +1,133 @@
+-- | This module provides functions to display errors in a fancy way.
+module App.DisplayErrors where
+
+import Prelude (show, ($), (<>))
+
+-- import Data.Foldable as Foldable
+import Data.Maybe (Maybe(..), maybe)
+import Halogen.HTML as HH
+
+import App.Validation.DNS as ValidationDNS
+import App.Validation.Label as ValidationLabel
+import GenericParser.DomainParser.Common (DomainError(..)) as DomainParser
+import GenericParser.IPAddress as IPAddress
+import Bulma as Bulma
+
+error_to_paragraph :: forall w i. ValidationDNS.Error -> HH.HTML w i
+error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
+  (case v of
+      ValidationDNS.UNKNOWN              -> Bulma.p "An internal error happened."
+      ValidationDNS.VEIPv4     err       -> maybe default_error show_error_ip4 err.error
+      ValidationDNS.VEIPv6     err       -> maybe default_error show_error_ip6 err.error
+      ValidationDNS.VEName     err       -> maybe default_error show_error_domain err.error
+      ValidationDNS.VETTL min max n      -> Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
+                                         <> ", current value: " <> show n <> "."
+      ValidationDNS.VETXT      err       -> maybe default_error show_error_txt err.error
+      ValidationDNS.VECNAME    err       -> maybe default_error show_error_domain err.error
+      ValidationDNS.VENS       err       -> maybe default_error show_error_domain err.error
+      ValidationDNS.VEMX       err       -> maybe default_error show_error_domain err.error
+      ValidationDNS.VEPriority min max n -> Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max
+                                         <> ", current value: " <> show n <> "."
+      ValidationDNS.VESRV      err       -> maybe default_error show_error_domain err.error
+      ValidationDNS.VEProtocol err       -> maybe default_error show_error_protocol err.error
+      ValidationDNS.VEPort min max n     -> Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max
+                                         <> ", current value: " <> show n <> "."
+      ValidationDNS.VEWeight min max n   -> Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max
+                                         <> ", current value: " <> show n <> "."
+  )
+  where default_error = Bulma.p ""
+
+-- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry.
+show_error_title :: ValidationDNS.Error -> String
+show_error_title v = case v of
+  ValidationDNS.UNKNOWN              -> "Unknown"
+  ValidationDNS.VEIPv4     err       -> "The IPv4 address is wrong (position: "        <> show err.position <> ")"
+  ValidationDNS.VEIPv6     err       -> "The IPv6 address is wrong (position: "        <> show err.position <> ")"
+  ValidationDNS.VEName     err       -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
+  ValidationDNS.VETTL min max n      -> "Invalid TTL (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
+  ValidationDNS.VETXT      err       -> "The TXT input is wrong (position: "           <> show err.position <> ")"
+  ValidationDNS.VECNAME    err       -> "The CNAME input is wrong (position: "         <> show err.position <> ")"
+  ValidationDNS.VENS       err       -> "The NS input is wrong (position: "            <> show err.position <> ")"
+  ValidationDNS.VEMX       err       -> "The MX target input is wrong (position: "     <> show err.position <> ")"
+  ValidationDNS.VEPriority min max n -> "Invalid Priority (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
+  ValidationDNS.VESRV      err       -> "The SRV target input is wrong (position: "    <> show err.position <> ")"
+  ValidationDNS.VEProtocol err       -> "The Protocol input is wrong (position: "      <> show err.position <> ")"
+  ValidationDNS.VEPort min max n     -> "Invalid Port (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
+  ValidationDNS.VEWeight min max n   -> "Invalid Weight (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
+
+show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i
+show_error_domain e = case e of
+  DomainParser.LabelTooLarge size ->
+    Bulma.p $ "The label contains too many characters (" <> show size <> ")."
+  DomainParser.DomainTooLarge size ->
+    Bulma.p $ "The domain contains too many characters (" <> show size <> ")."
+  -- DomainParser.InvalidCharacter
+  -- DomainParser.EOFExpected
+  _ -> Bulma.p """
+           The domain (or label) contains invalid characters.
+           A domain label should start with a letter,
+           then eventually a series of letters, digits and hyphenations ('-'),
+           and must finish with either a letter or a digit.
+         """
+
+show_error_protocol :: forall w i. ValidationDNS.ProtocolError -> HH.HTML w i
+show_error_protocol e = case e of
+  ValidationDNS.InvalidProtocol -> Bulma.p "Protocol should be a value as 'tcp' or 'udp'."
+
+show_error_ip6 :: forall w i. IPAddress.IPv6Error -> HH.HTML w i
+show_error_ip6 e = case e of
+  IPAddress.IP6TooManyHexaDecimalCharacters ->
+    Bulma.p "IP6TooManyHexaDecimalCharacters"
+  IPAddress.IP6NotEnoughChunks ->
+    Bulma.p """
+      The IPv6 representation is erroneous, it should contain 8 groups of hexadecimal characters or
+      being shortened with a double ':' character, such as '2000::1'.
+      """
+  IPAddress.IP6TooManyChunks ->
+    Bulma.p "The IPv6 representation is erroneous. It should contain only up to 8 groups of hexadecimal characters."
+  IPAddress.IP6IrrelevantShortRepresentation ->
+    Bulma.p "IPv6 address has been unnecessarily shortened (with two ':')."
+
+show_error_ip4 :: forall w i. IPAddress.IPv4Error -> HH.HTML w i
+show_error_ip4 e = case e of
+  IPAddress.IP4NumberTooBig n ->
+    Bulma.p $ "IPv4 address contains a number too big (should be between 0 and 255). Current entered number: " <> show n
+  IPAddress.IP4IrrelevantShortRepresentation ->
+    Bulma.p "IPv4 address has been unnecessarily shortened (with two '.')."
+
+show_error_txt :: forall w i. ValidationDNS.TXTError -> HH.HTML w i
+show_error_txt e = case e of
+  ValidationDNS.TXTInvalidCharacter -> Bulma.p "The TXT field contains some invalid characters."
+  ValidationDNS.TXTTooLong max n ->
+    Bulma.p $ "An TXT field is limited to " <> show max <> " characters (currently there are "
+              <> show n <> " characters)."
+
+domainerror_string :: DomainParser.DomainError -> String
+domainerror_string (DomainParser.LabelTooLarge size)  = "LabelTooLarge (size: " <> show size <> ")"
+domainerror_string (DomainParser.DomainTooLarge size) = "DomainTooLarge (size: " <> show size <> ")"
+domainerror_string (DomainParser.InvalidCharacter)    = "InvalidCharacter"
+domainerror_string (DomainParser.EOFExpected)         = "EOFExpected"
+
+-- | This `error_to_paragraph` is designed to go along the `Validation.Label` module.
+error_to_paragraph_label :: forall w i. ValidationLabel.Error -> HH.HTML w i
+error_to_paragraph_label v = Bulma.error_message (Bulma.p $ show_error_title_label v)
+  (case v of
+    ValidationLabel.ParsingError x -> case x.error of
+      Nothing -> Bulma.p ""
+      Just (ValidationLabel.CannotParse err) -> show_error_domain err
+      Just (ValidationLabel.CannotEntirelyParse) -> Bulma.p "Cannot entirely parse the label."
+      Just (ValidationLabel.Size min max n) ->
+        Bulma.p $ "Label size should be between " <> show min <> " and " <> show max
+                  <> " (current size: " <> show n <> ")."
+  )
+
+show_error_title_label :: ValidationLabel.Error -> String
+show_error_title_label v = case v of
+  ValidationLabel.ParsingError x -> case x.error of
+    Nothing -> "Cannot parse the label (position: " <> show x.position <> ")."
+    Just (ValidationLabel.CannotParse _) ->
+      "Cannot parse the label (position: " <> show x.position <> ")."
+    Just (ValidationLabel.CannotEntirelyParse) -> "Cannot entirely parse the label."
+    Just (ValidationLabel.Size min max n) ->
+      "Label size should be between " <> show min <> " and " <> show max
+      <> " (current size: " <> show n <> ")."

src/App/DomainListInterface.purs

@@ -0,0 +1,319 @@
+-- | `App.DomainListInterface` is a simple component with the list of own domains
+-- | and a form to add a new domain.
+-- |
+-- | This interface allows 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
+-- |   - TODO: validate the domain before sending a message to `dnsmanagerd`
+module App.DomainListInterface 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.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 App.DisplayErrors (error_to_paragraph_label)
+
+import App.Validation.Label as Validation
+
+import CSSClasses as C
+import App.LogMessage
+import App.Messages.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
+  | ConnectionIsDown a
+  | ConnectionIsUp 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
+-- | - remove a domain
+-- | - TODO: show the zone content (in another component)
+
+data Action
+  = UpdateAcceptedDomains (Array String)
+  | UpdateMyDomains (Array String)
+
+  | HandleNewDomainInput NewDomainFormAction
+
+  | NewDomainAttempt Event
+  | RemoveDomain String
+  | EnterDomain String
+
+  | DeleteDomainModal String
+  | CancelModal
+
+  | Initialize
+  | Finalize
+
+-- | The form only has two elements:
+-- | the subdomain name input and the selected TLD.
+
+type NewDomainFormState
+  = { new_domain      :: String
+    , _errors         :: Array Validation.Error
+    , selected_domain :: String
+    }
+
+-- | 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
+  , accepted_domains       :: Array String
+  , my_domains             :: Array String
+
+  , 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 _ =
+  { newDomainForm: { new_domain: ""
+                   , _errors: []
+                   , selected_domain: default_domain
+                   }
+  , accepted_domains: [ default_domain ]
+  , my_domains: [ ]
+  , wsUp: true
+  , active_modal: Nothing
+  }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { accepted_domains, my_domains, newDomainForm, wsUp, active_modal }
+  = Bulma.section_small
+      [ case wsUp of
+          false -> Bulma.p "You are disconnected."
+          true  -> case active_modal of
+            Nothing -> Bulma.columns_
+              [ Bulma.column_ [ Bulma.h3 "Add a domain!", render_add_domain_form]
+              , Bulma.column_ [ Bulma.h3 "My domains"
+                              , HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains
+                              ]
+              ]
+            Just domain -> Bulma.modal "Deleting a domain"
+              [warning_message domain] [modal_delete_button domain, modal_cancel_button]
+      ]
+  where
+    modal_delete_button domain = Bulma.alert_btn "Delete the domain" (RemoveDomain domain)
+    modal_cancel_button = Bulma.cancel_button CancelModal
+    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 "."
+                ]
+
+    domain_buttons domain
+      = [ Bulma.alert_btn "delete" (DeleteDomainModal domain)
+        , Bulma.btn domain (EnterDomain domain)
+        ]
+
+    render_add_domain_form = HH.form
+      [ HE.onSubmit NewDomainAttempt ]
+      [ Bulma.new_domain_field
+          (HandleNewDomainInput <<< INP_newdomain)
+          newDomainForm.new_domain
+          [ HHE.onSelectedIndexChange domain_choice ]
+          accepted_domains
+      , HH.button
+          [ HP.type_ HP.ButtonSubmit
+          , HP.classes C.button
+          ]
+          [ HH.text "add a new domain!" ]
+      , if A.length newDomainForm._errors > 0
+        then HH.div_ $ map error_to_paragraph_label newDomainForm._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_ _ { active_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 = 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 } }
+
+  EnterDomain domain -> do
+    H.raise $ ChangePageZoneInterface domain
+
+  DeleteDomainModal domain -> do
+    H.modify_ _ { active_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_ _ { 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 newDomainForm._errors, 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 $ SystemLog $ "Add a new domain (" <> new_domain <> ")"
+        handleAction $ HandleNewDomainInput $ INP_newdomain ""
+      _, _ ->
+        H.raise $ Log $ UnableToSend $ "You didn't enter a valid new domain"
+
+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 <> [response.domain])
+      (DNSManager.MkDomainDeleted response) -> do
+        { my_domains } <- H.get
+        handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains
+      _ -> H.raise $ Log $ ErrorLog $ "Message not handled in DomainListInterface."
+    pure (Just a)
+
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    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 = response.my_domains
+         }
+    _ -> s1
+
+build_new_domain :: String -> String -> String
+build_new_domain sub tld
+  | endsWith "." sub = sub <> tld
+  | otherwise        = sub <> "." <> tld

src/App/HomeInterface.purs

@@ -0,0 +1,109 @@
+-- | `App.HomeInterface` presents the website and its features.
+module App.HomeInterface where
+
+import Prelude (Unit, pure, unit, ($))
+
+-- import Data.Either (Either(..))
+-- import Data.Maybe (Maybe(..), maybe)
+-- import Data.Tuple (Tuple(..))
+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 Bulma as Bulma
+
+type Input = Unit
+type Action = Unit
+type State = Unit
+
+data Query a = DoNothing a
+type Output = Unit
+type Slot = H.Slot Query Output
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        }
+    }
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction _ = pure unit
+
+initialState :: forall input. input -> State
+initialState _ = unit
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render _ = HH.div_
+             [ Bulma.hero_danger
+                 "THIS IS AN ALPHA RELEASE"
+                 "You can register, login and play a bit with the tool! Please, report errors and suggestions"
+             , Bulma.section_small
+                 [ Bulma.h1 "Welcome to netlib.re"
+                 , Bulma.subtitle "Free domain names"
+                 , Bulma.hr
+                 , render_description
+                 , render_second_line
+                 , render_why_and_contact
+                 , Bulma.hr
+                 , render_how_and_code
+                 ]
+             ]
+  where
+    title = Bulma.h3
+    p = Bulma.p
+    b x = Bulma.column_ [ Bulma.box x ]
+
+    render_description = Bulma.columns_ [ render_basics, render_no_expert ]
+    render_basics
+      = b [ title "What is provided?"
+          , p "Reserve a domain name in <something>.netlib.re for free."
+          , p "Manage your own DNS zone."
+          ]
+    render_no_expert
+      = b [ title "No need to be an expert!"
+          , p """
+              This website will help you through your configuration, as much as we can.
+              """
+          ]
+    render_second_line = Bulma.columns_ [ render_no_housing, render_updates ]
+    render_no_housing
+      = b [ title "No housing, just a name"
+          , p """
+              We don't provide housing for your services or websites,
+              just a name.
+              """
+          ]
+    render_updates
+      = b [ title "Automatic updates"
+          , p "Update your current address with a simple script."
+          ]
+
+    render_why_and_contact = Bulma.columns_ [ render_why, render_contact ]
+    render_why
+      = b [ title "Why?"
+          , p "Because everyone should be able to have a place on the Internet."
+          , p "We provide you a name, build something meaningful with it."
+          ]
+    render_contact
+      = b [ title "Contact"
+          , p "You have a question, you saw a bug or you just want to chat?"
+          , p "You can contact us: ..."
+          ]
+
+    render_how_and_code = Bulma.columns_ [ render_how, render_code ]
+    render_how
+      = b [ title "How does this work?"
+          , p "We pay for the domain names (netlib.re and codelib.re) and let you have a subdomain."
+          , p "This service helps you manage your domain (a subdomain of netlib.re or codelib.re)."
+          ]
+    render_code
+      = b [ title "I want to see the code!"
+          , p "The project is fully open-source (ISC licence)."
+          , p "There are 3 parts: libipc, micro-services (authentication and dnsmanager) and this website."
+          ]

src/App/Log.purs

@@ -0,0 +1,95 @@
+module App.Log where
+
+{- Simple log component, showing the current events. -}
+
+import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (-), (<), (<>))
+
+import Control.Monad.State (class MonadState)
+import Data.Array as A
+import Data.Maybe (Maybe(..))
+import Effect.Aff.Class (class MonadAff)
+import Halogen as H
+import Halogen.HTML as HH
+
+import App.LogMessage
+
+data Output = Void
+type Slot = H.Slot Query Output
+
+-- type Query :: forall k. k -> Type
+data Query a = Log LogMessage a
+
+type Input = Unit
+
+type Action = Unit
+
+type State =
+  { messages               :: Array String
+  , messageHistoryLength   :: Int
+  }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval { handleQuery  = handleQuery }
+    }
+
+initialState :: Input -> State
+initialState _ =
+  { messages: []
+  , messageHistoryLength: 10
+  }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { messages }
+    = HH.div_ [ render_messages ]
+    where
+      render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  Log message a -> do
+    case message of
+      SystemLog    str -> systemMessage str
+      UnableToSend str -> unableToSend str
+      ErrorLog     str -> errorMessage str
+      SuccessLog   str -> successMessage str
+    pure (Just a)
+
+
+type IncompleteState rows
+  = { messages :: Array String
+    , messageHistoryLength :: Int
+    | rows }
+
+-- Append a new message to the chat history.
+-- The number of displayed `messages` in the chat history (including system)
+-- is controlled by the `messageHistoryLength` field in the component `State`.
+appendMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
+appendMessage msg = do
+  histSize <- H.gets _.messageHistoryLength
+  H.modify_ \st -> st { messages = appendSingle histSize msg st.messages }
+  where
+  -- Limits the number of recent messages to `maxHist`
+  appendSingle :: Int -> String -> Array String -> Array String
+  appendSingle maxHist x xs
+    | A.length xs < maxHist = xs `A.snoc` x
+    | otherwise             = (A.takeEnd (maxHist-1) xs) `A.snoc` x
+
+-- Append a system message to the chat log.
+systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
+systemMessage msg = appendMessage ("[🤖] System: " <> msg)
+
+-- Append an error message to the chat log.
+errorMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
+errorMessage msg = appendMessage ("[🛑] Error: " <> msg)
+
+-- Append a success message to the chat log.
+successMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
+successMessage msg = appendMessage ("[🎉] " <> msg)
+
+-- A system message to use when a message cannot be sent.
+unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
+unableToSend reason = appendMessage ("[🛑] Unable to send. " <> reason)

src/App/LogMessage.purs

@@ -0,0 +1,7 @@
+module App.LogMessage where
+
+data LogMessage
+  = SystemLog String
+  | UnableToSend String
+  | ErrorLog String
+  | SuccessLog String

src/App/MailValidationInterface.purs

@@ -0,0 +1,197 @@
+-- | `App.MailValidationInterface` is a simple interface for mail verification.
+-- | A token is sent at registration at the provided email address.
+-- | This token has to be used to validate the email address.
+module App.MailValidationInterface where
+
+import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
+
+import Data.Array as A
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Either (Either(..))
+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 App.LogMessage
+import App.Messages.AuthenticationDaemon as AuthD
+
+import App.Validation.Login as L
+import App.Validation.Token as T
+
+data Output
+  = MessageToSend ArrayBuffer
+  | Log LogMessage
+
+-- | The component is informed when the connection went up or down.
+data Query a
+  = ConnectionIsDown a
+  | ConnectionIsUp a
+
+type Slot = H.Slot Query Output
+
+type Input = Unit
+
+data RegisterInput
+  = VALIDATION_INP_login String
+  | VALIDATION_INP_token String
+
+data Action
+  -- | Simply get the inputs from the form.
+  = HandleValidationInput RegisterInput
+  -- | Validate inputs (login, email, password) then send the request
+  -- | (via `SendMailValidationToken`) or log errors.
+  | ValidateInputs Event
+  -- | Send the registration request to `dnsmanagerd`.
+  -- | This action is automatically called from `ValidateInputs`.
+  | SendMailValidationToken
+
+-- | The possible errors come from either the login or token input.
+data Error
+  = Login (Array L.Error)
+  | Token (Array T.Error)
+
+-- | The whole mail validation form is composed of two strings: the login and the token.
+type MailValidationForm = { login :: String, token :: String }
+
+-- | State is composed of the registration form, the errors and an indication whether
+-- | the websocket connection with `authd` is up or not.
+type State =
+  { mailValidationForm :: MailValidationForm
+  , errors             :: Array Error
+  , wsUp               :: Boolean
+  }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        , handleQuery  = handleQuery
+        }
+    }
+
+initialState :: Input -> State
+initialState _ =
+  { mailValidationForm: { login: "", token: "" }
+  , errors: []
+  , wsUp: true
+  }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { wsUp, mailValidationForm }
+  = Bulma.section_small
+      [ case wsUp of
+          false -> Bulma.p "You are disconnected."
+          true  -> Bulma.columns_ [ b mail_validation_form ]
+      ]
+
+  where
+    b e = Bulma.column_ [ Bulma.box e ]
+    mail_validation_form = [ Bulma.h3 "Verify your account", render_register_form ]
+
+    should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
+
+    render_register_form = HH.form
+      [ HE.onSubmit ValidateInputs ]
+      [ Bulma.box_input "loginValidation" "Login" "login"   -- title, placeholder
+          (HandleValidationInput <<< VALIDATION_INP_login)  -- action
+          mailValidationForm.login                          -- value
+          should_be_disabled                                -- condition
+      , Bulma.box_input "tokenValidation" "Token" "token"   -- title, placeholder
+          (HandleValidationInput <<< VALIDATION_INP_token)  -- action
+          mailValidationForm.token                          -- value
+          should_be_disabled                                -- condition
+      , HH.div_
+          [ HH.button
+              [ HP.style "padding: 0.5rem 1.25rem;"
+              , HP.type_ HP.ButtonSubmit
+              , (if wsUp then (HP.enabled true) else (HP.disabled true))
+              ]
+              [ HH.text "Send Message to Server" ]
+          ]
+      ]
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  HandleValidationInput reginp -> do
+    case reginp of
+      VALIDATION_INP_login v -> H.modify_ _ { mailValidationForm { login = v } }
+      VALIDATION_INP_token v -> H.modify_ _ { mailValidationForm { token = v } }
+
+  -- Validate inputs (login, token) then send the request
+  -- (via SendMailValidationToken) or log errors.
+  ValidateInputs ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { mailValidationForm } <- H.get
+    let { login, token } = mailValidationForm
+
+    case login, token of
+      "", _ ->
+        H.raise $ Log $ UnableToSend "Write your login!"
+
+      _, "" ->
+        H.raise $ Log $ UnableToSend "Write your token!"
+
+      _, _ -> do
+        case L.login login, T.token token of
+          Left errors, _   -> H.raise $ Log $ UnableToSend $ show_error $ Login errors
+          _, Left errors   -> H.raise $ Log $ UnableToSend $ show_error $ Token errors
+          Right _, Right _ -> handleAction $ SendMailValidationToken
+
+  SendMailValidationToken -> do
+    { mailValidationForm } <- H.get
+    let { login, token } = mailValidationForm
+    message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user: login, activation_key: token }
+    H.raise $ MessageToSend message
+    H.raise $ Log $ SystemLog $ "Trying to validate email address of user \"" <> login <> "\""
+
+show_error :: Error -> String
+show_error = case _ of
+  Login    arr -> "Error with the Login: "    <> (A.fold $ map show_error_login arr)
+  Token arr -> "Error with the Token: " <> (A.fold $ map show_error_token arr)
+
+show_error_login :: L.Error -> String
+show_error_login = case _ of
+  L.ParsingError {error, position} ->
+    "position " <> show position <> " " <> maybe "" string_error_login error
+
+string_error_login :: L.LoginParsingError -> String
+string_error_login = case _ of
+  L.CannotParse         -> "cannot parse the login"
+  L.CannotEntirelyParse -> "cannot entirely parse the login"
+  L.Size min max n      -> "login size should be between "
+                           <> show min <> " and " <> show max
+                           <> " (currently: " <> show n <> ")"
+
+show_error_token :: T.Error -> String
+show_error_token = case _ of
+  T.ParsingError {error, position} ->
+    "position " <> show position <> " " <> maybe "" string_error_token error
+
+string_error_token :: T.TokenParsingError -> String
+string_error_token = case _ of
+  T.CannotParse         -> "cannot parse the token"
+  T.CannotEntirelyParse -> "cannot entirely parse the token"
+  T.Size min max n      -> "token size should be between "
+                           <> show min <> " and " <> show max
+                           <> " (currently: " <> show n <> ")"
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    pure (Just a)

src/App/MaintenanceSubject.purs

@@ -0,0 +1,21 @@
+module App.MaintenanceSubject where
+
+import Data.Codec.Argonaut as CA
+import Data.Maybe (Maybe(..))
+
+data MaintenanceSubject
+  = Verbosity
+
+-- | Codec for just encoding a single value of type `MaintenanceSubject`
+codec :: CA.JsonCodec MaintenanceSubject
+codec =
+  CA.prismaticCodec "MaintenanceSubject" from to CA.string
+  where
+    from :: String -> Maybe MaintenanceSubject
+    from = case _ of
+      "verbosity"  -> Just Verbosity
+      _ -> Nothing
+
+    to :: MaintenanceSubject -> String
+    to = case _ of
+      Verbosity  -> "verbosity"

src/App/Messages/AuthenticationDaemon.purs

@@ -60,19 +60,21 @@ codecRegister
       , email: CAR.optional Email.codec })
 
 {- 2  -}
-type ValidateUser = { user :: UserID, activation_key :: String }
+type ValidateUser = { user :: String, activation_key :: String }
 codecValidateUser ∷ CA.JsonCodec ValidateUser
 codecValidateUser
   = CA.object "ValidateUser" (CAR.record
-      { user: CA.int
+      { user: CA.string
       , activation_key: CA.string })
 
 {- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID,
          but they'll be used as login since the user has to type it. -}
 {- 3  -}
-type AskPasswordRecovery = { user :: String }
+type AskPasswordRecovery = { user :: Maybe String, email :: Maybe Email.Email }
 codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
-codecAskPasswordRecovery = CA.object "AskPasswordRecovery" (CAR.record { user: CA.string })
+codecAskPasswordRecovery
+  = CA.object "AskPasswordRecovery"
+      (CAR.record { user: CAR.optional CA.string, email: CAR.optional Email.codec })
 
 {- 4  -}
 type PasswordRecovery = { user               :: String
@@ -162,6 +164,16 @@ codecSearchUser
       { regex:  CAR.optional CA.string
       , offset: CAR.optional CA.int })
 
+{- 13 and 14: these messages are not designed for clients. -}
+{- 15 -}
+type AuthByToken = { token :: String }
+codecAuthByToken ∷ CA.JsonCodec AuthByToken
+codecAuthByToken = CA.object "AuthByToken" (CAR.record { token: CA.string })
+
+{- 250 -}
+type KeepAlive = { }
+codecKeepAlive ∷ CA.JsonCodec KeepAlive
+codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
 
 {-
 	RESPONSES
@@ -232,10 +244,9 @@ codecGotPermissionSet
       , permission: PermissionLevel.codec })
 
 {- 9  -}
-type PasswordRecoverySent = { user :: UserPublic.UserPublic }
+type PasswordRecoverySent = { }
 codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent
-codecGotPasswordRecoverySent
-  = CA.object "PasswordRecoverySent" (CAR.record { user: UserPublic.codec })
+codecGotPasswordRecoverySent = CA.object "PasswordRecoverySent" (CAR.record { })
 
 {- 10 -}
 type PasswordRecovered = { }
@@ -328,6 +339,11 @@ type ErrorInvalidRenewKey = {}
 codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey
 codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {})
 
+{- 250 -}
+-- type KeepAlive = { }
+codecGotKeepAlive ∷ CA.JsonCodec KeepAlive
+codecGotKeepAlive = CA.object "KeepAlive" (CAR.record { })
+
 -- All possible requests.
 data RequestMessage
   = MkLogin                Login                -- 0
@@ -344,6 +360,8 @@ data RequestMessage
   | MkCheckPermission      CheckPermission      -- 10
   | MkSetPermission        SetPermission        -- 11
   | MkSearchUser           SearchUser           -- 12
+  | MkAuthByToken          AuthByToken          -- 15
+  | MkKeepAlive            KeepAlive            -- 250
 
 -- All possible answers from the authentication daemon (authd).
 data AnswerMessage
@@ -375,25 +393,28 @@ data AnswerMessage
   | GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32
   | GotErrorCannotContactUser    ErrorCannotContactUser    -- 33
   | GotErrorInvalidRenewKey      ErrorInvalidRenewKey      -- 34
+  | GotKeepAlive                 KeepAlive                 -- 250
 
 encode ∷ RequestMessage -> Tuple UInt String
 encode m = case m of
-    (MkLogin                request) -> get_tuple 0  codecLogin request
-    (MkRegister             request) -> get_tuple 1  codecRegister request
-    (MkValidateUser         request) -> get_tuple 2  codecValidateUser request
+    (MkLogin                request) -> get_tuple 0  codecLogin               request
+    (MkRegister             request) -> get_tuple 1  codecRegister            request
+    (MkValidateUser         request) -> get_tuple 2  codecValidateUser        request
     (MkAskPasswordRecovery  request) -> get_tuple 3  codecAskPasswordRecovery request
-    (MkPasswordRecovery     request) -> get_tuple 4  codecPasswordRecovery request
+    (MkPasswordRecovery     request) -> get_tuple 4  codecPasswordRecovery    request
     -- Both messages are actually a single message type, so they have the same number.
     -- TODO: change the message codec for an Either Int String.
-    (MkGetUserByUID         request) -> get_tuple 5  codecGetUserByUID request
+    (MkGetUserByUID         request) -> get_tuple 5  codecGetUserByUID  request
     (MkGetUserByName        request) -> get_tuple 5  codecGetUserByName request
-    (MkModUser              request) -> get_tuple 6  codecModUser request
+    (MkModUser              request) -> get_tuple 6  codecModUser       request
     -- 7 MkEditProfileContent
-    (MkDeleteUser           request) -> get_tuple 8  codecDeleteUser request
-    (MkAddUser              request) -> get_tuple 9  codecAddUser request
-    (MkCheckPermission      request) -> get_tuple 10 codecCheckPermission request
-    (MkSetPermission        request) -> get_tuple 11 codecSetPermission request
-    (MkSearchUser           request) -> get_tuple 12 codecSearchUser request
+    (MkDeleteUser           request) -> get_tuple 8   codecDeleteUser      request
+    (MkAddUser              request) -> get_tuple 9   codecAddUser         request
+    (MkCheckPermission      request) -> get_tuple 10  codecCheckPermission request
+    (MkSetPermission        request) -> get_tuple 11  codecSetPermission   request
+    (MkSearchUser           request) -> get_tuple 12  codecSearchUser      request
+    (MkAuthByToken          request) -> get_tuple 15  codecAuthByToken     request
+    (MkKeepAlive            request) -> get_tuple 250 codecKeepAlive       request
     where
       get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
       get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
@@ -406,34 +427,35 @@ data DecodeError
 decode :: Int -> String -> Either DecodeError AnswerMessage
 decode number string
   = case number of
-    0  -> error_management codecGotError                     GotError
-    1  -> error_management codecGotToken                     GotToken
-    2  -> error_management codecGotUser                      GotUser
-    3  -> error_management codecGotUserAdded                 GotUserAdded
-    4  -> error_management codecGotUserEdited                GotUserEdited
-    5  -> error_management codecGotUserValidated             GotUserValidated
-    6  -> error_management codecGotUsersList                 GotUsersList
-    7  -> error_management codecGotPermissionCheck           GotPermissionCheck
-    8  -> error_management codecGotPermissionSet             GotPermissionSet
-    9  -> error_management codecGotPasswordRecoverySent      GotPasswordRecoverySent
-    10 -> error_management codecGotPasswordRecovered         GotPasswordRecovered
-    11 -> error_management codecGotMatchingUsers             GotMatchingUsers
-    12 -> error_management codecGotUserDeleted               GotUserDeleted
-    20 -> error_management codecGotErrorMustBeAuthenticated  GotErrorMustBeAuthenticated
-    21 -> error_management codecGotErrorAlreadyUsedLogin     GotErrorAlreadyUsedLogin
-    22 -> error_management codecGotErrorMailRequired         GotErrorMailRequired
-    23 -> error_management codecGotErrorUserNotFound         GotErrorUserNotFound
-    24 -> error_management codecGotErrorPasswordTooShort     GotErrorPasswordTooShort
-    25 -> error_management codecGotErrorInvalidCredentials   GotErrorInvalidCredentials
-    26 -> error_management codecGotErrorRegistrationsClosed  GotErrorRegistrationsClosed
-    27 -> error_management codecGotErrorInvalidLoginFormat   GotErrorInvalidLoginFormat
-    28 -> error_management codecGotErrorInvalidEmailFormat   GotErrorInvalidEmailFormat
-    29 -> error_management codecGotErrorAlreadyUsersInDB     GotErrorAlreadyUsersInDB
-    30 -> error_management codecGotErrorReadOnlyProfileKeys  GotErrorReadOnlyProfileKeys
-    31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
-    32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
-    33 -> error_management codecGotErrorCannotContactUser    GotErrorCannotContactUser
-    34 -> error_management codecGotErrorInvalidRenewKey      GotErrorInvalidRenewKey
+    0   -> error_management codecGotError                     GotError
+    1   -> error_management codecGotToken                     GotToken
+    2   -> error_management codecGotUser                      GotUser
+    3   -> error_management codecGotUserAdded                 GotUserAdded
+    4   -> error_management codecGotUserEdited                GotUserEdited
+    5   -> error_management codecGotUserValidated             GotUserValidated
+    6   -> error_management codecGotUsersList                 GotUsersList
+    7   -> error_management codecGotPermissionCheck           GotPermissionCheck
+    8   -> error_management codecGotPermissionSet             GotPermissionSet
+    9   -> error_management codecGotPasswordRecoverySent      GotPasswordRecoverySent
+    10  -> error_management codecGotPasswordRecovered         GotPasswordRecovered
+    11  -> error_management codecGotMatchingUsers             GotMatchingUsers
+    12  -> error_management codecGotUserDeleted               GotUserDeleted
+    20  -> error_management codecGotErrorMustBeAuthenticated  GotErrorMustBeAuthenticated
+    21  -> error_management codecGotErrorAlreadyUsedLogin     GotErrorAlreadyUsedLogin
+    22  -> error_management codecGotErrorMailRequired         GotErrorMailRequired
+    23  -> error_management codecGotErrorUserNotFound         GotErrorUserNotFound
+    24  -> error_management codecGotErrorPasswordTooShort     GotErrorPasswordTooShort
+    25  -> error_management codecGotErrorInvalidCredentials   GotErrorInvalidCredentials
+    26  -> error_management codecGotErrorRegistrationsClosed  GotErrorRegistrationsClosed
+    27  -> error_management codecGotErrorInvalidLoginFormat   GotErrorInvalidLoginFormat
+    28  -> error_management codecGotErrorInvalidEmailFormat   GotErrorInvalidEmailFormat
+    29  -> error_management codecGotErrorAlreadyUsersInDB     GotErrorAlreadyUsersInDB
+    30  -> error_management codecGotErrorReadOnlyProfileKeys  GotErrorReadOnlyProfileKeys
+    31  -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
+    32  -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
+    33  -> error_management codecGotErrorCannotContactUser    GotErrorCannotContactUser
+    34  -> error_management codecGotErrorInvalidRenewKey      GotErrorInvalidRenewKey
+    250 -> error_management codecGotKeepAlive                 GotKeepAlive
     _  -> Left UnknownNumber
   where
     -- Signature is required since the compiler's guess is wrong.

src/App/Messages/DNSManagerDaemon.purs

@@ -0,0 +1,390 @@
+module App.Messages.DNSManagerDaemon where
+
+import Prelude (bind, pure, show, ($))
+
+import Effect (Effect)
+
+import Data.Argonaut.Core as J
+import Data.Codec.Argonaut as CA
+import Data.Maybe (Maybe)
+import Data.Either (Either(..))
+import Data.Codec.Argonaut.Record as CAR
+import Data.UInt (fromInt, toInt, UInt)
+
+import Data.Tuple (Tuple(..))
+import Data.ArrayBuffer.Types (ArrayBuffer)
+
+-- import App.PermissionLevel as PermissionLevel
+import App.MaintenanceSubject as MaintenanceSubject
+
+import Effect.Class (liftEffect)
+import Data.Argonaut.Parser as JSONParser
+import Data.Bifunctor (lmap)
+
+import App.IPC as IPC
+import App.DNSZone as DNSZone
+import App.ResourceRecord as ResourceRecord
+
+{- UserID should be in a separate module with a dedicated codec. -}
+type UserID = Int -- UserID is either a login or an uid number
+
+
+{- 0  -}
+type Login = { token :: String }
+codecLogin ∷ CA.JsonCodec Login
+codecLogin = CA.object "Login" (CAR.record { token: CA.string })
+
+{- 7  -}
+type Maintenance = { subject :: MaintenanceSubject.MaintenanceSubject
+                   , int :: Maybe Int
+                   , string :: Maybe String
+                   }
+codecMaintenance ∷ CA.JsonCodec Maintenance
+codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec
+                                                       , int: CAR.optional CA.int
+                                                       , string: CAR.optional CA.string
+                                                       })
+
+{- 9  -}
+type NewDomain = { domain :: String }
+codecNewDomain ∷ CA.JsonCodec NewDomain
+codecNewDomain = CA.object "NewDomain" (CAR.record { domain: CA.string })
+
+{- 10  -}
+type DeleteDomain = { domain :: String }
+codecDeleteDomain ∷ CA.JsonCodec DeleteDomain
+codecDeleteDomain = CA.object "DeleteDomain" (CAR.record { domain: CA.string })
+
+{- 11  -}
+type AddOrUpdateZone = { zone :: DNSZone.DNSZone }
+codecAddOrUpdateZone ∷ CA.JsonCodec AddOrUpdateZone
+codecAddOrUpdateZone = CA.object "AddOrUpdateZone" (CAR.record { zone: DNSZone.codec })
+
+{- 12  -}
+type GetZone = { domain :: String }
+codecGetZone ∷ CA.JsonCodec GetZone
+codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string })
+
+{- 13  -}
+type UserDomains = {}
+codecUserDomains ∷ CA.JsonCodec UserDomains
+codecUserDomains = CA.object "UserDomains" (CAR.record {})
+
+{- 14  -}
+type AddRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
+codecAddRR ∷ CA.JsonCodec AddRR
+codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
+
+{- 15  -}
+type UpdateRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
+codecUpdateRR ∷ CA.JsonCodec UpdateRR
+codecUpdateRR = CA.object "UpdateRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
+
+{- 16  -}
+type DeleteRR = { domain :: String, rrid :: Int }
+codecDeleteRR ∷ CA.JsonCodec DeleteRR
+codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int })
+
+{- 17  -}
+type AskGeneratedZoneFile = { domain :: String }
+codecAskGeneratedZoneFile ∷ CA.JsonCodec AskGeneratedZoneFile
+codecAskGeneratedZoneFile = CA.object "AskGeneratedZoneFile" (CAR.record { domain: CA.string })
+
+{- 100 -}
+type GenerateAllZoneFiles = {}
+codecGenerateAllZoneFiles ∷ CA.JsonCodec GenerateAllZoneFiles
+codecGenerateAllZoneFiles = CA.object "GenerateAllZoneFiles" (CAR.record {})
+
+{- 101 -}
+type GenerateZoneFile = { domain :: String }
+codecGenerateZoneFile ∷ CA.JsonCodec GenerateZoneFile
+codecGenerateZoneFile = CA.object "GenerateZoneFile" (CAR.record { domain: CA.string })
+
+{- 250 -}
+type KeepAlive = { }
+codecKeepAlive ∷ CA.JsonCodec KeepAlive
+codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
+
+{-
+	RESPONSES
+-}
+
+{- 0  -}
+-- type Error = { reason :: String | Array(String) }
+type Error = { reason :: String }
+codecError ∷ CA.JsonCodec Error
+codecError = CA.object "Error" (CAR.record { reason: CA.string })
+
+{- 1  -}
+type Success = { }
+codecSuccess ∷ CA.JsonCodec Success
+codecSuccess = CA.object "Success" (CAR.record { })
+
+{- 2  -}
+type ErrorInvalidToken = { }
+codecErrorInvalidToken ∷ CA.JsonCodec ErrorInvalidToken
+codecErrorInvalidToken = CA.object "ErrorInvalidToken" (CAR.record { })
+
+{- 3  -}
+type DomainAlreadyExists = { }
+codecDomainAlreadyExists ∷ CA.JsonCodec DomainAlreadyExists
+codecDomainAlreadyExists = CA.object "DomainAlreadyExists" (CAR.record { })
+
+{- 4  -}
+type ErrorUserNotLogged = { }
+codecErrorUserNotLogged ∷ CA.JsonCodec ErrorUserNotLogged
+codecErrorUserNotLogged = CA.object "ErrorUserNotLogged" (CAR.record { })
+
+{- 5  -}
+type DomainNotFound = { }
+codecDomainNotFound :: CA.JsonCodec DomainNotFound
+codecDomainNotFound = CA.object "DomainNotFound" (CAR.record { })
+
+{- 6  -}
+type RRNotFound = { }
+codecRRNotFound :: CA.JsonCodec RRNotFound
+codecRRNotFound = CA.object "RRNotFound" (CAR.record { })
+
+{- 7  -}
+type UnacceptableDomain = { }
+codecUnacceptableDomain :: CA.JsonCodec UnacceptableDomain
+codecUnacceptableDomain = CA.object "UnacceptableDomain" (CAR.record { })
+
+{- 8  -}
+type InvalidDomainName = { }
+codecInvalidDomainName :: CA.JsonCodec InvalidDomainName
+codecInvalidDomainName = CA.object "InvalidDomainName" (CAR.record { })
+
+{- 9  -}
+type DomainDeleted = { domain :: String }
+codecDomainDeleted :: CA.JsonCodec DomainDeleted
+codecDomainDeleted = CA.object "DomainDeleted" (CAR.record { domain: CA.string })
+
+{- 10  -}
+-- For now, Error is just an alias on String.
+-- type InvalidZone = { errors : Array(Storage::Zone::Error) }
+type InvalidZone = { errors :: Array String }
+codecInvalidZone ∷ CA.JsonCodec InvalidZone
+codecInvalidZone = CA.object "InvalidZone" (CAR.record { errors: CA.array CA.string })
+
+{- 11  -}
+type DomainChanged = { }
+codecDomainChanged ∷ CA.JsonCodec DomainChanged
+codecDomainChanged = CA.object "DomainChanged" (CAR.record { })
+
+{- 12  -}
+type Zone = { zone :: DNSZone.DNSZone }
+codecZone ∷ CA.JsonCodec Zone
+codecZone = CA.object "Zone" (CAR.record { zone: DNSZone.codec })
+
+{- 13  -}
+type UnknownZone = { }
+codecUnknownZone ∷ CA.JsonCodec UnknownZone
+codecUnknownZone = CA.object "UnknownZone" (CAR.record { })
+
+{- 14  -}
+type DomainList = { domains :: Array String }
+codecDomainList ∷ CA.JsonCodec DomainList
+codecDomainList = CA.object "DomainList" (CAR.record { domains: CA.array CA.string })
+
+{- 15  -}
+type AcceptedDomains = { domains :: Array String }
+codecAcceptedDomains ∷ CA.JsonCodec AcceptedDomains
+codecAcceptedDomains = CA.object "AcceptedDomains" (CAR.record { domains: CA.array CA.string })
+
+{- 16  -}
+type Logged = { accepted_domains :: Array String, my_domains :: Array String }
+codecLogged ∷ CA.JsonCodec Logged
+codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string
+                                             ,       my_domains: CA.array CA.string })
+
+{- 17  -}
+type DomainAdded = { domain :: String }
+codecDomainAdded ∷ CA.JsonCodec DomainAdded
+codecDomainAdded = CA.object "DomainAdded" (CAR.record { domain: CA.string })
+
+{- 18  -}
+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 })
+
+{- 20  -}
+-- For now, Error is just an alias on String.
+-- type InvalidZone = { errors : Array(Storage::Zone::Error) }
+type InvalidRR = { errors :: Array String }
+codecInvalidRR ∷ CA.JsonCodec InvalidRR
+codecInvalidRR = CA.object "InvalidRR" (CAR.record { errors: CA.array CA.string })
+
+{- 21  -}
+type RRUpdated = { domain :: String, rr :: ResourceRecord.ResourceRecord }
+codecRRUpdated ∷ CA.JsonCodec RRUpdated
+codecRRUpdated = CA.object "RRUpdated" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
+
+{- 22  -}
+type RRReadOnly = { domain :: String, rr :: ResourceRecord.ResourceRecord }
+codecRRReadOnly ∷ CA.JsonCodec RRReadOnly
+codecRRReadOnly = CA.object "RRReadOnly" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
+
+{- 23  -}
+type GeneratedZoneFile = { domain :: String, zonefile :: String }
+codecGeneratedZoneFile ∷ CA.JsonCodec GeneratedZoneFile
+codecGeneratedZoneFile = CA.object "GeneratedZoneFile" (CAR.record { domain: CA.string, zonefile: CA.string })
+
+{- 50  -}
+type UnknownUser = { }
+codecUnknownUser ∷ CA.JsonCodec UnknownUser
+codecUnknownUser = CA.object "UnknownUser" (CAR.record { })
+
+{- 51  -}
+type NoOwnership = { }
+codecNoOwnership ∷ CA.JsonCodec NoOwnership
+codecNoOwnership = CA.object "NoOwnership" (CAR.record { })
+
+{- 52  -}
+type InsufficientRights = { }
+codecInsufficientRights ∷ CA.JsonCodec InsufficientRights
+codecInsufficientRights = CA.object "InsufficientRights" (CAR.record { })
+
+{- 250 -}
+--type KeepAlive = { }
+--codecKeepAlive ∷ CA.JsonCodec KeepAlive
+--codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
+
+
+-- All possible requests.
+data RequestMessage
+  = MkLogin                Login                -- 0
+  | MkMaintenance          Maintenance          -- 7
+  | MkNewDomain            NewDomain            -- 9
+  | MkDeleteDomain         DeleteDomain         -- 10
+  | MkAddOrUpdateZone      AddOrUpdateZone      -- 11
+  | MkGetZone              GetZone              -- 12
+  | MkUserDomains          UserDomains          -- 13
+  | MkAddRR                AddRR                -- 14
+  | MkUpdateRR             UpdateRR             -- 15
+  | MkDeleteRR             DeleteRR             -- 16
+  | MkAskGeneratedZoneFile AskGeneratedZoneFile -- 17
+  | MkGenerateAllZoneFiles GenerateAllZoneFiles -- 100
+  | MkGenerateZoneFile     GenerateZoneFile     -- 101
+  | MkKeepAlive            KeepAlive            -- 250
+
+-- All possible answers from the authentication daemon (authd).
+data AnswerMessage
+  = MkError               Error               -- 0
+  | MkSuccess             Success             -- 1
+  | MkErrorInvalidToken   ErrorInvalidToken   -- 2
+  | MkDomainAlreadyExists DomainAlreadyExists -- 3
+  | MkErrorUserNotLogged  ErrorUserNotLogged  -- 4
+  | MkDomainNotFound      DomainNotFound      -- 5
+  | MkRRNotFound          RRNotFound          -- 6
+  | MkUnacceptableDomain  UnacceptableDomain  -- 7
+  | MkInvalidDomainName   InvalidDomainName   -- 8
+  | MkDomainDeleted       DomainDeleted       -- 9
+  | MkInvalidZone         InvalidZone         -- 10
+  | MkDomainChanged       DomainChanged       -- 11
+  | MkZone                Zone                -- 12
+  | MkUnknownZone         UnknownZone         -- 13
+  | MkDomainList          DomainList          -- 14
+  | MkAcceptedDomains     AcceptedDomains     -- 15
+  | MkLogged              Logged              -- 16
+  | MkDomainAdded         DomainAdded         -- 17
+  | MkRRDeleted           RRDeleted           -- 18
+  | MkRRAdded             RRAdded             -- 19
+  | MkInvalidRR           InvalidRR           -- 20
+  | MkRRUpdated           RRUpdated           -- 21
+  | MkRRReadOnly          RRReadOnly          -- 22
+  | MkGeneratedZoneFile   GeneratedZoneFile   -- 23
+  | MkUnknownUser         UnknownUser         -- 50
+  | MkNoOwnership         NoOwnership         -- 51
+  | MkInsufficientRights  InsufficientRights  -- 52
+  | GotKeepAlive          KeepAlive           -- 250
+
+encode ∷ RequestMessage -> Tuple UInt String
+encode m = case m of
+    (MkLogin                request) -> get_tuple 0   codecLogin                request
+    (MkMaintenance          request) -> get_tuple 7   codecMaintenance          request
+    (MkNewDomain            request) -> get_tuple 9   codecNewDomain            request
+    (MkDeleteDomain         request) -> get_tuple 10  codecDeleteDomain         request
+    (MkAddOrUpdateZone      request) -> get_tuple 11  codecAddOrUpdateZone      request
+    (MkGetZone              request) -> get_tuple 12  codecGetZone              request
+    (MkUserDomains          request) -> get_tuple 13  codecUserDomains          request
+    (MkAddRR                request) -> get_tuple 14  codecAddRR                request
+    (MkUpdateRR             request) -> get_tuple 15  codecUpdateRR             request
+    (MkDeleteRR             request) -> get_tuple 16  codecDeleteRR             request
+    (MkAskGeneratedZoneFile request) -> get_tuple 17  codecAskGeneratedZoneFile request
+    (MkGenerateAllZoneFiles request) -> get_tuple 100 codecGenerateAllZoneFiles request
+    (MkGenerateZoneFile     request) -> get_tuple 101 codecGenerateZoneFile     request
+    (MkKeepAlive            request) -> get_tuple 250 codecKeepAlive            request
+  where
+    get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
+    get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
+
+data DecodeError
+  = JSONERROR String
+  | UnknownError String
+  | UnknownNumber
+
+decode :: Int -> String -> Either DecodeError AnswerMessage
+decode number string
+  = case number of
+    0   -> error_management codecError               MkError
+    1   -> error_management codecSuccess             MkSuccess
+    2   -> error_management codecErrorInvalidToken   MkErrorInvalidToken
+    3   -> error_management codecDomainAlreadyExists MkDomainAlreadyExists
+    4   -> error_management codecErrorUserNotLogged  MkErrorUserNotLogged
+    5   -> error_management codecDomainNotFound      MkDomainNotFound
+    6   -> error_management codecRRNotFound          MkRRNotFound
+    7   -> error_management codecUnacceptableDomain  MkUnacceptableDomain
+    8   -> error_management codecInvalidDomainName   MkInvalidDomainName
+    9   -> error_management codecDomainDeleted       MkDomainDeleted
+    10  -> error_management codecInvalidZone         MkInvalidZone
+    11  -> error_management codecDomainChanged       MkDomainChanged
+    12  -> error_management codecZone                MkZone
+    13  -> error_management codecUnknownZone         MkUnknownZone
+    14  -> error_management codecDomainList          MkDomainList
+    15  -> error_management codecAcceptedDomains     MkAcceptedDomains
+    16  -> error_management codecLogged              MkLogged
+    17  -> error_management codecDomainAdded         MkDomainAdded
+    18  -> error_management codecRRDeleted           MkRRDeleted
+    19  -> error_management codecRRAdded             MkRRAdded
+    20  -> error_management codecInvalidRR           MkInvalidRR
+    21  -> error_management codecRRUpdated           MkRRUpdated
+    22  -> error_management codecRRReadOnly          MkRRReadOnly
+    23  -> error_management codecGeneratedZoneFile   MkGeneratedZoneFile
+    50  -> error_management codecUnknownUser         MkUnknownUser
+    51  -> error_management codecNoOwnership         MkNoOwnership
+    52  -> error_management codecInsufficientRights  MkInsufficientRights
+    250 -> error_management codecKeepAlive           GotKeepAlive
+    _  -> Left UnknownNumber
+  where
+    -- Signature is required since the compiler's guess is wrong.
+    error_management :: forall a. CA.JsonCodec a -> (a -> AnswerMessage) -> Either DecodeError AnswerMessage
+    error_management codec f
+      = case (parseDecodeJSON codec string) of
+          (Left err) -> Left (JSONERROR err)
+          (Right v)  -> Right (f v)
+
+parseDecodeJSON :: forall a. CA.JsonCodec a -> String -> Either String a
+parseDecodeJSON codec str = do
+  json <- JSONParser.jsonParser str
+  lmap CA.printJsonDecodeError (CA.decode codec json)
+
+serialize :: RequestMessage -> Effect ArrayBuffer
+serialize request
+  = case (encode request) of
+    (Tuple messageTypeNumber string) -> IPC.toTypedIPC messageTypeNumber string
+
+deserialize :: ArrayBuffer -> Effect (Either DecodeError AnswerMessage)
+deserialize arraybuffer
+  = do
+    value <- liftEffect $ IPC.fromTypedIPC arraybuffer
+    pure $ case (value) of
+      Left err -> Left (UnknownError $ show err)
+      Right (Tuple messageTypeNumber string) -> case (decode (toInt messageTypeNumber) string) of
+        Left parsingError -> Left parsingError
+        Right answerMessage -> Right answerMessage

src/App/NavigationInterface.purs

@@ -0,0 +1,195 @@
+-- | `App.NavigationInterface` is the navbar module.
+-- |
+-- | This module is required since some javascript is needed to toggle display of hidden resources.
+-- | On mobile, a burger menu is displayed and hides the navigation buttons.
+-- | On desktop, there is no need for this, all the navigation buttons are displayed by default.
+module App.NavigationInterface where
+
+import Prelude (Unit, (<>), not, ($), discard, pure)
+
+-- import Data.Array as A
+import Data.Maybe (Maybe(..))
+-- import Data.Either (Either(..))
+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 Halogen.HTML.Properties.ARIA as ARIA
+
+import CSSClasses as C
+import Bulma as Bulma
+
+import App.Pages (Page(..))
+import App.LogMessage (LogMessage)
+
+data Output
+  = Log LogMessage
+  -- | Once someone clicks on a routing button, `App.Container` needs to know.
+  | Routing Page
+  -- | Once someone clicks on a the Disconnection button, `App.Container` needs to know.
+  | Disconnection
+
+-- | The component needs to know when the user is logged or not.
+data Query a = ToggleLogged Boolean a
+
+type Slot = H.Slot Query Output
+
+type Input = Unit
+
+data Action
+  -- | `ToggleMenu`: display or hide the content of the burger menu.
+  = ToggleMenu
+  -- | The navigation interface must be informed when the client wants to change page.
+  -- | The request will be propagated to the parent (`App.Container`).
+  -- | (`Navigate` is `App.Container.Routing`)
+  | Navigate Page
+  -- | The navigation interface must be informed when the client wants to disconnect.
+  -- | The request will be propagated to the parent (`App.Container`).
+  -- | (`UnLog` is `App.Container.Disconnection`)
+  | UnLog
+
+-- | State is composed of:
+-- | - `logged`, a boolean to toggle the display of some parts of the menu.
+-- | - `active`, a boolean to toggle the display of the menu.
+-- | - `admin`, a boolean to toggle the display of administration page link.
+type State = { logged :: Boolean, active :: Boolean, admin :: Boolean }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval { handleAction = handleAction
+                                     , handleQuery = handleQuery
+                                     }
+    }
+
+initialState :: Input -> State
+initialState _ = { logged: false, active: false, admin: true }
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  ToggleMenu -> H.modify_ \state -> state { active = not state.active }
+  -- | Page change.
+  Navigate page -> H.raise $ Routing page
+  UnLog         -> do
+    H.raise $ Disconnection
+    H.modify_ _ { logged = false }
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  ToggleLogged islogged a -> do
+    H.modify_ _ { logged = islogged }
+    pure (Just a)
+
+
+-- | The navigation bar is a complex component to render.
+-- | The component changes when the user is authenticated.
+-- | A button has to appear for administrators.
+-- |
+-- | On mobile (a device with low resolution), a `burger icon` appears instead of the navigation bar.
+-- | When clicked, a list of options (such as pages or a disconnection button) should appear.
+-- | Also, when clicked again, the list disappears.
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { logged, active, admin } =
+  main_nav
+    [ nav_brand [ logo, burger_menu ]
+    , nav_menu
+        [ navbar_start left_bar_div
+        , navbar_end   right_bar_div
+        ]
+    ]
+
+  where
+  left_bar_div =
+    case logged, admin of
+      false, _ -> [ link_home,                                 code_dropdown ]
+      _, false -> [ link_home, link_domains,                   code_dropdown ]
+      _, _     -> [ link_home, link_domains, link_authd_admin, code_dropdown ]
+
+  right_bar_div =
+    case logged of
+        false -> [ link_auth, link_register, link_mail_validation ]
+        _     -> [ link_setup, link_disconnection ]
+
+  navbar_color = C.is_success
+
+  main_nav =
+    HH.nav [ HP.classes $ C.navbar <> navbar_color
+           , ARIA.label "main navigation"
+           , ARIA.role "navigation"
+           ]
+
+  logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🔻🍉"]
+  --  HH.a [HP.classes C.navbar_item, HP.href "/"]
+  --       [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]]
+
+  burger_menu =
+    HH.a [ HP.classes $ C.navbar_burger <> if active then C.is_active else []
+         , ARIA.label "menu"
+         , ARIA.expanded "false"
+         , Bulma.data_target "navbar-netlibre"
+         , HE.onClick (\_ -> ToggleMenu)
+         ] [ HH.span [ARIA.hidden "true"] []
+           , HH.span [ARIA.hidden "true"] []
+           , HH.span [ARIA.hidden "true"] []
+           ]
+
+  nav_brand = HH.div [HP.classes C.navbar_brand]
+  nav_menu = HH.div
+    [ HP.id "navbar-netlibre"
+    , HP.classes $ C.navbar_menu <> C.is_spaced <> if active then C.is_active else []
+    ]
+
+  navbar_start = HH.div [HP.classes C.navbar_start]
+  navbar_end = HH.div [HP.classes C.navbar_end]
+
+  link_home            = nav_link        "Home"              (Navigate Home)
+  link_domains         = nav_link        "Domains"           (Navigate DomainList)
+  link_authd_admin     = nav_link        "Admin"             (Navigate Administration)
+  link_auth            = nav_link        "Login"             (Navigate Authentication)
+  link_register        = nav_link_strong "Register"          (Navigate Registration)
+  link_mail_validation = nav_link        "Mail verification" (Navigate MailValidation)
+  link_setup           = nav_link_warn   "⚒ Setup"           (Navigate Setup)
+  link_disconnection   =
+    nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog
+
+  dropdown title dropdown_elements
+    = HH.div [HP.classes $ C.navbar_item <> C.has_dropdown <> C.is_hoverable]
+        [ dropdown_title title, HH.div [HP.classes C.navbar_dropdown] dropdown_elements ]
+  dropdown_title str = HH.a [HP.classes C.navbar_link] [HH.text str]
+  dropdown_element link str = HH.a [HP.classes C.navbar_item, HP.href link] [HH.text str]
+  dropdown_separator = HH.hr [HP.classes C.navbar_divider]
+
+  nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ])
+  nav_button classes str action = btn classes action (HH.text str)
+
+  nav_link_strong str action =
+    HH.a [ HP.classes (C.navbar_item <> C.is_danger <> C.has_background_success_dark)
+         , HE.onClick (\_ -> action)
+         ] [ (HH.strong [] [ HH.text str ]) ]
+
+  nav_link str action = nav_link_ navbar_color str action
+  nav_link_warn str action = nav_link_ (C.has_background_warning <> C.has_text_dark) str action
+
+  nav_link_ classes str action =
+    HH.a [ HP.classes (C.navbar_item <> classes)
+         , HE.onClick (\_ -> action)
+         ] [ (HH.text str) ]
+
+  code_dropdown =
+    dropdown "Source code"
+      [ dropdown_element "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
+      , dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager server"
+      , dropdown_separator
+      , dropdown_element
+          "https://git.baguette.netlib.re/karchnu/halogen-websocket-ipc-playzone/src/branch/dev"
+          "(temporary repo) dnsmanager website"
+      ]
+
+  btn c action str
+    = HH.a [ HP.classes (C.navbar_item <> C.button <> c)
+           , HE.onClick (\_ -> action)
+           ] [ str ]

src/App/Pages.purs

@@ -0,0 +1,13 @@
+module App.Pages where
+-- | This list will grow in a near future.
+-- |
+-- | TODO: 
+data Page
+  = Home           -- | `Home`: presentation of the project.
+  | Authentication -- | `Authentication`: authentication page.
+  | Registration   -- | `Registration`: to register new people.
+  | MailValidation -- | `MailValidation`: to validate email addresses (via a token).
+  | DomainList     -- | `DomainList`: to list owned domains and to ask for new domains.
+  | Zone String    -- | `Zone`: to manage a zone.
+  | Setup          -- | `Setup`: user account administration page
+  | Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).

src/App/RegistrationInterface.purs

@@ -0,0 +1,226 @@
+-- | `App.RegistrationInterface` is a registration interface.
+-- | Registration requires a login, an email address and a password.
+module App.RegistrationInterface where
+
+import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
+
+import Data.Array as A
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Maybe (Maybe(..), maybe)
+import Data.Either (Either(..))
+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 App.Email as Email
+import App.LogMessage
+import App.Messages.AuthenticationDaemon as AuthD
+
+import App.Validation.Login as L
+import App.Validation.Email as E
+import App.Validation.Password as P
+
+data Output
+  = MessageToSend ArrayBuffer
+  | Log LogMessage
+
+-- | The component is informed when the connection went up or down.
+data Query a
+  = ConnectionIsDown a
+  | ConnectionIsUp a
+
+type Slot = H.Slot Query Output
+
+type Input = Unit
+
+data RegisterInput
+  = REG_INP_login String
+  | REG_INP_email String
+  | REG_INP_pass String
+
+data Action
+  -- | Simply get the inputs from the form.
+  = HandleRegisterInput RegisterInput
+  -- | Validate inputs (login, email, password) then send the request
+  -- | (via `SendRegistrationRequest`) or log errors.
+  | ValidateInputs Event
+  -- | Send the registration request to `dnsmanagerd`.
+  -- | This action is automatically called from `ValidateInputs`.
+  | SendRegistrationRequest
+
+-- | The possible errors come from either the login, email or password input.
+data Error
+  = Login    (Array L.Error)
+  | Email    (Array E.Error)
+  | Password (Array P.Error)
+
+-- | The whole registration form is composed of three strings: login, email and password.
+type StateRegistrationForm = { login :: String, email :: String, pass :: String }
+
+-- | State is composed of the registration form, the errors and an indication whether
+-- | the websocket connection with `authd` is up or not.
+type State =
+  { registrationForm :: StateRegistrationForm
+  , errors           :: Array Error
+  , wsUp             :: Boolean
+  }
+
+initialState :: Input -> State
+initialState _ =
+  { registrationForm: { login: "", email: "", pass: "" }
+  , errors: []
+  , wsUp: true
+  }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        , handleQuery  = handleQuery
+        }
+    }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { wsUp, registrationForm }
+  = Bulma.section_small
+      [ case wsUp of
+          false -> Bulma.p "You are disconnected."
+          true  -> Bulma.columns_ [ b registration_form ]
+      ]
+
+  where
+    b e = Bulma.column_ [ Bulma.box e ]
+    registration_form = [ Bulma.h3 "Register!", render_register_form ]
+
+    should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
+
+    render_register_form = HH.form
+      [ HE.onSubmit ValidateInputs ]
+      [ Bulma.box_input "loginREGISTER" "Login" "login"                -- title, placeholder
+          (HandleRegisterInput <<< REG_INP_login)      -- action
+          registrationForm.login                       -- value
+          should_be_disabled                           -- condition
+      , Bulma.box_input "emailREGISTER" "Email" "email@example.com"    -- title, placeholder
+          (HandleRegisterInput <<< REG_INP_email)      -- action
+          registrationForm.email                       -- value
+          should_be_disabled                           -- condition
+      , Bulma.box_password "passwordREGISTER" "Password" "password"       -- title, placeholder
+          (HandleRegisterInput <<< REG_INP_pass)       -- action
+          registrationForm.pass                        -- value
+          should_be_disabled                           -- condition
+      , HH.div_
+          [ HH.button
+              [ HP.style "padding: 0.5rem 1.25rem;"
+              , HP.type_ HP.ButtonSubmit
+              , (if wsUp then (HP.enabled true) else (HP.disabled true))
+              ]
+              [ HH.text "Send Message to Server" ]
+          ]
+      ]
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  HandleRegisterInput reginp -> do
+    case reginp of
+      REG_INP_login v -> H.modify_ _ { registrationForm { login = v } }
+      REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
+      REG_INP_pass  v -> H.modify_ _ { registrationForm { pass  = v } }
+
+  -- Validate inputs (login, email, password) then send the request
+  -- (via SendRegistrationRequest) or log errors.
+  ValidateInputs ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { registrationForm } <- H.get
+    let login = registrationForm.login
+        email = registrationForm.email
+        pass  = registrationForm.pass
+
+    case login, email, pass of
+      "", _, _ ->
+        H.raise $ Log $ UnableToSend "Write your login!"
+
+      _, "", _ ->
+        H.raise $ Log $ UnableToSend "Write your email!"
+
+      _, _, "" ->
+        H.raise $ Log $ UnableToSend "Write your password!"
+
+      _, _, _ -> do
+        case L.login login, E.email email, P.password pass of
+          Left errors, _, _         -> H.raise $ Log $ UnableToSend $ show_error $ Login errors
+          _, Left errors, _         -> H.raise $ Log $ UnableToSend $ show_error $ Email errors
+          _, _, Left errors         -> H.raise $ Log $ UnableToSend $ show_error $ Password errors
+          Right _, Right _, Right _ -> handleAction $ SendRegistrationRequest
+
+  SendRegistrationRequest -> do
+    { registrationForm } <- H.get
+    let { login, email, pass } = registrationForm
+    message <- H.liftEffect $ AuthD.serialize $
+      AuthD.MkRegister { login, email: Just (Email.Email email), password: pass }
+    H.raise $ MessageToSend message
+    H.raise $ Log $ SystemLog $ "Trying to register (login: " <> login <> ")"
+
+show_error :: Error -> String
+show_error = case _ of
+  Login    arr -> "Error with the Login: "    <> (A.fold $ map show_error_login arr)
+  Email    arr -> "Error with the Email: "    <> (A.fold $ map show_error_email arr)
+  Password arr -> "Error with the Password: " <> (A.fold $ map show_error_password arr)
+
+show_error_login :: L.Error -> String
+show_error_login = case _ of
+  L.ParsingError {error, position} ->
+    "position " <> show position <> " " <> maybe "" string_error_login error
+
+string_error_login :: L.LoginParsingError -> String
+string_error_login = case _ of
+  L.CannotParse         -> "cannot parse the login"
+  L.CannotEntirelyParse -> "cannot entirely parse the login"
+  L.Size min max n      -> "login size should be between "
+                           <> show min <> " and " <> show max
+                           <> " (currently: " <> show n <> ")"
+
+show_error_email :: E.Error -> String
+show_error_email = case _ of
+  E.ParsingError {error, position} ->
+    "position " <> show position <> " " <> maybe "" string_error_email error
+
+string_error_email :: E.EmailParsingError -> String
+string_error_email = case _ of
+  E.CannotParse         -> "cannot parse the email"
+  E.CannotEntirelyParse -> "cannot entirely parse the email"
+  E.Size min max n      -> "email size should be between "
+                           <> show min <> " and " <> show max
+                           <> " (currently: " <> show n <> ")"
+
+show_error_password :: P.Error -> String
+show_error_password = case _ of
+  P.ParsingError {error, position} ->
+    "position " <> show position <> " " <> maybe "" string_error_password error
+
+string_error_password :: P.PasswordParsingError -> String
+string_error_password = case _ of
+  P.CannotParse         -> "cannot parse the password"
+  P.CannotEntirelyParse -> "cannot entirely parse the password"
+  P.Size min max n      -> "password size should be between "
+                           <> show min <> " and " <> show max
+                           <> " (currently: " <> show n <> ")"
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    pure (Just a)

src/App/ResourceRecord.purs

@@ -0,0 +1,61 @@
+module App.ResourceRecord where
+
+import Data.Maybe (Maybe)
+
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
+
+type ResourceRecord
+  = { rrtype   :: String
+    , rrid     :: Int
+    , name     :: String
+    , ttl      :: Int
+    , target   :: String
+    , readonly :: Boolean
+
+    -- MX (and SRV) specific entry.
+    , priority :: Maybe Int
+
+    -- SRV specific entries.
+    , port     :: Maybe Int
+    , protocol :: Maybe String
+    , weight   :: Maybe Int
+
+    -- SOA specific entries.
+    , mname   :: Maybe String
+    , rname   :: Maybe String
+    , serial  :: Maybe Int
+    , refresh :: Maybe Int
+    , retry   :: Maybe Int
+    , expire  :: Maybe Int
+    , minttl  :: Maybe Int
+    }
+
+codec :: JsonCodec ResourceRecord
+codec = CA.object "ResourceRecord"
+  (CAR.record
+    { rrtype:   CA.string
+    , rrid:     CA.int
+    , name:     CA.string
+    , ttl:      CA.int
+    , target:   CA.string
+    , readonly: CA.boolean
+
+    -- MX (and SRV) specific entry.
+    , priority: CAR.optional CA.int
+
+    -- SRV specific entries.
+    , port:     CAR.optional CA.int
+    , protocol: CAR.optional CA.string
+    , weight:   CAR.optional CA.int
+
+    -- SOA specific entries.
+    , mname:   CAR.optional CA.string
+    , rname:   CAR.optional CA.string
+    , serial:  CAR.optional CA.int
+    , refresh: CAR.optional CA.int
+    , retry:   CAR.optional CA.int
+    , expire:  CAR.optional CA.int
+    , minttl:  CAR.optional CA.int
+    })

src/App/Setup.purs

@@ -0,0 +1,171 @@
+-- | `App.SetupInterface` allows users to change their password or their email address.
+-- | Users can also erase their account.
+module App.SetupInterface where
+
+import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (==))
+
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+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 App.Email as Email
+import App.LogMessage
+import App.Messages.AuthenticationDaemon as AuthD
+
+data Output
+  = Log LogMessage
+  | ChangePassword String
+  | DeleteUserAccount
+
+-- | The component's parent provides received messages.
+-- |
+-- | Also, the component is informed when the connection went up or down.
+data Query a
+  = MessageReceived AuthD.AnswerMessage a
+  | ConnectionIsDown a
+  | ConnectionIsUp a
+
+type Slot = H.Slot Query Output
+
+type Input = String
+
+data AuthenticationInput
+  = AUTH_INP_login String
+  | AUTH_INP_pass String
+
+data NewPasswordInput
+  = NEWPASS_INP_password String
+  | NEWPASS_INP_confirmation String
+
+data Action
+  = HandleNewPassword NewPasswordInput
+  | ChangePasswordAttempt Event
+  | CancelModal
+  | DeleteAccountPopup
+  | DeleteAccount
+
+type StateNewPasswordForm = { password :: String, confirmation :: String }
+
+data Modal
+  = NoModal
+  | DeleteAccountModal
+
+type State =
+  { newPasswordForm :: StateNewPasswordForm
+  , token           :: String
+  , wsUp            :: Boolean
+  , modal           :: Modal
+  }
+
+component :: forall m. MonadAff m => H.Component Query Input Output m
+component =
+  H.mkComponent
+    { initialState
+    , render
+    , eval: H.mkEval $ H.defaultEval
+        { handleAction = handleAction
+        , handleQuery  = handleQuery
+        }
+    }
+
+initialState :: Input -> State
+initialState token =
+  { newPasswordForm: { password: "", confirmation: "" }
+  , token
+  , modal: NoModal
+  , wsUp: true
+  }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { modal, wsUp, newPasswordForm } =
+  case modal of
+    DeleteAccountModal -> render_delete_account_modal
+    NoModal -> Bulma.columns_ [ b [ Bulma.h3 "Change password", render_new_password_form ]
+                              , b [ Bulma.h3 "Delete account", render_delete_account ]
+                              ]
+
+  where
+  b e = Bulma.column_ [ Bulma.box e ]
+  should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
+
+  render_delete_account = Bulma.alert_btn "Delete my account" DeleteAccountPopup
+  render_new_password_form = HH.form
+    [ HE.onSubmit ChangePasswordAttempt ]
+    [ Bulma.box_input "passwordNEWPASS" "Password" "password"
+        (HandleNewPassword <<< NEWPASS_INP_password)
+        newPasswordForm.password
+        should_be_disabled
+    , Bulma.box_input "confirmationNEWPASS" "Confirmation" "confirmation"
+        (HandleNewPassword <<< NEWPASS_INP_confirmation)
+        newPasswordForm.confirmation
+        should_be_disabled
+    , HH.button
+       [ HP.style "padding: 0.5rem 1.25rem;"
+       , HP.type_ HP.ButtonSubmit
+       , (if wsUp then (HP.enabled true) else (HP.disabled true))
+       ]
+       [ HH.text "Send Message to Server" ]
+    ]
+
+  render_delete_account_modal = Bulma.modal "Delete your account"
+    [ Bulma.p "Your account and domains will be removed."
+    , Bulma.strong "⚠ You won't be able to recover your data."
+    ]
+    [ Bulma.alert_btn "GO AHEAD LOL" DeleteAccount
+    , Bulma.cancel_button CancelModal
+    ]
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  HandleNewPassword authinp -> do
+    case authinp of
+      NEWPASS_INP_password     v -> H.modify_ _ { newPasswordForm { password = v } }
+      NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } }
+
+  CancelModal -> do
+    H.modify_ _ { modal = NoModal }
+  DeleteAccountPopup -> do
+    H.modify_ _ { modal = DeleteAccountModal }
+  DeleteAccount -> do
+    H.raise $ DeleteUserAccount
+    handleAction $ CancelModal
+
+  ChangePasswordAttempt ev -> do
+    H.liftEffect $ Event.preventDefault ev
+
+    { newPasswordForm } <- H.get
+    case newPasswordForm.password, newPasswordForm.confirmation of
+      "" , _ -> H.raise $ Log $ UnableToSend "Write your password!"
+      _ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!"
+      pass, confirmation -> do
+        if pass == confirmation
+        then do H.raise $ Log $ SystemLog "Changing the password"
+                H.raise $ ChangePassword pass
+        else H.raise $ Log $ UnableToSend "Confirmation differs from password"
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  -- For now, no message actually needs to be handled here.
+  -- Error messages are simply logged (see the code in the Container component).
+  MessageReceived message _ -> do
+    case message of
+      _ -> do
+        H.raise $ Log $ ErrorLog $ "Message not handled in SetupInterface."
+    pure Nothing
+
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    pure (Just a)

src/App/UserPublic.purs

@@ -1,13 +1,10 @@
 module App.UserPublic where
 
-import Prelude
-
-import Data.Maybe
+import Data.Maybe (Maybe)
 
 import Data.Codec.Argonaut (JsonCodec)
 import Data.Codec.Argonaut as CA
 import Data.Codec.Argonaut.Record as CAR
-import Data.Newtype (class Newtype)
 
 -- | Currently not the real type.
 -- | Lacks 'profile' attribute.

src/App/Validation/DNS.purs

@@ -0,0 +1,248 @@
+module App.Validation.DNS where
+
+import Prelude (apply, between, bind, map, pure, ($), (-), (<))
+
+import Control.Alt ((<|>))
+import Data.Array as A
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), maybe)
+import Data.String.CodeUnits as CU
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import App.ResourceRecord (ResourceRecord)
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+import GenericParser.DomainParser.Common (DomainError) as DomainParser
+import GenericParser.DomainParser (sub_eof) as DomainParser
+import GenericParser.IPAddress as IPAddress
+import GenericParser.RFC5234 as RFC5234
+
+-- | **History:**
+-- | The module once used dedicated types for each type of RR.
+-- | That comes with several advantages.
+-- | First, type verification was a thing, and function were dedicated to a certain type of record.
+-- | Second, these dedicated types used strings for their fields,
+-- | which simplifies the typing when dealing with forms.
+-- | Finally, the validation was a way to convert dedicated types (used in forms)
+-- | to the general type (used for network serialization).
+-- | This ensures each resource record is verified before being sent to `dnsmanagerd`.
+-- |
+-- | The problem is that, with dedicated types, you are then required to have dedicated functions.
+-- | Conversion functions are also required.
+-- |
+-- | Maybe the code will change again in the future, but for now it will be enough.
+
+data Error
+  = UNKNOWN
+  | VEIPv4 (G.Error IPAddress.IPv4Error)
+  | VEIPv6 (G.Error IPAddress.IPv6Error)
+  | VEName (G.Error DomainParser.DomainError)
+  | VETTL Int Int Int
+  | VETXT (G.Error TXTError)
+  | VECNAME (G.Error DomainParser.DomainError)
+  | VENS (G.Error DomainParser.DomainError)
+  | VEMX (G.Error DomainParser.DomainError)
+  | VEPriority Int Int Int
+  | VESRV (G.Error DomainParser.DomainError)
+  | VEProtocol (G.Error ProtocolError)
+  | VEPort Int Int Int
+  | VEWeight Int Int Int
+
+type AVErrors = Array Error
+
+-- | Current default values.
+min_ttl :: Int
+min_ttl = 30
+max_ttl :: Int
+max_ttl = 86000
+max_txt :: Int
+max_txt = 500
+min_priority :: Int
+min_priority = 0
+max_priority :: Int
+max_priority = 65535
+min_port :: Int
+min_port = 0
+max_port :: Int
+max_port = 65535
+min_weight :: Int
+min_weight = 0
+max_weight :: Int
+max_weight = 65535
+
+-- Functions handling network-related structures (ResourceRecord).
+
+type RRPriority = Maybe Int
+type RRPort     = Maybe Int
+type RRProtocol = Maybe String
+type RRWeight   = Maybe Int
+type RRMname    = Maybe String
+type RRRname    = Maybe String
+type RRSerial   = Maybe Int
+type RRRefresh  = Maybe Int
+type RRRetry    = Maybe Int
+type RRExpire   = Maybe Int
+type RRMinttl   = Maybe Int
+
+
+toRR :: Int -> Boolean -> String -> String -> Int -> String
+     -> RRPriority
+     -> RRPort
+     -> RRProtocol
+     -> RRWeight
+     -> RRMname
+     -> RRRname
+     -> RRSerial
+     -> RRRefresh
+     -> RRRetry
+     -> RRExpire
+     -> RRMinttl
+     -> ResourceRecord
+toRR rrid readonly rrtype rrname ttl target
+     priority port protocol weight mname rname serial refresh retry expire minttl
+  = { rrid:         rrid
+    , readonly:     readonly
+    , rrtype:       rrtype
+    , name:         rrname
+    , ttl:          ttl
+    , target:       target
+
+    -- MX + SRV
+    , priority:     priority
+
+    -- SRV
+    , port:         port
+    , protocol:     protocol
+    , weight:       weight
+
+    -- SOA
+    , mname:        mname
+    , rname:        rname
+    , serial:       serial
+    , refresh:      refresh
+    , retry:        retry
+    , expire:       expire
+    , minttl:       minttl
+    }
+
+toRR_basic :: Int -> Boolean -> String -> String -> Int -> String -> ResourceRecord
+toRR_basic rrid readonly rrtype rrname ttl target
+  = toRR rrid readonly rrtype rrname ttl target
+         Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+-- last + priority
+toRR_mx :: Int -> Boolean -> String -> String -> Int -> String -> Int -> ResourceRecord
+toRR_mx rrid readonly rrtype rrname ttl target priority
+  = toRR rrid readonly rrtype rrname ttl target (Just priority)
+         Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+-- last + port + protocol + weight
+toRR_srv :: Int -> Boolean -> String -> String -> Int -> String -> Int -> Int -> String -> Int -> ResourceRecord
+toRR_srv rrid readonly rrtype rrname ttl target priority port protocol weight
+  = toRR rrid readonly rrtype rrname ttl target (Just priority) (Just port) (Just protocol) (Just weight)
+         Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+
+data TXTError
+  = TXTInvalidCharacter
+  | TXTTooLong Int Int -- max current
+-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
+txt_parser :: G.Parser TXTError String
+txt_parser = do pos <- G.current_position
+                v <- A.many (RFC5234.vchar <|> RFC5234.sp)
+                e <- G.tryMaybe SomeParsers.eof
+                pos2 <- G.current_position
+                case e of
+                  Nothing -> G.errorParser $ Just TXTInvalidCharacter
+                  Just _ -> do
+                    let nbchar = pos2 - pos
+                    if nbchar < max_txt
+                    then pure $ CU.fromCharArray v
+                    else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar)
+
+-- | `parse` allows to run any parser based on `GenericParser` and provide a validation error.
+-- | The actual validation error contains the parser's error including the position.
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+validationA :: ResourceRecord -> V (Array Error) ResourceRecord
+validationA form = ado
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
+  target <- parse IPAddress.ipv4       form.target VEIPv4
+  in toRR_basic form.rrid form.readonly "A" name ttl target
+
+validationAAAA :: ResourceRecord -> V (Array Error) ResourceRecord
+validationAAAA form = ado
+  name   <- parse DomainParser.sub_eof form.name VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl  VETTL
+  -- use read_input to get unaltered input (the IPv6 parser expands the input)
+  target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6
+  in toRR_basic form.rrid form.readonly "AAAA" name ttl target
+
+validationTXT :: ResourceRecord -> V (Array Error) ResourceRecord
+validationTXT form = ado
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
+  target <- parse txt_parser           form.target VETXT
+  in toRR_basic form.rrid form.readonly "TXT" name ttl target
+
+validationCNAME :: ResourceRecord -> V (Array Error) ResourceRecord
+validationCNAME form = ado
+  name   <- parse DomainParser.sub_eof form.name VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl      VETTL
+  target <- parse DomainParser.sub_eof form.target VECNAME
+  in toRR_basic form.rrid form.readonly "CNAME" name ttl target
+
+validationNS :: ResourceRecord -> V (Array Error) ResourceRecord
+validationNS form = ado
+  name   <- parse DomainParser.sub_eof form.name   VEName
+  ttl    <- is_between min_ttl max_ttl form.ttl    VETTL
+  target <- parse DomainParser.sub_eof form.target VENS
+  in toRR_basic form.rrid form.readonly "NS" name ttl target
+
+data ProtocolError
+  = InvalidProtocol
+
+protocol_parser :: G.Parser ProtocolError String
+protocol_parser = do
+  G.string "tcp" <|> G.string "udp" G.<:> \_ -> InvalidProtocol
+
+is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> Error) -> V (Array Error) Int
+is_between min max n ve = if between min max n
+                          then pure n
+                          else invalid [ve min max n]
+
+validationMX :: ResourceRecord -> V (Array Error) ResourceRecord
+validationMX form = ado
+  name     <- parse DomainParser.sub_eof form.name     VEName
+  ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
+  target   <- parse DomainParser.sub_eof form.target   VEMX
+  priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
+  in toRR_mx form.rrid form.readonly "MX" name ttl target priority
+
+validationSRV :: ResourceRecord -> V (Array Error) ResourceRecord
+validationSRV form = ado
+  name     <- parse DomainParser.sub_eof form.name     VEName
+  ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
+  target   <- parse DomainParser.sub_eof form.target   VESRV
+  priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
+  protocol <- parse protocol_parser      (maybe "" id   form.protocol)  VEProtocol
+  port     <- is_between min_port max_port (maybe 0 id form.port)       VEPort
+  weight   <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight
+  in toRR_srv form.rrid form.readonly "SRV" name ttl target priority port protocol weight
+
+validation :: ResourceRecord -> Either (Array Error) ResourceRecord
+validation entry = case entry.rrtype of
+  "A"     -> toEither $ validationA     entry
+  "AAAA"  -> toEither $ validationAAAA  entry
+  "TXT"   -> toEither $ validationTXT   entry
+  "CNAME" -> toEither $ validationCNAME entry
+  "NS"    -> toEither $ validationNS    entry
+  "MX"    -> toEither $ validationMX    entry
+  "SRV"   -> toEither $ validationSRV   entry
+  _       -> toEither $ invalid [UNKNOWN]
+
+id :: forall a. a -> a
+id x = x

src/App/Validation/Email.purs

@@ -0,0 +1,44 @@
+module App.Validation.Email where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.RFC5322 as RFC5322
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+
+data EmailParsingError
+  = CannotParse
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error EmailParsingError)
+
+min_email_size :: Int
+min_email_size = 5
+max_email_size :: Int
+max_email_size = 100
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+parse_full_email :: G.Parser EmailParsingError String
+parse_full_email = do
+  email_address <- RFC5322.address  G.<:> \_ -> CannotParse
+  _ <- SomeParsers.eof              G.<:> \_ -> CannotEntirelyParse
+  pos <- G.current_position
+  if between min_email_size max_email_size pos
+  then pure email_address
+  else G.errorParser $ Just $ Size min_email_size max_email_size pos
+
+parserEmail :: String -> V (Array Error) String
+parserEmail str = parse parse_full_email str ParsingError
+
+email :: String -> Either (Array Error) String
+email s = toEither $ parserEmail s

src/App/Validation/Label.purs

@@ -0,0 +1,41 @@
+module App.Validation.Label where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.Parser as G
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.DomainParser.Common (DomainError) as DomainParser
+import GenericParser.DomainParserRFC1035 (label) as RFC1035
+
+data LabelParsingError
+  = CannotParse (DomainParser.DomainError)
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error LabelParsingError)
+
+min_label_size = 1 :: Int  -- arbitrary
+max_label_size = 63 :: Int -- arbitrary
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+label_parser :: G.Parser LabelParsingError String
+label_parser = do
+  input <- G.current_input
+  _ <- RFC1035.label G.<:> \e -> CannotParse e
+  _ <- SomeParsers.eof    G.<:> \_ -> CannotEntirelyParse
+  pos <- G.current_position
+  if between min_label_size max_label_size pos
+  then pure input.string
+  else G.errorParser (Just $ Size min_label_size max_label_size pos)
+
+label :: String -> Either (Array Error) String
+label s = toEither $ parse label_parser s ParsingError

src/App/Validation/Login.purs

@@ -0,0 +1,43 @@
+module App.Validation.Login where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.RFC5234 (alpha, digit)
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+
+data LoginParsingError
+  = CannotParse
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error LoginParsingError)
+
+min_login_size :: Int
+min_login_size = 2
+max_login_size :: Int
+max_login_size = 50
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+login_parser :: G.Parser LoginParsingError String
+login_parser = do
+  input <- G.current_input
+  _ <- G.many1 (alpha <|> digit) G.<:> \_ -> CannotParse
+  _ <- SomeParsers.eof           G.<:> \_ -> CannotEntirelyParse
+  pos <- G.current_position
+  if between min_login_size max_login_size pos
+  then pure input.string
+  else G.errorParser (Just $ Size min_login_size max_login_size pos)
+
+login :: String -> Either (Array Error) String
+login s = toEither $ parse login_parser s ParsingError

src/App/Validation/Password.purs

@@ -0,0 +1,43 @@
+module App.Validation.Password where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Either (Either(..))
+import Data.String.CodeUnits as CU
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.RFC5234 (vchar)
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+
+data PasswordParsingError
+  = CannotParse
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error PasswordParsingError)
+
+min_password_size :: Int
+min_password_size = 2
+max_password_size :: Int
+max_password_size = 100
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+password_parser :: G.Parser PasswordParsingError String
+password_parser = do
+  l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
+  _ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
+  pos <- G.current_position
+  if pos < min_password_size || pos > max_password_size
+  then G.Parser \i -> G.failureError i.position (Just $ Size min_password_size max_password_size pos)
+  else pure $ CU.fromCharArray l
+
+password :: String -> Either (Array Error) String
+password s = toEither $ parse password_parser s ParsingError

src/App/Validation/Token.purs

@@ -0,0 +1,44 @@
+module App.Validation.Token where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Either (Either(..))
+import Data.String.CodeUnits as CU
+import Data.Maybe (Maybe(..))
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import GenericParser.RFC5234 (vchar)
+import GenericParser.SomeParsers as SomeParsers
+import GenericParser.Parser as G
+
+data TokenParsingError
+  = CannotParse
+  | CannotEntirelyParse
+  | Size Int Int Int
+
+data Error
+  = ParsingError (G.Error TokenParsingError)
+
+-- | TODO: this number should be exactly the size of the provided token.
+min_token_size :: Int
+min_token_size = 20
+max_token_size :: Int
+max_token_size = 60
+
+parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
+parse (G.Parser p) str c = case p { string: str, position: 0 } of
+  Left x  -> invalid $ [c x]
+  Right x -> pure x.result
+
+token_parser :: G.Parser TokenParsingError String
+token_parser = do
+  l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
+  _ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
+  pos <- G.current_position
+  if pos < min_token_size || pos > max_token_size
+  then G.Parser \i -> G.failureError i.position (Just $ Size min_token_size max_token_size pos)
+  else pure $ CU.fromCharArray l
+
+token :: String -> Either (Array Error) String
+token s = toEither $ parse token_parser s ParsingError

src/App/WS.purs

@@ -0,0 +1,334 @@
+-- | This component handles all WS operations.
+-- | This includes telling when a connection is established or closed, and notify a message has been received.
+module App.WS where
+
+import Prelude (Unit, bind, discard, pure, show, void, when
+               , ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<))
+
+import Control.Monad.Rec.Class (forever)
+import Control.Monad.Except (runExcept)
+import Data.Array as A
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Bifunctor (lmap)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), isJust, isNothing)
+import Data.String as String
+import Data.Tuple (Tuple(..))
+import Effect.Aff as Aff
+import Effect.Aff (Milliseconds(..))
+import Effect.Aff.Class (class MonadAff)
+import Effect (Effect)
+import Foreign as F
+import Halogen as H
+import Halogen.HTML as HH
+import Halogen.HTML.Events as HE
+import Halogen.HTML.Properties as HP
+import Halogen.Query.Event as HQE
+import Halogen.Subscription as HS
+import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
+import Web.Socket.Event.CloseEvent as WSCE
+import Web.Socket.Event.EventTypes as WSET
+import Web.Socket.Event.MessageEvent as WSME
+import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
+import Web.Socket.WebSocket as WS
+
+import App.LogMessage
+
+keepalive = 30000.0 :: Number
+
+-- Input is the WS url.
+type Input = String
+
+-- | The component can perform 4 actions: log messages, notify that a message has been received,
+-- | notify when a connection has been established or when it has been closed.
+data Output
+-- | MessageReceived (Tuple URL message)
+  = MessageReceived (Tuple String ArrayBuffer)  -- Provide a received message to the parent.
+  | WSJustConnected                             -- Inform the parent the connection is up.
+  | WSJustClosed                                -- Inform the parent the connection is down.
+  | Log LogMessage
+  | KeepAlive                                   -- Ask the parent to handle a keep-alive message.
+
+-- | The component can receive a single action from other components: sending a message throught the websocket.
+data Query a = ToSend ArrayBuffer a
+
+type Slot = H.Slot Query Output
+
+-- | `timer` triggers a `Tick` action every `keepalive` ms.
+timer :: forall m a. MonadAff m => a -> m (HS.Emitter a)
+timer val = do
+  { emitter, listener } <- H.liftEffect HS.create
+  _ <- H.liftAff $ Aff.forkAff $ forever do
+    Aff.delay $ Milliseconds keepalive
+    H.liftEffect $ HS.notify listener val
+  pure emitter
+
+data Action
+  -- | `Initialize` opens the connection (URL is received as an `input` of this component).
+  = Initialize
+
+  -- | The component provides a log each time a message failed to be parsed.
+  | WebSocketParseError String
+
+  -- | The component shows buttons when the connection is dropped for some reason.
+  -- | To reconnect, the button is clicked, and the `ConnectWebSocket` action is performed.
+  | ConnectWebSocket
+
+  -- | `SendMessage` effectively sends a message through the ws connection.
+  | SendMessage ArrayBuffer
+
+  -- | `Finalize` is the action performed once the component is destroyed, ending the connection.
+  | Finalize
+
+  -- | Tick: keep alive WS connections.
+  | Tick
+
+  -- | Every received websocket message and notification is handled in `HandleWebSocket`.
+  | HandleWebSocket (WebSocketEvent WebSocketMessageType)
+
+-- | The type `WSInfo` helps handle a websocket.
+-- | `WSInfo` is composed of an URL, an actual socket and a boolean
+-- | to inform if the connection has to be re-established.
+type WSInfo
+  = { url        :: String
+    , connection :: Maybe WS.WebSocket
+    , reconnect  :: Boolean
+    }
+
+-- | The state of this component only is composed of the websocket.
+type State = { wsInfo :: WSInfo }
+
+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
+        }
+    }
+
+initialState :: Input -> State
+initialState url =
+  { wsInfo: { url: url
+            , connection: Nothing
+            , reconnect: false
+            }
+  }
+
+-- | The component shows a string when the connection is established, or a button when the connection has closed.
+render :: forall m. State -> H.ComponentHTML Action () m
+render { wsInfo }
+    = HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ]
+    where
+      renderFootnote :: String -> H.ComponentHTML Action () m
+      renderFootnote txt =
+        HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
+
+      renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
+      renderReconnectButton cond =
+        if cond
+        then
+          HH.p_
+            [ HH.button
+              [ HP.type_ HP.ButtonButton
+              , HE.onClick \_ -> ConnectWebSocket
+              ]
+              [ HH.text "Reconnect?" ]
+            ]
+        else
+          HH.p_
+            [ renderFootnote $
+                "NOTE: A 'Reconnect?' button will appear if the connection drops (for URL: '"
+                <>
+                wsInfo.url
+                <>
+                "')"
+            ]
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction action = do
+  { wsInfo } <- H.get
+  case action of
+    Initialize -> do
+      _ <- H.subscribe =<< timer Tick
+      handleAction ConnectWebSocket
+
+    Tick -> H.raise KeepAlive
+
+    Finalize -> do
+      -- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
+      case wsInfo.connection of
+        Nothing -> H.raise $ Log $ SystemLog "No socket? How is that even possible?"
+        Just socket -> H.liftEffect $ WS.close socket
+
+    WebSocketParseError error ->
+      H.raise $ Log $ SystemLog $ renderError (UnknownError error)
+
+    ConnectWebSocket -> do
+      -- H.raise $ Log $ SystemLog $ "Connecting to \"" <> wsInfo.url <>  "\"..."
+      webSocket <- H.liftEffect $ WS.create wsInfo.url []
+      H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
+      H.modify_ _ { wsInfo { connection = Just webSocket } }
+      void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
+
+    SendMessage array_buffer_to_send -> do
+      case wsInfo.connection of
+        Nothing -> H.raise $ Log $ UnableToSend $ "Websocket is down!"
+        Just webSocket -> H.liftEffect $ do
+          sendArrayBuffer webSocket array_buffer_to_send
+
+    HandleWebSocket wsEvent -> do
+      case wsEvent of
+        WebSocketMessage received_message -> do
+          H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
+
+        WebSocketOpen -> do
+          H.raise $ WSJustConnected
+
+        WebSocketClose { code, reason, wasClean } -> do
+          H.raise $ Log $ SystemLog $ renderCloseMessage code wasClean reason
+          maybeCurrentConnection <- H.gets _.wsInfo.connection
+          when (isJust maybeCurrentConnection) do
+            H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
+          H.raise $ WSJustClosed
+
+        WebSocketError errorType -> do
+          H.raise $ Log $ SystemLog $ renderError errorType
+          H.raise $ WSJustClosed
+
+  where
+  renderCloseMessage
+    :: Int
+    -> Boolean
+    -> String
+    -> String
+  renderCloseMessage code wasClean = case _ of
+      ""     -> baseCloseMessage
+      reason -> baseCloseMessage <> "Reason: " <> reason
+    where
+    baseCloseMessage :: String
+    baseCloseMessage =
+      String.joinWith " "
+        [ "Connection to WebSocket closed"
+        , "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]"
+        ]
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+  ToSend message a -> do
+    send_message message
+    pure (Just a)
+
+send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
+send_message message = do
+    { wsInfo } <- H.get
+    case wsInfo.connection of
+      Nothing -> H.raise $ Log $ UnableToSend "Not connected to server."
+      Just webSocket -> do
+        H.liftEffect (WS.readyState webSocket) >>= case _ of
+          Connecting -> H.raise $ Log $ UnableToSend "Still connecting to server."
+          Closing    -> H.raise $ Log $ UnableToSend "Connection to server is closing."
+          Closed     -> do
+            H.raise $ Log $ UnableToSend "Connection to server has been closed."
+            H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
+          Open -> H.liftEffect $ sendArrayBuffer webSocket message
+--------------------------------------------------------------------------------
+-- WebSocket mess.
+--------------------------------------------------------------------------------
+
+data WebSocketEvent :: Type -> Type
+data WebSocketEvent msg
+  = WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
+  | WebSocketOpen
+  | WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
+  | WebSocketError ErrorType
+
+webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
+webSocketEmitter socket = do
+
+  HS.makeEmitter \push -> do
+
+    openId <- HS.subscribe openEmitter push
+    errorId <- HS.subscribe errorEmitter push
+    closeId <- HS.subscribe closeEmitter push
+    messageId <- HS.subscribe messageEmitter push
+
+    pure do
+      HS.unsubscribe openId
+      HS.unsubscribe errorId
+      HS.unsubscribe closeId
+      HS.unsubscribe messageId
+
+  where
+  target = WS.toEventTarget socket
+
+  openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
+  openEmitter =
+    HQE.eventListener WSET.onOpen target \_ ->
+      Just WebSocketOpen
+
+  errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
+  errorEmitter =
+    HQE.eventListener WSET.onError target \_ ->
+      Just (WebSocketError UnknownWebSocketError)
+
+  closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
+  closeEmitter =
+    HQE.eventListener WSET.onClose target \event ->
+      WSCE.fromEvent event >>= \closeEvent ->
+        Just $ WebSocketClose  { code: WSCE.code closeEvent
+                               , reason: WSCE.reason closeEvent
+                               , wasClean: WSCE.wasClean closeEvent
+                               }
+
+  messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
+  messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
+
+decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
+decodeMessageEvent = \msgEvent -> do
+  let
+    foreign' :: F.Foreign
+    foreign' = WSME.data_ msgEvent
+  case foreignToArrayBuffer foreign' of
+    Left errs -> pure $ WebSocketError $ UnknownError errs
+    Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer
+                                                 , origin: WSME.origin msgEvent
+                                                 , lastEventId: WSME.lastEventId msgEvent }
+
+---------------------------
+-- Errors
+---------------------------
+
+data ErrorType
+  = UnknownError String
+  | UnknownWebSocketError
+
+renderError :: ErrorType -> String
+renderError = case _ of
+  UnknownError str ->
+    "Unknown error: " <> str
+  UnknownWebSocketError ->
+    "Unknown 'error' event has been fired by WebSocket event listener"
+
+--------------------------------------------------------------------------------
+-- WebSocket message type
+--------------------------------------------------------------------------------
+
+type WebSocketMessageType = ArrayBuffer
+
+sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
+sendArrayBuffer = WS.sendArrayBuffer
+
+foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
+foreignToArrayBuffer
+  = lmap renderForeignErrors
+  <<< runExcept
+  <<< F.unsafeReadTagged "ArrayBuffer"
+  where
+  renderForeignErrors :: F.MultipleErrors -> String
+  renderForeignErrors =
+    String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError

src/App/ZoneInterface.purs

@@ -0,0 +1,864 @@
+-- | `App.ZoneInterface` provides an interface to display and modify a DNS zone.
+-- |
+-- | This interface allows to:
+-- |   - display all resource records of a zone (SOA, NS, A, AAAA, CNAME, TXT, MX, SRV)
+-- |   - add, modify, remove resource records
+-- |
+-- | **WIP**: Display relevant information for each record type in the (add/mod) modal.
+-- | This includes explaining use cases and displaying an appropriate interface for the
+-- | task at hand. For example, having a dedicated interface for DKIM.
+-- |
+-- | TODO: display errors not only for a record but for the whole zone.
+-- | A DNS zone is bound by a set of rules, the whole zone must be consistent.
+-- | For example, a CNAME `target` has to point to the `name` of an existing record.
+-- |
+-- | TODO: do not allow for the modification of read-only resource records.
+-- |
+-- | TODO: move all serialization code to a single module.
+module App.ZoneInterface where
+
+import Prelude (Unit, unit, void
+               , bind, pure
+               , not, comparing, discard, map, 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, maybe)
+import Effect.Aff.Class (class MonadAff)
+import Halogen as H
+import Halogen.HTML as HH
+import Halogen.HTML.Properties as HP
+
+import Bulma as Bulma
+import CSSClasses as C
+
+import App.AcceptedRRTypes (AcceptedRRTypes(..))
+import App.ResourceRecord (ResourceRecord)
+
+import App.DisplayErrors (error_to_paragraph)
+
+import App.LogMessage (LogMessage(..))
+import App.Messages.DNSManagerDaemon as DNSManager
+import App.Validation.DNS as Validation
+
+type RRId = Int
+
+id :: forall a. a -> a
+id x = x
+
+-- | `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
+
+-- | `App.ZoneInterface` can receive messages from `dnsmanagerd`.
+-- |
+-- | The component is also informed when the connection is lost or up again.
+
+data Query a
+  = MessageReceived DNSManager.AnswerMessage a
+  | ConnectionIsDown a
+  | ConnectionIsUp a
+
+type Slot = H.Slot Query Output
+
+-- | `App.ZoneInterface` has a single input: the domain name.
+
+type Input = String
+
+data Field
+  = Field_Domain    String
+  | Field_TTL       String
+  | Field_Target    String
+  | Field_Priority  String
+  | Field_Protocol  String
+  | Field_Weight    String
+  | Field_Port      String
+
+-- | Steps to create a new RR:
+-- | 1. `CreateNewRRModal AcceptedRRTypes`: create a modal with default values based on selected accepted type.
+-- | 2. `UpdateCurrentRR Field`: modify the fields of the future new RR.
+-- | 3. `ValidateRR AcceptedRRTypes`: validate the new RR stored in `_currentRR`.
+-- |    In case it works, automatically call `AddRR` then `CancelModal`.
+-- | 4. `AddRR AcceptedRRTypes ResourceRecord`: send a message to `dnsmanagerd`.
+-- |
+-- | Steps to update an entry:
+-- | 1. `CreateUpdateRRModal RRId`: create a modal from the values of the RR in `_resources` to update.
+-- | 2. `UpdateCurrentRR Field`: modify the currently displayed RR.
+-- | 3. `ValidateLocal RRId AcceptedRRTypes`: validate the RR.
+-- | 4. `SaveRR ResourceRecord`: save the _validated_ RR by sending a message to `dnsmanagerd`.
+
+data Action
+  -- | Initiate the component. This means asking the content of the zone to `dnsmanagerd`.
+  = Initialize
+
+  -- | Cancel the current displayed modal.
+  | CancelModal
+
+  -- | Create a new resource record modal (a form) for a certain type of component.
+  | CreateNewRRModal AcceptedRRTypes
+
+  -- | Create modal (a form) for a resource record to update.
+  | CreateUpdateRRModal RRId
+
+  -- | Create a modal to ask confirmation before deleting a resource record.
+  | DeleteRRModal RRId
+
+  -- | Update new entry form (in the `rr_modal` modal).
+  | UpdateCurrentRR Field
+
+  -- | Validate a new resource record before adding it.
+  | ValidateRR AcceptedRRTypes
+
+  -- | Validate the entries in an already existing resource record.
+  -- | Automatically calls for `SaveRR` once record is verified.
+  | ValidateLocal
+
+  -- | Add a new resource record to the zone.
+  | AddRR AcceptedRRTypes ResourceRecord
+
+  -- | Save the changes done in an already existing resource record.
+  | SaveRR ResourceRecord
+
+  -- | Send a message to remove a resource record.
+  -- | Automatically closes the modal.
+  | RemoveRR RRId
+
+  -- | Ask `dnsmanagerd` for the generated zone file.
+  | AskZoneFile
+
+data RRModal
+  = NoModal
+  | NewRRModal AcceptedRRTypes
+  | UpdateRRModal
+  | RemoveRRModal RRId
+
+show_accepted_type :: AcceptedRRTypes -> String
+show_accepted_type = case _ of
+  A     -> "A"
+  AAAA  -> "AAAA"
+  TXT   -> "TXT"
+  CNAME -> "CNAME"
+  NS    -> "NS"
+  MX    -> "MX"
+  SRV   -> "SRV"
+
+string_to_acceptedtype :: String -> Maybe AcceptedRRTypes
+string_to_acceptedtype str = case str of
+  "A"     -> Just     A
+  "AAAA"  -> Just  AAAA
+  "TXT"   -> Just   TXT
+  "CNAME" -> Just CNAME
+  "NS"    -> Just    NS
+  "MX"    -> Just    MX
+  "SRV"   -> Just   SRV
+  _       -> Nothing
+
+type State =
+  { _domain :: String
+  , wsUp :: Boolean
+
+  -- A modal to present a form for adding a new RR.
+  , rr_modal :: RRModal
+
+  -- | All resource records.
+  , _resources :: Array ResourceRecord
+  --, _local_errors :: Hash.HashMap RRId (Array Validation.Error)
+
+  -- Unique RR form.
+  , _currentRR :: ResourceRecord
+  , _currentRR_errors :: Array Validation.Error
+
+  , _zonefile :: 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
+        }
+    }
+
+-- | Default available domain: netlib.re.
+
+default_domain :: String
+default_domain = "netlib.re"
+
+default_empty_rr :: ResourceRecord
+default_empty_rr
+  = { rrtype: "A"
+    , rrid: 0
+    , name: "www"
+    , ttl: 1800
+    , target: "10.0.0.1"
+    , readonly: false
+
+    -- MX (and SRV) specific entry.
+    , priority: Nothing
+
+    -- SRV specific entries.
+    , port: Nothing
+    , protocol: Nothing
+    , weight: Nothing
+
+    -- SOA specific entries.
+    , mname: Nothing
+    , rname: Nothing
+    , serial: Nothing
+    , refresh: Nothing
+    , retry: Nothing
+    , expire: Nothing
+    , minttl: Nothing
+    }
+
+initialState :: Input -> State
+initialState domain =
+  { wsUp: true
+  , rr_modal: NoModal
+
+  , _domain: domain
+
+  , _resources: []
+  --, _local_errors: Hash.empty
+
+  -- This is the state for the new RR modal.
+  , _currentRR: default_empty_rr
+  -- List of errors within the form in new RR modal.
+  , _currentRR_errors: []
+  , _zonefile: Nothing
+  }
+
+type SortableRecord l = Record (rrtype :: String, rrid :: Int | l)
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render state
+  = Bulma.section_small
+      [ case state.wsUp, state.rr_modal of
+          false, _                   -> Bulma.p "You are disconnected."
+          true,  RemoveRRModal rr_id -> modal_rr_delete rr_id
+          true,  NewRRModal _        -> render_current_rr_modal
+          true,  UpdateRRModal       -> render_current_rr_modal
+          true,  NoModal -> HH.div_
+            [ Bulma.h1 state._domain
+            , Bulma.hr
+            , render_resources $ sorted state._resources
+            , Bulma.hr
+            , render_new_records state
+            , render_zonefile state._zonefile
+            ]
+      ]
+  where
+    sorted :: forall l. Array (SortableRecord (l)) -> Array (SortableRecord (l))
+    sorted array =
+      A.groupAllBy (comparing (_.rrtype)) array    -- [x2 z2 x1 y z1 z3] -> [ NE[x2x1] NE[y] NE[z2z1z3] ]
+      # map NonEmpty.toArray                       -- -> [[x2x1][y][z2z1z3]]
+      # map (A.sortBy (comparing (_.rrid)))        -- -> [[x1x2][y][z1z2z3]]
+      # A.concat                                   -- -> [x1 x2 y z1 z2 z3]
+
+    modal_rr_delete :: forall w. Int -> HH.HTML w Action
+    modal_rr_delete rr_id = Bulma.modal "Deleting a resource record"
+      [warning_message] [modal_delete_button, Bulma.cancel_button CancelModal]
+      where
+      modal_delete_button = Bulma.alert_btn "Delete the resource record." (RemoveRR rr_id)
+      warning_message
+        = HH.p [] [ HH.text "You are about to delete a resource record, this actions is "
+                  , Bulma.strong "irreversible"
+                  , HH.text "."
+                  ]
+
+    render_current_rr_modal :: forall w. HH.HTML w Action
+    render_current_rr_modal =
+      case state._currentRR.rrtype of
+      "A"     -> template content_simple (foot_content A)
+      "AAAA"  -> template content_simple (foot_content AAAA)
+      "TXT"   -> template content_simple (foot_content TXT)
+      "CNAME" -> template content_simple (foot_content CNAME)
+      "NS"    -> template content_simple (foot_content NS)
+      "MX"    -> template content_mx     (foot_content MX)
+      "SRV"   -> template content_srv    (foot_content SRV)
+      _       -> Bulma.p $ "Invalid type: " <> state._currentRR.rrtype
+      where
+        -- DRY
+        updateForm x = UpdateCurrentRR <<< x
+        render_errors = if A.length state._currentRR_errors > 0
+                        then HH.div_ $ [ Bulma.h3 "Errors: " ] <> map error_to_paragraph state._currentRR_errors
+                        else HH.div_ [ ]
+        content_simple :: Array (HH.HTML w Action)
+        content_simple =
+          [ render_errors
+          --, Bulma.box_input ("domain" <> state._currentRR.rrtype) "Name" "www"   -- id, title, placeholder
+          --    (updateForm Field_Domain)             -- action
+          --    state._currentRR.name                            -- value
+          --    should_be_disabled                           -- condition
+          , Bulma.input_with_side_text ("domain" <> state._currentRR.rrtype) "Name" "www" -- id, title, placeholder
+              (updateForm Field_Domain)             -- action
+              state._currentRR.name                 -- value
+              ("." <> state._domain)                -- sidetext
+          , Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600"
+              (updateForm Field_TTL)
+              (show state._currentRR.ttl)
+              should_be_disabled
+          , Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5"
+              (updateForm Field_Target)
+              state._currentRR.target
+              should_be_disabled
+          ]
+        content_mx :: Array (HH.HTML w Action)
+        content_mx =
+          [ render_errors
+          , Bulma.input_with_side_text "domainMX" "Name" "www" -- id, title, placeholder
+              (updateForm Field_Domain)             -- action
+              state._currentRR.name                 -- value
+              ("." <> state._domain)                -- sidetext
+          , Bulma.box_input ("ttlMX") "TTL" "600"
+              (updateForm Field_TTL)
+              (show state._currentRR.ttl)
+              should_be_disabled
+          , Bulma.box_input ("targetMX") "Target" "www"
+              (updateForm Field_Target)
+              state._currentRR.target
+              should_be_disabled
+          , Bulma.box_input ("priorityMX") "Priority" "10"
+              (updateForm Field_Priority)
+              (maybe "" show state._currentRR.priority)
+              should_be_disabled
+          ]
+        content_srv :: Array (HH.HTML w Action)
+        content_srv =
+          [ render_errors
+          , Bulma.input_with_side_text "domainSRV" "Name" "www" -- id, title, placeholder
+              (updateForm Field_Domain)             -- action
+              state._currentRR.name                 -- value
+              ("." <> state._domain)                -- sidetext
+          , Bulma.box_input ("ttlSRV") "TTL" "600"
+              (updateForm Field_TTL)
+              (show state._currentRR.ttl)
+              should_be_disabled
+          , Bulma.box_input ("targetSRV") "Target" "www"
+              (updateForm Field_Target)
+              state._currentRR.target
+              should_be_disabled
+          , Bulma.box_input ("prioritySRV") "Priority" "10"
+              (updateForm Field_Priority)
+              (maybe "" show state._currentRR.priority)
+              should_be_disabled
+          , Bulma.box_input ("portSRV") "Port" "5061"
+              (updateForm Field_Port)
+              (maybe "" show state._currentRR.port)
+              should_be_disabled
+          , Bulma.box_input ("weightSRV") "Weight" "100"
+              (updateForm Field_Weight)
+              (maybe "" show state._currentRR.weight)
+              should_be_disabled
+          , Bulma.box_input ("protocolSRV") "Protocol" "tcp"
+              (updateForm Field_Protocol)
+              (fromMaybe "tcp" state._currentRR.protocol)
+              should_be_disabled
+          ]
+
+        should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
+        foot_content x = [ case state.rr_modal of
+                             NewRRModal _ -> Bulma.btn_add (ValidateRR x)
+                             UpdateRRModal -> Bulma.btn_save ValidateLocal
+                             _ -> Bulma.p "state.rr_modal should either be NewRRModal or UpdateRRModal."
+                         ]
+        template content foot_ = Bulma.modal title content foot
+          where
+          title = case state.rr_modal of
+            NoModal             -> "Error: no modal should be displayed"
+            NewRRModal t_       -> "New " <> show_accepted_type t_ <> " resource record"
+            UpdateRRModal       -> "Update RR " <> show state._currentRR.rrid <> " resource record"
+            RemoveRRModal rr_id -> "Error: should display removal modal instead (for RR " <> show rr_id <> ")"
+          foot = foot_ <> [Bulma.cancel_button CancelModal]
+
+handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
+handleAction = case _ of
+  -- | Cancel the current modal being presented.
+  -- | Works for both "new RR", "update RR" and "remove RR" modals.
+  CancelModal -> do
+    H.modify_ _ { rr_modal = NoModal }
+    H.modify_ _ { _currentRR_errors = [] }
+
+  -- | Create the RR modal.
+  DeleteRRModal rr_id -> do
+    H.modify_ _ { rr_modal = RemoveRRModal rr_id }
+
+  -- | Create modal (a form) for a resource record to update.
+  CreateUpdateRRModal rr_id -> do
+    state <- H.get
+    case first (\rr -> rr.rrid == rr_id) state._resources of
+      Nothing -> H.raise $ Log $ ErrorLog $ "RR not found (RR " <> show rr_id <> ")"
+      Just rr -> do
+        H.modify_ _ { _currentRR = rr }
+        H.modify_ _ { rr_modal = UpdateRRModal }
+
+  -- | Each time a "new RR" button is clicked, the form resets.
+  CreateNewRRModal t -> do
+    state <- H.get
+    H.modify_ _ { rr_modal = NewRRModal t }
+    let defaultA = { rrtype: "A"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "www"
+          , target:   "192.0.2.1"
+          , port: Nothing
+          , weight: Nothing
+          , priority: Nothing
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultAAAA = { rrtype: "AAAA"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "www"
+          , target:   "2001:db8::1"
+          , port: Nothing
+          , weight: Nothing
+          , priority: Nothing
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultTXT = { rrtype: "TXT"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "txt"
+          , target:   "some text"
+          , port: Nothing
+          , weight: Nothing
+          , priority: Nothing
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultCNAME = { rrtype: "CNAME"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "blog"
+          , target:   "www"
+          , port: Nothing
+          , weight: Nothing
+          , priority: Nothing
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultNS = { rrtype: "NS"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     (state._domain <> ".")
+          , target:   "ns0.example.com."
+          , port: Nothing
+          , weight: Nothing
+          , priority: Nothing
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultMX = { rrtype: "MX"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "mail"
+          , target:   "www"
+          , port: Nothing
+          , weight: Nothing
+          , priority: Just 10
+          , protocol: Nothing
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+        defaultSRV = { rrtype: "SRV"
+          , rrid: 0
+          , ttl: 600
+          , readonly: false
+          , name:     "_sip._tcp"
+          , target:   "www"
+          , port: Just 5061
+          , weight: Just 100
+          , priority: Just 10
+          , protocol: Just "tcp"
+          , mname: Nothing
+          , rname: Nothing
+          , serial: Nothing
+          , refresh: Nothing
+          , retry: Nothing
+          , expire: Nothing
+          , minttl: Nothing
+          }
+    case t of
+      A     -> H.modify_ _ { _currentRR = defaultA }
+      AAAA  -> H.modify_ _ { _currentRR = defaultAAAA }
+      TXT   -> H.modify_ _ { _currentRR = defaultTXT }
+      CNAME -> H.modify_ _ { _currentRR = defaultCNAME }
+      NS    -> H.modify_ _ { _currentRR = defaultNS }
+      MX    -> H.modify_ _ { _currentRR = defaultMX }
+      SRV   -> H.modify_ _ { _currentRR = defaultSRV }
+
+  -- | Initialize the ZoneInterface component: ask for the domain zone to `dnsmanagerd`.
+  Initialize -> do
+    { _domain } <- H.get
+    H.raise $ Log $ SystemLog $ "Asking the domain " <> _domain
+    message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain }
+    H.raise $ MessageToSend message
+
+  -- | Perform validation. In case the record is valid, it is added to the zone then the modal is closed.
+  -- | Else, the different errors are added to the state.
+  ValidateRR t -> do
+    state <- H.get
+    case Validation.validation state._currentRR of
+      Left actual_errors -> do
+        -- H.raise $ Log $ ErrorLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
+        -- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
+        H.modify_ _ { _currentRR_errors = actual_errors }
+      Right newrr -> do
+        H.modify_ _ { _currentRR_errors = [] }
+        handleAction $ AddRR t newrr
+        handleAction CancelModal
+
+  -- | Try to add a resource record to the zone.
+  -- | Can fail if the content of the form isn't valid.
+  AddRR t newrr -> do
+    state <- H.get
+    H.raise $ Log $ SystemLog $ "Add new " <> show t
+    message <- H.liftEffect
+      $ DNSManager.serialize
+      $ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
+    H.raise $ MessageToSend message
+
+  -- | Update the currently displayed RR form (new or update RR).
+  UpdateCurrentRR field -> do
+    state <- H.get
+    let newRR = update_field state._currentRR field
+    H.modify_ _ { _currentRR = newRR }
+
+  -- | Validate any local RR with the new `_resources` and `_local_errors`.
+  ValidateLocal -> do
+    state <- H.get
+    case Validation.validation state._currentRR of
+      Left actual_errors -> do
+        H.modify_ _ { _currentRR_errors = actual_errors }
+      Right rr -> do
+        H.modify_ _ { _currentRR_errors = [] }
+        handleAction $ SaveRR rr
+
+  SaveRR rr -> do
+    state <- H.get
+    H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid
+    message <- H.liftEffect
+      $ DNSManager.serialize
+      $ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
+    H.raise $ MessageToSend message
+
+  RemoveRR rr_id -> do
+    { _domain } <- H.get
+    H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")"
+    -- Send a removal message.
+    message <- H.liftEffect
+      $ DNSManager.serialize
+      $ DNSManager.MkDeleteRR { domain: _domain, rrid: rr_id }
+    H.raise $ MessageToSend message
+    -- Modal doesn't need to be active anymore.
+    handleAction CancelModal
+
+  AskZoneFile -> do
+    state <- H.get
+    H.raise $ Log $ SystemLog $ "Asking for the '" <> state._domain <> "' zonefile"
+    message <- H.liftEffect
+      $ DNSManager.serialize
+      $ DNSManager.MkAskGeneratedZoneFile { domain: state._domain }
+    H.raise $ MessageToSend message
+
+handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
+handleQuery = case _ of
+
+  MessageReceived message a -> do
+    case message of
+      (DNSManager.MkRRUpdated response) -> do
+        replace_entry response.rr
+        -- When an update is received for a record, it means
+        -- the update request has been accepted, the current modal can be closed.
+        H.modify_ _ { rr_modal = NoModal }
+      (DNSManager.MkRRAdded response) -> do
+        state <- H.get
+        H.put $ add_RR state response.rr
+      (DNSManager.MkRRDeleted response) -> do
+        -- Remove the resource record.
+        state <- H.get
+        H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= response.rrid) state._resources }
+      (DNSManager.MkGeneratedZoneFile response) -> do
+        H.modify_ _ { _zonefile = Just response.zonefile }
+      (DNSManager.MkZone response) -> do
+        add_entries response.zone.resources
+
+      _ -> H.raise $ Log $ ErrorLog $ "Message not handled in ZoneInterface."
+    pure (Just a)
+
+  ConnectionIsDown a -> do
+    H.modify_ _ { wsUp = false }
+    pure (Just a)
+
+  ConnectionIsUp a -> do
+    H.modify_ _ { wsUp = true }
+    pure (Just a)
+
+  where
+    -- replace_entry :: ResourceRecord
+    replace_entry new_rr = do
+      state <- H.get
+      H.modify_ _ { _resources = A.filter (\rr -> rr.rrid /= new_rr.rrid) state._resources }
+
+      new_state <- H.get
+      H.put $ add_RR new_state new_rr
+
+    add_entries []  = pure unit
+    add_entries arr = do
+      case A.head arr, A.tail arr of
+        Nothing, _ -> pure unit
+        Just new_rr, tail -> do
+            state <- H.get
+            H.put $ add_RR state new_rr
+            add_entries $ fromMaybe [] tail
+
+    add_RR :: State -> ResourceRecord -> State
+    add_RR state new_rr = state { _resources = (state._resources <> [ new_rr ]) }
+
+-- Rendering
+render_soa :: forall (w :: Type). Maybe ResourceRecord -> HH.HTML w Action
+render_soa Nothing    = Bulma.box [ HH.text "SOA not loaded, yet" ]
+render_soa (Just soa) = Bulma.box [ Bulma.zone_rr_title "Start Of Authority (SOA)"
+                                  , table_rr
+                                  ]
+  where table_rr = Bulma.table [] [ Bulma.soa_table_header, table_content ]
+        table_content
+          = HH.tbody_ $ [ HH.tr_ $ [
+                                   --, Bulma.p $ "rrtype: "   <>      soa.rrtype
+                                   --, Bulma.p $ "rrid: "     <> show soa.rrid
+                                     HH.td_ [ HH.text soa.name ]
+                                   , HH.td_ [ HH.text $ show soa.ttl ]
+                                   , HH.td_ [ HH.text soa.target ]
+                                   , HH.td_ [ HH.text $ maybe "" id soa.mname   ]
+                                   , HH.td_ [ HH.text $ maybe "" id soa.rname   ]
+                                   , HH.td_ [ HH.text $ maybe "" show soa.serial  ]
+                                   , HH.td_ [ HH.text $ maybe "" show soa.refresh ]
+                                   , HH.td_ [ HH.text $ maybe "" show soa.retry   ]
+                                   , HH.td_ [ HH.text $ maybe "" show soa.expire  ]
+                                   , HH.td_ [ HH.text $ maybe "" show soa.minttl  ]
+                                   ]
+                        ]
+
+-- | Render all Resource Records.
+render_resources :: forall w
+  -- .  Hash.HashMap RRId (Array Validation.Error)
+  . Array (ResourceRecord)
+  -> HH.HTML w Action
+render_resources []
+  = Bulma.box [ Bulma.zone_rr_title "Resource records"
+              , Bulma.subtitle "No records for now"
+              ]
+render_resources records
+  = HH.div_ [ render_soa $ A.head $ A.filter (\rr -> rr.rrtype == "SOA") records
+            , Bulma.box [ basic_records_section ]
+            , Bulma.box [ mx_records_section    ]
+            , Bulma.box [ srv_records_section   ]
+            , Bulma.box_ C.has_background_warning_light [ basic_readonly_records_section ]
+            ]
+  where
+  all_basic_rr    = A.filter (\rr -> A.elem rr.rrtype baseRecords && not rr.readonly) records
+  all_basic_ro_rr = A.filter (\rr -> A.elem rr.rrtype baseRecords && rr.readonly)     records
+  all_mx_rr    = A.filter (\rr -> rr.rrtype == "MX") records
+  all_srv_rr   = A.filter (\rr -> rr.rrtype == "SRV") records
+
+  basic_records_section
+    = if A.length all_basic_rr > 0
+      then Bulma.table [] [ Bulma.simple_table_header, render_basic_records all_basic_rr]
+      else Bulma.p "no basic records"
+
+  basic_readonly_records_section
+    = if A.length all_basic_ro_rr > 0
+      then Bulma.table [] [ Bulma.simple_table_header_ro, render_basic_records all_basic_ro_rr]
+      else Bulma.p "no read only records?"
+
+  mx_records_section
+    = if A.length all_mx_rr > 0
+      then Bulma.table [] [ Bulma.mx_table_header, render_mx_records ]
+      else Bulma.p "no mx records"
+
+  srv_records_section
+    = if A.length all_srv_rr > 0
+      then Bulma.table [] [ Bulma.srv_table_header, render_srv_records ]
+      else Bulma.p "no srv records"
+
+  render_basic_records _rrs = table_content_with_separations _rrs
+  render_mx_records = table_content all_mx_rr
+  render_srv_records = table_content all_srv_rr
+
+  table_content_with_separations records_ = HH.tbody_ $
+    A.groupAllBy (comparing (_.rrtype)) records_ -- [x x y y z] -> [NE[xx], NE[yy], NE[z]]
+    # map NonEmpty.toArray                       -- -> [[xx], [yy], [z]]
+    # map (map rows)                             -- -> [[hh], [hh], [h]] ('h' means 'html')
+    # A.intersperse [emptyline]                  -- -> [[hh], [line], [hh], [line], [h]]
+    # A.concat                                   -- -> [h h line h h line h]
+
+  emptyline = HH.tr_ [ Bulma.txt_name "", HH.td_ [], HH.td_ [], HH.td_ [], HH.td_ [], HH.td_ [] ]
+
+  table_content records_ = HH.tbody_ $ map rows records_
+  rows rr = if rr.readonly
+            then HH.tr [ HP.classes C.has_background_warning_light ] $ render_row rr -- <> error_row rr
+            else HH.tr_ $ render_row rr -- <> error_row rr
+
+  render_row :: ResourceRecord -> Array (HH.HTML w Action)
+  render_row rr =
+    case rr.rrtype of
+      "SRV" ->
+        [ Bulma.txt_name rr.rrtype
+        , HH.td_ [ Bulma.p rr.name]
+        , HH.td_ [ Bulma.p $ show rr.ttl ]
+        , HH.td_ [ Bulma.p $ maybe "" show rr.priority ]
+        , HH.td_ [ Bulma.p $ maybe "" id rr.protocol ]
+        , HH.td_ [ Bulma.p $ maybe "" show rr.weight ]
+        , HH.td_ [ Bulma.p $ maybe "" show rr.port ]
+        , HH.td_ [ Bulma.p rr.target ]
+        , if rr.readonly
+          then HH.td_ [ Bulma.btn_readonly ]
+          else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid) ]
+        , if rr.readonly
+          then HH.td_ [ Bulma.btn_readonly ]
+          else HH.td_ [ Bulma.btn_delete (DeleteRRModal rr.rrid) ]
+        ]
+      "MX"  ->
+        [ Bulma.txt_name rr.rrtype
+        , HH.td_ [ Bulma.p rr.name]
+        , HH.td_ [ Bulma.p $ show rr.ttl ]
+        , HH.td_ [ Bulma.p $ maybe "" show rr.priority ]
+        , HH.td_ [ Bulma.p rr.target ]
+        , if rr.readonly
+          then HH.td_ [ Bulma.btn_readonly ]
+          else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid) ]
+        , if rr.readonly
+          then HH.td_ [ Bulma.btn_readonly ]
+          else HH.td_ [ Bulma.btn_delete (DeleteRRModal rr.rrid) ]
+        ]
+      _     ->
+        [ Bulma.txt_name rr.rrtype
+        , HH.td_ [ Bulma.p rr.name]
+        , HH.td_ [ Bulma.p $ show rr.ttl ]
+        , HH.td_ [ Bulma.p rr.target ]
+        ] <> if rr.readonly
+          then [ HH.td_ [ Bulma.btn_readonly ] ]
+          else [ HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid) ]
+               , HH.td_ [ Bulma.btn_delete (DeleteRRModal rr.rrid) ]
+               ]
+
+baseRecords :: Array String
+baseRecords = [ "A", "AAAA", "CNAME", "TXT", "NS" ]
+
+-- Component definition and initial state
+
+render_new_records :: forall (w :: Type). State -> HH.HTML w Action
+render_new_records _
+  = Bulma.hdiv
+      [ Bulma.h1 "Adding new records"
+      -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
+      , Bulma.level [
+            Bulma.btn     "A" (CreateNewRRModal A)
+          , Bulma.btn  "AAAA" (CreateNewRRModal AAAA)
+          , Bulma.btn   "TXT" (CreateNewRRModal TXT)
+          , Bulma.btn "CNAME" (CreateNewRRModal CNAME)
+          , Bulma.btn    "NS" (CreateNewRRModal NS)
+          , Bulma.btn    "MX" (CreateNewRRModal MX)
+          , Bulma.btn   "SRV" (CreateNewRRModal SRV)
+          ] []
+      , Bulma.hr
+      , Bulma.h1 "Special records about the mail system (soon)"
+      -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
+      , Bulma.level [
+            Bulma.btn_ro (C.is_small <> C.is_warning) "SPF"
+          , Bulma.btn_ro (C.is_small <> C.is_warning) "DKIM"
+          , Bulma.btn_ro (C.is_small <> C.is_warning) "DMARC"
+          ] []
+      , Bulma.hr
+      , Bulma.level [
+            Bulma.btn "Get the final zone file." AskZoneFile
+          ] [HH.text "For debug purposes. ⚠"]
+      ]
+
+render_zonefile :: forall (w :: Type). Maybe String -> HH.HTML w Action
+render_zonefile zonefile = Bulma.box [ maybe (HH.text "") (\x -> HH.pre_ [HH.text x]) zonefile ]
+
+-- ACTIONS
+
+first :: forall a. (a -> Boolean) -> Array a -> Maybe a
+first condition = A.head <<< (A.filter condition)
+
+loopE :: forall state action input output m a b
+  .  (a -> H.HalogenM state action input output m b)
+  -> Array a
+  -> H.HalogenM state action input output m Unit
+loopE f a = case (A.head a) of
+  Nothing -> pure unit
+  Just x  -> do void $ f x
+                case (A.tail a) of
+                  Nothing -> pure unit
+                  Just xs -> loopE f xs
+
+update_field :: ResourceRecord -> Field -> ResourceRecord
+update_field rr updated_field = case updated_field of
+  Field_Domain val   -> rr { name = val }
+  Field_Target val   -> rr { target = val }
+  Field_TTL val      -> rr { ttl = fromMaybe 0 (fromString val) }
+  Field_Priority val -> rr { priority = fromString val }
+  Field_Protocol val -> rr { protocol = Just val }
+  Field_Weight val   -> rr { weight = fromString val }
+  Field_Port val     -> rr { port = fromString val }

src/Bulma.purs

@@ -1,331 +1,423 @@
+-- | The `Bulma` module is a wrapper around the BULMA css framework.
 module Bulma where
-{- This file is a wrapper around the BULMA css framework. -}
-
 import Prelude
 
 import Halogen.HTML as HH
--- import DOM.HTML.Indexed as DHI
+import DOM.HTML.Indexed as DHI
 import Halogen.HTML.Properties as HP
 import Halogen.HTML.Events as HE
+-- import MissingHTMLProperties as MissingProperties
 
--- HTML PropName used with HP.prop
-import Halogen.HTML.Core (PropName(..))
+import CSSClasses as C
+
+import Halogen.HTML.Core (AttrName(..))
 -- import Web.Event.Event (type_, Event, EventType(..))
-import Web.UIEvent.MouseEvent (MouseEvent)
-
-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"  ]
-
+-- import Web.UIEvent.MouseEvent (MouseEvent) -- package web-uievents
 
 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) ]
+  Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+columns classes = HH.div [ HP.classes (C.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) ]
+  Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+column classes = HH.div [ HP.classes (C.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 ]
+h1 title = HH.h1 [ HP.classes (C.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 ]
+h3 title = HH.h3 [ HP.classes (C.title <> C.is5) ] [ HH.text title ]
+
+zone_rr_title :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
+zone_rr_title title
+  = HH.h3 [ HP.classes (C.title <> C.is5 <> C.has_text_light <> C.has_background_dark) ]
+          [ HH.text title ]
+
+subtitle :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
+subtitle title = HH.h2 [ HP.classes (C.subtitle <> C.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"] ]
 
---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" ]
+input_classes :: Array HH.ClassName
+input_classes = C.input <> C.is_small <> C.is_info
 
-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" ]
+table :: forall w i. HH.Node DHI.HTMLtable w i
+table prop xs = HH.table ([ HP.classes $ C.table ] <> prop) xs
 
---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
+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 "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
-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
-      ]
+simple_table_header_ro :: forall w i. HH.HTML w i
+simple_table_header_ro
+  = HH.thead_ [ HH.tr [ HP.classes C.has_background_warning_light ]
+                       [ HH.th  [ HP.style "width: 50px;" ] [ HH.text "Type"  ]
+                       , HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
-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 ]
-  ]
+mx_table_header :: forall w i. HH.HTML w i
+mx_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th  [ HP.style "width: 50px;" ] [ HH.text "Type"  ]
+                       , HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Priority" ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
-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
-      ]
+srv_table_header :: forall w i. HH.HTML w i
+srv_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th  [ HP.style "width: 50px;" ] [ HH.text "Type"  ]
+                       , HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Priority" ]
+                       , HH.th_ [ HH.text "Protocol" ]
+                       , HH.th_ [ HH.text "Weight" ]
+                       , HH.th_ [ HH.text "Port" ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
-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 ]
-  ]
+soa_table_header :: forall w i. HH.HTML w i
+soa_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "name"]
+                       , HH.th_ [ HH.text "ttl"]
+                       , HH.th_ [ HH.text "target"]
+                       , HH.th_ [ HH.text "mname"]
+                       , HH.th_ [ HH.text "rname"]
+                       , HH.th_ [ HH.text "serial"]
+                       , HH.th_ [ HH.text "refresh"]
+                       , HH.th_ [ HH.text "retry"]
+                       , HH.th_ [ HH.text "expire"]
+                       , HH.th_ [ HH.text "minttl"]
+                       ]
+              ]
 
-
----- 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
-
-
-btn :: forall w action. String -> action -> action -> Boolean -> HH.HTML w action
-btn title action1 action2 validity
-  = HH.button
-      [ btn_add_action validity
-      , btn_classes validity
-      ] [ HH.text title ]
+txt_name :: forall w i. String -> HH.HTML w i
+txt_name t
+  = HH.td  [ rr_name_style ] [ rr_name_text ]
   where
-    btn_add_action = case _ of
-      true -> HE.onClick \_ -> action1
-      _    -> HE.onClick \_ -> action2
+    rr_name_style = HP.style "width: 80px;"
+    rr_name_text  = HH.text t
 
-render_input password placeholder action value validity cond
+-- | For textareas I don't use Bulma's "textarea" class since it doesn't allow to expand
+-- | textareas horizontaly, which makes edition of TXT records painful.
+textarea_classes :: Boolean -> Array HH.ClassName
+textarea_classes true  = C.input <> C.is_small <> C.is_info
+textarea_classes false = C.input <> C.is_small <> C.is_danger
+
+textarea :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
+textarea action value validity
+  = HH.textarea
+      [ HE.onValueInput action
+      , HP.value value
+      , HP.placeholder "target"
+      , HP.classes $ textarea_classes validity
+      ]
+
+btn_modify :: forall w i. i -> HH.HTML w i
+btn_modify action = btn_ (C.is_small <> C.is_info) "modify" action
+
+btn_save :: forall w i. i -> HH.HTML w i
+btn_save action = btn_ C.is_info "Save" action
+
+btn_add :: forall w i. i -> HH.HTML w i
+btn_add action = btn_ C.is_info "Add" action
+
+btn_delete :: forall w i. i -> HH.HTML w i
+btn_delete action = btn_ (C.is_small <> C.is_danger) "remove" action
+
+btn_modify_ro :: forall w i. HH.HTML w i
+btn_modify_ro = btn_ro (C.is_small <> C.is_warning) "modify"
+
+btn_readonly :: forall w i. HH.HTML w i
+btn_readonly = btn_ro (C.is_small <> C.is_warning) "read only"
+
+btn_delete_ro :: forall w i. HH.HTML w i
+btn_delete_ro = btn_ro (C.is_small <> C.is_warning) "remove"
+
+btn_ro :: forall w i. Array HH.ClassName -> String -> HH.HTML w i
+btn_ro classes title
+  = HH.button
+      [ HP.classes $ C.button <> classes
+      ] [ HH.text title ]
+
+-- | Create a `level`, different components that should appear on the same horizontal line.
+-- | First argument, elements that should appear on the left, second on the right.
+level :: forall w i. Array (HH.HTML w i) -> Array (HH.HTML w i) -> HH.HTML w i
+level left right = HH.nav [ HP.classes C.level ]
+                          [ HH.div [ HP.classes C.level_left  ] $ itemize left
+                          , HH.div [ HP.classes C.level_right ] $ itemize right
+                          ]
+   where itemize = map (\v -> HH.div [ HP.classes C.level_item ] [v])
+
+btn_ :: forall w action. Array HH.ClassName -> String -> action -> HH.HTML w action
+btn_ classes title action
+  = HH.button
+      [ HE.onClick \_ -> action
+      , HP.classes $ C.button <> classes
+      ] [ HH.text title ]
+
+btn :: forall w action. String -> action -> HH.HTML w action
+btn title action = btn_ [] title action
+
+alert_btn :: forall w action. String -> action -> HH.HTML w action
+alert_btn title action = btn_ C.is_danger title action
+
+render_input :: forall w i.
+  Boolean -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
+render_input password id placeholder action value cond
   = HH.input $
       [ HE.onValueInput action
       , HP.value value
       , HP.placeholder placeholder
-      , input_classes validity
+      , HP.classes $ input_classes
+      , HP.id id
       , cond
       ] <> case password of
         false -> []
         true -> [ HP.type_ HP.InputPassword ]
 
-box_inner ispassword title placeholder action value validity cond
-  = HH.label [ ]
-      [ HH.label [HP.classes class_label ] [ HH.text title ]
-      , HH.div [HP.classes class_control ]
-          [ render_input ispassword placeholder action value validity cond ]
+div_field :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+div_field = HH.div [HP.classes (C.field <> C.is_horizontal)]
+
+div_field_label :: forall w i. String -> String -> HH.HTML w i
+div_field_label id title = HH.div [HP.classes (C.field_label <> C.normal)]
+                                  [HH.label [ HP.classes C.label, HP.for id ] [ HH.text title ]]
+
+div_field_content :: forall w i. HH.HTML w i -> HH.HTML w i
+div_field_content content
+  = HH.div [ HP.classes C.field_body ]
+           [ HH.div [HP.classes C.field ] [ HH.div [HP.classes C.control ] [ content ] ] ]
+
+field_inner :: forall w i.
+  Boolean -> String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
+field_inner ispassword id title placeholder action value cond
+  = div_field
+      [ div_field_label id title
+      , div_field_content $ render_input ispassword id placeholder action value cond
       ]
 
-box_input    = box_inner false
-box_password = box_inner true
+div_field_ :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+div_field_ classes = HH.div [ HP.classes (C.field <> classes) ]
 
---box_button action value validity cond
---  = HH.label [ ]
---      [ HH.label [HP.classes class_label ] [ HH.text title ]
---      , HH.div [HP.classes class_control ]
---          [ render_input ispassword placeholder action value validity cond ]
---      ]
+btn_labeled :: forall w i. String -> String -> String -> i -> HH.HTML w i
+btn_labeled id title button_text action
+  = div_field
+      [ div_field_label id title
+      , div_field_content $ HH.button
+          [ HE.onClick \_ -> action
+          , HP.classes $ C.button <> C.is_small <> C.is_info
+          , HP.id id
+          ] [ HH.text button_text ]
+      ]
+
+box_input :: forall w i.
+  String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
+box_input = field_inner false
+
+box_password :: forall w i.
+  String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
+box_password = field_inner true
+
+section_small :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+section_small = HH.section [ HP.classes (C.section <> C.is_small) ]
+
+section_medium :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+section_medium = HH.section [ HP.classes (C.section <> C.medium) ]
+
+new_domain_field :: forall w i.
+  (String -> i) -> String -> Array (HP.IProp DHI.HTMLselect i) -> Array String -> HH.HTML w i
+new_domain_field inputaction text_ selectaction accepted_domains
+  = div_field_ C.has_addons
+      [ HH.p
+          [ HP.classes C.control ]
+          [ HH.input $
+              [ HE.onValueInput inputaction
+              , HP.placeholder "www"
+              , HP.value text_
+              , HP.type_ HP.InputText
+              , HP.classes (C.is_primary <> C.input)
+              ]
+          ]
+      , HH.p
+          [ HP.classes C.control ]
+          [ select selectaction $ map option accepted_domains ]
+      ]
+
+code :: forall w i. String -> HH.HTML w i
+code str = HH.code_ [ HH.text str ]
+
+text :: forall w i. String -> HH.HTML w i
+text = HH.text
 
 p :: forall w i. String -> HH.HTML w i
 p str = HH.p_ [ HH.text str ]
 
+p_ :: forall w i. Array HH.ClassName -> String -> HH.HTML w i
+p_ classes str = HH.p [HP.classes classes] [ HH.text str ]
+
 box :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
-box = HH.div [HP.classes class_box]
+box = HH.div [HP.classes C.box]
+
+box_ :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+box_ classes = HH.div [HP.classes $ C.box <> classes]
+
+option :: forall w i. String -> HH.HTML w i
+option value = HH.option_ [HH.text value]
+
+select :: forall w i. HH.Node DHI.HTMLselect w i
+select action options
+  = HH.div [ HP.classes (C.select <> C.is_primary) ]
+           [ HH.select action options]
+
+hero :: forall w i. String -> String -> HH.HTML w i
+hero _title _subtitle
+  = HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
+      [ HH.div [ HP.classes C.hero_body ]
+          [ HH.p [ HP.classes C.title ] [ HH.text _title ]
+          , HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
+          ]
+      ]
+
+small_hero :: forall w i. String -> String -> HH.HTML w i
+small_hero _title _subtitle =
+  HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
+    [ HH.div [ HP.classes C.hero_body ]
+        [ HH.div [ HP.classes $ C.container <> C.has_text_centered ]
+            [ HH.p [ HP.classes C.title ]    [ HH.text _title ]
+            , HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
+            ]
+        ]
+    ]
+
+hero_danger :: forall w i. String -> String -> HH.HTML w i
+hero_danger _title _subtitle
+  = HH.section [ HP.classes (C.hero <> C.is_danger <> C.is_small) ]
+      [ HH.div [ HP.classes C.hero_body ]
+          [ HH.p [ HP.classes C.title ] [ HH.text _title ]
+          , HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
+          ]
+      ]
+
+header :: forall w i. String -> String -> HH.HTML w i
+header = hero
+
+container :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+container = HH.div [HP.classes (C.container <> C.is_info)]
+
+data_target :: forall r i. String -> HP.IProp r i
+data_target = HP.attr (AttrName "data-target")
+
+modal_ :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+modal_ = HH.div [HP.classes (C.modal <> C.is_active)]
+modal_background :: forall w i. HH.HTML w i
+modal_background = HH.div [HP.classes C.modal_background] []
+modal_card :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+modal_card = HH.div [HP.classes C.modal_card]
+modal_header :: forall w i. String -> HH.HTML w i
+modal_header title = HH.header [HP.classes C.modal_card_head]
+  [ HH.p [HP.classes C.modal_card_title] [HH.text title]
+  ]
+modal_body :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+modal_body = HH.section [HP.classes C.modal_card_body]
+modal_foot :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+modal_foot = HH.div [HP.classes C.modal_card_foot]
+
+cancel_button :: forall w i. i -> HH.HTML w i
+cancel_button action
+  = HH.button [ HP.classes C.button
+              , HE.onClick \_ -> action
+              ] [HH.text "Cancel"]
+
+strong :: forall w i. String -> HH.HTML w i
+strong str = HH.strong_ [ HH.text str ]
+
+hr :: forall w i. HH.HTML w i
+hr = HH.hr_
+
+tile :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+tile classes = HH.div [HP.classes (C.tile <> classes)]
+
+tile_ :: forall w i. Array (HH.HTML w i) ->  HH.HTML w i
+tile_ = tile []
+
+tile_danger :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+tile_danger classes = tile (C.is_danger <> C.notification <> classes)
+
+tile_warning :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+tile_warning classes = tile (C.is_warning <> C.notification <> classes)
+
+article_ :: forall w i. Array HH.ClassName -> HH.HTML w i -> HH.HTML w i -> HH.HTML w i
+article_ classes head body = HH.article [HP.classes (C.message <> classes)]
+  [ HH.div [HP.classes C.message_header] [head]
+  , HH.div [HP.classes C.message_body  ] [body]
+  ]
+
+article :: forall w i. HH.HTML w i -> HH.HTML w i -> HH.HTML w i
+article head body = article_ [] head body
+
+error_message :: forall w i. HH.HTML w i -> HH.HTML w i -> HH.HTML w i
+error_message head body = article_ C.is_danger head body
+
+input_with_side_text :: forall w i.
+  String -> String -> String -> (String -> i) -> String -> String -> HH.HTML w i
+input_with_side_text id title placeholder action value sidetext
+  = HH.div [HP.classes $ C.has_addons <> C.field <> C.is_horizontal]
+      [ HH.div [ HP.classes (C.field_label <> C.normal) ]
+               [HH.label [ HP.classes C.label, HP.for id ] [ HH.text title ]]
+      , HH.div [ HP.classes C.field_body ]
+          [ HH.p [HP.classes C.control]
+              [ HH.input $
+                [ HE.onValueInput action
+                , HP.value value
+                , HP.placeholder placeholder
+                , HP.classes $ input_classes
+                , HP.id id
+                ]
+              ]
+          , HH.p [HP.classes C.control]
+              [ HH.a [HP.classes $ C.button <> C.is_small <> C.is_static]
+                     [HH.text sidetext] ]
+          ]
+      ]
+
+-- | `modal`: create a modal by providing a few things:
+-- | - a title (a simple String)
+-- | - a body (`HTML` content)
+-- | - a footer (`HTML` content)
+modal :: forall w i. String -> Array (HH.HTML w i) -> Array (HH.HTML w i) -> HH.HTML w i
+modal title body foot =
+  modal_
+    [ modal_background
+    , modal_card [modal_header title, modal_body body]
+    , modal_foot foot
+    ]

src/CSSClasses.purs

@@ -0,0 +1,205 @@
+module CSSClasses where
+
+import Prelude (show, ($), (<>))
+
+import Halogen.HTML as HH
+
+is_spaced :: Array HH.ClassName
+is_spaced = [HH.ClassName "is-spaced"]
+
+is_ancestor :: Array HH.ClassName
+is_ancestor = [HH.ClassName "is-ancestor"]
+is_vertical :: Array HH.ClassName
+is_vertical = [HH.ClassName "is-vertical"]
+is_parent :: Array HH.ClassName
+is_parent = [HH.ClassName "is-parent"]
+is_child :: Array HH.ClassName
+is_child = [HH.ClassName "is-child"]
+notification :: Array HH.ClassName
+notification = [HH.ClassName "notification"]
+is_warning :: Array HH.ClassName
+is_warning = [HH.ClassName "is-warning"]
+
+message :: Array HH.ClassName
+message = [HH.ClassName "message"]
+
+message_header :: Array HH.ClassName
+message_header = [HH.ClassName "message-header"]
+
+has_text_centered :: Array HH.ClassName
+has_text_centered = [HH.ClassName "has-text-centered"]
+
+message_body :: Array HH.ClassName
+message_body = [HH.ClassName "message-body"]
+
+box :: Array HH.ClassName
+box = [HH.ClassName "box"]
+button :: Array HH.ClassName
+button = [HH.ClassName "button"]
+buttons :: Array HH.ClassName
+buttons = [HH.ClassName "buttons"]
+breadcrumb :: Array HH.ClassName
+breadcrumb = [HH.ClassName "breadcrumb"]
+column :: Array HH.ClassName
+column = [HH.ClassName "column"]
+columns :: Array HH.ClassName
+columns = [HH.ClassName "columns"]
+container :: Array HH.ClassName
+container = [HH.ClassName "container"]
+control :: Array HH.ClassName
+control = [HH.ClassName "control"]
+delete :: Array HH.ClassName
+delete = [HH.ClassName "delete"]
+field :: Array HH.ClassName
+field = [HH.ClassName "field"]
+field_body :: Array HH.ClassName
+field_body = [HH.ClassName "field-body"]
+field_label :: Array HH.ClassName
+field_label = [HH.ClassName "field-label"]
+has_addons :: Array HH.ClassName
+has_addons = [HH.ClassName "has-addons"]
+has_background_dark :: Array HH.ClassName
+has_background_dark = [HH.ClassName "has-background-dark"]
+has_background_warning :: Array HH.ClassName
+has_background_warning = [HH.ClassName "has-background-warning"]
+
+has_background_primary_dark :: Array HH.ClassName
+has_background_primary_dark = [HH.ClassName "has-background-primary-dark"]
+has_background_link_dark :: Array HH.ClassName
+has_background_link_dark = [HH.ClassName "has-background-link-dark"]
+has_background_info_dark :: Array HH.ClassName
+has_background_info_dark = [HH.ClassName "has-background-info-dark"]
+has_background_success_dark :: Array HH.ClassName
+has_background_success_dark = [HH.ClassName "has-background-success-dark"]
+has_background_warning_dark :: Array HH.ClassName
+has_background_warning_dark = [HH.ClassName "has-background-warning-dark"]
+has_background_danger_dark :: Array HH.ClassName
+has_background_danger_dark = [HH.ClassName "has-background-danger-dark"]
+has_background_danger :: Array HH.ClassName
+has_background_danger = [HH.ClassName "has-background-danger"]
+
+has_background_primary_light :: Array HH.ClassName
+has_background_primary_light = [HH.ClassName "has-background-primary-light"]
+has_background_link_light :: Array HH.ClassName
+has_background_link_light = [HH.ClassName "has-background-link-light"]
+has_background_info_light :: Array HH.ClassName
+has_background_info_light = [HH.ClassName "has-background-info-light"]
+has_background_success_light :: Array HH.ClassName
+has_background_success_light = [HH.ClassName "has-background-success-light"]
+has_background_warning_light :: Array HH.ClassName
+has_background_warning_light = [HH.ClassName "has-background-warning-light"]
+has_background_danger_light :: Array HH.ClassName
+has_background_danger_light = [HH.ClassName "has-background-danger-light"]
+
+has_text_dark :: Array HH.ClassName
+has_text_dark = [HH.ClassName "has-text-dark"]
+has_text_light :: Array HH.ClassName
+has_text_light = [HH.ClassName "has-text-light"]
+has_succeeds_separator :: Array HH.ClassName
+has_succeeds_separator = [HH.ClassName "has-succeeds-separator"]
+has_dropdown :: Array HH.ClassName
+has_dropdown = [HH.ClassName "has-dropdown"]
+help :: Array HH.ClassName
+help = [HH.ClassName "help"]
+hero :: Array HH.ClassName
+hero = [HH.ClassName "hero"]
+hero_body :: Array HH.ClassName
+hero_body = [HH.ClassName "hero-body"]
+input :: Array HH.ClassName
+input = [HH.ClassName "input"]
+is4 :: Array HH.ClassName
+is4 = [HH.ClassName "is-4"]
+is5 :: Array HH.ClassName
+is5 = [HH.ClassName "is-5"]
+is_active :: Array HH.ClassName
+is_active = [HH.ClassName "is-active"]
+is_centered :: Array HH.ClassName
+is_centered = [HH.ClassName "is-centered"]
+is_danger :: Array HH.ClassName
+is_danger = [HH.ClassName "is-danger"]
+is :: Int -> Array HH.ClassName
+is size = [HH.ClassName $ "is-" <> show size]
+is_size :: Int -> Array HH.ClassName
+is_size size = [HH.ClassName $ "is-size-" <> show size]
+is_horizontal :: Array HH.ClassName
+is_horizontal = [HH.ClassName "is-horizontal"]
+is_hoverable :: Array HH.ClassName
+is_hoverable = [HH.ClassName "is-hoverable"]
+is_info :: Array HH.ClassName
+is_info = [HH.ClassName "is-info"]
+is_light :: Array HH.ClassName
+is_light = [HH.ClassName "is-light"]
+is_normal :: Array HH.ClassName
+is_normal = [HH.ClassName "is-normal"]
+is_primary :: Array HH.ClassName
+is_primary = [HH.ClassName "is-primary"]
+is_small :: Array HH.ClassName
+is_small = [HH.ClassName "is-small"]
+is_success :: Array HH.ClassName
+is_success = [HH.ClassName "is-success"]
+is_selected :: Array HH.ClassName
+is_selected = [HH.ClassName "is-selected"]
+is_static :: Array HH.ClassName
+is_static = [HH.ClassName "is-static"]
+label :: Array HH.ClassName
+label = [HH.ClassName "label"]
+level :: Array HH.ClassName
+level = [HH.ClassName "level"]
+level_item :: Array HH.ClassName
+level_item = [HH.ClassName "level-item"]
+level_left :: Array HH.ClassName
+level_left = [HH.ClassName "level-left"]
+level_right :: Array HH.ClassName
+level_right = [HH.ClassName "level-right"]
+medium :: Array HH.ClassName
+medium = [HH.ClassName "is-medium"]
+modal :: Array HH.ClassName
+modal = [HH.ClassName "modal"]
+modal_background :: Array HH.ClassName
+modal_background = [HH.ClassName "modal-background"]
+modal_card :: Array HH.ClassName
+modal_card = [HH.ClassName "modal-card"]
+modal_card_body :: Array HH.ClassName
+modal_card_body = [HH.ClassName "modal-card-body"]
+modal_card_foot :: Array HH.ClassName
+modal_card_foot = [HH.ClassName "modal-card-foot"]
+modal_card_head :: Array HH.ClassName
+modal_card_head = [HH.ClassName "modal-card-head"]
+modal_card_title :: Array HH.ClassName
+modal_card_title = [HH.ClassName "modal-card-title"]
+navbar :: Array HH.ClassName
+navbar = [HH.ClassName "navbar"]
+navbar_brand :: Array HH.ClassName
+navbar_brand = [HH.ClassName "navbar-brand"]
+navbar_burger :: Array HH.ClassName
+navbar_burger = [HH.ClassName "navbar-burger"]
+navbar_divider :: Array HH.ClassName
+navbar_divider = [HH.ClassName "navbar-divider"]
+navbar_dropdown :: Array HH.ClassName
+navbar_dropdown = [HH.ClassName "navbar-dropdown"]
+navbar_end :: Array HH.ClassName
+navbar_end = [HH.ClassName "navbar-end"]
+navbar_item :: Array HH.ClassName
+navbar_item = [HH.ClassName "navbar-item"]
+navbar_link :: Array HH.ClassName
+navbar_link = [HH.ClassName "navbar-link"]
+navbar_menu :: Array HH.ClassName
+navbar_menu = [HH.ClassName "navbar-menu"]
+navbar_start :: Array HH.ClassName
+navbar_start = [HH.ClassName "navbar-start"]
+normal :: Array HH.ClassName
+normal = [HH.ClassName "is-normal"]
+section :: Array HH.ClassName
+section = [HH.ClassName "section"]
+select :: Array HH.ClassName
+select = [HH.ClassName "select"]
+subtitle :: Array HH.ClassName
+subtitle = [HH.ClassName "subtitle"]
+table :: Array HH.ClassName
+table = [HH.ClassName "table"]
+textarea :: Array HH.ClassName
+textarea = [HH.ClassName "textarea"]
+tile :: Array HH.ClassName
+tile = [HH.ClassName "tile"]
+title :: Array HH.ClassName
+title = [HH.ClassName "title"]

src/MissingHTMLProperties.purs

@@ -0,0 +1,12 @@
+-- | `MissingHTMLProperties` provides missing properties.
+-- | This shall pretty soon be removed.
+module MissingHTMLProperties where
+
+import Halogen.HTML.Properties as HP
+import Halogen.HTML.Core (PropName(..),AttrName(..))
+
+aria_current :: forall r i. String -> HP.IProp r i
+aria_current = HP.attr (AttrName "aria-current")
+
+size :: forall r i. Int -> HP.IProp (size :: Int | r) i
+size = HP.prop (PropName "size")