Home page: talk about the code.

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.

app/index.html

@@ -6,6 +6,12 @@
     <link rel="stylesheet" href="./bulma.css">
     <title>DNS Manager (beta)</title>
   </head>
+  <style>
+    .justified {
+      text-justify: auto;
+      text-align: justify
+    }
+  </style>
   <body>
     <script src="./index.js" type="module"></script>
   </body>

drop/APIStuff.purs

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

drop/Base64.purs

@@ -0,0 +1,14 @@
+module Base64 where
+
+import Prelude (($), (+), (/), (-))
+import Data.Int (toNumber, floor)
+import Data.Number ((%))
+
+datasize2b64size :: Int -> Int
+datasize2b64size v =
+  let x = toNumber v
+      remainder = x % 24.0
+      additional_chars = (x / 24.0) + (32.0 - remainder) / 8.0
+      base = x / 8.0
+  in floor $ base + additional_chars
+

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/DKIM.purs

@@ -0,0 +1,15 @@
+
+-- DKIM info in mail headers.
+-- a  :: Maybe Algorithm   -- TODO: (required), signing algorithm (example: `rsa-sha256`)
+-- d  :: Maybe String      -- TODO: (required), Signing Domain Identifier (SDID) (example: `netlib.re`)
+-- s  :: Maybe Selector    -- TODO: (required), selector (name of the DNS TXT entry for DKIM, such as `baguette` for `_baguette._dkim.netlib.re`)
+-- c  :: Maybe Algorithm   -- TODO: (optional), canonicalization algorithm(s) for header and body (ex: "relaxed/simple")
+-- q  :: Maybe String      -- TODO: (optional), default query method (example: `dns/txt`)
+-- i  :: Maybe String      -- TODO: (optional), Agent or User Identifier (AUID) (in practice, an email address)
+-- t  :: Maybe Time        -- TODO: (recommended), signature timestamp (time = number, such as `1117574938`)
+-- x  :: Maybe Time        -- TODO: (recommended), expire time (time = number, such as `1117574938`)
+-- l  :: Maybe Int         -- TODO: (optional), body length (such as `200`)
+-- h  :: Maybe String      -- TODO: (required), header fields - list of those that have been signed
+-- z  :: Maybe String      -- TODO: (optional), header fields - copy of selected header fields and values
+-- bh :: Maybe CryptoHash  -- TODO: (required), body hash
+-- b  :: Maybe Signature   -- TODO: (required), signature of headers and body

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,8 +1,15 @@
 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-mini:
+	PATH=$$PATH:node_modules/.bin spago bundle-app -y
+	mv index.js app/
+
 bundle: install-esbuild
 	PATH=$$PATH:node_modules/.bin spago bundle-app
 	mv index.js app/
