Compare commits
No commits in common. "dev" and "master" have entirely different histories.
88
README.md
88
README.md
|
@ -1,11 +1,91 @@
|
||||||
# dnsmanager interface
|
# Halogen Template
|
||||||
|
|
||||||
### Quick Start
|
### Quick Start
|
||||||
```sh
|
```sh
|
||||||
make
|
git clone https://github.com/purescript-halogen/purescript-halogen-template.git halogen-project
|
||||||
|
cd halogen-project
|
||||||
|
npm install
|
||||||
|
npm run build
|
||||||
|
npm run serve
|
||||||
```
|
```
|
||||||
|
|
||||||
### Introduction
|
### Introduction
|
||||||
|
|
||||||
This code is an alpha version of the official interface for `dnsmanager` (second edition).
|
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.
|
||||||
For now, nothing much to see.
|
|
||||||
|
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.
|
||||||
|
|
|
@ -6,12 +6,6 @@
|
||||||
<link rel="stylesheet" href="./bulma.css">
|
<link rel="stylesheet" href="./bulma.css">
|
||||||
<title>DNS Manager (beta)</title>
|
<title>DNS Manager (beta)</title>
|
||||||
</head>
|
</head>
|
||||||
<style>
|
|
||||||
.justified {
|
|
||||||
text-justify: auto;
|
|
||||||
text-align: justify
|
|
||||||
}
|
|
||||||
</style>
|
|
||||||
<body>
|
<body>
|
||||||
<script src="./index.js" type="module"></script>
|
<script src="./index.js" type="module"></script>
|
||||||
</body>
|
</body>
|
||||||
|
|
|
@ -1,3 +0,0 @@
|
||||||
maybeCurrentConnection <- H.gets _.wsInfo.connection
|
|
||||||
when (isJust maybeCurrentConnection) do
|
|
||||||
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
|
|
|
@ -1,14 +0,0 @@
|
||||||
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
|
|
||||||
|
|
|
@ -1,7 +0,0 @@
|
||||||
|
|
||||||
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" ]
|
|
|
@ -1,15 +0,0 @@
|
||||||
|
|
||||||
-- 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
|
|
|
@ -1,96 +0,0 @@
|
||||||
-- | `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
|
|
|
@ -1,171 +0,0 @@
|
||||||
-- | `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."
|
|
||||||
]
|
|
71
drop/RR.purs
71
drop/RR.purs
|
@ -1,71 +0,0 @@
|
||||||
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." }
|
|
|
@ -1,69 +0,0 @@
|
||||||
-- | `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))
|
|
|
@ -1,44 +0,0 @@
|
||||||
|
|
||||||
-- 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 }
|
|
|
@ -1,44 +0,0 @@
|
||||||
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
|
|
22
makefile
22
makefile
|
@ -1,15 +1,8 @@
|
||||||
all: build
|
all: build
|
||||||
|
|
||||||
clone-generic-parser:
|
build:
|
||||||
[ ! -d ../parser ] && cd .. && git clone ssh://_gitea@git.baguette.netlib.re:2299/Baguette/parser.git || :
|
|
||||||
|
|
||||||
build: clone-generic-parser
|
|
||||||
spago build
|
spago build
|
||||||
|
|
||||||
bundle-mini:
|
|
||||||
PATH=$$PATH:node_modules/.bin spago bundle-app -y
|
|
||||||
mv index.js app/
|
|
||||||
|
|
||||||
bundle: install-esbuild
|
bundle: install-esbuild
|
||||||
PATH=$$PATH:node_modules/.bin spago bundle-app
|
PATH=$$PATH:node_modules/.bin spago bundle-app
|
||||||
mv index.js app/
|
mv index.js app/
|
||||||
|
@ -20,19 +13,6 @@ repl:
|
||||||
spagobuild:
|
spagobuild:
|
||||||
spago build
|
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:
|
install-esbuild:
|
||||||
@echo "install ebbuild"
|
@echo "install ebbuild"
|
||||||
[ -f node_modules/.bin/esbuild ] || npm install esbuild
|
[ -f node_modules/.bin/esbuild ] || npm install esbuild
|
||||||
|
|
|
@ -3,4 +3,3 @@ let upstream =
|
||||||
sha256:8b94a0cd7f86589a6bd06d48cb9a61d69b66a94b668657b2f10c8b14c16e028c
|
sha256:8b94a0cd7f86589a6bd06d48cb9a61d69b66a94b668657b2f10c8b14c16e028c
|
||||||
|
|
||||||
in upstream
|
in upstream
|
||||||
with generic-parser = ../parser/spago.dhall as Location
|
|
||||||
|
|
15
spago.dhall
15
spago.dhall
|
@ -1,6 +1,7 @@
|
||||||
{ name = "dnsmanager-interface"
|
{ name = "halogen-project"
|
||||||
, dependencies =
|
, dependencies =
|
||||||
[ "aff"
|
[ "aff"
|
||||||
|
, "argonaut-codecs"
|
||||||
, "argonaut-core"
|
, "argonaut-core"
|
||||||
, "arraybuffer"
|
, "arraybuffer"
|
||||||
, "arraybuffer-builder"
|
, "arraybuffer-builder"
|
||||||
|
@ -9,16 +10,13 @@
|
||||||
, "bifunctors"
|
, "bifunctors"
|
||||||
, "codec-argonaut"
|
, "codec-argonaut"
|
||||||
, "console"
|
, "console"
|
||||||
, "control"
|
, "const"
|
||||||
, "dom-indexed"
|
|
||||||
, "effect"
|
, "effect"
|
||||||
, "either"
|
, "either"
|
||||||
, "exceptions"
|
, "exceptions"
|
||||||
, "foreign"
|
, "foreign"
|
||||||
, "generic-parser"
|
|
||||||
, "halogen"
|
, "halogen"
|
||||||
, "halogen-subscriptions"
|
, "halogen-subscriptions"
|
||||||
, "integers"
|
|
||||||
, "maybe"
|
, "maybe"
|
||||||
, "newtype"
|
, "newtype"
|
||||||
, "parsing"
|
, "parsing"
|
||||||
|
@ -26,17 +24,14 @@
|
||||||
, "prelude"
|
, "prelude"
|
||||||
, "profunctor"
|
, "profunctor"
|
||||||
, "strings"
|
, "strings"
|
||||||
, "stringutils"
|
|
||||||
, "tailrec"
|
|
||||||
, "transformers"
|
, "transformers"
|
||||||
, "tuples"
|
, "tuples"
|
||||||
, "uint"
|
, "uint"
|
||||||
, "validation"
|
, "variant"
|
||||||
, "web-encoding"
|
, "web-encoding"
|
||||||
, "web-events"
|
, "web-events"
|
||||||
, "web-html"
|
|
||||||
, "web-socket"
|
, "web-socket"
|
||||||
, "web-storage"
|
, "web-uievents"
|
||||||
]
|
]
|
||||||
, packages = ./packages.dhall
|
, packages = ./packages.dhall
|
||||||
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
|
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
|
||||||
|
|
|
@ -0,0 +1,474 @@
|
||||||
|
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
|
|
@ -0,0 +1,533 @@
|
||||||
|
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
|
|
@ -0,0 +1,34 @@
|
||||||
|
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 }
|
|
@ -1,208 +1,30 @@
|
||||||
-- | `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
|
module App.Container where
|
||||||
|
|
||||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure)
|
import Prelude
|
||||||
|
|
||||||
import Bulma as Bulma
|
import Bulma as Bulma
|
||||||
|
|
||||||
import Data.Array as A
|
import Data.Maybe (Maybe(..))
|
||||||
import Data.Maybe (Maybe(..), maybe)
|
|
||||||
import Data.Either (Either(..))
|
|
||||||
import Data.Tuple (Tuple(..))
|
import Data.Tuple (Tuple(..))
|
||||||
|
import App.AuthenticationForm as AF
|
||||||
|
import App.AuthenticationDaemonAdminInterface as AAI
|
||||||
import Halogen as H
|
import Halogen as H
|
||||||
import Halogen.HTML as HH
|
import Halogen.HTML as HH
|
||||||
import Halogen.HTML.Properties as HP
|
|
||||||
import Type.Proxy (Proxy(..))
|
import Type.Proxy (Proxy(..))
|
||||||
import Effect.Aff.Class (class MonadAff)
|
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
|
data Action
|
||||||
-- | Handle events from `AuthenticationInterface`.
|
= Authenticated AF.Output -- User has been authenticated.
|
||||||
= AuthenticationInterfaceEvent AI.Output
|
|
||||||
|
|
||||||
-- | Handle events from `RegistrationInterface`.
|
type State = { token :: Maybe String, uid :: Maybe Int }
|
||||||
| 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 =
|
type ChildSlots =
|
||||||
( log :: AppLog.Slot Unit
|
( af :: AF.Slot Unit
|
||||||
, ho :: HomeInterface.Slot Unit
|
, aai :: AAI.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
|
|
||||||
)
|
)
|
||||||
|
|
||||||
_ho = Proxy :: Proxy "ho" -- Home Interface
|
_af = Proxy :: Proxy "af"
|
||||||
_log = Proxy :: Proxy "log" -- Log
|
_aai = Proxy :: Proxy "aai"
|
||||||
_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 :: forall q i o m. MonadAff m => H.Component q i o m
|
||||||
component =
|
component =
|
||||||
|
@ -212,547 +34,33 @@ component =
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
, 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 :: forall i. i -> State
|
||||||
initialState _ = { token: Nothing
|
initialState _ = { token: Nothing, uid: Nothing }
|
||||||
, current_page: Home
|
|
||||||
, store_DomainListInterface_state: Nothing
|
|
||||||
, store_AuthenticationDaemonAdmin_state: Nothing
|
|
||||||
}
|
|
||||||
|
|
||||||
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
||||||
render state
|
render state
|
||||||
= HH.div_ $
|
= HH.div_ $
|
||||||
[ render_header
|
[ render_auth_form
|
||||||
, render_nav
|
, render_authd_admin_interface
|
||||||
, case state.current_page of
|
, div_token
|
||||||
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
|
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 :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||||
render_auth_form = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent
|
render_auth_form = Bulma.box $ case state.token of
|
||||||
render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
Nothing -> [ HH.slot _af unit AF.component "ws://127.0.0.1:8081" Authenticated ]
|
||||||
render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent
|
Just current_token -> [ Bulma.p ("Token is: " <> current_token) ]
|
||||||
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 :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||||
render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent
|
render_authd_admin_interface = Bulma.box $ case state.token of
|
||||||
|
Just _ ->
|
||||||
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
[ Bulma.h1 "Administrative interface for authd"
|
||||||
render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent
|
, HH.slot_ _aai unit AAI.component "ws://127.0.0.1:8081"
|
||||||
|
|
||||||
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 :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
|
||||||
handleAction = case _ of
|
handleAction = case _ of
|
||||||
Routing page -> do
|
Authenticated (AF.AuthToken (Tuple uid token)) -> H.modify_ _ { uid = Just uid, token = Just token }
|
||||||
-- 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
|
|
||||||
|
|
|
@ -1,156 +0,0 @@
|
||||||
-- | 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 <> ")."
|
|
|
@ -1,6 +1,6 @@
|
||||||
-- | TODO: Email module should include at least some sort of smart
|
-- | TODO: Email module should include at least some sort of smart
|
||||||
-- | constructors, rejecting invalid email addresses.
|
-- | constructors, rejecting invalid email addresses.
|
||||||
module App.Type.Email where
|
module App.Email where
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
module App.Message.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
|
module App.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
|
||||||
|
|
||||||
{-
|
{-
|
||||||
This file contains raw serialization and deserialization of IPC messages.
|
This file contains raw serialization and deserialization of IPC messages.
|
||||||
|
@ -10,7 +10,7 @@ module App.Message.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
|
||||||
|
|
||||||
The message type informs what format should be expected.
|
The message type informs what format should be expected.
|
||||||
For example: an authentication attempt, a page request, etc.
|
For example: an authentication attempt, a page request, etc.
|
||||||
Actual message formats can be found in the App.Message folder.
|
Actual message formats can be found in the App.Messages folder.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import Prelude (bind, (<$>), discard, ($), (>>>), (+), (-))
|
import Prelude (bind, (<$>), discard, ($), (>>>), (+), (-))
|
|
@ -1,95 +0,0 @@
|
||||||
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)
|
|
|
@ -1,420 +0,0 @@
|
||||||
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
|
|
|
@ -1,4 +1,4 @@
|
||||||
module App.Message.AuthenticationDaemon where
|
module App.Messages.AuthenticationDaemon where
|
||||||
|
|
||||||
import Prelude (bind, pure, show, ($))
|
import Prelude (bind, pure, show, ($))
|
||||||
|
|
||||||
|
@ -14,15 +14,15 @@ import Data.UInt (fromInt, toInt, UInt)
|
||||||
import Data.Tuple (Tuple(..))
|
import Data.Tuple (Tuple(..))
|
||||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||||
|
|
||||||
import App.Type.Email as Email
|
import App.Email as Email
|
||||||
import App.Type.UserPublic as UserPublic
|
import App.UserPublic as UserPublic
|
||||||
import App.Type.PermissionLevel as PermissionLevel
|
import App.PermissionLevel as PermissionLevel
|
||||||
|
|
||||||
import Effect.Class (liftEffect)
|
import Effect.Class (liftEffect)
|
||||||
import Data.Argonaut.Parser as JSONParser
|
import Data.Argonaut.Parser as JSONParser
|
||||||
import Data.Bifunctor (lmap)
|
import Data.Bifunctor (lmap)
|
||||||
|
|
||||||
import App.Message.IPC as IPC
|
import App.IPC as IPC
|
||||||
|
|
||||||
{- TODO:
|
{- TODO:
|
||||||
For a few messages, user can be designated by a string (login) or a number (its UID).
|
For a few messages, user can be designated by a string (login) or a number (its UID).
|
||||||
|
@ -60,21 +60,19 @@ codecRegister
|
||||||
, email: CAR.optional Email.codec })
|
, email: CAR.optional Email.codec })
|
||||||
|
|
||||||
{- 2 -}
|
{- 2 -}
|
||||||
type ValidateUser = { user :: String, activation_key :: String }
|
type ValidateUser = { user :: UserID, activation_key :: String }
|
||||||
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
||||||
codecValidateUser
|
codecValidateUser
|
||||||
= CA.object "ValidateUser" (CAR.record
|
= CA.object "ValidateUser" (CAR.record
|
||||||
{ user: CA.string
|
{ user: CA.int
|
||||||
, activation_key: CA.string })
|
, activation_key: CA.string })
|
||||||
|
|
||||||
{- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID,
|
{- 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. -}
|
but they'll be used as login since the user has to type it. -}
|
||||||
{- 3 -}
|
{- 3 -}
|
||||||
type AskPasswordRecovery = { user :: Maybe String, email :: Maybe Email.Email }
|
type AskPasswordRecovery = { user :: String }
|
||||||
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
||||||
codecAskPasswordRecovery
|
codecAskPasswordRecovery = CA.object "AskPasswordRecovery" (CAR.record { user: CA.string })
|
||||||
= CA.object "AskPasswordRecovery"
|
|
||||||
(CAR.record { user: CAR.optional CA.string, email: CAR.optional Email.codec })
|
|
||||||
|
|
||||||
{- 4 -}
|
{- 4 -}
|
||||||
type PasswordRecovery = { user :: String
|
type PasswordRecovery = { user :: String
|
||||||
|
@ -164,16 +162,6 @@ codecSearchUser
|
||||||
{ regex: CAR.optional CA.string
|
{ regex: CAR.optional CA.string
|
||||||
, offset: CAR.optional CA.int })
|
, 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
|
RESPONSES
|
||||||
|
@ -244,9 +232,10 @@ codecGotPermissionSet
|
||||||
, permission: PermissionLevel.codec })
|
, permission: PermissionLevel.codec })
|
||||||
|
|
||||||
{- 9 -}
|
{- 9 -}
|
||||||
type PasswordRecoverySent = { }
|
type PasswordRecoverySent = { user :: UserPublic.UserPublic }
|
||||||
codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent
|
codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent
|
||||||
codecGotPasswordRecoverySent = CA.object "PasswordRecoverySent" (CAR.record { })
|
codecGotPasswordRecoverySent
|
||||||
|
= CA.object "PasswordRecoverySent" (CAR.record { user: UserPublic.codec })
|
||||||
|
|
||||||
{- 10 -}
|
{- 10 -}
|
||||||
type PasswordRecovered = { }
|
type PasswordRecovered = { }
|
||||||
|
@ -339,11 +328,6 @@ type ErrorInvalidRenewKey = {}
|
||||||
codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey
|
codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey
|
||||||
codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {})
|
codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {})
|
||||||
|
|
||||||
{- 250 -}
|
|
||||||
-- type KeepAlive = { }
|
|
||||||
codecGotKeepAlive ∷ CA.JsonCodec KeepAlive
|
|
||||||
codecGotKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
|
||||||
|
|
||||||
-- All possible requests.
|
-- All possible requests.
|
||||||
data RequestMessage
|
data RequestMessage
|
||||||
= MkLogin Login -- 0
|
= MkLogin Login -- 0
|
||||||
|
@ -360,8 +344,6 @@ data RequestMessage
|
||||||
| MkCheckPermission CheckPermission -- 10
|
| MkCheckPermission CheckPermission -- 10
|
||||||
| MkSetPermission SetPermission -- 11
|
| MkSetPermission SetPermission -- 11
|
||||||
| MkSearchUser SearchUser -- 12
|
| MkSearchUser SearchUser -- 12
|
||||||
| MkAuthByToken AuthByToken -- 15
|
|
||||||
| MkKeepAlive KeepAlive -- 250
|
|
||||||
|
|
||||||
-- All possible answers from the authentication daemon (authd).
|
-- All possible answers from the authentication daemon (authd).
|
||||||
data AnswerMessage
|
data AnswerMessage
|
||||||
|
@ -393,28 +375,25 @@ data AnswerMessage
|
||||||
| GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32
|
| GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32
|
||||||
| GotErrorCannotContactUser ErrorCannotContactUser -- 33
|
| GotErrorCannotContactUser ErrorCannotContactUser -- 33
|
||||||
| GotErrorInvalidRenewKey ErrorInvalidRenewKey -- 34
|
| GotErrorInvalidRenewKey ErrorInvalidRenewKey -- 34
|
||||||
| GotKeepAlive KeepAlive -- 250
|
|
||||||
|
|
||||||
encode ∷ RequestMessage -> Tuple UInt String
|
encode ∷ RequestMessage -> Tuple UInt String
|
||||||
encode m = case m of
|
encode m = case m of
|
||||||
(MkLogin request) -> get_tuple 0 codecLogin request
|
(MkLogin request) -> get_tuple 0 codecLogin request
|
||||||
(MkRegister request) -> get_tuple 1 codecRegister request
|
(MkRegister request) -> get_tuple 1 codecRegister request
|
||||||
(MkValidateUser request) -> get_tuple 2 codecValidateUser request
|
(MkValidateUser request) -> get_tuple 2 codecValidateUser request
|
||||||
(MkAskPasswordRecovery request) -> get_tuple 3 codecAskPasswordRecovery 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.
|
-- Both messages are actually a single message type, so they have the same number.
|
||||||
-- TODO: change the message codec for an Either Int String.
|
-- 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
|
(MkGetUserByName request) -> get_tuple 5 codecGetUserByName request
|
||||||
(MkModUser request) -> get_tuple 6 codecModUser request
|
(MkModUser request) -> get_tuple 6 codecModUser request
|
||||||
-- 7 MkEditProfileContent
|
-- 7 MkEditProfileContent
|
||||||
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
|
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
|
||||||
(MkAddUser request) -> get_tuple 9 codecAddUser request
|
(MkAddUser request) -> get_tuple 9 codecAddUser request
|
||||||
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
|
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
|
||||||
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
|
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
|
||||||
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
|
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
|
||||||
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
|
|
||||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
|
||||||
where
|
where
|
||||||
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
|
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)
|
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
|
||||||
|
@ -427,35 +406,34 @@ data DecodeError
|
||||||
decode :: Int -> String -> Either DecodeError AnswerMessage
|
decode :: Int -> String -> Either DecodeError AnswerMessage
|
||||||
decode number string
|
decode number string
|
||||||
= case number of
|
= case number of
|
||||||
0 -> error_management codecGotError GotError
|
0 -> error_management codecGotError GotError
|
||||||
1 -> error_management codecGotToken GotToken
|
1 -> error_management codecGotToken GotToken
|
||||||
2 -> error_management codecGotUser GotUser
|
2 -> error_management codecGotUser GotUser
|
||||||
3 -> error_management codecGotUserAdded GotUserAdded
|
3 -> error_management codecGotUserAdded GotUserAdded
|
||||||
4 -> error_management codecGotUserEdited GotUserEdited
|
4 -> error_management codecGotUserEdited GotUserEdited
|
||||||
5 -> error_management codecGotUserValidated GotUserValidated
|
5 -> error_management codecGotUserValidated GotUserValidated
|
||||||
6 -> error_management codecGotUsersList GotUsersList
|
6 -> error_management codecGotUsersList GotUsersList
|
||||||
7 -> error_management codecGotPermissionCheck GotPermissionCheck
|
7 -> error_management codecGotPermissionCheck GotPermissionCheck
|
||||||
8 -> error_management codecGotPermissionSet GotPermissionSet
|
8 -> error_management codecGotPermissionSet GotPermissionSet
|
||||||
9 -> error_management codecGotPasswordRecoverySent GotPasswordRecoverySent
|
9 -> error_management codecGotPasswordRecoverySent GotPasswordRecoverySent
|
||||||
10 -> error_management codecGotPasswordRecovered GotPasswordRecovered
|
10 -> error_management codecGotPasswordRecovered GotPasswordRecovered
|
||||||
11 -> error_management codecGotMatchingUsers GotMatchingUsers
|
11 -> error_management codecGotMatchingUsers GotMatchingUsers
|
||||||
12 -> error_management codecGotUserDeleted GotUserDeleted
|
12 -> error_management codecGotUserDeleted GotUserDeleted
|
||||||
20 -> error_management codecGotErrorMustBeAuthenticated GotErrorMustBeAuthenticated
|
20 -> error_management codecGotErrorMustBeAuthenticated GotErrorMustBeAuthenticated
|
||||||
21 -> error_management codecGotErrorAlreadyUsedLogin GotErrorAlreadyUsedLogin
|
21 -> error_management codecGotErrorAlreadyUsedLogin GotErrorAlreadyUsedLogin
|
||||||
22 -> error_management codecGotErrorMailRequired GotErrorMailRequired
|
22 -> error_management codecGotErrorMailRequired GotErrorMailRequired
|
||||||
23 -> error_management codecGotErrorUserNotFound GotErrorUserNotFound
|
23 -> error_management codecGotErrorUserNotFound GotErrorUserNotFound
|
||||||
24 -> error_management codecGotErrorPasswordTooShort GotErrorPasswordTooShort
|
24 -> error_management codecGotErrorPasswordTooShort GotErrorPasswordTooShort
|
||||||
25 -> error_management codecGotErrorInvalidCredentials GotErrorInvalidCredentials
|
25 -> error_management codecGotErrorInvalidCredentials GotErrorInvalidCredentials
|
||||||
26 -> error_management codecGotErrorRegistrationsClosed GotErrorRegistrationsClosed
|
26 -> error_management codecGotErrorRegistrationsClosed GotErrorRegistrationsClosed
|
||||||
27 -> error_management codecGotErrorInvalidLoginFormat GotErrorInvalidLoginFormat
|
27 -> error_management codecGotErrorInvalidLoginFormat GotErrorInvalidLoginFormat
|
||||||
28 -> error_management codecGotErrorInvalidEmailFormat GotErrorInvalidEmailFormat
|
28 -> error_management codecGotErrorInvalidEmailFormat GotErrorInvalidEmailFormat
|
||||||
29 -> error_management codecGotErrorAlreadyUsersInDB GotErrorAlreadyUsersInDB
|
29 -> error_management codecGotErrorAlreadyUsersInDB GotErrorAlreadyUsersInDB
|
||||||
30 -> error_management codecGotErrorReadOnlyProfileKeys GotErrorReadOnlyProfileKeys
|
30 -> error_management codecGotErrorReadOnlyProfileKeys GotErrorReadOnlyProfileKeys
|
||||||
31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
|
31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
|
||||||
32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
|
32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
|
||||||
33 -> error_management codecGotErrorCannotContactUser GotErrorCannotContactUser
|
33 -> error_management codecGotErrorCannotContactUser GotErrorCannotContactUser
|
||||||
34 -> error_management codecGotErrorInvalidRenewKey GotErrorInvalidRenewKey
|
34 -> error_management codecGotErrorInvalidRenewKey GotErrorInvalidRenewKey
|
||||||
250 -> error_management codecGotKeepAlive GotKeepAlive
|
|
||||||
_ -> Left UnknownNumber
|
_ -> Left UnknownNumber
|
||||||
where
|
where
|
||||||
-- Signature is required since the compiler's guess is wrong.
|
-- Signature is required since the compiler's guess is wrong.
|
|
@ -1,330 +0,0 @@
|
||||||
{- 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)
|
|
|
@ -1,342 +0,0 @@
|
||||||
-- | `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)
|
|
|
@ -1,319 +0,0 @@
|
||||||
-- | `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
|
|
|
@ -1,151 +0,0 @@
|
||||||
-- | `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
|
|
||||||
]
|
|
|
@ -1,197 +0,0 @@
|
||||||
-- | `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)
|
|
|
@ -1,195 +0,0 @@
|
||||||
-- | `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 ]
|
|
|
@ -1,226 +0,0 @@
|
||||||
-- | `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)
|
|
|
@ -1,168 +0,0 @@
|
||||||
-- | `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)
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,4 +1,4 @@
|
||||||
module App.Type.PermissionLevel where
|
module App.PermissionLevel where
|
||||||
|
|
||||||
import Data.Codec.Argonaut as CA
|
import Data.Codec.Argonaut as CA
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Maybe (Maybe(..))
|
|
@ -1,136 +0,0 @@
|
||||||
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 "."
|
|
||||||
]
|
|
||||||
]
|
|
|
@ -1,24 +0,0 @@
|
||||||
-- | 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
|
|
|
@ -1,89 +0,0 @@
|
||||||
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"
|
|
|
@ -1,24 +0,0 @@
|
||||||
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
|
|
||||||
})
|
|
|
@ -1,7 +0,0 @@
|
||||||
module App.Type.LogMessage where
|
|
||||||
|
|
||||||
data LogMessage
|
|
||||||
= SystemLog String
|
|
||||||
| UnableToSend String
|
|
||||||
| ErrorLog String
|
|
||||||
| SuccessLog String
|
|
|
@ -1,21 +0,0 @@
|
||||||
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"
|
|
|
@ -1,13 +0,0 @@
|
||||||
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`).
|
|
|
@ -1,253 +0,0 @@
|
||||||
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"
|
|
|
@ -1,10 +1,13 @@
|
||||||
module App.Type.UserPublic where
|
module App.UserPublic where
|
||||||
|
|
||||||
import Data.Maybe (Maybe)
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
import Data.Codec.Argonaut (JsonCodec)
|
import Data.Codec.Argonaut (JsonCodec)
|
||||||
import Data.Codec.Argonaut as CA
|
import Data.Codec.Argonaut as CA
|
||||||
import Data.Codec.Argonaut.Record as CAR
|
import Data.Codec.Argonaut.Record as CAR
|
||||||
|
import Data.Newtype (class Newtype)
|
||||||
|
|
||||||
-- | Currently not the real type.
|
-- | Currently not the real type.
|
||||||
-- | Lacks 'profile' attribute.
|
-- | Lacks 'profile' attribute.
|
|
@ -1,326 +0,0 @@
|
||||||
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
|
|
|
@ -1,44 +0,0 @@
|
||||||
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
|
|
|
@ -1,41 +0,0 @@
|
||||||
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
|
|
|
@ -1,43 +0,0 @@
|
||||||
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
|
|
|
@ -1,43 +0,0 @@
|
||||||
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
|
|
|
@ -1,44 +0,0 @@
|
||||||
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
|
|
334
src/App/WS.purs
334
src/App/WS.purs
|
@ -1,334 +0,0 @@
|
||||||
-- | 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
|
|
717
src/Bulma.purs
717
src/Bulma.purs
|
@ -1,508 +1,331 @@
|
||||||
-- | The `Bulma` module is a wrapper around the BULMA css framework.
|
|
||||||
module Bulma where
|
module Bulma where
|
||||||
|
{- This file is a wrapper around the BULMA css framework. -}
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Halogen.HTML as HH
|
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.Properties as HP
|
||||||
import Halogen.HTML.Events as HE
|
import Halogen.HTML.Events as HE
|
||||||
-- import MissingHTMLProperties as MissingProperties
|
|
||||||
|
|
||||||
import CSSClasses as C
|
-- HTML PropName used with HP.prop
|
||||||
|
import Halogen.HTML.Core (PropName(..))
|
||||||
import Halogen.HTML.Core (AttrName(..))
|
|
||||||
-- import Web.Event.Event (type_, Event, EventType(..))
|
-- import Web.Event.Event (type_, Event, EventType(..))
|
||||||
-- import Web.UIEvent.MouseEvent (MouseEvent) -- package web-uievents
|
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" ]
|
||||||
|
|
||||||
|
|
||||||
columns :: forall (w :: Type) (i :: Type).
|
columns :: forall (w :: Type) (i :: Type).
|
||||||
Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||||
columns classes = HH.div [ HP.classes (C.columns <> classes) ]
|
columns classes = HH.div [ HP.classes (class_columns <> classes) ]
|
||||||
|
|
||||||
columns_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
columns_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||||
columns_ = columns []
|
columns_ = columns []
|
||||||
|
|
||||||
column :: forall (w :: Type) (i :: Type).
|
column :: forall (w :: Type) (i :: Type).
|
||||||
Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
Array (HH.ClassName) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||||
column classes = HH.div [ HP.classes (C.column <> classes) ]
|
column classes = HH.div [ HP.classes (class_column <> classes) ]
|
||||||
|
|
||||||
column_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
column_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||||
column_ = column []
|
column_ = column []
|
||||||
|
|
||||||
h1 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
h1 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||||
h1 title = HH.h1 [ HP.classes (C.title) ] [ HH.text title ]
|
h1 title = HH.h1 [ HP.classes (class_title) ] [ HH.text title ]
|
||||||
|
|
||||||
h3 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
h3 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||||
h3 title = HH.h3 [ HP.classes (C.title <> C.is5) ] [ HH.text title ]
|
h3 title = HH.h1 [ HP.classes (class_title <> class_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).
|
--offcolumn :: forall (w :: Type) (a :: Type).
|
||||||
-- Int -> Int -> Array (HH.HTML w a) -> HH.HTML w a
|
-- Int -> Int -> Array (HH.HTML w a) -> HH.HTML w a
|
||||||
--offcolumn 0 size = HH.div [ HP.classes [HH.ClassName ("mt-"<>show size)] ]
|
--offcolumn 0 size = HH.div [ HP.classes [HH.ClassName ("mt-"<>show size)] ]
|
||||||
--offcolumn offset size
|
--offcolumn offset size
|
||||||
-- = column [ HH.ClassName ("is-offset-" <> (show offset) <> " is-" <> (show size)) ]
|
-- = column [ HH.ClassName ("is-offset-" <> (show offset) <> " is-" <> (show size)) ]
|
||||||
|
|
||||||
input_classes :: Array HH.ClassName
|
input_classes :: forall (r :: Row Type) (i :: Type). Boolean -> HP.IProp ( class :: String | r ) i
|
||||||
input_classes = C.input <> C.is_small <> C.is_info
|
input_classes true = HP.classes [ HH.ClassName "input is-small is-info" ]
|
||||||
|
input_classes false = HP.classes [ HH.ClassName "input is-small is-danger" ]
|
||||||
|
|
||||||
table :: forall w i. HH.Node DHI.HTMLtable w i
|
btn_classes :: forall (r :: Row Type) (i :: Type)
|
||||||
table prop xs = HH.table ([ HP.classes $ C.table ] <> prop) xs
|
. 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. Array HH.ClassName -> HH.Node DHI.HTMLtable w i
|
--simple_table_header :: forall w i. HH.HTML w i
|
||||||
table_ classes prop xs = HH.table ([ HP.classes $ C.table <> classes] <> prop) xs
|
--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
|
||||||
|
|
||||||
mechanism_table_header :: forall w i. HH.HTML w i
|
input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
mechanism_table_header
|
input_email action "" validity
|
||||||
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Policy" ]
|
= HH.input [ HE.onValueInput action, HP.placeholder "email", input_classes validity ]
|
||||||
, HH.th_ [ HH.text "Type" ]
|
input_email action email validity
|
||||||
, HH.th_ [ HH.text "Value" ]
|
= HH.input
|
||||||
, HH.th_ [ HH.text "" ]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
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 "" ]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
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" ]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
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 "" ]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
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 "" ]
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
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
|
|
||||||
rr_name_style = HP.style "width: 80px;"
|
|
||||||
rr_name_text = HH.text t
|
|
||||||
|
|
||||||
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
|
[ HE.onValueInput action
|
||||||
, HP.value value
|
, HP.value email
|
||||||
, HP.placeholder placeholder
|
, HP.placeholder "email"
|
||||||
, HP.classes $ C.textarea <> classes
|
, input_classes validity
|
||||||
]
|
]
|
||||||
|
|
||||||
textarea :: forall w i. String -> String -> (String -> i) -> HH.HTML w i
|
box_input_email :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
textarea placeholder value action = textarea_ [] placeholder value action
|
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 ]
|
||||||
|
]
|
||||||
|
|
||||||
btn_modify :: forall w i. i -> HH.HTML w i
|
input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
btn_modify action = btn_ (C.is_small <> C.is_info) "⚒" action
|
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
|
||||||
|
]
|
||||||
|
|
||||||
btn_save :: forall w i. i -> HH.HTML w i
|
box_input_password :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
btn_save action = btn_ C.is_info "Save" action
|
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 ]
|
||||||
|
]
|
||||||
|
|
||||||
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
|
---- TODO: right types
|
||||||
btn_delete action = btn_ (C.is_small <> C.is_danger) "✖" action
|
---- input_domain :: forall a w i
|
||||||
|
---- . (String -> a)
|
||||||
|
---- -> String
|
||||||
|
---- -> Boolean
|
||||||
|
---- -> HH.HTML w i
|
||||||
|
--input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_domain action domain validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value domain
|
||||||
|
-- , HP.placeholder "domain"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_domain :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_domain action domain validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "Domain" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_domain action domain validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_ttl action ttl validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value ttl
|
||||||
|
-- , HP.prop (PropName "size") 6.0
|
||||||
|
-- , HP.placeholder "ttl"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_ttl :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_ttl action value validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "TTL" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_ttl action value validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_priority action priority validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value priority
|
||||||
|
-- , HP.prop (PropName "size") 6.0
|
||||||
|
-- , HP.placeholder "priority"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_priority :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_priority action value validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "Priority" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_priority action value validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_value action value validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value value
|
||||||
|
-- , HP.placeholder "value"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_value :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_value action value validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "Value" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_value action value validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_weight action weight validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value weight
|
||||||
|
-- , HP.prop (PropName "size") 6.0
|
||||||
|
-- , HP.placeholder "weight"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_weight :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_weight action weight validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "Weight" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_weight action weight validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--input_port action port validity
|
||||||
|
-- = HH.input
|
||||||
|
-- [ HE.onValueInput action
|
||||||
|
-- , HP.value port
|
||||||
|
-- , HP.prop (PropName "size") 6.0
|
||||||
|
-- , HP.placeholder "port"
|
||||||
|
-- , input_classes validity
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--box_input_port :: forall w i. (String -> i) -> String -> Boolean -> HH.HTML w i
|
||||||
|
--box_input_port action port validity = HH.label [ ]
|
||||||
|
-- [ HH.label [HP.classes class_label ] [ HH.text "Port" ]
|
||||||
|
-- , HH.div [HP.classes class_control ] [ input_port action port validity ]
|
||||||
|
-- ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--btn_change :: forall w i. i -> i -> Boolean -> Boolean -> HH.HTML w i
|
||||||
|
--btn_change action1 action2 modified validity
|
||||||
|
-- = HH.button
|
||||||
|
-- [ HP.disabled (not modified)
|
||||||
|
-- , btn_change_action validity
|
||||||
|
-- , btn_classes validity
|
||||||
|
-- ] [ HH.text "fix" ]
|
||||||
|
-- where
|
||||||
|
--
|
||||||
|
-- btn_change_action = case _ of
|
||||||
|
-- true -> HE.onClick \_ -> action1
|
||||||
|
-- _ -> HE.onClick \_ -> action2
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--btn_delete :: forall w i. (MouseEvent -> i) -> HH.HTML w i
|
||||||
|
--btn_delete action
|
||||||
|
-- = HH.button
|
||||||
|
-- [ HE.onClick action
|
||||||
|
-- , HP.classes [ HH.ClassName "button is-small is-danger" ]
|
||||||
|
-- ] [ HH.text "X" ]
|
||||||
|
--
|
||||||
|
--
|
||||||
|
--btn_add :: forall w i. i -> i -> Boolean -> HH.HTML w i
|
||||||
|
--btn_add action1 action2 validity
|
||||||
|
-- = HH.button
|
||||||
|
-- [ btn_add_action validity
|
||||||
|
-- , btn_classes validity
|
||||||
|
-- ] [ HH.text "Add" ]
|
||||||
|
-- where
|
||||||
|
--
|
||||||
|
-- btn_add_action = case _ of
|
||||||
|
-- true -> HE.onClick \_ -> action1
|
||||||
|
-- _ -> HE.onClick \_ -> action2
|
||||||
|
|
||||||
btn_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 :: forall w action. String -> action -> action -> Boolean -> HH.HTML w action
|
||||||
btn_readonly = btn_ro (C.is_small <> C.is_warning) "read only"
|
btn title action1 action2 validity
|
||||||
|
|
||||||
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
|
= HH.button
|
||||||
[ HP.classes $ C.button <> classes
|
[ btn_add_action validity
|
||||||
|
, btn_classes validity
|
||||||
] [ HH.text title ]
|
] [ HH.text title ]
|
||||||
|
where
|
||||||
|
btn_add_action = case _ of
|
||||||
|
true -> HE.onClick \_ -> action1
|
||||||
|
_ -> HE.onClick \_ -> action2
|
||||||
|
|
||||||
-- | Create a `level`, different components that should appear on the same horizontal line.
|
render_input password placeholder action value validity cond
|
||||||
-- | 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 $
|
= HH.input $
|
||||||
[ HE.onValueInput action
|
[ HE.onValueInput action
|
||||||
, HP.value value
|
, HP.value value
|
||||||
, HP.placeholder placeholder
|
, HP.placeholder placeholder
|
||||||
, HP.classes $ input_classes
|
, input_classes validity
|
||||||
, HP.id id
|
|
||||||
, cond
|
, cond
|
||||||
] <> case password of
|
] <> case password of
|
||||||
false -> []
|
false -> []
|
||||||
true -> [ HP.type_ HP.InputPassword ]
|
true -> [ HP.type_ HP.InputPassword ]
|
||||||
|
|
||||||
div_field :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
box_inner ispassword title placeholder action value validity cond
|
||||||
div_field = HH.div [HP.classes (C.field <> C.is_horizontal)]
|
= HH.label [ ]
|
||||||
|
[ HH.label [HP.classes class_label ] [ HH.text title ]
|
||||||
div_field_label :: forall w i. String -> String -> HH.HTML w i
|
, HH.div [HP.classes class_control ]
|
||||||
div_field_label id title = HH.div [HP.classes (C.field_label <> C.normal)]
|
[ render_input ispassword placeholder action value validity cond ]
|
||||||
[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
|
|
||||||
]
|
]
|
||||||
|
|
||||||
div_field_ :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
box_input = box_inner false
|
||||||
div_field_ classes = HH.div [ HP.classes (C.field <> classes) ]
|
box_password = box_inner true
|
||||||
|
|
||||||
btn_labeled :: forall w i. String -> String -> String -> i -> HH.HTML w i
|
--box_button action value validity cond
|
||||||
btn_labeled id title button_text action
|
-- = HH.label [ ]
|
||||||
= div_field
|
-- [ HH.label [HP.classes class_label ] [ HH.text title ]
|
||||||
[ div_field_label id title
|
-- , HH.div [HP.classes class_control ]
|
||||||
, div_field_content $ HH.button
|
-- [ render_input ispassword placeholder action value validity cond ]
|
||||||
[ 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 :: forall w i. String -> HH.HTML w i
|
||||||
p str = HH.p_ [ HH.text str ]
|
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 :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||||
box = HH.div [HP.classes C.box]
|
box = HH.div [HP.classes class_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] ]
|
|
||||||
|
|
|
@ -1,123 +0,0 @@
|
||||||
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
|
|
|
@ -1,12 +0,0 @@
|
||||||
-- | `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")
|
|
Loading…
Reference in New Issue