@@ -13,6 +20,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/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/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,208 @@
+-- | `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.Message.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 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 App.Message.DNSManagerDaemon as DNSManager
+import App.Message.AuthenticationDaemon as AuthD
+
+import App.Log as AppLog
+import App.WS as WS
+
+import App.Page.Authentication as AI
+import App.Page.Registration   as RI
+import App.Page.MailValidation as MVI
+import App.Page.Administration as AdminInterface
+import App.Page.Setup          as SetupInterface
+import App.Page.DomainList     as DomainListInterface
+import App.Page.Zone           as ZoneInterface
+import App.Page.Home           as HomeInterface
+import App.Page.Navigation     as NavigationInterface
+
+import Web.HTML (window) as HTML
+import Web.HTML.Window (sessionStorage) as Window
+import Web.Storage.Storage as Storage
+
+import App.Type.Email as Email
+
+import App.Type.LogMessage (LogMessage(..))
+
+import App.Type.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 +212,547 @@ 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.hr
+    , Bulma.columns_ [ Bulma.column_ [ Bulma.h3 "Logs (watch this if something fails! 😅)", 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 "ws://127.0.0.1:8080" AuthenticationDaemonEvent
+
+    render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
+    render_dnsmanager_WS = HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" 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 $ SystemLog "Self termination. 😿"
+
+      {- no user id, it's self termination -}
+      dns_message  <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Nothing }
+      auth_message <- H.liftEffect $ AuthD.serialize      $ AuthD.MkDeleteUser      { user:    Nothing }
+      H.tell _ws_dns unit (WS.ToSend dns_message)
+      H.tell _ws_auth unit (WS.ToSend auth_message)
+
+      -- Once the user has been deleted, just act like it was just a disconnection.
+      handleAction $ Disconnection
+
+    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)
+    AdminInterface.DeleteUserAccount uid -> do
+      handleAction $ Log $ SystemLog "Remove user account. 😿"
+
+      {- User id is provided this time, it's (probably) NOT self termination. -}
+      dns_message  <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Just uid }
+      auth_message <- H.liftEffect $ AuthD.serialize      $ AuthD.MkDeleteUser      { user:    Just uid }
+      H.tell _ws_dns unit (WS.ToSend dns_message)
+      H.tell _ws_auth unit (WS.ToSend auth_message)
+    AdminInterface.GetOrphanDomains -> do
+      message  <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetOrphanDomains {}
+      H.tell _ws_dns unit (WS.ToSend message)
+
+  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
+
+    handleAction $ Routing Home
+
+  -- | `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.MkOrphanDomainList response -> do
+            handleAction $ Log $ SuccessLog "Received orphan domain list."
+            H.tell _admini unit (AdminInterface.GotOrphanDomainList response.domains)
+          (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/DisplayErrors.purs

@@ -0,0 +1,156 @@
+-- | 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 <> "."
+
+      -- SPF dedicated RR
+      ValidationDNS.VESPFMechanismName err -> maybe default_error show_error_domain err.error
+      ValidationDNS.VESPFMechanismIPv4 err -> maybe default_error show_error_ip4 err.error
+      ValidationDNS.VESPFMechanismIPv6 err -> maybe default_error show_error_ip6 err.error
+      ValidationDNS.VESPFModifierName  err -> maybe default_error show_error_domain err.error
+
+      ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max
+  )
+  where default_error = Bulma.p ""
+
+show_error_key_sizes :: forall w i. Int -> Int -> HH.HTML w i
+show_error_key_sizes min max
+  = Bulma.p $ "Chosen signature algorithm only accepts public key input between "
+              <> show min <> " and " <> show max <> " characters."
+
+-- | `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 <> ")"
+
+  -- SPF dedicated RR
+  ValidationDNS.VESPFMechanismName err -> "The domain name in a SPF mechanism is wrong (position: " <> show err.position <> ")"
+  ValidationDNS.VESPFMechanismIPv4 err -> "The IPv4 address in a SPF mechanism is wrong (position: "        <> show err.position <> ")"
+  ValidationDNS.VESPFMechanismIPv6 err -> "The IPv6 address in a SPF mechanism is wrong (position: "        <> show err.position <> ")"
+
+  ValidationDNS.VESPFModifierName err  -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong (position: " <> show err.position <> ")"
+  ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length."
+
+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 ':')."
+  IPAddress.IP6InvalidRange -> Bulma.p "IPv6 address or range isn't valid."
+
+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 '.')."
+  IPAddress.IP4InvalidRange -> Bulma.p "IPv4 address or range isn't valid."
+
+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/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.Type.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/Message/AuthenticationDaemon.purs

@@ -1,4 +1,4 @@
-module App.Messages.AuthenticationDaemon where
+module App.Message.AuthenticationDaemon where
 
 import Prelude (bind, pure, show, ($))
 
@@ -14,15 +14,15 @@ import Data.UInt (fromInt, toInt, UInt)
 import Data.Tuple (Tuple(..))
 import Data.ArrayBuffer.Types (ArrayBuffer)
 
-import App.Email as Email
-import App.UserPublic as UserPublic
-import App.PermissionLevel as PermissionLevel
+import App.Type.Email as Email
+import App.Type.UserPublic as UserPublic
+import App.Type.PermissionLevel as PermissionLevel
 
 import Effect.Class (liftEffect)
 import Data.Argonaut.Parser as JSONParser
 import Data.Bifunctor (lmap)
 
-import App.IPC as IPC
+import App.Message.IPC as IPC
 
 {- TODO:
   For a few messages, user can be designated by a string (login) or a number (its UID).
@@ -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/Message/DNSManagerDaemon.purs

@@ -0,0 +1,420 @@
+module App.Message.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.Type.PermissionLevel as PermissionLevel
+import App.Type.MaintenanceSubject as MaintenanceSubject
+
+import Effect.Class (liftEffect)
+import Data.Argonaut.Parser as JSONParser
+import Data.Bifunctor (lmap)
+
+import App.Message.IPC as IPC
+import App.Type.DNSZone as DNSZone
+import App.Type.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 })
+
+{- 1  -}
+type DeleteUser = { user_id :: Maybe Int }
+codecDeleteUser ∷ CA.JsonCodec DeleteUser
+codecDeleteUser = CA.object "DeleteUser" (CAR.record { user_id: CAR.optional CA.int })
+
+{- 6  -}
+type GetOrphanDomains = { }
+codecGetOrphanDomains ∷ CA.JsonCodec GetOrphanDomains
+codecGetOrphanDomains = CA.object "GetOrphanDomains" (CAR.record { })
+
+{- 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 })
+
+{- 18  -}
+type NewToken = { domain :: String, rrid :: Int }
+codecNewToken ∷ CA.JsonCodec NewToken
+codecNewToken = CA.object "NewToken" (CAR.record { domain: CA.string, rrid: CA.int })
+
+{- 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 })
+
+{- 24  -}
+type OrphanDomainList = { domains :: Array String }
+codecOrphanDomainList ∷ CA.JsonCodec OrphanDomainList
+codecOrphanDomainList = CA.object "OrphanDomainList" (CAR.record { domains: CA.array 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
+  | MkDeleteUser           DeleteUser           -- 1
+  | MkGetOrphanDomains     GetOrphanDomains     -- 6
+  | 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
+  | MkNewToken             NewToken             -- 18
+  --| MkUseToken           UseToken             -- 19
+  | 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
+  | MkOrphanDomainList    OrphanDomainList    -- 24
+  | 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
+    (MkDeleteUser           request) -> get_tuple 1   codecDeleteUser           request
+    (MkGetOrphanDomains     request) -> get_tuple 6   codecGetOrphanDomains     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
+    (MkNewToken             request) -> get_tuple 18  codecNewToken             request
+    --(MkUseToken           request) -> get_tuple 19  codecUseToken             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
+    24  -> error_management codecOrphanDomainList    MkOrphanDomainList
+    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/Message/IPC.purs

@@ -1,4 +1,4 @@
-module App.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
+module App.Message.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
 
 {-
   This file contains raw serialization and deserialization of IPC messages.
@@ -10,7 +10,7 @@ module App.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
 
   The message type informs what format should be expected.
   For example: an authentication attempt, a page request, etc.
-  Actual message formats can be found in the App.Messages folder.
+  Actual message formats can be found in the App.Message folder.
 -}
 
 import Prelude (bind, (<$>), discard, ($), (>>>), (+), (-))

src/App/Page/Administration.purs

@@ -0,0 +1,330 @@
+{- 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.Page.Administration where
+
+import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==))
+import Data.Eq (class Eq)
+
+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.Type.UserPublic (UserPublic)
+import Data.ArrayBuffer.Types (ArrayBuffer)
+
+import App.Type.LogMessage
+-- import App.IPC as IPC
+import App.Type.Email as Email
+
+-- import App.Message.DNSManagerDaemon as DNSManager
+import App.Message.AuthenticationDaemon as AuthD
+
+data Output
+  = MessageToSend ArrayBuffer
+  | Log LogMessage
+  | AskState
+  | StoreState State
+  | DeleteUserAccount Int
+  | GetOrphanDomains
+
+  --| DeleteDomain String
+  --| RequestDomain String
+
+data Query a
+  = MessageReceived AuthD.AnswerMessage a
+  | ConnectionIsDown a
+  | ConnectionIsUp a
+  | GotOrphanDomainList (Array String) 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
+
+  -- Domains.
+  | ShowOrphanDomains
+  | RemoveDomain String
+  | ShowDomain String
+
+  -- | Change the displayed tab.
+  | ChangeTab Tab
+
+  | Initialize
+  | Finalize
+
+-- | There are different tabs in the administration page.
+-- | For example, users can be searched (`authd`) and a list is provided.
+data Tab = Home | Search | Add | OrphanDomains
+derive instance eqTab :: Eq Tab
+
+type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
+type StateSearchUserForm = { regex :: String {-, admin :: Boolean, domain :: String -} }
+
+type State =
+  { addUserForm    :: StateAddUserForm
+  , searchUserForm :: StateSearchUserForm
+  , current_tab    :: Tab
+  , wsUp           :: Boolean
+  , matching_users :: Array UserPublic
+  , orphan_domains :: Array 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
+        }
+    }
+
+initialState :: Input -> State
+initialState _ = { addUserForm:    { login: "", admin: false, email: "", pass: "" }
+                 , searchUserForm: { regex: "" {-, admin: false, domain: "" -} }
+                 , matching_users: []
+                 , orphan_domains: []
+                 , current_tab: Home
+                 , wsUp: true
+                 }
+
+render :: forall m. State -> H.ComponentHTML Action () m
+render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domains, wsUp }
+  = Bulma.section_small
+      [ fancy_tab_bar
+      , case current_tab of
+          Home -> 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] ]
+          OrphanDomains -> HH.div_
+            [ Bulma.btn_ (C.is_small) "Get orphan domains" ShowOrphanDomains
+            , show_orphan_domains
+            ]
+      ]
+    where
+    fancy_tab_bar =
+      Bulma.fancy_tabs
+        [ Bulma.tab_entry (is_tab_active Home)          "Home"             (ChangeTab Home)
+        , Bulma.tab_entry (is_tab_active Search)        "Search"           (ChangeTab Search)
+        , Bulma.tab_entry (is_tab_active Add)           "Add"              (ChangeTab Add)
+        , Bulma.tab_entry (is_tab_active OrphanDomains) "OrphanDomains"    (ChangeTab OrphanDomains)
+        ]
+    is_tab_active tab = current_tab == tab
+
+    show_found_users = Bulma.box [ HH.ul_ $ map user_card matching_users ]
+    user_card user = HH.li_ [ Bulma.btn_delete (RemoveUser user.uid)
+                            , Bulma.btn_ (C.is_small) user.login (ShowUser user.uid)
+                            ]
+    show_orphan_domains = Bulma.box [ HH.ul_ $ map domain_entry orphan_domains ]
+    domain_entry domain = HH.li_ [ Bulma.btn_delete (RemoveDomain domain)
+                                 , Bulma.btn_ (C.is_small) domain (ShowDomain domain)
+                                 ]
+    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
+        ]
+
+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_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage
+    case old_tab of
+      Nothing -> H.raise $ Log $ ErrorLog "We hadn't changed tab before reload apparently."
+      Just current_tab -> case current_tab of
+        "Home"          -> handleAction $ ChangeTab Home
+        "Search"        -> handleAction $ ChangeTab Search
+        "Add"           -> handleAction $ ChangeTab Add
+        "OrphanDomains" -> handleAction $ ChangeTab OrphanDomains
+        _               -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
+
+  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 <> ")"
+
+  ShowOrphanDomains -> do
+    H.raise $ Log $ SystemLog $ "Get orphan domains"
+    H.raise $ GetOrphanDomains
+
+  RemoveUser uid -> do
+    H.raise $ Log $ SystemLog $ "Remove user " <> show uid
+    H.raise $ DeleteUserAccount uid
+
+  RemoveDomain domain -> do
+    H.raise $ Log $ SystemLog $ "TODO: remove domain " <> domain
+    --H.raise $ DeleteDomain domain
+
+  ShowDomain domain -> do
+    H.raise $ Log $ SystemLog $ "TODO: show domain " <> domain
+    -- H.raise $ RequestDomain domain
+
+  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"
+
+  ChangeTab current_tab -> do
+    -- Store the current tab we are on and restore it when we reload.
+    sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+    _ <- case current_tab of
+      Home           -> H.liftEffect $ Storage.setItem "current-ada-tab" "Home"          sessionstorage
+      Search         -> H.liftEffect $ Storage.setItem "current-ada-tab" "Search"        sessionstorage
+      Add            -> H.liftEffect $ Storage.setItem "current-ada-tab" "Add"           sessionstorage
+      OrphanDomains  -> H.liftEffect $ Storage.setItem "current-ada-tab" "OrphanDomains" sessionstorage
+    H.modify_ _ { current_tab = current_tab }
+
+  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)
+
+  GotOrphanDomainList domains a -> do
+    H.raise $ Log $ SuccessLog "Got orphan domain list!"
+    H.modify_ _ { orphan_domains = domains }
+    pure (Just a)

src/App/Page/Authentication.purs

@@ -0,0 +1,342 @@
+-- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
+-- | TODO: token validation.
+module App.Page.Authentication 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.Type.LogMessage
+import App.Message.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/Page/DomainList.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.Page.DomainList where
+
+import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>), (>))
+
+import Data.Array as A
+import Data.ArrayBuffer.Types (ArrayBuffer)
+import Data.Either (Either(..))
+import Data.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.Type.LogMessage
+import App.Message.DNSManagerDaemon as DNSManager
+
+-- | `App.DomainListInterface` can send messages through websocket interface
+-- | connected to dnsmanagerd. See `App.WS`.
+-- |
+-- | Also, this component can log messages and ask its parent (`App.Container`) to
+-- | reconnect the websocket to `dnsmanagerd`.
+-- |
+-- | Finally, the component can ask its state to its parent.
+-- | The reason is quite simple.
+-- | The component can be deleted, meaning that it loses its state.
+-- | Instead of asking `dnsmanagerd` the list of available domains and the list of owned domains
+-- | each time the component is instanciated, the parent stores the component's state when the
+-- | component is removed. This way, the data is conserved.
+
+data Output
+  = MessageToSend ArrayBuffer
+  | Log LogMessage
+  | ChangePageZoneInterface String
+  | AskState
+  | StoreState State
+
+-- | `App.DomainListInterface` can receive messages from `dnsmanagerd`.
+-- |
+-- | The component is also informed when the connection is lost or up again.
+-- |
+-- | Finally, its entire state can be provided by its parent.
+-- | See the explanation for the `Output` data type.
+
+data Query a
+  = MessageReceived DNSManager.AnswerMessage a
+  | 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/Page/Home.purs

@@ -0,0 +1,151 @@
+-- | `App.HomeInterface` presents the website and its features.
+module App.Page.Home 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 [ Bulma.div_content 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 host your services or websites.
+              We just provide a name.
+              You can host your websites anywhere you want: at home for example.
+              """
+          ]
+    render_updates
+      = b [ title "Automatic updates"
+          , p "Update your records with a single, stupidly simple command. For example:"
+          , expl [ Bulma.strong "wget https://beta.netlib.re/token-update/<token>" ]
+          , p "Every A and AAAA records have tokens for easy updates!"
+          ]
+
+    expl content = Bulma.div_content [ Bulma.explanation content ]
+    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 have seen a bug, you have suggestions or you just want to chat?"
+          , p "You can contact us: netlibre@karchnu.fr"
+          ]
+
+    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)."
+          , HH.text "There are a few parts:"
+          , HH.ul_
+            [ link "https://git.baguette.netlib.re/Baguette/authd" "authd"
+                   """
+                   the authentication (and authorization) daemon, used to authenticate
+                   clients through different services;
+                   """
+            , link "https://git.baguette.netlib.re/Baguette/dnsmanagerd" "dnsmanagerd"
+                   """
+                   the dns manager daemon, used as an interactive database, allowing clients
+                   to ask for domains, then handle the domain zones;
+                   """
+            , link "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient"
+                   "dnsmanager webclient"
+                   """
+                   the web client that you are currently using, reading this very text,
+                   and enjoying while managing your zones. 🥰
+                   """
+            ]
+          , Bulma.hr
+          , Bulma.p "But of course, there are a few more technical parts:"
+          , HH.ul_
+            [ link "https://git.baguette.netlib.re/Baguette/libipc" "libIPC"
+                   """
+                   the Inter Process Communication library used between different applications,
+                   such as authd and dnsmanagerd;
+                   """
+            , link "https://git.baguette.netlib.re/Baguette/dodb.cr" "dodb"
+                   """
+                   the Document Oriented DataBase, allowing to store serialized objects
+                   (a Zone, a User, etc.) in simple files as opposed to the usual complexity of
+                   traditional databases.
+                   """
+            ]
+          ]
+    link url link_title content
+      = HH.li_ [ HH.a [HP.href url] [HH.text link_title]
+               , HH.text ", "
+               , HH.text content
+               ]

src/App/Page/MailValidation.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.Page.MailValidation 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.Type.LogMessage
+import App.Message.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/Page/Navigation.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.Page.Navigation 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.Type.Pages (Page(..))
+import App.Type.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/Page/Registration.purs

@@ -0,0 +1,226 @@
+-- | `App.RegistrationInterface` is a registration interface.
+-- | Registration requires a login, an email address and a password.
+module App.Page.Registration 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.Type.Email as Email
+import App.Type.LogMessage
+import App.Message.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/Page/Setup.purs

@@ -0,0 +1,168 @@
+-- | `App.SetupInterface` allows users to change their password or their email address.
+-- | Users can also erase their account.
+module App.Page.Setup where
+
+import Prelude (Unit, bind, discard, pure, ($), (<<<), (==))
+
+import Data.Maybe (Maybe(..))
+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.Type.LogMessage
+import App.Message.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/Text/Explanations.purs

@@ -0,0 +1,136 @@
+module App.Text.Explanations where
+import Halogen.HTML as HH
+import Bulma as Bulma
+
+expl :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+expl content = Bulma.div_content [ Bulma.explanation content ]
+
+tokens :: forall w i. HH.HTML w i
+tokens = HH.div_
+  [ Bulma.h3 "What are tokens?"
+  , expl [ Bulma.p """
+          Tokens are a simple way to update a resource record (A or AAAA) with your current IP address.
+          """
+         ]
+  , HH.p_ [ HH.text "Let's take an example: you have a A record (IPv4) pointing to your web server at home, "
+          , HH.text "but your ISP changes your IP address from time to time. "
+          , HH.text "You can ask for a token (which looks like "
+          , HH.u_ [HH.text "53be0c45-61c4-4d29-8ae9-c2cc8767603d"]
+          , HH.text ") for this specific entry, then make your server regularly visit the following website."
+          ]
+  , expl [ HH.p_ [ HH.text "https://beta.netlib.re/token-update/"
+                 , HH.u_ [HH.text "<your-token>"]
+                 ]
+         ]
+  , Bulma.p "For example: https://beta.netlib.re/token-update/53be0c45-61c4-4d29-8ae9-c2cc8767603d"
+  , Bulma.hr
+  , Bulma.h3 "How to automate the update of my IP address?"
+  , Bulma.p "On Linux, you can make your computer access the update link with the following command."
+  , expl [ Bulma.strong "wget https://beta.netlib.re/token-update/<token>" ]
+  , Bulma.p """
+    No need for a more complex program. This works just fine.
+    And you can run this command every hour.
+    For example, in your crontab (Linux and Unix related):
+    """
+  , expl [ Bulma.strong "0 * * * * wget <url>" ]
+  , Bulma.p """
+    Commands for other operating systems may differ, but you get the idea.
+    """
+  , Bulma.hr
+  , Bulma.h3 "The obvious trap ⚠"
+  , Bulma.p """
+    Make sure to access the website using the related IP address.
+    To update an IPv6 address (AAAA), force your application to access the URL using an IPv6 address.
+    """
+  , expl [ HH.p_ [ Bulma.strong "wget -6 <url>" ]
+         , HH.p_ [ HH.text "To force the use of an IPv6 address." ]
+         , HH.p_ [ Bulma.strong "wget -4 <url>" ]
+         , HH.p_ [ HH.text "To force the use of an IPv4 address." ]
+         ]
+  ]
+
+dkim_introduction :: forall w i. Array (HH.HTML w i)
+dkim_introduction =
+  [ Bulma.p """
+    DKIM is a way to share a public signature key for the domain.
+    This allows emails to be signed by the sender, and for the receiver to prove the origin of the mail.
+    """
+  , HH.p []
+    [ HH.text """
+        Default name is fine, change it only if you know what you are doing.
+        For the configuration of your mail server, remember that your
+      """
+    , HH.u_ [HH.text "selector"]
+    , HH.text " is "
+    , Bulma.strong "default"
+    , HH.text "."
+    ]
+  ]
+
+dkim_default_algorithms :: forall w i. Array (HH.HTML w i)
+dkim_default_algorithms =
+  [ Bulma.p """
+    Default values should be fine (RSA + SHA256), change them only if you know what you are doing.
+    Just enter your public key.
+  """
+  ]
+
+spf_introduction :: forall w i. Array (HH.HTML w i)
+spf_introduction =
+  [ HH.p []
+    [ HH.text "Sender Policy Framework (SPF) is a way to tell "
+    , HH.u_ [HH.text "other mail servers"]
+    , HH.text " what are mail servers susceptible to send mails with email addresses from "
+    , HH.u_ [HH.text "our domain"]
+    , HH.text ". "
+    ]
+  , HH.p []
+    [ HH.text """
+    This way, we can mitigate spam.
+    A server receiving a mail with our email address but coming from an IP address we didn't list as authorized will be discarded.
+    This is not a bullet-proof technique, but it's simple enough and works great with the most basic forms of spam.
+    """
+    ]
+  , HH.p []
+    [ HH.text "A correctly configured domain with a mail server should only advertise the right IP addresses that can possibly send mails from the domain."
+    ]
+  , HH.p []
+    [ HH.u_ [HH.text "Advice for novice users"]
+    , HH.text """
+      : default values should work great with simple domains.
+      """
+    ]
+  ]
+
+spf_default_behavior :: forall w i. Array (HH.HTML w i)
+spf_default_behavior = [Bulma.p """
+  What should someone do when receiving a mail with your email address but not from a listed domain or IP address?
+  """
+  , HH.text """
+  By default, let's advise to drop the mail (a
+  """
+  , HH.u_ [HH.text "hard fail"]
+  , HH.text """).
+  The only way for DKIM to be really meaningful is to block any mail not coming from the intended email servers.
+  Otherwise, it's just a statu quo, and the spamming will continue.
+  """]
+
+srv_introduction :: forall w i. Array (HH.HTML w i)
+srv_introduction =
+  [ Bulma.p "The SRV record is a DNS RR for specifying the location of services."
+  , HH.p_ [ HH.text "Given a specific "
+          , HH.u_ [HH.text "service name"]
+          , HH.text " (which may be arbitrary) and a "
+          , HH.u_ [HH.text "protocol"]
+          , HH.text " (such as TCP or UDP), you can tell where the server is (address name and port). "
+          , HH.text """
+            Both the names of the service and the protocol are used to construct the name of the RR.
+          """
+          ]
+  , HH.p_ [ HH.text "For example, for a service named "
+          , HH.u_ [HH.text "voip"]
+          , HH.text " and given that this service uses the TCP protocol, you can specify that the target is "
+          , HH.u_ [HH.text "server1.example.com."]
+          , HH.text "."
+          ]
+  ]

src/App/Type/AcceptedRRTypes.purs

@@ -0,0 +1,24 @@
+-- | 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.Type.AcceptedRRTypes where
+
+import Prelude
+import Data.Generic.Rep (class Generic)
+import Data.Show.Generic (genericShow)
+
+data AcceptedRRTypes
+  = A
+  | AAAA
+  | TXT
+  | CNAME
+  | NS
+  | MX
+  | SRV
+  | SPF
+  | DKIM
+
+derive instance genericMyADT :: Generic AcceptedRRTypes _
+
+instance showMyADT :: Show AcceptedRRTypes where
+  show = genericShow

src/App/Type/DKIM.purs

@@ -0,0 +1,89 @@
+module App.Type.DKIM where
+
+import Data.Maybe (Maybe(..))
+
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
+
+type PublicKey = String
+
+type DKIM
+  = { v :: Maybe Version            -- v= "DKIM1", entirely optional (for now, even ignored).
+    , k :: Maybe SignatureAlgorithm -- k= Key type (optional, default is "rsa").
+    , h :: Maybe HashingAlgorithm   -- h= hash algorigthm (optional, "sha1" or "sha256" from RFC6376)
+    , p :: PublicKey                -- p= Public-key data (base64; REQUIRED).
+                                    --    The syntax and semantics of this tag value before being
+                                    --    encoded in base64 are defined by the "k=" tag.
+    , n :: Maybe String             -- n= Notes that might be of interest to a human (optional)
+    }
+
+codec :: JsonCodec DKIM
+codec = CA.object "DKIM"
+  (CAR.record
+    { v: CAR.optional codecVersion
+    , k: CAR.optional codecSignatureAlgorithm
+    , h: CAR.optional codecHashingAlgorithm
+    , p: CA.string
+    , n: CAR.optional CA.string
+    })
+
+emptyDKIMRR :: DKIM
+emptyDKIMRR = { v: Nothing, k: Just RSA, h: Just SHA256, p: "", n: Nothing }
+
+-- RFC6376 section 3.6.2.1
+-- All DKIM keys are stored in a subdomain named "_domainkey".  Given a
+-- DKIM-Signature field with a "d=" tag of "example.com" and an "s=" tag
+-- of "foo.bar", the DNS query will be for
+-- "foo.bar._domainkey.example.com".
+
+data HashingAlgorithm = {- SHA1 | -} SHA256
+hash_algos = [ {- "sha1", -} SHA256] :: Array HashingAlgorithm
+
+-- | Codec for just encoding a single value of type `HashingAlgorithm`.
+codecHashingAlgorithm :: CA.JsonCodec HashingAlgorithm
+codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm show_hashing_algorithm CA.string
+
+str_to_hashing_algorithm :: String -> Maybe HashingAlgorithm
+str_to_hashing_algorithm = case _ of
+  -- "sha1"      -> Just SHA1
+  "sha256"    -> Just SHA256
+  _ -> Nothing
+
+show_hashing_algorithm :: HashingAlgorithm -> String
+show_hashing_algorithm = case _ of
+  -- SHA1   -> "sha1"
+  SHA256 -> "sha256"
+
+data SignatureAlgorithm = RSA | ED25519
+sign_algos = [RSA, ED25519] :: Array SignatureAlgorithm
+
+-- | Codec for just encoding a single value of type `SignatureAlgorithm`.
+codecSignatureAlgorithm :: CA.JsonCodec SignatureAlgorithm
+codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm show_signature_algorithm CA.string
+
+str_to_signature_algorithm :: String -> Maybe SignatureAlgorithm
+str_to_signature_algorithm = case _ of
+  "rsa"       -> Just RSA
+  "ed25519"   -> Just ED25519
+  _ -> Nothing
+
+show_signature_algorithm :: SignatureAlgorithm -> String
+show_signature_algorithm = case _ of
+  RSA     -> "rsa"
+  ED25519 -> "ed25519"
+
+data Version = DKIM1
+
+-- | Codec for just encoding a single value of type `Version`.
+codecVersion :: CA.JsonCodec Version
+codecVersion = CA.prismaticCodec "Version" str_to_version show_version CA.string
+
+str_to_version :: String -> Maybe Version
+str_to_version = case _ of
+  "dkim1"       -> Just DKIM1
+  _ -> Nothing
+
+show_version :: Version -> String
+show_version = case _ of
+  DKIM1 -> "dkim1"

src/App/Type/DNSZone.purs

@@ -0,0 +1,24 @@
+module App.Type.DNSZone where
+
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
+import App.Type.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/Type/Email.purs

@@ -1,6 +1,6 @@
 -- | TODO: Email module should include at least some sort of smart
 -- | constructors, rejecting invalid email addresses.
-module App.Email where
+module App.Type.Email where
 
 import Prelude
 

src/App/Type/LogMessage.purs

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

src/App/Type/MaintenanceSubject.purs

@@ -0,0 +1,21 @@
+module App.Type.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/Type/Pages.purs

@@ -0,0 +1,13 @@
+module App.Type.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/Type/PermissionLevel.purs

@@ -1,4 +1,4 @@
-module App.PermissionLevel where
+module App.Type.PermissionLevel where
 
 import Data.Codec.Argonaut as CA
 import Data.Maybe (Maybe(..))

src/App/Type/ResourceRecord.purs

@@ -0,0 +1,253 @@
+module App.Type.ResourceRecord where
+
+import Prelude ((<>), map, bind, pure)
+
+import Data.Maybe (Maybe(..), maybe)
+
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CAR
+
+import App.Type.DKIM as DKIM
+
+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
+
+    , token   :: Maybe String
+
+    -- SPF specific entries.
+    , v :: Maybe String -- Default: spf1
+    , mechanisms :: Maybe (Array Mechanism)
+    , modifiers  :: Maybe (Array Modifier)
+    , q          :: Maybe Qualifier  -- Qualifier for default mechanism (`all`).
+
+    , dkim :: Maybe DKIM.DKIM
+
+    -- TODO: DMARC specific entries.
+    }
+
+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
+
+    , token:   CAR.optional CA.string
+
+    -- SPF specific entries.
+    , v:          CAR.optional CA.string
+    , mechanisms: CAR.optional (CA.array codecMechanism)
+    , modifiers:  CAR.optional (CA.array codecModifier)
+    , q:          CAR.optional codecQualifier
+
+    , dkim:       CAR.optional DKIM.codec
+    })
+
+type Mechanism
+  = { q :: Maybe Qualifier
+    , t :: MechanismType
+    , v :: String    -- Value (IP addresses or ranges, or domains).
+    }
+
+codecMechanism :: JsonCodec Mechanism
+codecMechanism = CA.object "Mechanism"
+  (CAR.record
+    { q: CAR.optional codecQualifier
+    , t: codecMechanismType
+    , v: CA.string
+    })
+
+-- TODO: this is debug code, before actual validation.
+to_mechanism :: String -> String -> String -> Maybe Mechanism
+to_mechanism q t v = do
+  mechanism_type <- str_to_mechanism_type t
+  pure { q: str_to_qualifier q, t: mechanism_type, v }
+to_modifier :: String -> String -> Maybe Modifier
+to_modifier t v = do
+  modifier_type <- str_to_modifier_type t
+  pure { t: modifier_type, v }
+
+-- | `show_modifier` acts like `show_mechanism` regarding the value (meaning: it can be discarded).
+-- | But this probably shouldn't since both values of modifiers actually NEED a value.
+show_modifier :: Modifier -> String
+show_modifier m =
+  let mtype = show_modifier_type m.t
+      value = case m.v of
+               "" -> ""
+               _  -> "=" <> m.v
+  in mtype <> value
+
+show_mechanism :: Mechanism -> String
+show_mechanism m =
+  let qualifier = case maybe "" show_qualifier_char m.q of
+                    "+" -> ""
+                    v      -> v
+      mtype = show_mechanism_type m.t
+      value = case m.v of
+               "" -> ""
+               _  -> "=" <> m.v
+  in qualifier <> mtype <> value
+
+show_qualifier_char :: Qualifier -> String
+show_qualifier_char = case _ of
+  Pass      -> "+"
+  Neutral   -> "?"
+  SoftFail  -> "~"
+  HardFail  -> "-"
+
+data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE
+mechanism_types :: Array String
+mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ]
+
+-- | Codec for just encoding a single value of type `MechanismType`.
+codecMechanismType :: CA.JsonCodec MechanismType
+codecMechanismType = CA.prismaticCodec "MechanismType" str_to_mechanism_type show_mechanism_type CA.string
+
+str_to_mechanism_type :: String -> Maybe MechanismType
+str_to_mechanism_type = case _ of
+  "a"         -> Just A
+  "ip4"       -> Just IP4
+  "ip6"       -> Just IP6
+  "mx"        -> Just MX
+  "ptr"       -> Just PTR
+  "exists"    -> Just EXISTS
+  "include"   -> Just INCLUDE
+  _ -> Nothing
+
+show_mechanism_type :: MechanismType -> String
+show_mechanism_type = case _ of
+  A       -> "a"
+  IP4     -> "ip4"
+  IP6     -> "ip6"
+  MX      -> "mx"
+  PTR     -> "ptr"
+  EXISTS  -> "exists"
+  INCLUDE -> "include"
+
+data ModifierType = EXP | REDIRECT
+modifier_types :: Array String
+modifier_types = ["exp", "redirect"]
+
+show_modifier_type :: ModifierType -> String
+show_modifier_type = case _ of
+  EXP      -> "exp"
+  REDIRECT -> "redirect"
+
+-- | Codec for just encoding a single value of type `ModifierType`.
+codecModifierType :: CA.JsonCodec ModifierType
+codecModifierType = CA.prismaticCodec "ModifierType" str_to_modifier_type show_modifier_type CA.string
+
+str_to_modifier_type :: String -> Maybe ModifierType
+str_to_modifier_type = case _ of
+  "exp"      -> Just EXP
+  "redirect" -> Just REDIRECT
+  _          -> Nothing
+
+type Modifier = { t :: ModifierType, v :: String  {- Value (domain). -} }
+codecModifier :: JsonCodec Modifier
+codecModifier = CA.object "Modifier" (CAR.record { t: codecModifierType, v: CA.string })
+
+emptyRR :: ResourceRecord
+emptyRR
+  = { rrid:         0
+    , readonly:     false
+    , rrtype:       ""
+    , name:         ""
+    , ttl:          1800
+    , target:       ""
+
+    -- MX + SRV
+    , priority:     Nothing
+
+    -- SRV
+    , port:         Nothing
+    , protocol:     Nothing
+    , weight:       Nothing
+
+    -- SOA
+    , mname:        Nothing
+    , rname:        Nothing
+    , serial:       Nothing
+    , refresh:      Nothing
+    , retry:        Nothing
+    , expire:       Nothing
+    , minttl:       Nothing
+
+    , token:        Nothing
+
+    -- SPF specific entries.
+    , v:            Nothing
+    , mechanisms:   Nothing
+    , modifiers:    Nothing
+    , q:            Nothing
+
+    , dkim:         Nothing
+    }
+
+data Qualifier = Pass | Neutral | SoftFail | HardFail
+all_qualifiers :: Array Qualifier
+all_qualifiers = [Pass, Neutral, SoftFail, HardFail]
+qualifier_types :: Array String
+qualifier_types = ["pass", "neutral", "soft_fail", "hard_fail"]
+
+-- | Codec for just encoding a single value of type `Qualifier`.
+codecQualifier :: CA.JsonCodec Qualifier
+codecQualifier = CA.prismaticCodec "Qualifier" str_to_qualifier show_qualifier CA.string
+
+str_to_qualifier :: String -> Maybe Qualifier
+str_to_qualifier = case _ of
+  "pass"      -> Just Pass      -- +
+  "neutral"   -> Just Neutral   -- ?
+  "soft_fail" -> Just SoftFail  -- ~
+  "hard_fail" -> Just HardFail  -- -
+  _ -> Nothing
+
+show_qualifier :: Qualifier -> String
+show_qualifier = case _ of
+  Pass      -> "pass"
+  Neutral   -> "neutral"
+  SoftFail  -> "soft_fail"
+  HardFail  -> "hard_fail"

src/App/Type/UserPublic.purs

@@ -1,13 +1,10 @@
-module App.UserPublic where
+module App.Type.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,326 @@
+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, fromMaybe)
+import Data.String.CodeUnits as CU
+import Data.String as S
+import Data.Validation.Semigroup (V, invalid, toEither)
+
+import App.Type.ResourceRecord (ResourceRecord, emptyRR, Mechanism, Modifier)
+import App.Type.ResourceRecord (MechanismType(..), ModifierType(..)) as RR
+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
+
+import App.Type.DKIM as DKIM
+
+-- | **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
+
+  -- SPF
+  | VESPFMechanismName (G.Error DomainParser.DomainError)
+  | VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error)
+  | VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error)
+
+  | VESPFModifierName (G.Error DomainParser.DomainError)
+
+  | DKIMInvalidKeySize Int Int
+
+type AVErrors = Array Error
+
+-- | Current default values.
+min_ttl      =     30 :: Int
+max_ttl      =  86000 :: Int
+max_txt      =    500 :: Int
+min_priority =      0 :: Int
+max_priority =  65535 :: Int
+min_port     =      0 :: Int
+max_port     =  65535 :: Int
+min_weight   =      0 :: Int
+max_weight   =  65535 :: Int
+
+-- 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
+
+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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "A", name = name, ttl = ttl, target = target
+             , token = form.token }
+
+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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "AAAA", name = name, ttl = ttl, target = target
+             , token = form.token }
+
+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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "TXT", name = name, ttl = ttl, target = 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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CNAME", name = name, ttl = ttl, target = 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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS", name = name, ttl = ttl, target = 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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "MX"
+             , name = name, ttl = ttl, target = target, priority = Just 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 emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV"
+             , name = name, ttl = ttl, target = target
+             , priority = Just priority, port = Just port, protocol = Just protocol, weight = Just weight }
+
+-- My version of "map" lol.
+verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a)
+verification_loop _ [] = pure []
+verification_loop f arr =
+  case A.head arr, A.tail arr of
+    Nothing, _ -> pure []
+    Just value, tail -> ado
+      v <- f value
+      following <- verification_loop f $ maybe [] id tail
+      in [v] <> following
+
+first :: forall a b. a -> b -> a
+first a _ = a
+
+or_nothing :: forall e. G.Parser e String -> G.Parser e String
+or_nothing p = do v <- G.tryMaybe p
+                  e <- G.tryMaybe SomeParsers.eof
+                  case v, e of
+                    Just value, _       -> pure value
+                    _,          Just _  -> pure ""
+                    Nothing,    Nothing -> p -- at least give the right error results
+
+-- | `validate_SPF_mechanism` validates the different values for each mechanism.
+-- | A and MX can both either doesn't have a value or a domain name.
+-- | EXISTS requires a domain name.
+-- |
+-- | **What differs from RFC7208**:
+-- | Some features of the mechanisms described in RFC7208 are lacking.
+-- | For instance, INCLUDE, A, MX, PTR and EXISTS accept domain *specs* not simply domain *names*.
+-- | Also, some of them should accept a CIDR, which currently isn't a thing.
+-- |
+-- | TODO: I don't intend to implement the full RFC7208, but accepting CIDR can be done.
+validate_SPF_mechanism :: Mechanism -> V (Array Error) Mechanism
+validate_SPF_mechanism m = case m.t of
+  -- RFC: `a         = "a"      [ ":" domain-spec ] [ dual-cidr-length ]`
+  RR.A       -> test (or_nothing DomainParser.sub_eof)          VESPFMechanismName
+
+  -- RFC: `mx        = "mx"     [ ":" domain-spec ] [ dual-cidr-length ]`
+  RR.MX      -> test (or_nothing DomainParser.sub_eof)          VESPFMechanismName
+
+  -- RFC: `exists    = "exists"   ":" domain-spec`
+  RR.EXISTS  -> test DomainParser.sub_eof                       VESPFMechanismName
+
+  -- RFC: `ptr       = "ptr"    [ ":" domain-spec ]`
+  RR.PTR     -> test (or_nothing DomainParser.sub_eof)          VESPFMechanismName
+
+  -- RFC: `ip4       = "ip4"      ":" ip4-network   [ ip4-cidr-length ]`
+  RR.IP4     -> test (IPAddress.ipv4_range <|> IPAddress.ipv4)  VESPFMechanismIPv4
+
+  -- RFC: `ip6       = "ip6"      ":" ip6-network   [ ip6-cidr-length ]`
+  RR.IP6     -> test (IPAddress.ipv6_range <|> IPAddress.ipv6)  VESPFMechanismIPv6
+
+  -- RFC: `include   = "include"  ":" domain-spec`
+  RR.INCLUDE -> test DomainParser.sub_eof                       VESPFMechanismName
+
+  where
+  test :: forall e. G.Parser e String -> ((G.Error e) -> Error) -> V (Array Error) Mechanism
+  test p e = ado
+    name <- parse p m.v e
+    in first m name -- name is discarded
+
+validate_SPF_modifier :: Modifier -> V (Array Error) Modifier
+validate_SPF_modifier m = case m.t of
+  RR.EXP -> ado
+    name <- parse DomainParser.sub_eof m.v VESPFModifierName
+    in first m name -- name is discarded
+  RR.REDIRECT -> ado
+    name <- parse DomainParser.sub_eof m.v VESPFModifierName
+    in first m name -- name is discarded
+
+validationSPF :: ResourceRecord -> V (Array Error) ResourceRecord
+validationSPF form = ado
+  name     <- parse DomainParser.sub_eof form.name     VEName
+  ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
+  mechanisms <- verification_loop validate_SPF_mechanism (maybe [] id form.mechanisms)
+  modifiers  <- verification_loop validate_SPF_modifier  (maybe [] id form.modifiers)
+  -- No need to validate the target, actually, it will be completely discarded.
+  -- The different specific entries replace `target` completely.
+  in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SPF"
+             , name = name, ttl = ttl, target = "" -- `target` is discarded!
+             , v = form.v, mechanisms = Just mechanisms
+             , modifiers = Just modifiers, q = form.q }
+
+-- | Accepted RSA key sizes = 2048 or 4096 bits, 256 bits for ED25519.
+-- |
+-- | Since the public key representation for the RSA algorithm is in PKCS format (RFC 5958)
+-- | then converted in PEM (RFC 7468), and knowing this format allows some optional parameters,
+-- | it is not possible to expect an exact size for the public key input.
+-- | Consequently, we expect *at least* an input of 250 bytes for public key, loosely leading
+-- | to accept key sizes of at least 2048 bits. Maximum allowed key size is also arbitrary.
+rsa_min_key_size = 250  :: Int
+rsa_max_key_size = 1000 :: Int
+
+-- | Contrary to RSA, ED25519 doesn't use a PEM-converted PKCS representation to exchange
+-- | public keys, and the key size is 256 bits (32 bytes).
+-- | This key is converted directly in base64, leading to a simple 44-byte key representation.
+ed25519_key_size = 44 :: Int
+
+verify_public_key :: DKIM.SignatureAlgorithm -> DKIM.PublicKey -> V (Array Error) DKIM.PublicKey
+verify_public_key signalgo key = case signalgo of
+  DKIM.RSA -> ado
+    k <- if between rsa_min_key_size rsa_max_key_size (S.length key)
+         then pure key
+         else invalid [DKIMInvalidKeySize rsa_min_key_size rsa_max_key_size]
+    in k
+  DKIM.ED25519 -> ado
+    k <- if S.length key == ed25519_key_size
+         then pure key
+         else invalid [DKIMInvalidKeySize ed25519_key_size ed25519_key_size]
+    in k
+
+validationDKIM :: ResourceRecord -> V (Array Error) ResourceRecord
+validationDKIM form =
+  let dkim = fromMaybe DKIM.emptyDKIMRR form.dkim
+  in ado
+    name     <- parse DomainParser.sub_eof form.name     VEName
+    ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
+    -- TODO: v n
+    p        <- verify_public_key (fromMaybe DKIM.RSA dkim.k) dkim.p
+    -- No need to validate the target, actually, it will be completely discarded.
+    -- The different specific entries replace `target` completely.
+    in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DKIM"
+               , name = name, ttl = ttl, target = "" -- `target` is discarded!
+               , dkim = Just $ dkim { p = p } }
+
+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
+  "SPF"   -> toEither $ validationSPF   entry
+  "DKIM"  -> toEither $ validationDKIM  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.Type.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/Bulma.purs

@@ -1,331 +1,508 @@
+-- | 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
+table_ :: forall w i. Array HH.ClassName -> HH.Node DHI.HTMLtable w i
+table_ classes prop xs = HH.table ([ HP.classes $ C.table <> classes] <> prop) xs
 
-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
-      ]
+mechanism_table_header :: forall w i. HH.HTML w i
+mechanism_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Policy" ]
+                       , HH.th_ [ HH.text "Type" ]
+                       , HH.th_ [ HH.text "Value" ]
+                       , 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 ]
-  ]
+modifier_table_header :: forall w i. HH.HTML w i
+modifier_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Type"  ]
+                       , HH.th_ [ HH.text "Value"   ]
+                       , 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
-      ]
+simple_table_header :: forall w i. HH.HTML w i
+simple_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ 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 "Token" ]
+                       ]
+              ]
 
-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 ]
-  ]
+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 "" ]
+                       ]
+              ]
 
+mx_table_header :: forall w i. HH.HTML w i
+mx_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Priority" ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
----- 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
+srv_table_header :: forall w i. HH.HTML w i
+srv_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "Protocol" ]
+                       , HH.th_ [ HH.text "Target" ]
+                       , HH.th_ [ HH.text "Port" ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       , HH.th_ [ HH.text "Priority" ]
+                       , HH.th_ [ HH.text "Weight" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
+spf_table_header :: forall w i. HH.HTML w i
+spf_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       -- , HH.th_ [ HH.text "Version" ] -- For now, version isn't displayed.
+                       , HH.th_ [ HH.text "Mechanisms" ]
+                       , HH.th_ [ HH.text "Modifiers" ]
+                       , HH.th_ [ HH.text "Default Policy" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
 
-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 ]
+dkim_table_header :: forall w i. HH.HTML w i
+dkim_table_header
+  = HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Name"  ]
+                       , HH.th_ [ HH.text "TTL"   ]
+                       -- , HH.th_ [ HH.text "Version" ] -- For now, version isn't displayed. Assume DKIM1.
+                       , HH.th_ [ HH.text "Hash algo" ]
+                       , HH.th_ [ HH.text "Signature algo" ]
+                       , HH.th_ [ HH.text "Public Key" ]
+                       , HH.th_ [ HH.text "Notes" ]
+                       , HH.th_ [ HH.text "" ]
+                       ]
+              ]
+
+soa_table_header :: forall w i. HH.HTML w i
+soa_table_header
+  = HH.thead_ [ HH.tr [ HP.classes C.has_background_warning_light ]
+                      [ 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"]
+                      ]
+              ]
+
+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
+textarea_ :: forall w i. Array HH.ClassName -> String -> String -> (String -> i) -> HH.HTML w i
+textarea_ classes placeholder value action
+  = HH.textarea
+      [ HE.onValueInput action
+      , HP.value value
+      , HP.placeholder placeholder
+      , HP.classes $ C.textarea <> classes
+      ]
+
+textarea :: forall w i. String ->  String -> (String -> i) -> HH.HTML w i
+textarea placeholder value action = textarea_ [] placeholder value action
+
+btn_modify :: forall w i. i -> HH.HTML w i
+btn_modify action = btn_ (C.is_small <> C.is_info) "⚒" 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) "✖" 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 ]
+      ]
+
+labeled_field :: forall w i. String -> String -> HH.HTML w i -> HH.HTML w i
+labeled_field id title content
+  = div_field
+      [ div_field_label id title
+      , div_field_content content
+      ]
+
+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
+    ]
+
+-- selection: create a "select" input.
+-- Get the changes with "onSelectedIndexChange" which provides an index.
+selection :: forall w i. (Int -> i) -> Array String -> String -> HH.HTML w i
+selection action values selected = HH.div [HP.classes $ C.select <> C.is_normal]
+  [ HH.select [ HE.onSelectedIndexChange action ]
+    $ map (\n -> HH.option [HP.value n, HP.selected (n == selected)] [HH.text n]) values
+  ]
+
+selection_field :: forall w i. String -> String -> (Int -> i) -> Array String -> String -> HH.HTML w i
+selection_field id title action values selected
+  = div_field
+      [ div_field_label id title
+      , div_field_content $ selection action values selected
+      ]
+
+tag_light_info :: forall w i. String -> HH.HTML w i
+tag_light_info str = HH.span [HP.classes (C.tag <> C.is_info <> C.is_light)] [HH.text str]
+
+div_large_content :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+div_large_content content = HH.div [HP.classes (C.is_large <> C.content)] content
+
+div_content :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+div_content content = HH.div [HP.classes (C.content)] content
+
+explanation :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+explanation content = HH.blockquote [HP.classes [HH.ClassName "justified"]] content
+
+
+tabs :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
+tabs classes tab_list = HH.div [HP.classes $ C.tabs <> classes] [HH.ul_ tab_list]
+
+fancy_tabs :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
+fancy_tabs arr = tabs (C.is_medium <> C.is_boxed <> C.is_centered) arr
+
+tab_entry :: forall w i. Boolean -> String -> i -> HH.HTML w i
+tab_entry active name action =
+  HH.li (if active then [HP.classes C.is_active] else [])
+    [ HH.a [HE.onClick \_ -> action] [HH.text name] ]

src/CSSClasses.purs

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

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")