Initial commit for the dnsmanager web client project.
This commit is contained in:
commit
06c43a1c0b
12
.gitignore
vendored
Normal file
12
.gitignore
vendored
Normal file
@ -0,0 +1,12 @@
|
||||
.*
|
||||
!.gitignore
|
||||
!.github
|
||||
|
||||
app/index.js
|
||||
output
|
||||
generated-docs
|
||||
bower_components
|
||||
node_modules
|
||||
|
||||
package-lock.json
|
||||
*.lock
|
||||
18
README.md
Normal file
18
README.md
Normal file
@ -0,0 +1,18 @@
|
||||
# dnsmanager interface
|
||||
|
||||
### Quick Start
|
||||
|
||||
To install and test this application, you'll need:
|
||||
- both **purs** and **spago**, in order to compile this purescript application;
|
||||
- both **authd** and **dnsmanagerd**, in order to use this dnsmanager webclient with its related services, and they both require **libipc**;
|
||||
- (optional) a http server to serve the website and its documentation (such as darkhttpd, which is used in the makefile).
|
||||
|
||||
To compile this purescript application:
|
||||
```sh
|
||||
make bundle
|
||||
```
|
||||
|
||||
### Introduction
|
||||
|
||||
This code is a **beta version** of the official interface for `dnsmanager` (second edition).
|
||||
It will soon change in numerous ways, but represents an acceptable start for the **dnsmanager webclient** project.
|
||||
7790
app/bulma.css
vendored
Normal file
7790
app/bulma.css
vendored
Normal file
File diff suppressed because it is too large
Load Diff
18
app/index.html
Normal file
18
app/index.html
Normal file
@ -0,0 +1,18 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="UTF-8">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||
<link rel="stylesheet" href="./bulma.css">
|
||||
<title>DNS Manager (beta)</title>
|
||||
</head>
|
||||
<style>
|
||||
.justified {
|
||||
text-justify: auto;
|
||||
text-align: justify
|
||||
}
|
||||
</style>
|
||||
<body>
|
||||
<script src="./index.js" type="module"></script>
|
||||
</body>
|
||||
</html>
|
||||
52
makefile
Normal file
52
makefile
Normal file
@ -0,0 +1,52 @@
|
||||
all: build
|
||||
|
||||
clone-generic-parser:
|
||||
[ ! -d ../parser ] && cd .. && git clone ssh://_gitea@git.baguette.netlib.re:2299/Baguette/parser.git || :
|
||||
|
||||
build: clone-generic-parser
|
||||
spago build
|
||||
|
||||
bundle-mini: install-esbuild
|
||||
PATH=$$PATH:node_modules/.bin spago bundle-app -y
|
||||
mv index.js app/
|
||||
|
||||
bundle: install-esbuild
|
||||
PATH=$$PATH:node_modules/.bin spago bundle-app
|
||||
mv index.js app/
|
||||
|
||||
repl:
|
||||
spago repl
|
||||
|
||||
spagobuild:
|
||||
spago build
|
||||
|
||||
docs-with-search:
|
||||
spago docs
|
||||
|
||||
docs:
|
||||
spago docs --no-search
|
||||
|
||||
DOCS_HTTPD_ACCESS_LOGS ?= /tmp/docs-access.log
|
||||
DOCS_HTTPD_ADDR ?= 127.0.0.1
|
||||
DOCS_HTTPD_PORT ?= 31000
|
||||
DOCS_DIR ?= generated-docs/html
|
||||
serve-docs: docs
|
||||
darkhttpd $(DOCS_DIR) --addr $(DOCS_HTTPD_ADDR) --port $(DOCS_HTTPD_PORT) --log $(DOCS_HTTPD_ACCESS_LOGS)
|
||||
|
||||
install-esbuild:
|
||||
@[ -f node_modules/.bin/esbuild ] || echo "install ebbuild"
|
||||
[ -f node_modules/.bin/esbuild ] || npm install esbuild
|
||||
|
||||
HTTPD_ACCESS_LOGS ?= /tmp/access.log
|
||||
HTTPD_ADDR ?= 127.0.0.1
|
||||
HTTPD_PORT ?= 35000
|
||||
DIR ?= app
|
||||
serve:
|
||||
darkhttpd $(DIR) --addr $(HTTPD_ADDR) --port $(HTTPD_PORT) --log $(HTTPD_ACCESS_LOGS)
|
||||
|
||||
# NPM can serve it, but it's slow for nothing.
|
||||
#serve:
|
||||
# npm run serve
|
||||
|
||||
# You can add your specific instructions there.
|
||||
-include makefile.user
|
||||
6
packages.dhall
Normal file
6
packages.dhall
Normal file
@ -0,0 +1,6 @@
|
||||
let upstream =
|
||||
https://github.com/purescript/package-sets/releases/download/psc-0.15.8-20230517/packages.dhall
|
||||
sha256:8b94a0cd7f86589a6bd06d48cb9a61d69b66a94b668657b2f10c8b14c16e028c
|
||||
|
||||
in upstream
|
||||
with generic-parser = ../parser/spago.dhall as Location
|
||||
43
spago.dhall
Normal file
43
spago.dhall
Normal file
@ -0,0 +1,43 @@
|
||||
{ name = "dnsmanager-interface"
|
||||
, dependencies =
|
||||
[ "aff"
|
||||
, "argonaut-core"
|
||||
, "arraybuffer"
|
||||
, "arraybuffer-builder"
|
||||
, "arraybuffer-types"
|
||||
, "arrays"
|
||||
, "bifunctors"
|
||||
, "codec-argonaut"
|
||||
, "console"
|
||||
, "control"
|
||||
, "dom-indexed"
|
||||
, "effect"
|
||||
, "either"
|
||||
, "exceptions"
|
||||
, "foreign"
|
||||
, "generic-parser"
|
||||
, "halogen"
|
||||
, "halogen-subscriptions"
|
||||
, "integers"
|
||||
, "maybe"
|
||||
, "newtype"
|
||||
, "parsing"
|
||||
, "parsing-dataview"
|
||||
, "prelude"
|
||||
, "profunctor"
|
||||
, "strings"
|
||||
, "stringutils"
|
||||
, "tailrec"
|
||||
, "transformers"
|
||||
, "tuples"
|
||||
, "uint"
|
||||
, "validation"
|
||||
, "web-encoding"
|
||||
, "web-events"
|
||||
, "web-html"
|
||||
, "web-socket"
|
||||
, "web-storage"
|
||||
]
|
||||
, packages = ./packages.dhall
|
||||
, sources = [ "src/**/*.purs", "test/**/*.purs" ]
|
||||
}
|
||||
758
src/App/Container.purs
Normal file
758
src/App/Container.purs
Normal file
@ -0,0 +1,758 @@
|
||||
-- | `App.Container` is the parent of all other components of the application.
|
||||
-- |
|
||||
-- | Each page has its own module and the `App.Container` informs them when the websocket is up or down.
|
||||
-- | A module implements Websocket operations and is used twice, once for the connection to `authd`,
|
||||
-- | another for the connection to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | `App.Container` stores the state of different components (domain list and zone interface)
|
||||
-- | to avoid useless requests to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | `App.Container` detects when a page has been reloaded and:
|
||||
-- | 1. authenticate the user to `dnsmanagerd` via a stored token in session storage.
|
||||
-- | The authentication to `dnsmanagerd` automatically provides own domains and accepted domains (such as `netlib.re`).
|
||||
-- | This is enough data for the `DomainList` page.
|
||||
-- | 2. go back to that page.
|
||||
-- | In case the old page is `Zone`, send a request to `dnsmanagerd` to get the zone content again.
|
||||
-- |
|
||||
-- | Once a message is received, it is transfered to the module of the current page;
|
||||
-- | except for the `App.Message.DNSManagerDaemon.AnswerMessage` `Logged` which is an hint when the
|
||||
-- | page has been reloaded, thus having a special treatment.
|
||||
-- |
|
||||
-- | TODO:
|
||||
-- | Each received message is transfered to the current page module because there is no centralized state.
|
||||
-- | This may be a good idea to store the state of the entire application at the same place, avoiding to
|
||||
-- | handle messages in the different pages.
|
||||
-- | Pages could handle semantic operations directly instead.
|
||||
-- |
|
||||
-- | Tested features:
|
||||
-- | - registration, mail validation, login, disconnection
|
||||
-- | - domain registration
|
||||
-- | - zone display, RR creation, update and removal
|
||||
-- |
|
||||
-- | Validation:
|
||||
-- | - registration page: login, password, mail
|
||||
-- | - login and password recovery page: TODO
|
||||
-- | - mail verification: TODO
|
||||
-- | - domain list: domain (`label`) is insufficient.
|
||||
-- |
|
||||
-- | TODO: when reading a RR `name`, always make it an FQDN by adding `<user-domain>.netlib.re.`.
|
||||
-- |
|
||||
-- | TODO: remove the FQDN when showing RR names.
|
||||
-- |
|
||||
-- | TODO: application-level heartbeat to avoid disconnections.
|
||||
-- |
|
||||
-- | Untested features:
|
||||
-- | - mail recovery, password change
|
||||
module App.Container where
|
||||
|
||||
import Prelude (Unit, bind, discard, unit, ($), (=<<), (<>), show, pure)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import Data.Array as A
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Type.Proxy (Proxy(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
|
||||
import App.Message.DNSManagerDaemon as DNSManager
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
import App.Log as AppLog
|
||||
import App.WS as WS
|
||||
|
||||
import App.Page.Authentication as AI
|
||||
import App.Page.Registration as RI
|
||||
import App.Page.MailValidation as MVI
|
||||
import App.Page.Administration as AdminInterface
|
||||
import App.Page.Setup as SetupInterface
|
||||
import App.Page.DomainList as DomainListInterface
|
||||
import App.Page.Zone as ZoneInterface
|
||||
import App.Page.Home as HomeInterface
|
||||
import App.Page.Navigation as NavigationInterface
|
||||
|
||||
import Web.HTML (window) as HTML
|
||||
import Web.HTML.Window (sessionStorage) as Window
|
||||
import Web.Storage.Storage as Storage
|
||||
|
||||
import App.Type.Email as Email
|
||||
|
||||
import App.Type.LogMessage (LogMessage(..))
|
||||
|
||||
import App.Type.Pages
|
||||
import CSSClasses as C
|
||||
|
||||
type Token = String
|
||||
type Login = String
|
||||
type Password = String
|
||||
type LogInfo = Tuple Login Password
|
||||
|
||||
data Action
|
||||
-- | Handle events from `AuthenticationInterface`.
|
||||
= AuthenticationInterfaceEvent AI.Output
|
||||
|
||||
-- | Handle events from `RegistrationInterface`.
|
||||
| RegistrationInterfaceEvent RI.Output
|
||||
|
||||
-- | Handle events from `MailValidationInterface`.
|
||||
| MailValidationInterfaceEvent MVI.Output
|
||||
|
||||
-- | Handle events from `SetupInterface`.
|
||||
| SetupInterfaceEvent SetupInterface.Output
|
||||
|
||||
-- | Handle events from `NavigationInterface`.
|
||||
| NavigationInterfaceEvent NavigationInterface.Output
|
||||
|
||||
-- | Handle events from `AuthenticationDaemonAdminComponent`.
|
||||
| AdministrationEvent AdminInterface.Output -- Administration interface.
|
||||
|
||||
-- | Handle events from `DomainListComponent`.
|
||||
| DomainListComponentEvent DomainListInterface.Output
|
||||
|
||||
-- | Handle events from `AuthenticationDaemon` (`authd websocket component`).
|
||||
| AuthenticationDaemonEvent WS.Output
|
||||
|
||||
-- | Handle events from `DNSManagerDaemon` (`dnsmanagerd websocket component`).
|
||||
| DNSManagerDaemonEvent WS.Output
|
||||
|
||||
-- | Handle events from `ZoneInterface`.
|
||||
| ZoneInterfaceEvent ZoneInterface.Output
|
||||
|
||||
-- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
|
||||
-- | then return to the home page.
|
||||
| Disconnection
|
||||
|
||||
-- | Try to authenticate the user to `dnsmanagerd`.
|
||||
| AuthenticateToDNSManager
|
||||
|
||||
| AuthenticateToAuthd (Either Token LogInfo)
|
||||
|
||||
-- | Change the displayed page.
|
||||
| Routing Page
|
||||
|
||||
-- | `DecodeDNSMessage`: decode received `dnsmanagerd` messages into `DNSManager.AnswerMessage`,
|
||||
-- | then provide it to `DispatchDNSMessage`.
|
||||
| DecodeDNSMessage ArrayBuffer
|
||||
|
||||
-- | `DispatchDNSMessage`: send the DNS message to the right component.
|
||||
-- | The DNS message (from `dnsmanagerd`) was first received and decoded through the `DecodeDNSMessage` action.
|
||||
| DispatchDNSMessage DNSManager.AnswerMessage
|
||||
|
||||
-- | `DecodeAuthMessage`: decode received `authd` messages into ``, then provide
|
||||
-- | Then, the message is provided to the `DispatchAuthDaemonMessage` action (when needed).
|
||||
| DecodeAuthMessage ArrayBuffer
|
||||
|
||||
-- | DispatchAuthDaemonMessage: an auth daemon message (from `authd`) was received and decoded through the
|
||||
-- | `DecodeAuthMessage` action.
|
||||
-- | The message is provided to the right component.
|
||||
| DispatchAuthDaemonMessage AuthD.AnswerMessage
|
||||
|
||||
-- | Log message (through the Log component).
|
||||
| Log LogMessage
|
||||
|
||||
-- | `KeepAlive` send a keepalive message to either `authd` or `dnsmanagerd`.
|
||||
| KeepAlive (Either Unit Unit)
|
||||
|
||||
-- | `ToggleAuthenticated` performs some actions required when a connection or a disconnection occurs.
|
||||
-- | Currently, this handles the navigation bar.
|
||||
| ToggleAuthenticated (Maybe Token)
|
||||
|
||||
-- | The component's state is composed of:
|
||||
-- | a potential authentication token,
|
||||
-- | the current page,
|
||||
-- | the states of both `DomainListInterface` and `AuthenticationDaemonAdmin` modules,
|
||||
-- | to avoid many useless network exchanges.
|
||||
type State = { token :: Maybe String
|
||||
, current_page :: Page
|
||||
, store_DomainListInterface_state :: Maybe DomainListInterface.State
|
||||
, store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State
|
||||
}
|
||||
|
||||
-- | The list of child components: log, `WS` twice (once for each ws connection),
|
||||
-- | then all the pages (AuthenticationInterface, RegistrationInterface, MailValidationInterface,
|
||||
-- | HomeInterface, DomainListInterface, ZoneInterface and AdministrationInterface).
|
||||
type ChildSlots =
|
||||
( log :: AppLog.Slot Unit
|
||||
, ho :: HomeInterface.Slot Unit
|
||||
, ws_auth :: WS.Slot Unit
|
||||
, ws_dns :: WS.Slot Unit
|
||||
, nav :: NavigationInterface.Slot Unit
|
||||
, ai :: AI.Slot Unit
|
||||
, ri :: RI.Slot Unit
|
||||
, mvi :: MVI.Slot Unit
|
||||
, admini :: AdminInterface.Slot Unit
|
||||
, setupi :: SetupInterface.Slot Unit
|
||||
, dli :: DomainListInterface.Slot Unit
|
||||
, zi :: ZoneInterface.Slot Unit
|
||||
)
|
||||
|
||||
_ho = Proxy :: Proxy "ho" -- Home Interface
|
||||
_log = Proxy :: Proxy "log" -- Log
|
||||
_ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd`
|
||||
_ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd`
|
||||
_nav = Proxy :: Proxy "nav" -- Navigation Interface
|
||||
_ai = Proxy :: Proxy "ai" -- Authentication Interface
|
||||
_ri = Proxy :: Proxy "ri" -- Registration Interface
|
||||
_mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface
|
||||
_admini = Proxy :: Proxy "admini" -- Administration Interface
|
||||
_setupi = Proxy :: Proxy "setupi" -- Setup Interface
|
||||
_dli = Proxy :: Proxy "dli" -- Domain List
|
||||
_zi = Proxy :: Proxy "zi" -- Zone Interface
|
||||
|
||||
component :: forall q i o m. MonadAff m => H.Component q i o m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
||||
}
|
||||
|
||||
-- | Initial state is simple: the user is on the home page, nothing else is stored.
|
||||
initialState :: forall i. i -> State
|
||||
initialState _ = { token: Nothing
|
||||
, current_page: Home
|
||||
, store_DomainListInterface_state: Nothing
|
||||
, store_AuthenticationDaemonAdmin_state: Nothing
|
||||
}
|
||||
|
||||
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
|
||||
render state
|
||||
= HH.div_ $
|
||||
[ render_header
|
||||
, render_nav
|
||||
, case state.current_page of
|
||||
Home -> render_home
|
||||
Authentication -> render_auth_form
|
||||
Registration -> render_registration
|
||||
MailValidation -> render_mail_validation
|
||||
DomainList -> render_domainlist_interface
|
||||
Zone domain -> render_zone domain
|
||||
Setup -> render_setup
|
||||
Administration -> render_authd_admin_interface
|
||||
-- The footer includes logs and both the WS child components.
|
||||
, Bulma.hr
|
||||
, Bulma.columns_ [ Bulma.column_ [ Bulma.h3 "Logs (watch this if something fails! 😅)", render_logs ]
|
||||
, Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ]
|
||||
]
|
||||
where
|
||||
|
||||
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 = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent
|
||||
render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent
|
||||
render_setup :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_setup = case state.token of
|
||||
Just token -> HH.slot _setupi unit SetupInterface.component token SetupInterfaceEvent
|
||||
Nothing -> Bulma.p "You shouldn't see this page. Reconnect!"
|
||||
render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_mail_validation = HH.slot _mvi unit MVI.component unit MailValidationInterfaceEvent
|
||||
render_zone :: forall monad. String -> MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_zone domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent
|
||||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent
|
||||
|
||||
render_nav :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_nav = HH.slot _nav unit NavigationInterface.component unit NavigationInterfaceEvent
|
||||
|
||||
render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_header =
|
||||
HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
|
||||
[ HH.div [ HP.classes C.hero_body ]
|
||||
[ HH.div [ HP.classes $ C.container <> C.has_text_centered ]
|
||||
[ HH.p [ HP.classes C.subtitle ]
|
||||
[ HH.strong_ [ HH.u_ [ HH.text "net libre" ]]
|
||||
, HH.text ": providing free domains since 2015!"
|
||||
]
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_logs = Bulma.container [ HH.slot_ _log unit AppLog.component unit ]
|
||||
|
||||
render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_auth_WS = HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthenticationDaemonEvent
|
||||
|
||||
render_dnsmanager_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_dnsmanager_WS = HH.slot _ws_dns unit WS.component "ws://127.0.0.1:8081" DNSManagerDaemonEvent
|
||||
|
||||
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
|
||||
handleAction = case _ of
|
||||
Routing page -> do
|
||||
-- Store the current page we are on and restore it when we reload.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- case page of
|
||||
Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
|
||||
Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
|
||||
Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage
|
||||
MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" sessionstorage
|
||||
DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage
|
||||
Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage
|
||||
H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
|
||||
Setup -> H.liftEffect $ Storage.setItem "current-page" "Setup" sessionstorage
|
||||
Administration -> H.liftEffect $ Storage.setItem "current-page" "Administration" sessionstorage
|
||||
H.modify_ _ { current_page = page }
|
||||
|
||||
Log message -> H.tell _log unit $ AppLog.Log message
|
||||
|
||||
ToggleAuthenticated maybe_token -> case maybe_token of
|
||||
Nothing -> H.tell _nav unit $ NavigationInterface.ToggleLogged false
|
||||
Just _ -> H.tell _nav unit $ NavigationInterface.ToggleLogged true
|
||||
|
||||
KeepAlive auth_or_dnsmanager -> case auth_or_dnsmanager of
|
||||
Left _ -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkKeepAlive {}
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right _ -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkKeepAlive {}
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
|
||||
AuthenticateToAuthd v -> case v of
|
||||
Left token -> do
|
||||
handleAction $ Log $ SystemLog "Authenticate to authd with a token!"
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkLogin { login, password }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
AuthenticateToDNSManager -> do
|
||||
state <- H.get
|
||||
case state.token of
|
||||
Just token -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
Nothing -> do
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> handleAction $ Log $ ErrorLog "no token!"
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
handleAction AuthenticateToDNSManager
|
||||
|
||||
NavigationInterfaceEvent ev -> case ev of
|
||||
NavigationInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
NavigationInterface.Routing page -> handleAction $ Routing page
|
||||
NavigationInterface.Disconnection -> handleAction $ Disconnection
|
||||
|
||||
AuthenticationInterfaceEvent ev -> case ev of
|
||||
AI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
AI.AskPasswordRecovery e -> case e of
|
||||
Left email -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkAskPasswordRecovery { user: Nothing, email: Just (Email.Email email) }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right login -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkAskPasswordRecovery { user: (Just login), email: Nothing }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
AI.PasswordRecovery login token pass -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkPasswordRecovery
|
||||
{ user: login
|
||||
, password_renew_key: token
|
||||
, new_password: pass }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
|
||||
AI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
RegistrationInterfaceEvent ev -> case ev of
|
||||
RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
RI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
MailValidationInterfaceEvent ev -> case ev of
|
||||
MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
MVI.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
SetupInterfaceEvent ev -> case ev of
|
||||
SetupInterface.DeleteUserAccount -> do
|
||||
handleAction $ Log $ SystemLog "Self termination. 😿"
|
||||
|
||||
{- no user id, it's self termination -}
|
||||
dns_message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Nothing }
|
||||
auth_message <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Nothing }
|
||||
H.tell _ws_dns unit (WS.ToSend dns_message)
|
||||
H.tell _ws_auth unit (WS.ToSend auth_message)
|
||||
|
||||
-- Once the user has been deleted, just act like it was just a disconnection.
|
||||
handleAction $ Disconnection
|
||||
|
||||
SetupInterface.ChangePassword pass -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkModUser { user: Nothing
|
||||
, admin: Nothing
|
||||
, password: Just pass
|
||||
, email: Nothing
|
||||
}
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
|
||||
SetupInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
AdministrationEvent ev -> case ev of
|
||||
AdminInterface.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
|
||||
AdminInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
AdminInterface.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s }
|
||||
AdminInterface.AskState -> do
|
||||
state <- H.get
|
||||
H.tell _admini unit (AdminInterface.ProvideState state.store_AuthenticationDaemonAdmin_state)
|
||||
AdminInterface.DeleteUserAccount uid -> do
|
||||
handleAction $ Log $ SystemLog "Remove user account. 😿"
|
||||
|
||||
{- User id is provided this time, it's (probably) NOT self termination. -}
|
||||
dns_message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteUser { user_id: Just uid }
|
||||
auth_message <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid }
|
||||
H.tell _ws_dns unit (WS.ToSend dns_message)
|
||||
H.tell _ws_auth unit (WS.ToSend auth_message)
|
||||
AdminInterface.GetOrphanDomains -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetOrphanDomains {}
|
||||
H.tell _ws_dns unit (WS.ToSend message)
|
||||
|
||||
ZoneInterfaceEvent ev -> case ev of
|
||||
ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
ZoneInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
|
||||
DomainListComponentEvent ev -> case ev of
|
||||
DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
DomainListInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
DomainListInterface.StoreState s -> H.modify_ _ { store_DomainListInterface_state = Just s }
|
||||
DomainListInterface.ChangePageZoneInterface domain -> do
|
||||
handleAction $ Routing $ Zone domain
|
||||
|
||||
DomainListInterface.AskState -> do
|
||||
state <- H.get
|
||||
H.tell _dli unit (DomainListInterface.ProvideState state.store_DomainListInterface_state)
|
||||
|
||||
-- | `authd websocket component` wants to do something.
|
||||
AuthenticationDaemonEvent ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> do
|
||||
handleAction $ DecodeAuthMessage message
|
||||
|
||||
WS.WSJustConnected -> do
|
||||
H.tell _ai unit AI.ConnectionIsUp
|
||||
H.tell _admini unit AdminInterface.ConnectionIsUp
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> handleAction $ Log $ ErrorLog "no token!"
|
||||
Just t -> do
|
||||
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
||||
handleAction $ AuthenticateToAuthd (Left t)
|
||||
|
||||
WS.WSJustClosed -> do
|
||||
H.tell _ai unit AI.ConnectionIsDown
|
||||
H.tell _admini unit AdminInterface.ConnectionIsDown
|
||||
WS.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
|
||||
|
||||
DecodeAuthMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ AuthD.deserialize message
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(AuthD.JSONERROR jerr) -> do
|
||||
-- print_json_string messageEvent.message
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
|
||||
"Parsing error: AuthD.UnknownError" <> (show unerr)
|
||||
(AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog
|
||||
"Parsing error: AuthD.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
-- TODO: create a modal to show some of these?
|
||||
Right response -> do
|
||||
case response of
|
||||
(AuthD.GotUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
|
||||
m@(AuthD.GotUserAdded _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Registration -> do
|
||||
handleAction $ Log $ SuccessLog """
|
||||
You are now registered, copy the token we sent you by email to finish your registration.
|
||||
"""
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> handleAction $ DispatchAuthDaemonMessage m
|
||||
(AuthD.GotUserEdited u) -> do
|
||||
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified!"
|
||||
(AuthD.GotUserValidated _) -> do
|
||||
handleAction $ Log $ SuccessLog "User got validated! You can now log in!"
|
||||
handleAction $ Routing Authentication
|
||||
(AuthD.GotUsersList _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
|
||||
(AuthD.GotPermissionCheck _) -> do
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
|
||||
(AuthD.GotPermissionSet _) -> do
|
||||
handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
|
||||
(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SuccessLog "your new password is now valid!"
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotMatchingUsers message while not on authd admin page."
|
||||
m@(AuthD.GotUserDeleted _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotUserDeleted message while not on authd admin page."
|
||||
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
|
||||
(AuthD.GotErrorAlreadyUsedLogin _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
|
||||
(AuthD.GotErrorUserNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
|
||||
|
||||
-- The authentication failed.
|
||||
(AuthD.GotError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog $ " generic error message: "
|
||||
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
|
||||
(AuthD.GotPasswordRecoverySent _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
|
||||
(AuthD.GotErrorPasswordTooShort _) -> do
|
||||
handleAction $ Log $ ErrorLog "Password too short!"
|
||||
(AuthD.GotErrorMailRequired _) -> do
|
||||
handleAction $ Log $ ErrorLog "Email required!"
|
||||
(AuthD.GotErrorInvalidCredentials _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid credentials!"
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
(AuthD.GotErrorRegistrationsClosed _) -> do
|
||||
handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator."
|
||||
(AuthD.GotErrorInvalidLoginFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid login format!"
|
||||
(AuthD.GotErrorInvalidEmailFormat _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid email format!"
|
||||
(AuthD.GotErrorAlreadyUsersInDB _) -> do
|
||||
handleAction $ Log $ ErrorLog "Login already taken!"
|
||||
(AuthD.GotErrorReadOnlyProfileKeys _) -> do
|
||||
handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys!"
|
||||
(AuthD.GotErrorInvalidActivationKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid activation key!"
|
||||
(AuthD.GotErrorUserAlreadyValidated _) -> do
|
||||
handleAction $ Log $ ErrorLog "User already validated!"
|
||||
(AuthD.GotErrorCannotContactUser _) -> do
|
||||
handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
|
||||
(AuthD.GotErrorInvalidRenewKey _) -> do
|
||||
handleAction $ Log $ ErrorLog "Invalid renew key!"
|
||||
-- The authentication was a success!
|
||||
(AuthD.GotToken msg) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to authd!"
|
||||
H.modify_ _ { token = Just msg.token }
|
||||
handleAction $ ToggleAuthenticated (Just msg.token)
|
||||
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
||||
|
||||
handleAction AuthenticateToDNSManager
|
||||
(AuthD.GotKeepAlive _) -> do
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive!"
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
DispatchAuthDaemonMessage message -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> H.tell _admini unit (AdminInterface.MessageReceived message)
|
||||
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
||||
pure unit
|
||||
|
||||
Disconnection -> do
|
||||
H.put $ initialState unit
|
||||
|
||||
-- Remove all stored session data.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
H.liftEffect $ Storage.clear sessionstorage
|
||||
|
||||
handleAction $ Routing Home
|
||||
|
||||
-- | `dnsmanagerd websocket component` wants to do something.
|
||||
DNSManagerDaemonEvent ev -> case ev of
|
||||
WS.MessageReceived (Tuple _ message) -> do
|
||||
handleAction $ DecodeDNSMessage message
|
||||
WS.WSJustConnected -> do
|
||||
handleAction $ Log $ SystemLog "Connection with dnsmanagerd was closed, let's re-authenticate"
|
||||
handleAction AuthenticateToDNSManager
|
||||
H.tell _dli unit DomainListInterface.ConnectionIsUp
|
||||
WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
|
||||
WS.Log message -> H.tell _log unit (AppLog.Log message)
|
||||
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
|
||||
|
||||
-- | `DecodeDNSMessage`: decode a received `dnsmanagerd` message, then transfer it to `DispatchDNSMessage`.
|
||||
DecodeDNSMessage message -> do
|
||||
receivedMessage <- H.liftEffect $ DNSManager.deserialize message
|
||||
case receivedMessage of
|
||||
-- Cases where we didn't understand the message.
|
||||
Left err -> do
|
||||
-- handleAction $ Log $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(DNSManager.JSONERROR jerr) -> do
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(DNSManager.UnknownError unerr) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
|
||||
(DNSManager.UnknownNumber ) ->
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
Right received_msg -> do
|
||||
case received_msg of
|
||||
(DNSManager.MkDomainNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "DomainNotFound"
|
||||
(DNSManager.MkRRNotFound _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "RRNotFound"
|
||||
(DNSManager.MkInvalidZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "InvalidZone"
|
||||
(DNSManager.MkDomainChanged _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "DomainChanged"
|
||||
(DNSManager.MkUnknownZone _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
||||
(DNSManager.MkDomainList _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkDomainList"
|
||||
(DNSManager.MkUnknownUser _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
|
||||
(DNSManager.MkNoOwnership _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
|
||||
(DNSManager.MkInsufficientRights _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkError errmsg) -> do
|
||||
handleAction $ Log $ ErrorLog $ "reason is: " <> errmsg.reason
|
||||
(DNSManager.MkErrorUserNotLogged _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The user isn't connected!"
|
||||
handleAction $ Log $ SystemLog $ "Trying to authenticate to fix the problem..."
|
||||
handleAction AuthenticateToDNSManager
|
||||
(DNSManager.MkErrorInvalidToken _) -> do
|
||||
H.modify_ _ { token = Nothing, current_page = Home }
|
||||
handleAction $ Log $ ErrorLog $ "Invalid token! Try re-authenticate."
|
||||
-- TODO: should we disconnect from authd?
|
||||
handleAction $ ToggleAuthenticated Nothing
|
||||
(DNSManager.MkDomainAlreadyExists _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain already exists."
|
||||
m@(DNSManager.MkUnacceptableDomain _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkAcceptedDomains _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received the list of accepted domains!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkLogged _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkDomainAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkRRReadOnly response) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Trying to modify a read-only resource! "
|
||||
<> "domain: " <> response.domain
|
||||
<> "resource rrid: " <> show response.rr.rrid
|
||||
m@(DNSManager.MkRRUpdated _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource updated!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkRRAdded response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkGeneratedZoneFile response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkInvalidDomainName _) -> do
|
||||
handleAction $ Log $ ErrorLog $ "The domain is not valid!"
|
||||
m@(DNSManager.MkDomainDeleted response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkRRDeleted response) -> do
|
||||
handleAction $ Log $ SuccessLog $ "RR (rrid: '" <> show response.rrid <> "') has been deleted!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkZone _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Zone received!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(DNSManager.MkInvalidRR response) -> do
|
||||
handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors
|
||||
(DNSManager.MkSuccess _) -> do
|
||||
handleAction $ Log $ SuccessLog $ "(generic) Success!"
|
||||
DNSManager.MkOrphanDomainList response -> do
|
||||
handleAction $ Log $ SuccessLog "Received orphan domain list."
|
||||
H.tell _admini unit (AdminInterface.GotOrphanDomainList response.domains)
|
||||
(DNSManager.GotKeepAlive _) -> do
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive!"
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | Send a received DNS manager message to a component.
|
||||
-- | TODO: in case the message is a `logged` message, it means that the connection has been reset, and should be
|
||||
-- | handled no matter the actual page we're on.
|
||||
DispatchDNSMessage message -> do
|
||||
|
||||
-- The message `Logged` can be received after a re-connection (typically, after a page reload).
|
||||
-- This is an hint, and the application should do a series of actions based on this.
|
||||
-- First, we should check if there is a "current page", if so, switch page.
|
||||
-- Second, depending on the page, actions have to be undertaken.
|
||||
-- For `DomainList`, send a request to `dnsmanagerd` for the list of own domains and acceptable domains.
|
||||
-- For `Zone`, send a request to `dnsmanagerd` for the zone content.
|
||||
state <- H.get
|
||||
case state.current_page, message of
|
||||
-- Home + Logged = page just reloaded.
|
||||
Home, m@(DNSManager.MkLogged _) -> do
|
||||
update_domain_list state m
|
||||
revert_old_page
|
||||
Authentication, m@(DNSManager.MkLogged _) -> do
|
||||
update_domain_list state m
|
||||
-- handleAction $ Log $ SystemLog "go to domain list!"
|
||||
handleAction $ Routing DomainList
|
||||
-- Logged = page just reloaded, but page already changed, no need to do that again.
|
||||
_, m@(DNSManager.MkLogged _) -> do
|
||||
-- handleAction $ Log $ SystemLog "logged to dnsmanagerd, do not change page"
|
||||
update_domain_list state m
|
||||
DomainList, _ -> H.tell _dli unit (DomainListInterface.MessageReceived message)
|
||||
Zone _ , _ -> H.tell _zi unit (ZoneInterface.MessageReceived message)
|
||||
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
||||
pure unit
|
||||
where
|
||||
update_domain_list state m = do
|
||||
case state.store_DomainListInterface_state of
|
||||
Nothing -> do
|
||||
let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m
|
||||
H.modify_ _ { store_DomainListInterface_state = Just new_value }
|
||||
Just _ -> pure unit
|
||||
|
||||
revert_old_page = do
|
||||
-- Get back to the previous page.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
page <- H.liftEffect $ Storage.getItem "current-page" sessionstorage
|
||||
case page of
|
||||
Nothing -> pure unit
|
||||
Just "Home" -> handleAction $ Routing Home
|
||||
Just "Authentication" -> handleAction $ Routing Authentication
|
||||
Just "Registration" -> handleAction $ Routing Registration
|
||||
Just "DomainList" -> handleAction $ Routing DomainList
|
||||
Just "MailValidation" -> handleAction $ Routing MailValidation
|
||||
Just "Setup" -> handleAction $ Routing Setup
|
||||
Just "Administration" -> handleAction $ Routing Administration
|
||||
Just "Zone" -> do
|
||||
domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage
|
||||
case domain of
|
||||
Nothing -> handleAction $ Log $ SystemLog "Zone but no domain recorded!! WEIRD"
|
||||
Just zone -> do handleAction $ Log $ SystemLog $ "zone to display: " <> zone
|
||||
handleAction $ Routing (Zone zone)
|
||||
Just p -> handleAction $ Log $ SystemLog $ "Oopsie, we didn't understand the old page: " <> p
|
||||
|
||||
|
||||
--print_json_string :: forall m. MonadEffect m => MonadState State m => ArrayBuffer -> m Unit
|
||||
--print_json_string arraybuffer = do
|
||||
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
|
||||
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
|
||||
-- H.raise $ Log $ ErrorLog $ case (value) of
|
||||
-- Left _ -> "Cannot even fromTypedIPC the message."
|
||||
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
|
||||
156
src/App/DisplayErrors.purs
Normal file
156
src/App/DisplayErrors.purs
Normal file
@ -0,0 +1,156 @@
|
||||
-- | This module provides functions to display errors in a fancy way.
|
||||
module App.DisplayErrors where
|
||||
|
||||
import Prelude (show, ($), (<>))
|
||||
|
||||
-- import Data.Foldable as Foldable
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Halogen.HTML as HH
|
||||
|
||||
import App.Validation.DNS as ValidationDNS
|
||||
import App.Validation.Label as ValidationLabel
|
||||
import GenericParser.DomainParser.Common (DomainError(..)) as DomainParser
|
||||
import GenericParser.IPAddress as IPAddress
|
||||
import Bulma as Bulma
|
||||
|
||||
error_to_paragraph :: forall w i. ValidationDNS.Error -> HH.HTML w i
|
||||
error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
|
||||
(case v of
|
||||
ValidationDNS.UNKNOWN -> Bulma.p "An internal error happened."
|
||||
ValidationDNS.VEIPv4 err -> maybe default_error show_error_ip4 err.error
|
||||
ValidationDNS.VEIPv6 err -> maybe default_error show_error_ip6 err.error
|
||||
ValidationDNS.VEName err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VETTL min max n -> Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
|
||||
<> ", current value: " <> show n <> "."
|
||||
ValidationDNS.VETXT err -> maybe default_error show_error_txt err.error
|
||||
ValidationDNS.VECNAME err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VENS err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VEMX err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VEPriority min max n -> Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max
|
||||
<> ", current value: " <> show n <> "."
|
||||
ValidationDNS.VESRV err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VEProtocol err -> maybe default_error show_error_protocol err.error
|
||||
ValidationDNS.VEPort min max n -> Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max
|
||||
<> ", current value: " <> show n <> "."
|
||||
ValidationDNS.VEWeight min max n -> Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max
|
||||
<> ", current value: " <> show n <> "."
|
||||
|
||||
-- SPF dedicated RR
|
||||
ValidationDNS.VESPFMechanismName err -> maybe default_error show_error_domain err.error
|
||||
ValidationDNS.VESPFMechanismIPv4 err -> maybe default_error show_error_ip4 err.error
|
||||
ValidationDNS.VESPFMechanismIPv6 err -> maybe default_error show_error_ip6 err.error
|
||||
ValidationDNS.VESPFModifierName err -> maybe default_error show_error_domain err.error
|
||||
|
||||
ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max
|
||||
)
|
||||
where default_error = Bulma.p ""
|
||||
|
||||
show_error_key_sizes :: forall w i. Int -> Int -> HH.HTML w i
|
||||
show_error_key_sizes min max
|
||||
= Bulma.p $ "Chosen signature algorithm only accepts public key input between "
|
||||
<> show min <> " and " <> show max <> " characters."
|
||||
|
||||
-- | `show_error_title` provide a simple title string to display to the user in case of an error with an entry.
|
||||
show_error_title :: ValidationDNS.Error -> String
|
||||
show_error_title v = case v of
|
||||
ValidationDNS.UNKNOWN -> "Unknown"
|
||||
ValidationDNS.VEIPv4 err -> "The IPv4 address is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEIPv6 err -> "The IPv6 address is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEName err -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VETTL min max n -> "Invalid TTL (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
||||
ValidationDNS.VETXT err -> "The TXT input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VECNAME err -> "The CNAME input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VENS err -> "The NS input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEMX err -> "The MX target input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEPriority min max n -> "Invalid Priority (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
||||
ValidationDNS.VESRV err -> "The SRV target input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEProtocol err -> "The Protocol input is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VEPort min max n -> "Invalid Port (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
||||
ValidationDNS.VEWeight min max n -> "Invalid Weight (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
||||
|
||||
-- SPF dedicated RR
|
||||
ValidationDNS.VESPFMechanismName err -> "The domain name in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VESPFMechanismIPv4 err -> "The IPv4 address in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.VESPFMechanismIPv6 err -> "The IPv6 address in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
||||
|
||||
ValidationDNS.VESPFModifierName err -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong (position: " <> show err.position <> ")"
|
||||
ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length."
|
||||
|
||||
show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i
|
||||
show_error_domain e = case e of
|
||||
DomainParser.LabelTooLarge size ->
|
||||
Bulma.p $ "The label contains too many characters (" <> show size <> ")."
|
||||
DomainParser.DomainTooLarge size ->
|
||||
Bulma.p $ "The domain contains too many characters (" <> show size <> ")."
|
||||
-- DomainParser.InvalidCharacter
|
||||
-- DomainParser.EOFExpected
|
||||
_ -> Bulma.p """
|
||||
The domain (or label) contains invalid characters.
|
||||
A domain label should start with a letter,
|
||||
then eventually a series of letters, digits and hyphenations ('-'),
|
||||
and must finish with either a letter or a digit.
|
||||
"""
|
||||
|
||||
show_error_protocol :: forall w i. ValidationDNS.ProtocolError -> HH.HTML w i
|
||||
show_error_protocol e = case e of
|
||||
ValidationDNS.InvalidProtocol -> Bulma.p "Protocol should be a value as 'tcp' or 'udp'."
|
||||
|
||||
show_error_ip6 :: forall w i. IPAddress.IPv6Error -> HH.HTML w i
|
||||
show_error_ip6 e = case e of
|
||||
IPAddress.IP6TooManyHexaDecimalCharacters ->
|
||||
Bulma.p "IP6TooManyHexaDecimalCharacters"
|
||||
IPAddress.IP6NotEnoughChunks ->
|
||||
Bulma.p """
|
||||
The IPv6 representation is erroneous, it should contain 8 groups of hexadecimal characters or
|
||||
being shortened with a double ':' character, such as '2000::1'.
|
||||
"""
|
||||
IPAddress.IP6TooManyChunks ->
|
||||
Bulma.p "The IPv6 representation is erroneous. It should contain only up to 8 groups of hexadecimal characters."
|
||||
IPAddress.IP6IrrelevantShortRepresentation ->
|
||||
Bulma.p "IPv6 address has been unnecessarily shortened (with two ':')."
|
||||
IPAddress.IP6InvalidRange -> Bulma.p "IPv6 address or range isn't valid."
|
||||
|
||||
show_error_ip4 :: forall w i. IPAddress.IPv4Error -> HH.HTML w i
|
||||
show_error_ip4 e = case e of
|
||||
IPAddress.IP4NumberTooBig n ->
|
||||
Bulma.p $ "IPv4 address contains a number too big (should be between 0 and 255). Current entered number: " <> show n
|
||||
IPAddress.IP4IrrelevantShortRepresentation ->
|
||||
Bulma.p "IPv4 address has been unnecessarily shortened (with two '.')."
|
||||
IPAddress.IP4InvalidRange -> Bulma.p "IPv4 address or range isn't valid."
|
||||
|
||||
show_error_txt :: forall w i. ValidationDNS.TXTError -> HH.HTML w i
|
||||
show_error_txt e = case e of
|
||||
ValidationDNS.TXTInvalidCharacter -> Bulma.p "The TXT field contains some invalid characters."
|
||||
ValidationDNS.TXTTooLong max n ->
|
||||
Bulma.p $ "An TXT field is limited to " <> show max <> " characters (currently there are "
|
||||
<> show n <> " characters)."
|
||||
|
||||
domainerror_string :: DomainParser.DomainError -> String
|
||||
domainerror_string (DomainParser.LabelTooLarge size) = "LabelTooLarge (size: " <> show size <> ")"
|
||||
domainerror_string (DomainParser.DomainTooLarge size) = "DomainTooLarge (size: " <> show size <> ")"
|
||||
domainerror_string (DomainParser.InvalidCharacter) = "InvalidCharacter"
|
||||
domainerror_string (DomainParser.EOFExpected) = "EOFExpected"
|
||||
|
||||
-- | This `error_to_paragraph` is designed to go along the `Validation.Label` module.
|
||||
error_to_paragraph_label :: forall w i. ValidationLabel.Error -> HH.HTML w i
|
||||
error_to_paragraph_label v = Bulma.error_message (Bulma.p $ show_error_title_label v)
|
||||
(case v of
|
||||
ValidationLabel.ParsingError x -> case x.error of
|
||||
Nothing -> Bulma.p ""
|
||||
Just (ValidationLabel.CannotParse err) -> show_error_domain err
|
||||
Just (ValidationLabel.CannotEntirelyParse) -> Bulma.p "Cannot entirely parse the label."
|
||||
Just (ValidationLabel.Size min max n) ->
|
||||
Bulma.p $ "Label size should be between " <> show min <> " and " <> show max
|
||||
<> " (current size: " <> show n <> ")."
|
||||
)
|
||||
|
||||
show_error_title_label :: ValidationLabel.Error -> String
|
||||
show_error_title_label v = case v of
|
||||
ValidationLabel.ParsingError x -> case x.error of
|
||||
Nothing -> "Cannot parse the label (position: " <> show x.position <> ")."
|
||||
Just (ValidationLabel.CannotParse _) ->
|
||||
"Cannot parse the label (position: " <> show x.position <> ")."
|
||||
Just (ValidationLabel.CannotEntirelyParse) -> "Cannot entirely parse the label."
|
||||
Just (ValidationLabel.Size min max n) ->
|
||||
"Label size should be between " <> show min <> " and " <> show max
|
||||
<> " (current size: " <> show n <> ")."
|
||||
95
src/App/Log.purs
Normal file
95
src/App/Log.purs
Normal file
@ -0,0 +1,95 @@
|
||||
module App.Log where
|
||||
|
||||
{- Simple log component, showing the current events. -}
|
||||
|
||||
import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (-), (<), (<>))
|
||||
|
||||
import Control.Monad.State (class MonadState)
|
||||
import Data.Array as A
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
|
||||
import App.Type.LogMessage
|
||||
|
||||
data Output = Void
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
-- type Query :: forall k. k -> Type
|
||||
data Query a = Log LogMessage a
|
||||
|
||||
type Input = Unit
|
||||
|
||||
type Action = Unit
|
||||
|
||||
type State =
|
||||
{ messages :: Array String
|
||||
, messageHistoryLength :: Int
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery }
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ messages: []
|
||||
, messageHistoryLength: 10
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { messages }
|
||||
= HH.div_ [ render_messages ]
|
||||
where
|
||||
render_messages = HH.ul_ $ map (\msg -> HH.li_ [ HH.text msg ]) messages
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
Log message a -> do
|
||||
case message of
|
||||
SystemLog str -> systemMessage str
|
||||
UnableToSend str -> unableToSend str
|
||||
ErrorLog str -> errorMessage str
|
||||
SuccessLog str -> successMessage str
|
||||
pure (Just a)
|
||||
|
||||
|
||||
type IncompleteState rows
|
||||
= { messages :: Array String
|
||||
, messageHistoryLength :: Int
|
||||
| rows }
|
||||
|
||||
-- Append a new message to the chat history.
|
||||
-- The number of displayed `messages` in the chat history (including system)
|
||||
-- is controlled by the `messageHistoryLength` field in the component `State`.
|
||||
appendMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
appendMessage msg = do
|
||||
histSize <- H.gets _.messageHistoryLength
|
||||
H.modify_ \st -> st { messages = appendSingle histSize msg st.messages }
|
||||
where
|
||||
-- Limits the number of recent messages to `maxHist`
|
||||
appendSingle :: Int -> String -> Array String -> Array String
|
||||
appendSingle maxHist x xs
|
||||
| A.length xs < maxHist = xs `A.snoc` x
|
||||
| otherwise = (A.takeEnd (maxHist-1) xs) `A.snoc` x
|
||||
|
||||
-- Append a system message to the chat log.
|
||||
systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
systemMessage msg = appendMessage ("[🤖] System: " <> msg)
|
||||
|
||||
-- Append an error message to the chat log.
|
||||
errorMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
errorMessage msg = appendMessage ("[🛑] Error: " <> msg)
|
||||
|
||||
-- Append a success message to the chat log.
|
||||
successMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
successMessage msg = appendMessage ("[🎉] " <> msg)
|
||||
|
||||
-- A system message to use when a message cannot be sent.
|
||||
unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
unableToSend reason = appendMessage ("[🛑] Unable to send. " <> reason)
|
||||
486
src/App/Message/AuthenticationDaemon.purs
Normal file
486
src/App/Message/AuthenticationDaemon.purs
Normal file
@ -0,0 +1,486 @@
|
||||
module App.Message.AuthenticationDaemon 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.Email as Email
|
||||
import App.Type.UserPublic as UserPublic
|
||||
import App.Type.PermissionLevel as PermissionLevel
|
||||
|
||||
import Effect.Class (liftEffect)
|
||||
import Data.Argonaut.Parser as JSONParser
|
||||
import Data.Bifunctor (lmap)
|
||||
|
||||
import App.Message.IPC as IPC
|
||||
|
||||
{- TODO:
|
||||
For a few messages, user can be designated by a string (login) or a number (its UID).
|
||||
This was simplified by using the uid for each.
|
||||
Maybe this could be changed in the future to match the actual possibilities of the API.
|
||||
-}
|
||||
|
||||
type Password = String
|
||||
|
||||
{- UserID should be in a separate module with a dedicated codec. -}
|
||||
type UserID = Int -- UserID is either a login or an uid number
|
||||
|
||||
{-
|
||||
REQUESTS
|
||||
|
||||
General notes:
|
||||
- when the "UserID" is optional, the server will work on the requesting user
|
||||
-}
|
||||
|
||||
{- 0 -}
|
||||
type Login = { login :: String, password :: String }
|
||||
codecLogin ∷ CA.JsonCodec Login
|
||||
codecLogin = CA.object "Login" (CAR.record { login: CA.string, password: CA.string })
|
||||
|
||||
{- 1 -}
|
||||
type Register = { login :: String
|
||||
, password :: Password
|
||||
, email :: Maybe Email.Email
|
||||
{-, profile :: Maybe Hash(String, JSON::Any) -} }
|
||||
codecRegister ∷ CA.JsonCodec Register
|
||||
codecRegister
|
||||
= CA.object "Register" (CAR.record
|
||||
{ login: CA.string
|
||||
, password: CA.string
|
||||
, email: CAR.optional Email.codec })
|
||||
|
||||
{- 2 -}
|
||||
type ValidateUser = { user :: String, activation_key :: String }
|
||||
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
||||
codecValidateUser
|
||||
= CA.object "ValidateUser" (CAR.record
|
||||
{ user: CA.string
|
||||
, activation_key: CA.string })
|
||||
|
||||
{- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID,
|
||||
but they'll be used as login since the user has to type it. -}
|
||||
{- 3 -}
|
||||
type AskPasswordRecovery = { user :: Maybe String, email :: Maybe Email.Email }
|
||||
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
||||
codecAskPasswordRecovery
|
||||
= CA.object "AskPasswordRecovery"
|
||||
(CAR.record { user: CAR.optional CA.string, email: CAR.optional Email.codec })
|
||||
|
||||
{- 4 -}
|
||||
type PasswordRecovery = { user :: String
|
||||
, password_renew_key :: String
|
||||
, new_password :: Password }
|
||||
codecPasswordRecovery ∷ CA.JsonCodec PasswordRecovery
|
||||
codecPasswordRecovery
|
||||
= CA.object "PasswordRecovery" (CAR.record
|
||||
{ user: CA.string
|
||||
, password_renew_key: CA.string
|
||||
, new_password: CA.string })
|
||||
|
||||
{- 5 -}
|
||||
-- I'll split a message in two: either get a user by UID or by name.
|
||||
-- TODO: change it for an Either Int String type.
|
||||
type GetUserByUID = { user :: Int }
|
||||
type GetUserByName = { user :: String }
|
||||
codecGetUserByUID ∷ CA.JsonCodec GetUserByUID
|
||||
codecGetUserByUID = CA.object "GetUserByUID" (CAR.record { user: CA.int })
|
||||
codecGetUserByName ∷ CA.JsonCodec GetUserByName
|
||||
codecGetUserByName = CA.object "GetUserByName" (CAR.record { user: CA.string })
|
||||
|
||||
{- 6 -}
|
||||
type ModUser = { user :: Maybe UserID
|
||||
, admin :: Maybe Boolean
|
||||
, password :: Maybe Password
|
||||
, email :: Maybe Email.Email }
|
||||
codecModUser ∷ CA.JsonCodec ModUser
|
||||
codecModUser
|
||||
= CA.object "ModUser" (CAR.record
|
||||
{ user: CAR.optional CA.int
|
||||
, admin: CAR.optional CA.boolean
|
||||
, password: CAR.optional CA.string
|
||||
, email: CAR.optional Email.codec })
|
||||
|
||||
{- 7 -}
|
||||
{- type EditProfileEntries = { user :: Maybe UserID
|
||||
, new_profile_entries :: Hash(String, JSON::Any) } -}
|
||||
|
||||
{- 8 -}
|
||||
type DeleteUser = { user :: Maybe UserID }
|
||||
codecDeleteUser ∷ CA.JsonCodec DeleteUser
|
||||
codecDeleteUser = CA.object "DeleteUser" (CAR.record { user: CAR.optional CA.int })
|
||||
|
||||
{- 9 -}
|
||||
type AddUser = { login :: String
|
||||
, password :: Password
|
||||
, admin :: Boolean
|
||||
, email :: Maybe Email.Email
|
||||
{-, profile :: Maybe Hash(String, JSON::Any) -} }
|
||||
codecAddUser ∷ CA.JsonCodec AddUser
|
||||
codecAddUser
|
||||
= CA.object "AddUser" (CAR.record
|
||||
{ login: CA.string
|
||||
, password: CA.string
|
||||
, admin: CA.boolean
|
||||
, email: CAR.optional Email.codec
|
||||
{-, profile :: Maybe Hash(String, JSON::Any) -} })
|
||||
|
||||
{- 10 -}
|
||||
type CheckPermission = { user :: Maybe UserID, service :: String, resource :: String }
|
||||
codecCheckPermission ∷ CA.JsonCodec CheckPermission
|
||||
codecCheckPermission
|
||||
= CA.object "CheckPermission" (CAR.record
|
||||
{ user: CAR.optional CA.int
|
||||
, service: CA.string
|
||||
, resource: CA.string })
|
||||
|
||||
{- 11 -}
|
||||
type SetPermission = { user :: UserID
|
||||
, service :: String
|
||||
, resource :: String
|
||||
, permission :: PermissionLevel.PermissionLevel }
|
||||
codecSetPermission ∷ CA.JsonCodec SetPermission
|
||||
codecSetPermission
|
||||
= CA.object "SetPermission" (CAR.record
|
||||
{ user: CA.int
|
||||
, service: CA.string
|
||||
, resource: CA.string
|
||||
, permission: PermissionLevel.codec })
|
||||
|
||||
{- 12 -}
|
||||
type SearchUser = { regex :: Maybe String, offset :: Maybe Int }
|
||||
codecSearchUser ∷ CA.JsonCodec SearchUser
|
||||
codecSearchUser
|
||||
= CA.object "SearchUser" (CAR.record
|
||||
{ regex: CAR.optional CA.string
|
||||
, offset: CAR.optional CA.int })
|
||||
|
||||
{- 13 and 14: these messages are not designed for clients. -}
|
||||
{- 15 -}
|
||||
type AuthByToken = { token :: String }
|
||||
codecAuthByToken ∷ CA.JsonCodec AuthByToken
|
||||
codecAuthByToken = CA.object "AuthByToken" (CAR.record { token: CA.string })
|
||||
|
||||
{- 250 -}
|
||||
type KeepAlive = { }
|
||||
codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
||||
codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
||||
|
||||
{-
|
||||
RESPONSES
|
||||
-}
|
||||
|
||||
-- TODO: note to myself: messages seem chaotic. Could be simpler. Should be simpler.
|
||||
{- 0 -}
|
||||
type Error = { reason :: Maybe String }
|
||||
codecGotError ∷ CA.JsonCodec Error
|
||||
codecGotError = CA.object "Error" (CAR.record { reason: CAR.optional CA.string })
|
||||
|
||||
{- 1 -}
|
||||
type Logged = { uid :: Int, token :: String }
|
||||
codecGotToken ∷ CA.JsonCodec Logged
|
||||
codecGotToken = CA.object "Logged" (CAR.record { "uid": CA.int, "token": CA.string })
|
||||
|
||||
{- 2 -}
|
||||
type User = { user :: UserPublic.UserPublic }
|
||||
codecGotUser ∷ CA.JsonCodec User
|
||||
codecGotUser = CA.object "User" (CAR.record { user: UserPublic.codec })
|
||||
|
||||
{- 3 -}
|
||||
type UserAdded = { user :: UserPublic.UserPublic }
|
||||
codecGotUserAdded ∷ CA.JsonCodec UserAdded
|
||||
codecGotUserAdded = CA.object "UserAdded" (CAR.record { user: UserPublic.codec })
|
||||
|
||||
{- 4 -}
|
||||
type UserEdited = { uid :: Int }
|
||||
codecGotUserEdited ∷ CA.JsonCodec UserEdited
|
||||
codecGotUserEdited = CA.object "UserEdited" (CAR.record { "uid": CA.int })
|
||||
|
||||
{- 5 -}
|
||||
type UserValidated = { user :: UserPublic.UserPublic }
|
||||
codecGotUserValidated ∷ CA.JsonCodec UserValidated
|
||||
codecGotUserValidated = CA.object "UserValidated" (CAR.record { user: UserPublic.codec })
|
||||
|
||||
{- 6 -}
|
||||
type UsersList = { users :: Array UserPublic.UserPublic }
|
||||
codecGotUsersList ∷ CA.JsonCodec UsersList
|
||||
codecGotUsersList = CA.object "UsersList" (CAR.record { users: CA.array UserPublic.codec })
|
||||
|
||||
{- 7 -}
|
||||
type PermissionCheck
|
||||
= { user :: Int
|
||||
, service :: String
|
||||
, resource :: String
|
||||
, permission :: PermissionLevel.PermissionLevel }
|
||||
codecGotPermissionCheck :: CA.JsonCodec PermissionCheck
|
||||
codecGotPermissionCheck
|
||||
= CA.object "PermissionCheck" (CAR.record
|
||||
{ user: CA.int
|
||||
, service: CA.string
|
||||
, resource: CA.string
|
||||
, permission: PermissionLevel.codec })
|
||||
|
||||
{- 8 -}
|
||||
type PermissionSet
|
||||
= { user :: Int
|
||||
, service :: String
|
||||
, resource :: String
|
||||
, permission :: PermissionLevel.PermissionLevel }
|
||||
codecGotPermissionSet :: CA.JsonCodec PermissionSet
|
||||
codecGotPermissionSet
|
||||
= CA.object "PermissionSet" (CAR.record
|
||||
{ user: CA.int
|
||||
, service: CA.string
|
||||
, resource: CA.string
|
||||
, permission: PermissionLevel.codec })
|
||||
|
||||
{- 9 -}
|
||||
type PasswordRecoverySent = { }
|
||||
codecGotPasswordRecoverySent ∷ CA.JsonCodec PasswordRecoverySent
|
||||
codecGotPasswordRecoverySent = CA.object "PasswordRecoverySent" (CAR.record { })
|
||||
|
||||
{- 10 -}
|
||||
type PasswordRecovered = { }
|
||||
codecGotPasswordRecovered ∷ CA.JsonCodec PasswordRecovered
|
||||
codecGotPasswordRecovered = CA.object "PasswordRecovered" (CAR.record { })
|
||||
|
||||
{- 11 -}
|
||||
type MatchingUsers = { users :: Array UserPublic.UserPublic }
|
||||
codecGotMatchingUsers ∷ CA.JsonCodec MatchingUsers
|
||||
codecGotMatchingUsers = CA.object "MatchingUsers" (CAR.record { users: CA.array UserPublic.codec })
|
||||
|
||||
{- 12 -}
|
||||
type UserDeleted = { uid :: Int }
|
||||
codecGotUserDeleted ∷ CA.JsonCodec UserDeleted
|
||||
codecGotUserDeleted = CA.object "UserDeleted" (CAR.record { uid: CA.int })
|
||||
|
||||
{- 20 -}
|
||||
type ErrorMustBeAuthenticated = {}
|
||||
codecGotErrorMustBeAuthenticated :: CA.JsonCodec ErrorMustBeAuthenticated
|
||||
codecGotErrorMustBeAuthenticated = CA.object "ErrorMustBeAuthenticated" (CAR.record {})
|
||||
|
||||
{- 21 -}
|
||||
type ErrorAlreadyUsedLogin = {}
|
||||
codecGotErrorAlreadyUsedLogin :: CA.JsonCodec ErrorAlreadyUsedLogin
|
||||
codecGotErrorAlreadyUsedLogin = CA.object "ErrorAlreadyUsedLogin" (CAR.record {})
|
||||
|
||||
{- 22 -}
|
||||
type ErrorMailRequired = {}
|
||||
codecGotErrorMailRequired :: CA.JsonCodec ErrorMailRequired
|
||||
codecGotErrorMailRequired = CA.object "ErrorMailRequired" (CAR.record {})
|
||||
|
||||
{- 23 -}
|
||||
type ErrorUserNotFound = {}
|
||||
codecGotErrorUserNotFound :: CA.JsonCodec ErrorUserNotFound
|
||||
codecGotErrorUserNotFound = CA.object "ErrorUserNotFound" (CAR.record {})
|
||||
|
||||
{- 24 -}
|
||||
type ErrorPasswordTooShort = {}
|
||||
codecGotErrorPasswordTooShort :: CA.JsonCodec ErrorPasswordTooShort
|
||||
codecGotErrorPasswordTooShort = CA.object "ErrorPasswordTooShort" (CAR.record {})
|
||||
|
||||
{- 25 -}
|
||||
type ErrorInvalidCredentials = {}
|
||||
codecGotErrorInvalidCredentials :: CA.JsonCodec ErrorInvalidCredentials
|
||||
codecGotErrorInvalidCredentials = CA.object "ErrorInvalidCredentials" (CAR.record {})
|
||||
|
||||
{- 26 -}
|
||||
type ErrorRegistrationsClosed = {}
|
||||
codecGotErrorRegistrationsClosed :: CA.JsonCodec ErrorRegistrationsClosed
|
||||
codecGotErrorRegistrationsClosed = CA.object "ErrorRegistrationsClosed" (CAR.record {})
|
||||
|
||||
{- 27 -}
|
||||
type ErrorInvalidLoginFormat = {}
|
||||
codecGotErrorInvalidLoginFormat :: CA.JsonCodec ErrorInvalidLoginFormat
|
||||
codecGotErrorInvalidLoginFormat = CA.object "ErrorInvalidLoginFormat" (CAR.record {})
|
||||
|
||||
{- 28 -}
|
||||
type ErrorInvalidEmailFormat = {}
|
||||
codecGotErrorInvalidEmailFormat :: CA.JsonCodec ErrorInvalidEmailFormat
|
||||
codecGotErrorInvalidEmailFormat = CA.object "ErrorInvalidEmailFormat" (CAR.record {})
|
||||
|
||||
{- 29 -}
|
||||
type ErrorAlreadyUsersInDB = {}
|
||||
codecGotErrorAlreadyUsersInDB :: CA.JsonCodec ErrorAlreadyUsersInDB
|
||||
codecGotErrorAlreadyUsersInDB = CA.object "ErrorAlreadyUsersInDB" (CAR.record {})
|
||||
|
||||
{- 30 -}
|
||||
type ErrorReadOnlyProfileKeys = { read_only_keys :: Array String }
|
||||
codecGotErrorReadOnlyProfileKeys :: CA.JsonCodec ErrorReadOnlyProfileKeys
|
||||
codecGotErrorReadOnlyProfileKeys
|
||||
= CA.object "ErrorReadOnlyProfileKeys" (CAR.record { read_only_keys: CA.array CA.string })
|
||||
|
||||
{- 31 -}
|
||||
type ErrorInvalidActivationKey = {}
|
||||
codecGotErrorInvalidActivationKey :: CA.JsonCodec ErrorInvalidActivationKey
|
||||
codecGotErrorInvalidActivationKey = CA.object "ErrorInvalidActivationKey" (CAR.record {})
|
||||
|
||||
{- 32 -}
|
||||
type ErrorUserAlreadyValidated = {}
|
||||
codecGotErrorUserAlreadyValidated :: CA.JsonCodec ErrorUserAlreadyValidated
|
||||
codecGotErrorUserAlreadyValidated = CA.object "ErrorUserAlreadyValidated" (CAR.record {})
|
||||
|
||||
{- 33 -}
|
||||
type ErrorCannotContactUser = {}
|
||||
codecGotErrorCannotContactUser :: CA.JsonCodec ErrorCannotContactUser
|
||||
codecGotErrorCannotContactUser = CA.object "ErrorCannotContactUser" (CAR.record {})
|
||||
|
||||
{- 34 -}
|
||||
type ErrorInvalidRenewKey = {}
|
||||
codecGotErrorInvalidRenewKey :: CA.JsonCodec ErrorInvalidRenewKey
|
||||
codecGotErrorInvalidRenewKey = CA.object "ErrorInvalidRenewKey" (CAR.record {})
|
||||
|
||||
{- 250 -}
|
||||
-- type KeepAlive = { }
|
||||
codecGotKeepAlive ∷ CA.JsonCodec KeepAlive
|
||||
codecGotKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
||||
|
||||
-- All possible requests.
|
||||
data RequestMessage
|
||||
= MkLogin Login -- 0
|
||||
| MkRegister Register -- 1
|
||||
| MkValidateUser ValidateUser -- 2
|
||||
| MkAskPasswordRecovery AskPasswordRecovery -- 3
|
||||
| MkPasswordRecovery PasswordRecovery -- 4
|
||||
| MkGetUserByUID GetUserByUID -- 5
|
||||
| MkGetUserByName GetUserByName -- 5 (bis)
|
||||
| MkModUser ModUser -- 6
|
||||
--| MkEditProfileContent EditProfileContent -- 7
|
||||
| MkDeleteUser DeleteUser -- 8
|
||||
| MkAddUser AddUser -- 9
|
||||
| MkCheckPermission CheckPermission -- 10
|
||||
| MkSetPermission SetPermission -- 11
|
||||
| MkSearchUser SearchUser -- 12
|
||||
| MkAuthByToken AuthByToken -- 15
|
||||
| MkKeepAlive KeepAlive -- 250
|
||||
|
||||
-- All possible answers from the authentication daemon (authd).
|
||||
data AnswerMessage
|
||||
= GotError Error -- 0
|
||||
| GotToken Logged -- 1
|
||||
| GotUser User -- 2
|
||||
| GotUserAdded UserAdded -- 3
|
||||
| GotUserEdited UserEdited -- 4
|
||||
| GotUserValidated UserValidated -- 5
|
||||
| GotUsersList UsersList -- 6
|
||||
| GotPermissionCheck PermissionCheck -- 7
|
||||
| GotPermissionSet PermissionSet -- 8
|
||||
| GotPasswordRecoverySent PasswordRecoverySent -- 9
|
||||
| GotPasswordRecovered PasswordRecovered -- 10
|
||||
| GotMatchingUsers MatchingUsers -- 11
|
||||
| GotUserDeleted UserDeleted -- 12
|
||||
| GotErrorMustBeAuthenticated ErrorMustBeAuthenticated -- 20
|
||||
| GotErrorAlreadyUsedLogin ErrorAlreadyUsedLogin -- 21
|
||||
| GotErrorMailRequired ErrorMailRequired -- 22
|
||||
| GotErrorUserNotFound ErrorUserNotFound -- 23
|
||||
| GotErrorPasswordTooShort ErrorPasswordTooShort -- 24
|
||||
| GotErrorInvalidCredentials ErrorInvalidCredentials -- 25
|
||||
| GotErrorRegistrationsClosed ErrorRegistrationsClosed -- 26
|
||||
| GotErrorInvalidLoginFormat ErrorInvalidLoginFormat -- 27
|
||||
| GotErrorInvalidEmailFormat ErrorInvalidEmailFormat -- 28
|
||||
| GotErrorAlreadyUsersInDB ErrorAlreadyUsersInDB -- 29
|
||||
| GotErrorReadOnlyProfileKeys ErrorReadOnlyProfileKeys -- 30
|
||||
| GotErrorInvalidActivationKey ErrorInvalidActivationKey -- 31
|
||||
| GotErrorUserAlreadyValidated ErrorUserAlreadyValidated -- 32
|
||||
| GotErrorCannotContactUser ErrorCannotContactUser -- 33
|
||||
| GotErrorInvalidRenewKey ErrorInvalidRenewKey -- 34
|
||||
| GotKeepAlive KeepAlive -- 250
|
||||
|
||||
encode ∷ RequestMessage -> Tuple UInt String
|
||||
encode m = case m of
|
||||
(MkLogin request) -> get_tuple 0 codecLogin request
|
||||
(MkRegister request) -> get_tuple 1 codecRegister request
|
||||
(MkValidateUser request) -> get_tuple 2 codecValidateUser request
|
||||
(MkAskPasswordRecovery request) -> get_tuple 3 codecAskPasswordRecovery request
|
||||
(MkPasswordRecovery request) -> get_tuple 4 codecPasswordRecovery request
|
||||
-- Both messages are actually a single message type, so they have the same number.
|
||||
-- TODO: change the message codec for an Either Int String.
|
||||
(MkGetUserByUID request) -> get_tuple 5 codecGetUserByUID request
|
||||
(MkGetUserByName request) -> get_tuple 5 codecGetUserByName request
|
||||
(MkModUser request) -> get_tuple 6 codecModUser request
|
||||
-- 7 MkEditProfileContent
|
||||
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
|
||||
(MkAddUser request) -> get_tuple 9 codecAddUser request
|
||||
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
|
||||
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
|
||||
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
|
||||
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
|
||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
||||
where
|
||||
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
|
||||
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
|
||||
|
||||
data DecodeError
|
||||
= JSONERROR String
|
||||
| UnknownError String
|
||||
| UnknownNumber
|
||||
|
||||
decode :: Int -> String -> Either DecodeError AnswerMessage
|
||||
decode number string
|
||||
= case number of
|
||||
0 -> error_management codecGotError GotError
|
||||
1 -> error_management codecGotToken GotToken
|
||||
2 -> error_management codecGotUser GotUser
|
||||
3 -> error_management codecGotUserAdded GotUserAdded
|
||||
4 -> error_management codecGotUserEdited GotUserEdited
|
||||
5 -> error_management codecGotUserValidated GotUserValidated
|
||||
6 -> error_management codecGotUsersList GotUsersList
|
||||
7 -> error_management codecGotPermissionCheck GotPermissionCheck
|
||||
8 -> error_management codecGotPermissionSet GotPermissionSet
|
||||
9 -> error_management codecGotPasswordRecoverySent GotPasswordRecoverySent
|
||||
10 -> error_management codecGotPasswordRecovered GotPasswordRecovered
|
||||
11 -> error_management codecGotMatchingUsers GotMatchingUsers
|
||||
12 -> error_management codecGotUserDeleted GotUserDeleted
|
||||
20 -> error_management codecGotErrorMustBeAuthenticated GotErrorMustBeAuthenticated
|
||||
21 -> error_management codecGotErrorAlreadyUsedLogin GotErrorAlreadyUsedLogin
|
||||
22 -> error_management codecGotErrorMailRequired GotErrorMailRequired
|
||||
23 -> error_management codecGotErrorUserNotFound GotErrorUserNotFound
|
||||
24 -> error_management codecGotErrorPasswordTooShort GotErrorPasswordTooShort
|
||||
25 -> error_management codecGotErrorInvalidCredentials GotErrorInvalidCredentials
|
||||
26 -> error_management codecGotErrorRegistrationsClosed GotErrorRegistrationsClosed
|
||||
27 -> error_management codecGotErrorInvalidLoginFormat GotErrorInvalidLoginFormat
|
||||
28 -> error_management codecGotErrorInvalidEmailFormat GotErrorInvalidEmailFormat
|
||||
29 -> error_management codecGotErrorAlreadyUsersInDB GotErrorAlreadyUsersInDB
|
||||
30 -> error_management codecGotErrorReadOnlyProfileKeys GotErrorReadOnlyProfileKeys
|
||||
31 -> error_management codecGotErrorInvalidActivationKey GotErrorInvalidActivationKey
|
||||
32 -> error_management codecGotErrorUserAlreadyValidated GotErrorUserAlreadyValidated
|
||||
33 -> error_management codecGotErrorCannotContactUser GotErrorCannotContactUser
|
||||
34 -> error_management codecGotErrorInvalidRenewKey GotErrorInvalidRenewKey
|
||||
250 -> error_management codecGotKeepAlive 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
|
||||
420
src/App/Message/DNSManagerDaemon.purs
Normal file
420
src/App/Message/DNSManagerDaemon.purs
Normal file
@ -0,0 +1,420 @@
|
||||
module App.Message.DNSManagerDaemon where
|
||||
|
||||
import Prelude (bind, pure, show, ($))
|
||||
|
||||
import Effect (Effect)
|
||||
|
||||
import Data.Argonaut.Core as J
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Maybe (Maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Codec.Argonaut.Record as CAR
|
||||
import Data.UInt (fromInt, toInt, UInt)
|
||||
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
|
||||
-- import App.Type.PermissionLevel as PermissionLevel
|
||||
import App.Type.MaintenanceSubject as MaintenanceSubject
|
||||
|
||||
import Effect.Class (liftEffect)
|
||||
import Data.Argonaut.Parser as JSONParser
|
||||
import Data.Bifunctor (lmap)
|
||||
|
||||
import App.Message.IPC as IPC
|
||||
import App.Type.DNSZone as DNSZone
|
||||
import App.Type.ResourceRecord as ResourceRecord
|
||||
|
||||
{- UserID should be in a separate module with a dedicated codec. -}
|
||||
type UserID = Int -- UserID is either a login or an uid number
|
||||
|
||||
|
||||
{- 0 -}
|
||||
type Login = { token :: String }
|
||||
codecLogin ∷ CA.JsonCodec Login
|
||||
codecLogin = CA.object "Login" (CAR.record { token: CA.string })
|
||||
|
||||
{- 1 -}
|
||||
type DeleteUser = { user_id :: Maybe Int }
|
||||
codecDeleteUser ∷ CA.JsonCodec DeleteUser
|
||||
codecDeleteUser = CA.object "DeleteUser" (CAR.record { user_id: CAR.optional CA.int })
|
||||
|
||||
{- 6 -}
|
||||
type GetOrphanDomains = { }
|
||||
codecGetOrphanDomains ∷ CA.JsonCodec GetOrphanDomains
|
||||
codecGetOrphanDomains = CA.object "GetOrphanDomains" (CAR.record { })
|
||||
|
||||
{- 7 -}
|
||||
type Maintenance = { subject :: MaintenanceSubject.MaintenanceSubject
|
||||
, int :: Maybe Int
|
||||
, string :: Maybe String
|
||||
}
|
||||
codecMaintenance ∷ CA.JsonCodec Maintenance
|
||||
codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec
|
||||
, int: CAR.optional CA.int
|
||||
, string: CAR.optional CA.string
|
||||
})
|
||||
|
||||
{- 9 -}
|
||||
type NewDomain = { domain :: String }
|
||||
codecNewDomain ∷ CA.JsonCodec NewDomain
|
||||
codecNewDomain = CA.object "NewDomain" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 10 -}
|
||||
type DeleteDomain = { domain :: String }
|
||||
codecDeleteDomain ∷ CA.JsonCodec DeleteDomain
|
||||
codecDeleteDomain = CA.object "DeleteDomain" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 11 -}
|
||||
type AddOrUpdateZone = { zone :: DNSZone.DNSZone }
|
||||
codecAddOrUpdateZone ∷ CA.JsonCodec AddOrUpdateZone
|
||||
codecAddOrUpdateZone = CA.object "AddOrUpdateZone" (CAR.record { zone: DNSZone.codec })
|
||||
|
||||
{- 12 -}
|
||||
type GetZone = { domain :: String }
|
||||
codecGetZone ∷ CA.JsonCodec GetZone
|
||||
codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 13 -}
|
||||
type UserDomains = {}
|
||||
codecUserDomains ∷ CA.JsonCodec UserDomains
|
||||
codecUserDomains = CA.object "UserDomains" (CAR.record {})
|
||||
|
||||
{- 14 -}
|
||||
type AddRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
||||
codecAddRR ∷ CA.JsonCodec AddRR
|
||||
codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
||||
|
||||
{- 15 -}
|
||||
type UpdateRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
||||
codecUpdateRR ∷ CA.JsonCodec UpdateRR
|
||||
codecUpdateRR = CA.object "UpdateRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
||||
|
||||
{- 16 -}
|
||||
type DeleteRR = { domain :: String, rrid :: Int }
|
||||
codecDeleteRR ∷ CA.JsonCodec DeleteRR
|
||||
codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int })
|
||||
|
||||
{- 17 -}
|
||||
type AskGeneratedZoneFile = { domain :: String }
|
||||
codecAskGeneratedZoneFile ∷ CA.JsonCodec AskGeneratedZoneFile
|
||||
codecAskGeneratedZoneFile = CA.object "AskGeneratedZoneFile" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 18 -}
|
||||
type NewToken = { domain :: String, rrid :: Int }
|
||||
codecNewToken ∷ CA.JsonCodec NewToken
|
||||
codecNewToken = CA.object "NewToken" (CAR.record { domain: CA.string, rrid: CA.int })
|
||||
|
||||
{- 100 -}
|
||||
type GenerateAllZoneFiles = {}
|
||||
codecGenerateAllZoneFiles ∷ CA.JsonCodec GenerateAllZoneFiles
|
||||
codecGenerateAllZoneFiles = CA.object "GenerateAllZoneFiles" (CAR.record {})
|
||||
|
||||
{- 101 -}
|
||||
type GenerateZoneFile = { domain :: String }
|
||||
codecGenerateZoneFile ∷ CA.JsonCodec GenerateZoneFile
|
||||
codecGenerateZoneFile = CA.object "GenerateZoneFile" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 250 -}
|
||||
type KeepAlive = { }
|
||||
codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
||||
codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
||||
|
||||
{-
|
||||
RESPONSES
|
||||
-}
|
||||
|
||||
{- 0 -}
|
||||
-- type Error = { reason :: String | Array(String) }
|
||||
type Error = { reason :: String }
|
||||
codecError ∷ CA.JsonCodec Error
|
||||
codecError = CA.object "Error" (CAR.record { reason: CA.string })
|
||||
|
||||
{- 1 -}
|
||||
type Success = { }
|
||||
codecSuccess ∷ CA.JsonCodec Success
|
||||
codecSuccess = CA.object "Success" (CAR.record { })
|
||||
|
||||
{- 2 -}
|
||||
type ErrorInvalidToken = { }
|
||||
codecErrorInvalidToken ∷ CA.JsonCodec ErrorInvalidToken
|
||||
codecErrorInvalidToken = CA.object "ErrorInvalidToken" (CAR.record { })
|
||||
|
||||
{- 3 -}
|
||||
type DomainAlreadyExists = { }
|
||||
codecDomainAlreadyExists ∷ CA.JsonCodec DomainAlreadyExists
|
||||
codecDomainAlreadyExists = CA.object "DomainAlreadyExists" (CAR.record { })
|
||||
|
||||
{- 4 -}
|
||||
type ErrorUserNotLogged = { }
|
||||
codecErrorUserNotLogged ∷ CA.JsonCodec ErrorUserNotLogged
|
||||
codecErrorUserNotLogged = CA.object "ErrorUserNotLogged" (CAR.record { })
|
||||
|
||||
{- 5 -}
|
||||
type DomainNotFound = { }
|
||||
codecDomainNotFound :: CA.JsonCodec DomainNotFound
|
||||
codecDomainNotFound = CA.object "DomainNotFound" (CAR.record { })
|
||||
|
||||
{- 6 -}
|
||||
type RRNotFound = { }
|
||||
codecRRNotFound :: CA.JsonCodec RRNotFound
|
||||
codecRRNotFound = CA.object "RRNotFound" (CAR.record { })
|
||||
|
||||
{- 7 -}
|
||||
type UnacceptableDomain = { }
|
||||
codecUnacceptableDomain :: CA.JsonCodec UnacceptableDomain
|
||||
codecUnacceptableDomain = CA.object "UnacceptableDomain" (CAR.record { })
|
||||
|
||||
{- 8 -}
|
||||
type InvalidDomainName = { }
|
||||
codecInvalidDomainName :: CA.JsonCodec InvalidDomainName
|
||||
codecInvalidDomainName = CA.object "InvalidDomainName" (CAR.record { })
|
||||
|
||||
{- 9 -}
|
||||
type DomainDeleted = { domain :: String }
|
||||
codecDomainDeleted :: CA.JsonCodec DomainDeleted
|
||||
codecDomainDeleted = CA.object "DomainDeleted" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 10 -}
|
||||
-- For now, Error is just an alias on String.
|
||||
-- type InvalidZone = { errors : Array(Storage::Zone::Error) }
|
||||
type InvalidZone = { errors :: Array String }
|
||||
codecInvalidZone ∷ CA.JsonCodec InvalidZone
|
||||
codecInvalidZone = CA.object "InvalidZone" (CAR.record { errors: CA.array CA.string })
|
||||
|
||||
{- 11 -}
|
||||
type DomainChanged = { }
|
||||
codecDomainChanged ∷ CA.JsonCodec DomainChanged
|
||||
codecDomainChanged = CA.object "DomainChanged" (CAR.record { })
|
||||
|
||||
{- 12 -}
|
||||
type Zone = { zone :: DNSZone.DNSZone }
|
||||
codecZone ∷ CA.JsonCodec Zone
|
||||
codecZone = CA.object "Zone" (CAR.record { zone: DNSZone.codec })
|
||||
|
||||
{- 13 -}
|
||||
type UnknownZone = { }
|
||||
codecUnknownZone ∷ CA.JsonCodec UnknownZone
|
||||
codecUnknownZone = CA.object "UnknownZone" (CAR.record { })
|
||||
|
||||
{- 14 -}
|
||||
type DomainList = { domains :: Array String }
|
||||
codecDomainList ∷ CA.JsonCodec DomainList
|
||||
codecDomainList = CA.object "DomainList" (CAR.record { domains: CA.array CA.string })
|
||||
|
||||
{- 15 -}
|
||||
type AcceptedDomains = { domains :: Array String }
|
||||
codecAcceptedDomains ∷ CA.JsonCodec AcceptedDomains
|
||||
codecAcceptedDomains = CA.object "AcceptedDomains" (CAR.record { domains: CA.array CA.string })
|
||||
|
||||
{- 16 -}
|
||||
type Logged = { accepted_domains :: Array String, my_domains :: Array String }
|
||||
codecLogged ∷ CA.JsonCodec Logged
|
||||
codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string
|
||||
, my_domains: CA.array CA.string })
|
||||
|
||||
{- 17 -}
|
||||
type DomainAdded = { domain :: String }
|
||||
codecDomainAdded ∷ CA.JsonCodec DomainAdded
|
||||
codecDomainAdded = CA.object "DomainAdded" (CAR.record { domain: CA.string })
|
||||
|
||||
{- 18 -}
|
||||
type RRDeleted = { rrid :: Int }
|
||||
codecRRDeleted ∷ CA.JsonCodec RRDeleted
|
||||
codecRRDeleted = CA.object "RRDeleted" (CAR.record { rrid: CA.int })
|
||||
|
||||
{- 19 -}
|
||||
type RRAdded = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
||||
codecRRAdded ∷ CA.JsonCodec RRAdded
|
||||
codecRRAdded = CA.object "RRAdded" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
||||
|
||||
{- 20 -}
|
||||
-- For now, Error is just an alias on String.
|
||||
-- type InvalidZone = { errors : Array(Storage::Zone::Error) }
|
||||
type InvalidRR = { errors :: Array String }
|
||||
codecInvalidRR ∷ CA.JsonCodec InvalidRR
|
||||
codecInvalidRR = CA.object "InvalidRR" (CAR.record { errors: CA.array CA.string })
|
||||
|
||||
{- 21 -}
|
||||
type RRUpdated = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
||||
codecRRUpdated ∷ CA.JsonCodec RRUpdated
|
||||
codecRRUpdated = CA.object "RRUpdated" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
||||
|
||||
{- 22 -}
|
||||
type RRReadOnly = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
||||
codecRRReadOnly ∷ CA.JsonCodec RRReadOnly
|
||||
codecRRReadOnly = CA.object "RRReadOnly" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
||||
|
||||
{- 23 -}
|
||||
type GeneratedZoneFile = { domain :: String, zonefile :: String }
|
||||
codecGeneratedZoneFile ∷ CA.JsonCodec GeneratedZoneFile
|
||||
codecGeneratedZoneFile = CA.object "GeneratedZoneFile" (CAR.record { domain: CA.string, zonefile: CA.string })
|
||||
|
||||
{- 24 -}
|
||||
type OrphanDomainList = { domains :: Array String }
|
||||
codecOrphanDomainList ∷ CA.JsonCodec OrphanDomainList
|
||||
codecOrphanDomainList = CA.object "OrphanDomainList" (CAR.record { domains: CA.array CA.string })
|
||||
|
||||
{- 50 -}
|
||||
type UnknownUser = { }
|
||||
codecUnknownUser ∷ CA.JsonCodec UnknownUser
|
||||
codecUnknownUser = CA.object "UnknownUser" (CAR.record { })
|
||||
|
||||
{- 51 -}
|
||||
type NoOwnership = { }
|
||||
codecNoOwnership ∷ CA.JsonCodec NoOwnership
|
||||
codecNoOwnership = CA.object "NoOwnership" (CAR.record { })
|
||||
|
||||
{- 52 -}
|
||||
type InsufficientRights = { }
|
||||
codecInsufficientRights ∷ CA.JsonCodec InsufficientRights
|
||||
codecInsufficientRights = CA.object "InsufficientRights" (CAR.record { })
|
||||
|
||||
{- 250 -}
|
||||
--type KeepAlive = { }
|
||||
--codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
||||
--codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
||||
|
||||
|
||||
-- All possible requests.
|
||||
data RequestMessage
|
||||
= MkLogin Login -- 0
|
||||
| MkDeleteUser DeleteUser -- 1
|
||||
| MkGetOrphanDomains GetOrphanDomains -- 6
|
||||
| MkMaintenance Maintenance -- 7
|
||||
| MkNewDomain NewDomain -- 9
|
||||
| MkDeleteDomain DeleteDomain -- 10
|
||||
| MkAddOrUpdateZone AddOrUpdateZone -- 11
|
||||
| MkGetZone GetZone -- 12
|
||||
| MkUserDomains UserDomains -- 13
|
||||
| MkAddRR AddRR -- 14
|
||||
| MkUpdateRR UpdateRR -- 15
|
||||
| MkDeleteRR DeleteRR -- 16
|
||||
| MkAskGeneratedZoneFile AskGeneratedZoneFile -- 17
|
||||
| MkNewToken NewToken -- 18
|
||||
--| MkUseToken UseToken -- 19
|
||||
| MkGenerateAllZoneFiles GenerateAllZoneFiles -- 100
|
||||
| MkGenerateZoneFile GenerateZoneFile -- 101
|
||||
| MkKeepAlive KeepAlive -- 250
|
||||
|
||||
-- All possible answers from the authentication daemon (authd).
|
||||
data AnswerMessage
|
||||
= MkError Error -- 0
|
||||
| MkSuccess Success -- 1
|
||||
| MkErrorInvalidToken ErrorInvalidToken -- 2
|
||||
| MkDomainAlreadyExists DomainAlreadyExists -- 3
|
||||
| MkErrorUserNotLogged ErrorUserNotLogged -- 4
|
||||
| MkDomainNotFound DomainNotFound -- 5
|
||||
| MkRRNotFound RRNotFound -- 6
|
||||
| MkUnacceptableDomain UnacceptableDomain -- 7
|
||||
| MkInvalidDomainName InvalidDomainName -- 8
|
||||
| MkDomainDeleted DomainDeleted -- 9
|
||||
| MkInvalidZone InvalidZone -- 10
|
||||
| MkDomainChanged DomainChanged -- 11
|
||||
| MkZone Zone -- 12
|
||||
| MkUnknownZone UnknownZone -- 13
|
||||
| MkDomainList DomainList -- 14
|
||||
| MkAcceptedDomains AcceptedDomains -- 15
|
||||
| MkLogged Logged -- 16
|
||||
| MkDomainAdded DomainAdded -- 17
|
||||
| MkRRDeleted RRDeleted -- 18
|
||||
| MkRRAdded RRAdded -- 19
|
||||
| MkInvalidRR InvalidRR -- 20
|
||||
| MkRRUpdated RRUpdated -- 21
|
||||
| MkRRReadOnly RRReadOnly -- 22
|
||||
| MkGeneratedZoneFile GeneratedZoneFile -- 23
|
||||
| MkOrphanDomainList OrphanDomainList -- 24
|
||||
| MkUnknownUser UnknownUser -- 50
|
||||
| MkNoOwnership NoOwnership -- 51
|
||||
| MkInsufficientRights InsufficientRights -- 52
|
||||
| GotKeepAlive KeepAlive -- 250
|
||||
|
||||
encode ∷ RequestMessage -> Tuple UInt String
|
||||
encode m = case m of
|
||||
(MkLogin request) -> get_tuple 0 codecLogin request
|
||||
(MkDeleteUser request) -> get_tuple 1 codecDeleteUser request
|
||||
(MkGetOrphanDomains request) -> get_tuple 6 codecGetOrphanDomains request
|
||||
(MkMaintenance request) -> get_tuple 7 codecMaintenance request
|
||||
(MkNewDomain request) -> get_tuple 9 codecNewDomain request
|
||||
(MkDeleteDomain request) -> get_tuple 10 codecDeleteDomain request
|
||||
(MkAddOrUpdateZone request) -> get_tuple 11 codecAddOrUpdateZone request
|
||||
(MkGetZone request) -> get_tuple 12 codecGetZone request
|
||||
(MkUserDomains request) -> get_tuple 13 codecUserDomains request
|
||||
(MkAddRR request) -> get_tuple 14 codecAddRR request
|
||||
(MkUpdateRR request) -> get_tuple 15 codecUpdateRR request
|
||||
(MkDeleteRR request) -> get_tuple 16 codecDeleteRR request
|
||||
(MkAskGeneratedZoneFile request) -> get_tuple 17 codecAskGeneratedZoneFile request
|
||||
(MkNewToken request) -> get_tuple 18 codecNewToken request
|
||||
--(MkUseToken request) -> get_tuple 19 codecUseToken request
|
||||
(MkGenerateAllZoneFiles request) -> get_tuple 100 codecGenerateAllZoneFiles request
|
||||
(MkGenerateZoneFile request) -> get_tuple 101 codecGenerateZoneFile request
|
||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
||||
where
|
||||
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
|
||||
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
|
||||
|
||||
data DecodeError
|
||||
= JSONERROR String
|
||||
| UnknownError String
|
||||
| UnknownNumber
|
||||
|
||||
decode :: Int -> String -> Either DecodeError AnswerMessage
|
||||
decode number string
|
||||
= case number of
|
||||
0 -> error_management codecError MkError
|
||||
1 -> error_management codecSuccess MkSuccess
|
||||
2 -> error_management codecErrorInvalidToken MkErrorInvalidToken
|
||||
3 -> error_management codecDomainAlreadyExists MkDomainAlreadyExists
|
||||
4 -> error_management codecErrorUserNotLogged MkErrorUserNotLogged
|
||||
5 -> error_management codecDomainNotFound MkDomainNotFound
|
||||
6 -> error_management codecRRNotFound MkRRNotFound
|
||||
7 -> error_management codecUnacceptableDomain MkUnacceptableDomain
|
||||
8 -> error_management codecInvalidDomainName MkInvalidDomainName
|
||||
9 -> error_management codecDomainDeleted MkDomainDeleted
|
||||
10 -> error_management codecInvalidZone MkInvalidZone
|
||||
11 -> error_management codecDomainChanged MkDomainChanged
|
||||
12 -> error_management codecZone MkZone
|
||||
13 -> error_management codecUnknownZone MkUnknownZone
|
||||
14 -> error_management codecDomainList MkDomainList
|
||||
15 -> error_management codecAcceptedDomains MkAcceptedDomains
|
||||
16 -> error_management codecLogged MkLogged
|
||||
17 -> error_management codecDomainAdded MkDomainAdded
|
||||
18 -> error_management codecRRDeleted MkRRDeleted
|
||||
19 -> error_management codecRRAdded MkRRAdded
|
||||
20 -> error_management codecInvalidRR MkInvalidRR
|
||||
21 -> error_management codecRRUpdated MkRRUpdated
|
||||
22 -> error_management codecRRReadOnly MkRRReadOnly
|
||||
23 -> error_management codecGeneratedZoneFile MkGeneratedZoneFile
|
||||
24 -> error_management codecOrphanDomainList MkOrphanDomainList
|
||||
50 -> error_management codecUnknownUser MkUnknownUser
|
||||
51 -> error_management codecNoOwnership MkNoOwnership
|
||||
52 -> error_management codecInsufficientRights MkInsufficientRights
|
||||
250 -> error_management codecKeepAlive GotKeepAlive
|
||||
_ -> Left UnknownNumber
|
||||
where
|
||||
-- Signature is required since the compiler's guess is wrong.
|
||||
error_management :: forall a. CA.JsonCodec a -> (a -> AnswerMessage) -> Either DecodeError AnswerMessage
|
||||
error_management codec f
|
||||
= case (parseDecodeJSON codec string) of
|
||||
(Left err) -> Left (JSONERROR err)
|
||||
(Right v) -> Right (f v)
|
||||
|
||||
parseDecodeJSON :: forall a. CA.JsonCodec a -> String -> Either String a
|
||||
parseDecodeJSON codec str = do
|
||||
json <- JSONParser.jsonParser str
|
||||
lmap CA.printJsonDecodeError (CA.decode codec json)
|
||||
|
||||
serialize :: RequestMessage -> Effect ArrayBuffer
|
||||
serialize request
|
||||
= case (encode request) of
|
||||
(Tuple messageTypeNumber string) -> IPC.toTypedIPC messageTypeNumber string
|
||||
|
||||
deserialize :: ArrayBuffer -> Effect (Either DecodeError AnswerMessage)
|
||||
deserialize arraybuffer
|
||||
= do
|
||||
value <- liftEffect $ IPC.fromTypedIPC arraybuffer
|
||||
pure $ case (value) of
|
||||
Left err -> Left (UnknownError $ show err)
|
||||
Right (Tuple messageTypeNumber string) -> case (decode (toInt messageTypeNumber) string) of
|
||||
Left parsingError -> Left parsingError
|
||||
Right answerMessage -> Right answerMessage
|
||||
102
src/App/Message/IPC.purs
Normal file
102
src/App/Message/IPC.purs
Normal file
@ -0,0 +1,102 @@
|
||||
module App.Message.IPC (toIPC, fromIPC, toTypedIPC, fromTypedIPC) where
|
||||
|
||||
{-
|
||||
This file contains raw serialization and deserialization of IPC messages.
|
||||
An IPC message can contain either the payload length followed by the content,
|
||||
or a 'type number' can be added between those values.
|
||||
|
||||
[payload length in bytes][payload]
|
||||
[payload length in bytes][message type][payload]
|
||||
|
||||
The message type informs what format should be expected.
|
||||
For example: an authentication attempt, a page request, etc.
|
||||
Actual message formats can be found in the App.Message folder.
|
||||
-}
|
||||
|
||||
import Prelude (bind, (<$>), discard, ($), (>>>), (+), (-))
|
||||
|
||||
import Effect (Effect)
|
||||
import Effect.Class (liftEffect)
|
||||
|
||||
import Data.UInt (fromInt, toInt, UInt)
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Data.ArrayBuffer.ArrayBuffer as ArrayBuffer
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer, DataView)
|
||||
import Data.ArrayBuffer.Builder as Builder
|
||||
|
||||
import Data.ArrayBuffer.Cast as Cast
|
||||
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Except (ExceptT(ExceptT), withExceptT)
|
||||
import Data.ArrayBuffer.Typed as Typed
|
||||
import Data.ArrayBuffer.DataView as DataView
|
||||
import Parsing.DataView as Parsing.DataView
|
||||
import Parsing as Parsing
|
||||
import Parsing (ParseError, ParserT, runParserT)
|
||||
|
||||
import Web.Encoding.TextEncoder as TextEncoder
|
||||
import Web.Encoding.TextDecoder as TextDecoder
|
||||
import Web.Encoding.UtfLabel as UtfLabel
|
||||
|
||||
import Data.Either (Either)
|
||||
import Effect.Exception as Exception
|
||||
|
||||
hoistEffectParserT
|
||||
:: forall a
|
||||
. Effect a
|
||||
-> ParserT DataView Effect a
|
||||
hoistEffectParserT
|
||||
= Exception.try
|
||||
>>> ExceptT
|
||||
>>> withExceptT Exception.message
|
||||
>>> Parsing.liftExceptT
|
||||
|
||||
toIPC :: String -> Effect ArrayBuffer
|
||||
toIPC s = Builder.execPutM do
|
||||
textEncoder <- liftEffect TextEncoder.new
|
||||
let stringbuf = Typed.buffer $ TextEncoder.encode s textEncoder
|
||||
-- Put a 32-bit big-endian length for the utf8 string, in bytes.
|
||||
Builder.putUint32be $ fromInt $ ArrayBuffer.byteLength stringbuf
|
||||
Builder.putArrayBuffer stringbuf
|
||||
|
||||
toTypedIPC :: UInt -> String -> Effect ArrayBuffer
|
||||
toTypedIPC n s = Builder.execPutM do
|
||||
textEncoder <- liftEffect TextEncoder.new
|
||||
let stringbuf = Typed.buffer $ TextEncoder.encode s textEncoder
|
||||
-- Put a 32-bit big-endian length for the utf8 string, in bytes.
|
||||
Builder.putUint32be $ fromInt $ (ArrayBuffer.byteLength stringbuf) + 1 -- 1 for message type
|
||||
Builder.putUint8 n
|
||||
Builder.putArrayBuffer stringbuf
|
||||
|
||||
-- TODO: this code doesn't verify the actual length of the message.
|
||||
-- An inconsistent length would be an error sign, message should be discarded
|
||||
-- and the connection should be closed.
|
||||
fromIPC :: ArrayBuffer -> Effect (Either ParseError String)
|
||||
fromIPC arrayBuffer = do
|
||||
textDecoder <- TextDecoder.new UtfLabel.utf8
|
||||
let dataView = DataView.whole arrayBuffer
|
||||
runParserT dataView do
|
||||
-- First parse a 32-bit big-endian length prefix for the length
|
||||
-- of the UTF-8 string in bytes.
|
||||
length <- Parsing.DataView.anyUint32be
|
||||
stringview <- Parsing.DataView.takeN (toInt length)
|
||||
stringarray <- lift $ liftEffect $ Cast.toUint8Array stringview
|
||||
hoistEffectParserT $ TextDecoder.decode stringarray textDecoder
|
||||
|
||||
-- TODO: this code doesn't verify the actual length of the message.
|
||||
-- An inconsistent length would be an error sign, message should be discarded
|
||||
-- and the connection should be closed.
|
||||
fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
|
||||
fromTypedIPC arraybuffer = do
|
||||
textDecoder <- TextDecoder.new UtfLabel.utf8
|
||||
let dataView = DataView.whole arraybuffer
|
||||
runParserT dataView do
|
||||
-- First parse a 32-bit big-endian length prefix for the length
|
||||
-- of the UTF-8 string in bytes.
|
||||
length <- Parsing.DataView.anyUint32be
|
||||
-- Second parse a 8-bit unsigned integer representing the type of
|
||||
-- the message to decode.
|
||||
messageTypeNumber <- Parsing.DataView.anyUint8
|
||||
stringview <- Parsing.DataView.takeN ((toInt length) - 1)
|
||||
stringarray <- lift $ liftEffect $ Cast.toUint8Array stringview
|
||||
hoistEffectParserT $ (Tuple messageTypeNumber) <$> TextDecoder.decode stringarray textDecoder
|
||||
330
src/App/Page/Administration.purs
Normal file
330
src/App/Page/Administration.purs
Normal file
@ -0,0 +1,330 @@
|
||||
{- Administration interface.
|
||||
Allows to:
|
||||
- add, remove, search users
|
||||
- TODO: validate users
|
||||
- TODO: change user password
|
||||
- TODO: show user details (list of owned domains)
|
||||
- TODO: show user domain details (zone content) and to modify users' zone
|
||||
- TODO: raise a user to admin (and vice versa)
|
||||
- TODO: list users (getting them slowly, otherwise it will cause problems with thousands of logins)
|
||||
-}
|
||||
module App.Page.Administration where
|
||||
|
||||
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==))
|
||||
import Data.Eq (class Eq)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Array as A
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event (Event)
|
||||
import Web.Event.Event as Event
|
||||
|
||||
import CSSClasses as C
|
||||
|
||||
import Web.HTML (window) as HTML
|
||||
import Web.HTML.Window (sessionStorage) as Window
|
||||
import Web.Storage.Storage as Storage
|
||||
|
||||
import App.Type.UserPublic (UserPublic)
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
|
||||
import App.Type.LogMessage
|
||||
-- import App.IPC as IPC
|
||||
import App.Type.Email as Email
|
||||
|
||||
-- import App.Message.DNSManagerDaemon as DNSManager
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| Log LogMessage
|
||||
| AskState
|
||||
| StoreState State
|
||||
| DeleteUserAccount Int
|
||||
| GetOrphanDomains
|
||||
|
||||
--| DeleteDomain String
|
||||
--| RequestDomain String
|
||||
|
||||
data Query a
|
||||
= MessageReceived AuthD.AnswerMessage a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
| GotOrphanDomainList (Array String) a
|
||||
| ProvideState (Maybe State) a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
data AddUserInput
|
||||
= ADDUSER_INP_login String
|
||||
| ADDUSER_INP_email String
|
||||
| ADDUSER_toggle_admin
|
||||
| ADDUSER_INP_pass String
|
||||
| SEARCHUSER_INP_regex String
|
||||
--| SEARCHUSER_INP_domain String
|
||||
|
||||
data Action
|
||||
= HandleAddUserInput AddUserInput
|
||||
|
||||
| AddUserAttempt
|
||||
| SearchUserAttempt
|
||||
| PreventSubmit Event
|
||||
|
||||
| ShowUser Int
|
||||
| RemoveUser Int
|
||||
|
||||
-- Domains.
|
||||
| ShowOrphanDomains
|
||||
| RemoveDomain String
|
||||
| ShowDomain String
|
||||
|
||||
-- | Change the displayed tab.
|
||||
| ChangeTab Tab
|
||||
|
||||
| Initialize
|
||||
| Finalize
|
||||
|
||||
-- | There are different tabs in the administration page.
|
||||
-- | For example, users can be searched (`authd`) and a list is provided.
|
||||
data Tab = Home | Search | Add | OrphanDomains
|
||||
derive instance eqTab :: Eq Tab
|
||||
|
||||
type StateAddUserForm = { login :: String, admin :: Boolean, email :: String, pass :: String }
|
||||
type StateSearchUserForm = { regex :: String {-, admin :: Boolean, domain :: String -} }
|
||||
|
||||
type State =
|
||||
{ addUserForm :: StateAddUserForm
|
||||
, searchUserForm :: StateSearchUserForm
|
||||
, current_tab :: Tab
|
||||
, wsUp :: Boolean
|
||||
, matching_users :: Array UserPublic
|
||||
, orphan_domains :: Array String
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ initialize = Just Initialize
|
||||
, handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
, finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "" }
|
||||
, searchUserForm: { regex: "" {-, admin: false, domain: "" -} }
|
||||
, matching_users: []
|
||||
, orphan_domains: []
|
||||
, current_tab: Home
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domains, wsUp }
|
||||
= Bulma.section_small
|
||||
[ fancy_tab_bar
|
||||
, case current_tab of
|
||||
Home -> Bulma.h3 "Select an action"
|
||||
Search -> Bulma.columns_
|
||||
[ Bulma.column (C.is 3) [Bulma.article (Bulma.p "Search users") render_searchuser_form]
|
||||
, Bulma.column_ [ Bulma.h3 "Result", show_found_users ]
|
||||
]
|
||||
Add -> Bulma.columns_
|
||||
[ Bulma.column (C.is 5) [Bulma.article (Bulma.p "Add a new user") render_adduser_form] ]
|
||||
OrphanDomains -> HH.div_
|
||||
[ Bulma.btn_ (C.is_small) "Get orphan domains" ShowOrphanDomains
|
||||
, show_orphan_domains
|
||||
]
|
||||
]
|
||||
where
|
||||
fancy_tab_bar =
|
||||
Bulma.fancy_tabs
|
||||
[ Bulma.tab_entry (is_tab_active Home) "Home" (ChangeTab Home)
|
||||
, Bulma.tab_entry (is_tab_active Search) "Search" (ChangeTab Search)
|
||||
, Bulma.tab_entry (is_tab_active Add) "Add" (ChangeTab Add)
|
||||
, Bulma.tab_entry (is_tab_active OrphanDomains) "OrphanDomains" (ChangeTab OrphanDomains)
|
||||
]
|
||||
is_tab_active tab = current_tab == tab
|
||||
|
||||
show_found_users = Bulma.box [ HH.ul_ $ map user_card matching_users ]
|
||||
user_card user = HH.li_ [ Bulma.btn_delete (RemoveUser user.uid)
|
||||
, Bulma.btn_ (C.is_small) user.login (ShowUser user.uid)
|
||||
]
|
||||
show_orphan_domains = Bulma.box [ HH.ul_ $ map domain_entry orphan_domains ]
|
||||
domain_entry domain = HH.li_ [ Bulma.btn_delete (RemoveDomain domain)
|
||||
, Bulma.btn_ (C.is_small) domain (ShowDomain domain)
|
||||
]
|
||||
up x = HandleAddUserInput <<< x
|
||||
active = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_adduser_form =
|
||||
HH.form
|
||||
[ HE.onSubmit PreventSubmit ]
|
||||
[ Bulma.box_input "login" "User login" "login" (up ADDUSER_INP_login) addUserForm.login active
|
||||
, Bulma.btn_labeled "adminbtn" "Admin" (show addUserForm.admin) (HandleAddUserInput ADDUSER_toggle_admin)
|
||||
, Bulma.box_input "email" "User email" "email" (up ADDUSER_INP_email) addUserForm.email active
|
||||
, Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass active
|
||||
, Bulma.btn "Send" AddUserAttempt
|
||||
]
|
||||
|
||||
render_searchuser_form =
|
||||
HH.form
|
||||
[ HE.onSubmit PreventSubmit ]
|
||||
[ Bulma.p """
|
||||
Following input accepts any regex.
|
||||
This will be used to search an user based on his login, full name or email address.
|
||||
"""
|
||||
, Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex active
|
||||
--, Bulma.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin)
|
||||
-- (HandleAddUserInput SEARCHUSER_toggle_admin)
|
||||
--, Bulma.box_input "domain" "Domain owned" "blah.netlib.re."
|
||||
-- (up SEARCHUSER_INP_domain) searchUserForm.domain active
|
||||
, Bulma.btn "Send" SearchUserAttempt
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
Initialize -> do
|
||||
H.raise $ AskState
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
old_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage
|
||||
case old_tab of
|
||||
Nothing -> H.raise $ Log $ ErrorLog "We hadn't changed tab before reload apparently."
|
||||
Just current_tab -> case current_tab of
|
||||
"Home" -> handleAction $ ChangeTab Home
|
||||
"Search" -> handleAction $ ChangeTab Search
|
||||
"Add" -> handleAction $ ChangeTab Add
|
||||
"OrphanDomains" -> handleAction $ ChangeTab OrphanDomains
|
||||
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
|
||||
|
||||
Finalize -> do
|
||||
state <- H.get
|
||||
H.raise $ StoreState state
|
||||
|
||||
HandleAddUserInput adduserinp -> do
|
||||
{ addUserForm } <- H.get
|
||||
case adduserinp of
|
||||
ADDUSER_INP_login v -> H.modify_ _ { addUserForm { login = v } }
|
||||
ADDUSER_INP_email v -> H.modify_ _ { addUserForm { email = v } }
|
||||
ADDUSER_toggle_admin -> H.modify_ _ { addUserForm { admin = not addUserForm.admin } }
|
||||
ADDUSER_INP_pass v -> H.modify_ _ { addUserForm { pass = v } }
|
||||
SEARCHUSER_INP_regex v -> H.modify_ _ { searchUserForm { regex = v } }
|
||||
|
||||
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
ShowUser uid -> do
|
||||
H.raise $ Log $ SystemLog $ "Show a user details (uid: " <> show uid <> ")"
|
||||
|
||||
ShowOrphanDomains -> do
|
||||
H.raise $ Log $ SystemLog $ "Get orphan domains"
|
||||
H.raise $ GetOrphanDomains
|
||||
|
||||
RemoveUser uid -> do
|
||||
H.raise $ Log $ SystemLog $ "Remove user " <> show uid
|
||||
H.raise $ DeleteUserAccount uid
|
||||
|
||||
RemoveDomain domain -> do
|
||||
H.raise $ Log $ SystemLog $ "TODO: remove domain " <> domain
|
||||
--H.raise $ DeleteDomain domain
|
||||
|
||||
ShowDomain domain -> do
|
||||
H.raise $ Log $ SystemLog $ "TODO: show domain " <> domain
|
||||
-- H.raise $ RequestDomain domain
|
||||
|
||||
AddUserAttempt -> do
|
||||
{ addUserForm } <- H.get
|
||||
let login = addUserForm.login
|
||||
email = addUserForm.email
|
||||
pass = addUserForm.pass
|
||||
|
||||
case login, email, pass of
|
||||
"", _, _ -> H.raise $ Log $ UnableToSend "Write the user's login!"
|
||||
_, "", _ -> H.raise $ Log $ UnableToSend "Write the user's email!"
|
||||
_, _, "" -> H.raise $ Log $ UnableToSend "Write the user's password!"
|
||||
|
||||
_, _, _ -> do
|
||||
ab <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkAddUser { login: login
|
||||
, admin: addUserForm.admin
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass }
|
||||
H.raise $ MessageToSend ab
|
||||
H.raise $ Log $ SystemLog "Add a user"
|
||||
|
||||
ChangeTab current_tab -> do
|
||||
-- Store the current tab we are on and restore it when we reload.
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- case current_tab of
|
||||
Home -> H.liftEffect $ Storage.setItem "current-ada-tab" "Home" sessionstorage
|
||||
Search -> H.liftEffect $ Storage.setItem "current-ada-tab" "Search" sessionstorage
|
||||
Add -> H.liftEffect $ Storage.setItem "current-ada-tab" "Add" sessionstorage
|
||||
OrphanDomains -> H.liftEffect $ Storage.setItem "current-ada-tab" "OrphanDomains" sessionstorage
|
||||
H.modify_ _ { current_tab = current_tab }
|
||||
|
||||
SearchUserAttempt -> do
|
||||
{ searchUserForm } <- H.get
|
||||
let regex = searchUserForm.regex
|
||||
-- domain = searchUserForm.domain
|
||||
-- admin = searchUserForm.admin
|
||||
ab <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 }
|
||||
H.raise $ MessageToSend ab
|
||||
H.modify_ _ { matching_users = [] }
|
||||
|
||||
not_empty_string :: String -> Maybe String
|
||||
not_empty_string "" = Nothing
|
||||
not_empty_string v = Just v
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
|
||||
ProvideState maybe_state a -> do
|
||||
case maybe_state of
|
||||
Nothing -> pure Nothing
|
||||
Just s -> do
|
||||
H.put s
|
||||
pure (Just a)
|
||||
|
||||
MessageReceived message a -> do
|
||||
case message of
|
||||
(AuthD.GotUserAdded msg) -> do
|
||||
H.raise $ Log $ SuccessLog $ "Added user: " <> show msg.user
|
||||
|
||||
(AuthD.GotMatchingUsers msg) -> do
|
||||
H.raise $ Log $ SuccessLog "Got list of matched users."
|
||||
H.modify_ _ { matching_users = msg.users }
|
||||
|
||||
(AuthD.GotUserDeleted msg) -> do
|
||||
H.raise $ Log $ SuccessLog $ "User (uid: " <> show msg.uid <> ") got removed."
|
||||
{ matching_users } <- H.get
|
||||
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
|
||||
|
||||
-- Unexpected message.
|
||||
_ -> do
|
||||
H.raise $ Log $ ErrorLog $ "Authentication server didn't send a valid message."
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
|
||||
GotOrphanDomainList domains a -> do
|
||||
H.raise $ Log $ SuccessLog "Got orphan domain list!"
|
||||
H.modify_ _ { orphan_domains = domains }
|
||||
pure (Just a)
|
||||
342
src/App/Page/Authentication.purs
Normal file
342
src/App/Page/Authentication.purs
Normal file
@ -0,0 +1,342 @@
|
||||
-- | `App.AuthenticationInterface` is both the authentication and password recovery interface.
|
||||
-- | TODO: token validation.
|
||||
module App.Page.Authentication where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (>), (==), map, show)
|
||||
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.Type.LogMessage
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
import App.Validation.Login as L
|
||||
import App.Validation.Email as E
|
||||
import App.Validation.Password as P
|
||||
|
||||
type Login = String
|
||||
type Email = String
|
||||
type Password = String
|
||||
type PasswordRecoveryToken = String
|
||||
|
||||
data Error
|
||||
= Login (Array L.Error)
|
||||
| Email (Array E.Error)
|
||||
| Password (Array P.Error)
|
||||
|
||||
-- | The component can inform the parent (`App.Container`) that the authentication is complete,
|
||||
-- | and share both the uid and token. The token is useful to authenticate the user to the
|
||||
-- | dnsmanager daemon.
|
||||
-- |
|
||||
-- | Also, the component can send a message to a websocket and log messages.
|
||||
-- |
|
||||
-- | TODO: authentication is performed in `App.Container`.
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| AuthenticateToAuthd (Tuple Login Password)
|
||||
| Log LogMessage
|
||||
| PasswordRecovery Login PasswordRecoveryToken Password
|
||||
| AskPasswordRecovery (Either Email Login)
|
||||
|
||||
-- | The component's parent provides received messages.
|
||||
-- |
|
||||
-- | Also, the component is informed when the connection went up or down.
|
||||
data Query a
|
||||
= MessageReceived AuthD.AnswerMessage a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
data AuthenticationInput
|
||||
= AUTH_INP_login String
|
||||
| AUTH_INP_pass String
|
||||
|
||||
data PasswordRecoveryInput
|
||||
= PASSR_INP_login String
|
||||
| PASSR_INP_email String
|
||||
|
||||
data NewPasswordInput
|
||||
= NEWPASS_INP_login String
|
||||
| NEWPASS_INP_token String
|
||||
| NEWPASS_INP_password String
|
||||
| NEWPASS_INP_confirmation String
|
||||
|
||||
data Action
|
||||
= HandleAuthenticationInput AuthenticationInput
|
||||
| HandlePasswordRecovery PasswordRecoveryInput
|
||||
| HandleNewPassword NewPasswordInput
|
||||
--
|
||||
| AuthenticationAttempt Event
|
||||
| PasswordRecoveryAttempt Event
|
||||
| NewPasswordAttempt Event
|
||||
|
||||
type StateAuthenticationForm = { login :: String, pass :: String }
|
||||
type StatePasswordRecoveryForm = { login :: String, email :: String }
|
||||
type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String }
|
||||
|
||||
type State =
|
||||
{ authenticationForm :: StateAuthenticationForm
|
||||
, passwordRecoveryForm :: StatePasswordRecoveryForm
|
||||
, newPasswordForm :: StateNewPasswordForm
|
||||
, errors :: Array Error
|
||||
, wsUp :: Boolean
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ authenticationForm: { login: "", pass: "" }
|
||||
, passwordRecoveryForm: { login: "", email: "" }
|
||||
, newPasswordForm: { login: "", token: "", password: "", confirmation: "" }
|
||||
, wsUp: true
|
||||
, errors: []
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
|
||||
Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true ->
|
||||
if A.length errors > 0
|
||||
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ]
|
||||
, Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
||||
]
|
||||
else Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
|
||||
show_error :: Error -> String
|
||||
show_error = case _ of
|
||||
Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr)
|
||||
Email arr -> "Error with the Email: " <> (A.fold $ map show_error_email arr)
|
||||
Password arr -> "Error with the Password: " <> (A.fold $ map show_error_password arr)
|
||||
|
||||
show_error_login :: L.Error -> String
|
||||
show_error_login = case _ of
|
||||
L.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_login error
|
||||
|
||||
string_error_login :: L.LoginParsingError -> String
|
||||
string_error_login = case _ of
|
||||
L.CannotParse -> "cannot parse the login"
|
||||
L.CannotEntirelyParse -> "cannot entirely parse the login"
|
||||
L.Size min max n -> "login size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
show_error_email :: E.Error -> String
|
||||
show_error_email = case _ of
|
||||
E.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_email error
|
||||
|
||||
string_error_email :: E.EmailParsingError -> String
|
||||
string_error_email = case _ of
|
||||
E.CannotParse -> "cannot parse the email"
|
||||
E.CannotEntirelyParse -> "cannot entirely parse the email"
|
||||
E.Size min max n -> "email size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
show_error_password :: P.Error -> String
|
||||
show_error_password = case _ of
|
||||
P.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_password error
|
||||
|
||||
string_error_password :: P.PasswordParsingError -> String
|
||||
string_error_password = case _ of
|
||||
P.CannotParse -> "cannot parse the password"
|
||||
P.CannotEntirelyParse -> "cannot entirely parse the password"
|
||||
P.Size min max n -> "password size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
auth_form = [ Bulma.h3 "Authentication" , render_auth_form ]
|
||||
passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
|
||||
newpass_form = [ Bulma.h3 "New password", render_new_password_form ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_auth_form = HH.form
|
||||
[ HE.onSubmit AuthenticationAttempt ]
|
||||
[ Bulma.box_input "loginLOGIN" "Login" "login" -- title, placeholder
|
||||
(HandleAuthenticationInput <<< AUTH_INP_login) -- action
|
||||
authenticationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_password "passwordLOGIN" "Password" "password" -- title, placeholder
|
||||
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action
|
||||
authenticationForm.pass -- value
|
||||
should_be_disabled -- condition
|
||||
, HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
|
||||
render_password_recovery_form = HH.form
|
||||
[ HE.onSubmit PasswordRecoveryAttempt ]
|
||||
[ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder
|
||||
(HandlePasswordRecovery <<< PASSR_INP_login) -- action
|
||||
passwordRecoveryForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "emailPASSR" "Email" "email" -- title, placeholder
|
||||
(HandlePasswordRecovery <<< PASSR_INP_email) -- action
|
||||
passwordRecoveryForm.email -- value
|
||||
should_be_disabled -- condition
|
||||
, HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
|
||||
render_new_password_form = HH.form
|
||||
[ HE.onSubmit NewPasswordAttempt ]
|
||||
[ Bulma.box_input "loginNEWPASS" "Login" "login"
|
||||
(HandleNewPassword <<< NEWPASS_INP_login)
|
||||
newPasswordForm.login
|
||||
should_be_disabled
|
||||
, Bulma.box_input "tokenNEWPASS" "Token" "token"
|
||||
(HandleNewPassword <<< NEWPASS_INP_token)
|
||||
newPasswordForm.token
|
||||
should_be_disabled
|
||||
, Bulma.box_password "passwordNEWPASS" "Password" "password"
|
||||
(HandleNewPassword <<< NEWPASS_INP_password)
|
||||
newPasswordForm.password
|
||||
should_be_disabled
|
||||
, Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation"
|
||||
(HandleNewPassword <<< NEWPASS_INP_confirmation)
|
||||
newPasswordForm.confirmation
|
||||
should_be_disabled
|
||||
, HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
HandleAuthenticationInput authinp -> do
|
||||
case authinp of
|
||||
AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
|
||||
AUTH_INP_pass v -> H.modify_ _ { authenticationForm { pass = v } }
|
||||
|
||||
HandlePasswordRecovery passrecovinp -> do
|
||||
case passrecovinp of
|
||||
PASSR_INP_login v -> H.modify_ _ { passwordRecoveryForm { login = v } }
|
||||
PASSR_INP_email v -> H.modify_ _ { passwordRecoveryForm { email = v } }
|
||||
|
||||
HandleNewPassword newpassinp -> do
|
||||
case newpassinp of
|
||||
NEWPASS_INP_login v -> H.modify_ _ { newPasswordForm { login = v } }
|
||||
NEWPASS_INP_token v -> H.modify_ _ { newPasswordForm { token = v } }
|
||||
NEWPASS_INP_password v -> H.modify_ _ { newPasswordForm { password = v } }
|
||||
NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } }
|
||||
|
||||
AuthenticationAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ authenticationForm } <- H.get
|
||||
let { login, pass } = authenticationForm
|
||||
|
||||
case login, pass of
|
||||
"" , _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your login!"
|
||||
|
||||
_ , "" ->
|
||||
H.raise $ Log $ UnableToSend "Write your password!"
|
||||
|
||||
_, _ -> do
|
||||
case L.login login, P.password pass of
|
||||
Left errors, _ -> H.modify_ _ { errors = [ Login errors ] }
|
||||
_, Left errors -> H.modify_ _ { errors = [ Password errors ] }
|
||||
_, _ -> do H.modify_ _ { errors = [] }
|
||||
H.raise $ AuthenticateToAuthd (Tuple login pass)
|
||||
H.raise $ Log $ SystemLog $ "authenticate (login: " <> login <> ")"
|
||||
|
||||
PasswordRecoveryAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ passwordRecoveryForm } <- H.get
|
||||
let login = passwordRecoveryForm.login
|
||||
email = passwordRecoveryForm.email
|
||||
|
||||
case login, email of
|
||||
"", "" -> H.raise $ Log $ UnableToSend "Write your login or your email!"
|
||||
_, _ -> do
|
||||
H.raise $ Log $ SystemLog "password recovery"
|
||||
if email == ""
|
||||
then case L.login login of
|
||||
Left errors -> H.modify_ _ { errors = [ Login errors ] }
|
||||
_ -> do H.modify_ _ { errors = [] }
|
||||
H.raise $ AskPasswordRecovery (Right login)
|
||||
else case E.email email of
|
||||
Left errors -> H.modify_ _ { errors = [ Email errors ] }
|
||||
_ -> do H.modify_ _ { errors = [] }
|
||||
H.raise $ AskPasswordRecovery (Left email)
|
||||
|
||||
-- TODO: verify the login?
|
||||
NewPasswordAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ newPasswordForm } <- H.get
|
||||
let { login, token, password, confirmation} = newPasswordForm
|
||||
|
||||
if A.any (_ == "") [ login, token, password, confirmation ]
|
||||
then H.raise $ Log $ ErrorLog "All entries are required!"
|
||||
else if password == confirmation
|
||||
then case L.login login of
|
||||
Left errors -> H.modify_ _ { errors = [ Login errors ] }
|
||||
Right _ -> do H.modify_ _ { errors = [] }
|
||||
H.raise $ PasswordRecovery login token password
|
||||
else H.raise $ Log $ UnableToSend "Confirmation differs from password!"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
-- For now, no message actually needs to be handled here.
|
||||
-- Error messages are simply logged (see the code in the Container component).
|
||||
MessageReceived message _ -> do
|
||||
case message of
|
||||
_ -> do
|
||||
H.raise $ Log $ ErrorLog $ "Message not handled in AuthenticationInterface."
|
||||
pure Nothing
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
319
src/App/Page/DomainList.purs
Normal file
319
src/App/Page/DomainList.purs
Normal file
@ -0,0 +1,319 @@
|
||||
-- | `App.DomainListInterface` is a simple component with the list of own domains
|
||||
-- | and a form to add a new domain.
|
||||
-- |
|
||||
-- | This interface allows to:
|
||||
-- | - display the list of own domains
|
||||
-- | - show and select accepted domains (TLDs)
|
||||
-- | - create new domains
|
||||
-- | - delete a domain
|
||||
-- | - ask for confirmation
|
||||
-- | - switch to the interface to show and modify the content of a Zone
|
||||
-- | - TODO: validate the domain before sending a message to `dnsmanagerd`
|
||||
module App.Page.DomainList where
|
||||
|
||||
import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>), (>))
|
||||
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.String.Utils (endsWith)
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Events as HHE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.DisplayErrors (error_to_paragraph_label)
|
||||
|
||||
import App.Validation.Label as Validation
|
||||
|
||||
import CSSClasses as C
|
||||
import App.Type.LogMessage
|
||||
import App.Message.DNSManagerDaemon as DNSManager
|
||||
|
||||
-- | `App.DomainListInterface` can send messages through websocket interface
|
||||
-- | connected to dnsmanagerd. See `App.WS`.
|
||||
-- |
|
||||
-- | Also, this component can log messages and ask its parent (`App.Container`) to
|
||||
-- | reconnect the websocket to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | Finally, the component can ask its state to its parent.
|
||||
-- | The reason is quite simple.
|
||||
-- | The component can be deleted, meaning that it loses its state.
|
||||
-- | Instead of asking `dnsmanagerd` the list of available domains and the list of owned domains
|
||||
-- | each time the component is instanciated, the parent stores the component's state when the
|
||||
-- | component is removed. This way, the data is conserved.
|
||||
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| Log LogMessage
|
||||
| ChangePageZoneInterface String
|
||||
| AskState
|
||||
| StoreState State
|
||||
|
||||
-- | `App.DomainListInterface` can receive messages from `dnsmanagerd`.
|
||||
-- |
|
||||
-- | The component is also informed when the connection is lost or up again.
|
||||
-- |
|
||||
-- | Finally, its entire state can be provided by its parent.
|
||||
-- | See the explanation for the `Output` data type.
|
||||
|
||||
data Query a
|
||||
= MessageReceived DNSManager.AnswerMessage a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
| ProvideState (Maybe State) a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
-- | `App.DomainListInterface` has no input.
|
||||
|
||||
type Input = Unit
|
||||
|
||||
-- | `App.DomainListInterface` has a single form to add a new domain.
|
||||
-- | Only two possible inputs: the (sub)domain name and the selection of the TLD.
|
||||
|
||||
data NewDomainFormAction
|
||||
= INP_newdomain String
|
||||
| UpdateSelectedDomain String
|
||||
|
||||
-- | Possible component's actions are:
|
||||
-- | - update the accepted domains (examples: netlib.re, codelib.re and example.com)
|
||||
-- | - update the list of own domains
|
||||
-- | - handle user inputs
|
||||
-- | - add a new domain
|
||||
-- | - remove a domain
|
||||
-- | - TODO: show the zone content (in another component)
|
||||
|
||||
data Action
|
||||
= UpdateAcceptedDomains (Array String)
|
||||
| UpdateMyDomains (Array String)
|
||||
|
||||
| HandleNewDomainInput NewDomainFormAction
|
||||
|
||||
| NewDomainAttempt Event
|
||||
| RemoveDomain String
|
||||
| EnterDomain String
|
||||
|
||||
| DeleteDomainModal String
|
||||
| CancelModal
|
||||
|
||||
| Initialize
|
||||
| Finalize
|
||||
|
||||
-- | The form only has two elements:
|
||||
-- | the subdomain name input and the selected TLD.
|
||||
|
||||
type NewDomainFormState
|
||||
= { new_domain :: String
|
||||
, _errors :: Array Validation.Error
|
||||
, selected_domain :: String
|
||||
}
|
||||
|
||||
-- | The entire component's state contains the form, accepted domains,
|
||||
-- | the list of own domains and a boolean to know if the connection is up.
|
||||
|
||||
type State =
|
||||
{ newDomainForm :: NewDomainFormState
|
||||
, accepted_domains :: Array String
|
||||
, my_domains :: Array String
|
||||
|
||||
, wsUp :: Boolean
|
||||
, active_modal :: Maybe String
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ initialize = Just Initialize
|
||||
, handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
, finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
-- | Default available domain: netlib.re.
|
||||
|
||||
default_domain :: String
|
||||
default_domain = "netlib.re"
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ newDomainForm: { new_domain: ""
|
||||
, _errors: []
|
||||
, selected_domain: default_domain
|
||||
}
|
||||
, accepted_domains: [ default_domain ]
|
||||
, my_domains: [ ]
|
||||
, wsUp: true
|
||||
, active_modal: Nothing
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { accepted_domains, my_domains, newDomainForm, wsUp, active_modal }
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> case active_modal of
|
||||
Nothing -> Bulma.columns_
|
||||
[ Bulma.column_ [ Bulma.h3 "Add a domain!", render_add_domain_form]
|
||||
, Bulma.column_ [ Bulma.h3 "My domains"
|
||||
, HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains
|
||||
]
|
||||
]
|
||||
Just domain -> Bulma.modal "Deleting a domain"
|
||||
[warning_message domain] [modal_delete_button domain, modal_cancel_button]
|
||||
]
|
||||
where
|
||||
modal_delete_button domain = Bulma.alert_btn "Delete the domain" (RemoveDomain domain)
|
||||
modal_cancel_button = Bulma.cancel_button CancelModal
|
||||
warning_message domain
|
||||
= HH.p [] [ HH.text $ "You are about to delete your domain '"
|
||||
<> domain
|
||||
<> "'. Are you sure you want to do this? This is "
|
||||
, HH.strong_ [ HH.text "irreversible" ]
|
||||
, HH.text "."
|
||||
]
|
||||
|
||||
domain_buttons domain
|
||||
= [ Bulma.alert_btn "delete" (DeleteDomainModal domain)
|
||||
, Bulma.btn domain (EnterDomain domain)
|
||||
]
|
||||
|
||||
render_add_domain_form = HH.form
|
||||
[ HE.onSubmit NewDomainAttempt ]
|
||||
[ Bulma.new_domain_field
|
||||
(HandleNewDomainInput <<< INP_newdomain)
|
||||
newDomainForm.new_domain
|
||||
[ HHE.onSelectedIndexChange domain_choice ]
|
||||
accepted_domains
|
||||
, HH.button
|
||||
[ HP.type_ HP.ButtonSubmit
|
||||
, HP.classes C.button
|
||||
]
|
||||
[ HH.text "add a new domain!" ]
|
||||
, if A.length newDomainForm._errors > 0
|
||||
then HH.div_ $ map error_to_paragraph_label newDomainForm._errors
|
||||
else HH.div_ [ ]
|
||||
]
|
||||
|
||||
domain_choice :: Int -> Action
|
||||
domain_choice i
|
||||
= HandleNewDomainInput <<< UpdateSelectedDomain $ maybe default_domain (\x -> x) $ accepted_domains A.!! i
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
Initialize -> do
|
||||
H.raise $ AskState
|
||||
|
||||
Finalize -> do
|
||||
state <- H.get
|
||||
H.raise $ StoreState state
|
||||
|
||||
CancelModal -> do
|
||||
H.modify_ _ { active_modal = Nothing }
|
||||
|
||||
UpdateAcceptedDomains domains -> do
|
||||
H.modify_ _ { accepted_domains = domains }
|
||||
|
||||
UpdateMyDomains domains -> do
|
||||
H.modify_ _ { my_domains = domains }
|
||||
|
||||
HandleNewDomainInput adduserinp -> do
|
||||
case adduserinp of
|
||||
INP_newdomain v -> do
|
||||
H.modify_ _ { newDomainForm { new_domain = v } }
|
||||
case v of
|
||||
"" -> H.modify_ _ { newDomainForm { _errors = [] } }
|
||||
_ -> case Validation.label v of
|
||||
Left arr -> H.modify_ _ { newDomainForm { _errors = arr } }
|
||||
Right _ -> H.modify_ _ { newDomainForm { _errors = [] } }
|
||||
UpdateSelectedDomain domain -> H.modify_ _ { newDomainForm { selected_domain = domain } }
|
||||
|
||||
EnterDomain domain -> do
|
||||
H.raise $ ChangePageZoneInterface domain
|
||||
|
||||
DeleteDomainModal domain -> do
|
||||
H.modify_ _ { active_modal = Just domain }
|
||||
|
||||
RemoveDomain domain -> do
|
||||
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkDeleteDomain { domain: domain }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Remove domain: " <> domain
|
||||
H.modify_ _ { active_modal = Nothing }
|
||||
|
||||
NewDomainAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ newDomainForm } <- H.get
|
||||
let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain
|
||||
|
||||
case newDomainForm._errors, new_domain of
|
||||
_, "" ->
|
||||
H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
|
||||
[], _ -> do
|
||||
message <- H.liftEffect
|
||||
$ DNSManager.serialize
|
||||
$ DNSManager.MkNewDomain { domain: new_domain }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")"
|
||||
handleAction $ HandleNewDomainInput $ INP_newdomain ""
|
||||
_, _ ->
|
||||
H.raise $ Log $ UnableToSend $ "You didn't enter a valid new domain"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
|
||||
ProvideState maybe_state a -> do
|
||||
case maybe_state of
|
||||
Nothing -> pure Nothing
|
||||
Just s -> do
|
||||
H.put s
|
||||
pure (Just a)
|
||||
|
||||
MessageReceived message a -> do
|
||||
case message of
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkAcceptedDomains response) -> do
|
||||
handleAction $ UpdateAcceptedDomains response.domains
|
||||
(DNSManager.MkLogged response) -> do
|
||||
handleAction $ UpdateAcceptedDomains response.accepted_domains
|
||||
handleAction $ UpdateMyDomains response.my_domains
|
||||
(DNSManager.MkDomainAdded response) -> do
|
||||
{ my_domains } <- H.get
|
||||
handleAction $ UpdateMyDomains (my_domains <> [response.domain])
|
||||
(DNSManager.MkDomainDeleted response) -> do
|
||||
{ my_domains } <- H.get
|
||||
handleAction $ UpdateMyDomains $ A.filter ((/=) response.domain) my_domains
|
||||
_ -> H.raise $ Log $ ErrorLog $ "Message not handled in DomainListInterface."
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
|
||||
page_reload :: State -> DNSManager.AnswerMessage -> State
|
||||
page_reload s1 message =
|
||||
case message of
|
||||
DNSManager.MkLogged response ->
|
||||
s1 { accepted_domains = response.accepted_domains
|
||||
, my_domains = response.my_domains
|
||||
}
|
||||
_ -> s1
|
||||
|
||||
build_new_domain :: String -> String -> String
|
||||
build_new_domain sub tld
|
||||
| endsWith "." sub = sub <> tld
|
||||
| otherwise = sub <> "." <> tld
|
||||
151
src/App/Page/Home.purs
Normal file
151
src/App/Page/Home.purs
Normal file
@ -0,0 +1,151 @@
|
||||
-- | `App.HomeInterface` presents the website and its features.
|
||||
module App.Page.Home where
|
||||
|
||||
import Prelude (Unit, pure, unit, ($))
|
||||
|
||||
-- import Data.Either (Either(..))
|
||||
-- import Data.Maybe (Maybe(..), maybe)
|
||||
-- import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
-- import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
type Input = Unit
|
||||
type Action = Unit
|
||||
type State = Unit
|
||||
|
||||
data Query a = DoNothing a
|
||||
type Output = Unit
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
}
|
||||
}
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction _ = pure unit
|
||||
|
||||
initialState :: forall input. input -> State
|
||||
initialState _ = unit
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render _ = HH.div_
|
||||
[ Bulma.hero_danger
|
||||
"THIS IS AN ALPHA RELEASE"
|
||||
"You can register, login and play a bit with the tool! Please, report errors and suggestions"
|
||||
, Bulma.section_small
|
||||
[ Bulma.h1 "Welcome to netlib.re"
|
||||
, Bulma.subtitle "Free domain names"
|
||||
, Bulma.hr
|
||||
, render_description
|
||||
, render_second_line
|
||||
, render_why_and_contact
|
||||
, Bulma.hr
|
||||
, render_how_and_code
|
||||
]
|
||||
]
|
||||
where
|
||||
title = Bulma.h3
|
||||
p = Bulma.p
|
||||
b x = Bulma.column_ [ Bulma.box [ Bulma.div_content x ] ]
|
||||
|
||||
render_description = Bulma.columns_ [ render_basics, render_no_expert ]
|
||||
render_basics
|
||||
= b [ title "What is provided?"
|
||||
, p "Reserve a domain name in <something>.netlib.re for free."
|
||||
, p "Manage your own DNS zone."
|
||||
]
|
||||
render_no_expert
|
||||
= b [ title "No need to be an expert!"
|
||||
, p """
|
||||
This website will help you through your configuration, as much as we can.
|
||||
"""
|
||||
]
|
||||
render_second_line = Bulma.columns_ [ render_no_housing, render_updates ]
|
||||
render_no_housing
|
||||
= b [ title "No housing, just a name"
|
||||
, p """
|
||||
We don't host your services or websites.
|
||||
We just provide a name.
|
||||
You can host your websites anywhere you want: at home for example.
|
||||
"""
|
||||
]
|
||||
render_updates
|
||||
= b [ title "Automatic updates"
|
||||
, p "Update your records with a single, stupidly simple command. For example:"
|
||||
, expl [ Bulma.strong "wget https://beta.netlib.re/token-update/<token>" ]
|
||||
, p "Every A and AAAA records have tokens for easy updates!"
|
||||
]
|
||||
|
||||
expl content = Bulma.div_content [ Bulma.explanation content ]
|
||||
render_why_and_contact = Bulma.columns_ [ render_why, render_contact ]
|
||||
render_why
|
||||
= b [ title "Why?"
|
||||
, p "Because everyone should be able to have a place on the Internet."
|
||||
, p "We provide you a name, build something meaningful with it."
|
||||
]
|
||||
render_contact
|
||||
= b [ title "Contact"
|
||||
, p "You have a question, you have seen a bug, you have suggestions or you just want to chat?"
|
||||
, p "You can contact us: netlibre@karchnu.fr"
|
||||
]
|
||||
|
||||
render_how_and_code = Bulma.columns_ [ render_how, render_code ]
|
||||
render_how
|
||||
= b [ title "How does this work?"
|
||||
, p "We pay for the domain names (netlib.re and codelib.re) and let you have a subdomain."
|
||||
, p "This service helps you manage your domain (a subdomain of netlib.re or codelib.re)."
|
||||
]
|
||||
render_code
|
||||
= b [ title "I want to see the code!"
|
||||
, p "The project is fully open-source (ISC licence)."
|
||||
, HH.text "There are a few parts:"
|
||||
, HH.ul_
|
||||
[ link "https://git.baguette.netlib.re/Baguette/authd" "authd"
|
||||
"""
|
||||
the authentication (and authorization) daemon, used to authenticate
|
||||
clients through different services;
|
||||
"""
|
||||
, link "https://git.baguette.netlib.re/Baguette/dnsmanagerd" "dnsmanagerd"
|
||||
"""
|
||||
the dns manager daemon, used as an interactive database, allowing clients
|
||||
to ask for domains, then handle the domain zones;
|
||||
"""
|
||||
, link "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient"
|
||||
"dnsmanager webclient"
|
||||
"""
|
||||
the web client that you are currently using, reading this very text,
|
||||
and enjoying while managing your zones. 🥰
|
||||
"""
|
||||
]
|
||||
, Bulma.hr
|
||||
, Bulma.p "But of course, there are a few more technical parts:"
|
||||
, HH.ul_
|
||||
[ link "https://git.baguette.netlib.re/Baguette/libipc" "libIPC"
|
||||
"""
|
||||
the Inter Process Communication library used between different applications,
|
||||
such as authd and dnsmanagerd;
|
||||
"""
|
||||
, link "https://git.baguette.netlib.re/Baguette/dodb.cr" "dodb"
|
||||
"""
|
||||
the Document Oriented DataBase, allowing to store serialized objects
|
||||
(a Zone, a User, etc.) in simple files as opposed to the usual complexity of
|
||||
traditional databases.
|
||||
"""
|
||||
]
|
||||
]
|
||||
link url link_title content
|
||||
= HH.li_ [ HH.a [HP.href url] [HH.text link_title]
|
||||
, HH.text ", "
|
||||
, HH.text content
|
||||
]
|
||||
197
src/App/Page/MailValidation.purs
Normal file
197
src/App/Page/MailValidation.purs
Normal file
@ -0,0 +1,197 @@
|
||||
-- | `App.MailValidationInterface` is a simple interface for mail verification.
|
||||
-- | A token is sent at registration at the provided email address.
|
||||
-- | This token has to be used to validate the email address.
|
||||
module App.Page.MailValidation where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
|
||||
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.Type.LogMessage
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
import App.Validation.Login as L
|
||||
import App.Validation.Token as T
|
||||
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| Log LogMessage
|
||||
|
||||
-- | The component is informed when the connection went up or down.
|
||||
data Query a
|
||||
= ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
data RegisterInput
|
||||
= VALIDATION_INP_login String
|
||||
| VALIDATION_INP_token String
|
||||
|
||||
data Action
|
||||
-- | Simply get the inputs from the form.
|
||||
= HandleValidationInput RegisterInput
|
||||
-- | Validate inputs (login, email, password) then send the request
|
||||
-- | (via `SendMailValidationToken`) or log errors.
|
||||
| ValidateInputs Event
|
||||
-- | Send the registration request to `dnsmanagerd`.
|
||||
-- | This action is automatically called from `ValidateInputs`.
|
||||
| SendMailValidationToken
|
||||
|
||||
-- | The possible errors come from either the login or token input.
|
||||
data Error
|
||||
= Login (Array L.Error)
|
||||
| Token (Array T.Error)
|
||||
|
||||
-- | The whole mail validation form is composed of two strings: the login and the token.
|
||||
type MailValidationForm = { login :: String, token :: String }
|
||||
|
||||
-- | State is composed of the registration form, the errors and an indication whether
|
||||
-- | the websocket connection with `authd` is up or not.
|
||||
type State =
|
||||
{ mailValidationForm :: MailValidationForm
|
||||
, errors :: Array Error
|
||||
, wsUp :: Boolean
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ mailValidationForm: { login: "", token: "" }
|
||||
, errors: []
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, mailValidationForm }
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> Bulma.columns_ [ b mail_validation_form ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
mail_validation_form = [ Bulma.h3 "Verify your account", render_register_form ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_register_form = HH.form
|
||||
[ HE.onSubmit ValidateInputs ]
|
||||
[ Bulma.box_input "loginValidation" "Login" "login" -- title, placeholder
|
||||
(HandleValidationInput <<< VALIDATION_INP_login) -- action
|
||||
mailValidationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "tokenValidation" "Token" "token" -- title, placeholder
|
||||
(HandleValidationInput <<< VALIDATION_INP_token) -- action
|
||||
mailValidationForm.token -- value
|
||||
should_be_disabled -- condition
|
||||
, HH.div_
|
||||
[ HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
HandleValidationInput reginp -> do
|
||||
case reginp of
|
||||
VALIDATION_INP_login v -> H.modify_ _ { mailValidationForm { login = v } }
|
||||
VALIDATION_INP_token v -> H.modify_ _ { mailValidationForm { token = v } }
|
||||
|
||||
-- Validate inputs (login, token) then send the request
|
||||
-- (via SendMailValidationToken) or log errors.
|
||||
ValidateInputs ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ mailValidationForm } <- H.get
|
||||
let { login, token } = mailValidationForm
|
||||
|
||||
case login, token of
|
||||
"", _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your login!"
|
||||
|
||||
_, "" ->
|
||||
H.raise $ Log $ UnableToSend "Write your token!"
|
||||
|
||||
_, _ -> do
|
||||
case L.login login, T.token token of
|
||||
Left errors, _ -> H.raise $ Log $ UnableToSend $ show_error $ Login errors
|
||||
_, Left errors -> H.raise $ Log $ UnableToSend $ show_error $ Token errors
|
||||
Right _, Right _ -> handleAction $ SendMailValidationToken
|
||||
|
||||
SendMailValidationToken -> do
|
||||
{ mailValidationForm } <- H.get
|
||||
let { login, token } = mailValidationForm
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user: login, activation_key: token }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Trying to validate email address of user \"" <> login <> "\""
|
||||
|
||||
show_error :: Error -> String
|
||||
show_error = case _ of
|
||||
Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr)
|
||||
Token arr -> "Error with the Token: " <> (A.fold $ map show_error_token arr)
|
||||
|
||||
show_error_login :: L.Error -> String
|
||||
show_error_login = case _ of
|
||||
L.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_login error
|
||||
|
||||
string_error_login :: L.LoginParsingError -> String
|
||||
string_error_login = case _ of
|
||||
L.CannotParse -> "cannot parse the login"
|
||||
L.CannotEntirelyParse -> "cannot entirely parse the login"
|
||||
L.Size min max n -> "login size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
show_error_token :: T.Error -> String
|
||||
show_error_token = case _ of
|
||||
T.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_token error
|
||||
|
||||
string_error_token :: T.TokenParsingError -> String
|
||||
string_error_token = case _ of
|
||||
T.CannotParse -> "cannot parse the token"
|
||||
T.CannotEntirelyParse -> "cannot entirely parse the token"
|
||||
T.Size min max n -> "token size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
195
src/App/Page/Navigation.purs
Normal file
195
src/App/Page/Navigation.purs
Normal file
@ -0,0 +1,195 @@
|
||||
-- | `App.NavigationInterface` is the navbar module.
|
||||
-- |
|
||||
-- | This module is required since some javascript is needed to toggle display of hidden resources.
|
||||
-- | On mobile, a burger menu is displayed and hides the navigation buttons.
|
||||
-- | On desktop, there is no need for this, all the navigation buttons are displayed by default.
|
||||
module App.Page.Navigation where
|
||||
|
||||
import Prelude (Unit, (<>), not, ($), discard, pure)
|
||||
|
||||
-- import Data.Array as A
|
||||
import Data.Maybe (Maybe(..))
|
||||
-- import Data.Either (Either(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.HTML.Properties.ARIA as ARIA
|
||||
|
||||
import CSSClasses as C
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.Type.Pages (Page(..))
|
||||
import App.Type.LogMessage (LogMessage)
|
||||
|
||||
data Output
|
||||
= Log LogMessage
|
||||
-- | Once someone clicks on a routing button, `App.Container` needs to know.
|
||||
| Routing Page
|
||||
-- | Once someone clicks on a the Disconnection button, `App.Container` needs to know.
|
||||
| Disconnection
|
||||
|
||||
-- | The component needs to know when the user is logged or not.
|
||||
data Query a = ToggleLogged Boolean a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
data Action
|
||||
-- | `ToggleMenu`: display or hide the content of the burger menu.
|
||||
= ToggleMenu
|
||||
-- | The navigation interface must be informed when the client wants to change page.
|
||||
-- | The request will be propagated to the parent (`App.Container`).
|
||||
-- | (`Navigate` is `App.Container.Routing`)
|
||||
| Navigate Page
|
||||
-- | The navigation interface must be informed when the client wants to disconnect.
|
||||
-- | The request will be propagated to the parent (`App.Container`).
|
||||
-- | (`UnLog` is `App.Container.Disconnection`)
|
||||
| UnLog
|
||||
|
||||
-- | State is composed of:
|
||||
-- | - `logged`, a boolean to toggle the display of some parts of the menu.
|
||||
-- | - `active`, a boolean to toggle the display of the menu.
|
||||
-- | - `admin`, a boolean to toggle the display of administration page link.
|
||||
type State = { logged :: Boolean, active :: Boolean, admin :: Boolean }
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ = { logged: false, active: false, admin: true }
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
ToggleMenu -> H.modify_ \state -> state { active = not state.active }
|
||||
-- | Page change.
|
||||
Navigate page -> H.raise $ Routing page
|
||||
UnLog -> do
|
||||
H.raise $ Disconnection
|
||||
H.modify_ _ { logged = false }
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
ToggleLogged islogged a -> do
|
||||
H.modify_ _ { logged = islogged }
|
||||
pure (Just a)
|
||||
|
||||
|
||||
-- | The navigation bar is a complex component to render.
|
||||
-- | The component changes when the user is authenticated.
|
||||
-- | A button has to appear for administrators.
|
||||
-- |
|
||||
-- | On mobile (a device with low resolution), a `burger icon` appears instead of the navigation bar.
|
||||
-- | When clicked, a list of options (such as pages or a disconnection button) should appear.
|
||||
-- | Also, when clicked again, the list disappears.
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { logged, active, admin } =
|
||||
main_nav
|
||||
[ nav_brand [ logo, burger_menu ]
|
||||
, nav_menu
|
||||
[ navbar_start left_bar_div
|
||||
, navbar_end right_bar_div
|
||||
]
|
||||
]
|
||||
|
||||
where
|
||||
left_bar_div =
|
||||
case logged, admin of
|
||||
false, _ -> [ link_home, code_dropdown ]
|
||||
_, false -> [ link_home, link_domains, code_dropdown ]
|
||||
_, _ -> [ link_home, link_domains, link_authd_admin, code_dropdown ]
|
||||
|
||||
right_bar_div =
|
||||
case logged of
|
||||
false -> [ link_auth, link_register, link_mail_validation ]
|
||||
_ -> [ link_setup, link_disconnection ]
|
||||
|
||||
navbar_color = C.is_success
|
||||
|
||||
main_nav =
|
||||
HH.nav [ HP.classes $ C.navbar <> navbar_color
|
||||
, ARIA.label "main navigation"
|
||||
, ARIA.role "navigation"
|
||||
]
|
||||
|
||||
logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🔻🍉"]
|
||||
-- HH.a [HP.classes C.navbar_item, HP.href "/"]
|
||||
-- [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]]
|
||||
|
||||
burger_menu =
|
||||
HH.a [ HP.classes $ C.navbar_burger <> if active then C.is_active else []
|
||||
, ARIA.label "menu"
|
||||
, ARIA.expanded "false"
|
||||
, Bulma.data_target "navbar-netlibre"
|
||||
, HE.onClick (\_ -> ToggleMenu)
|
||||
] [ HH.span [ARIA.hidden "true"] []
|
||||
, HH.span [ARIA.hidden "true"] []
|
||||
, HH.span [ARIA.hidden "true"] []
|
||||
]
|
||||
|
||||
nav_brand = HH.div [HP.classes C.navbar_brand]
|
||||
nav_menu = HH.div
|
||||
[ HP.id "navbar-netlibre"
|
||||
, HP.classes $ C.navbar_menu <> C.is_spaced <> if active then C.is_active else []
|
||||
]
|
||||
|
||||
navbar_start = HH.div [HP.classes C.navbar_start]
|
||||
navbar_end = HH.div [HP.classes C.navbar_end]
|
||||
|
||||
link_home = nav_link "Home" (Navigate Home)
|
||||
link_domains = nav_link "Domains" (Navigate DomainList)
|
||||
link_authd_admin = nav_link "Admin" (Navigate Administration)
|
||||
link_auth = nav_link "Login" (Navigate Authentication)
|
||||
link_register = nav_link_strong "Register" (Navigate Registration)
|
||||
link_mail_validation = nav_link "Mail verification" (Navigate MailValidation)
|
||||
link_setup = nav_link_warn "⚒ Setup" (Navigate Setup)
|
||||
link_disconnection =
|
||||
nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog
|
||||
|
||||
dropdown title dropdown_elements
|
||||
= HH.div [HP.classes $ C.navbar_item <> C.has_dropdown <> C.is_hoverable]
|
||||
[ dropdown_title title, HH.div [HP.classes C.navbar_dropdown] dropdown_elements ]
|
||||
dropdown_title str = HH.a [HP.classes C.navbar_link] [HH.text str]
|
||||
dropdown_element link str = HH.a [HP.classes C.navbar_item, HP.href link] [HH.text str]
|
||||
dropdown_separator = HH.hr [HP.classes C.navbar_divider]
|
||||
|
||||
--nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ])
|
||||
--nav_button classes str action = btn classes action (HH.text str)
|
||||
|
||||
nav_link_strong str action =
|
||||
HH.a [ HP.classes (C.navbar_item <> C.is_danger <> C.has_background_success_dark)
|
||||
, HE.onClick (\_ -> action)
|
||||
] [ (HH.strong [] [ HH.text str ]) ]
|
||||
|
||||
nav_link str action = nav_link_ navbar_color str action
|
||||
nav_link_warn str action = nav_link_ (C.has_background_warning <> C.has_text_dark) str action
|
||||
|
||||
nav_link_ classes str action =
|
||||
HH.a [ HP.classes (C.navbar_item <> classes)
|
||||
, HE.onClick (\_ -> action)
|
||||
] [ (HH.text str) ]
|
||||
|
||||
code_dropdown =
|
||||
dropdown "Source code"
|
||||
[ dropdown_element "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
|
||||
, dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager server"
|
||||
, dropdown_separator
|
||||
, dropdown_element
|
||||
"https://git.baguette.netlib.re/karchnu/halogen-websocket-ipc-playzone/src/branch/dev"
|
||||
"(temporary repo) dnsmanager website"
|
||||
]
|
||||
|
||||
--btn c action str
|
||||
-- = HH.a [ HP.classes (C.navbar_item <> C.button <> c)
|
||||
-- , HE.onClick (\_ -> action)
|
||||
-- ] [ str ]
|
||||
226
src/App/Page/Registration.purs
Normal file
226
src/App/Page/Registration.purs
Normal file
@ -0,0 +1,226 @@
|
||||
-- | `App.RegistrationInterface` is a registration interface.
|
||||
-- | Registration requires a login, an email address and a password.
|
||||
module App.Page.Registration where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
|
||||
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
import Data.Either (Either(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.Type.Email as Email
|
||||
import App.Type.LogMessage
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
import App.Validation.Login as L
|
||||
import App.Validation.Email as E
|
||||
import App.Validation.Password as P
|
||||
|
||||
data Output
|
||||
= MessageToSend ArrayBuffer
|
||||
| Log LogMessage
|
||||
|
||||
-- | The component is informed when the connection went up or down.
|
||||
data Query a
|
||||
= ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
data RegisterInput
|
||||
= REG_INP_login String
|
||||
| REG_INP_email String
|
||||
| REG_INP_pass String
|
||||
|
||||
data Action
|
||||
-- | Simply get the inputs from the form.
|
||||
= HandleRegisterInput RegisterInput
|
||||
-- | Validate inputs (login, email, password) then send the request
|
||||
-- | (via `SendRegistrationRequest`) or log errors.
|
||||
| ValidateInputs Event
|
||||
-- | Send the registration request to `dnsmanagerd`.
|
||||
-- | This action is automatically called from `ValidateInputs`.
|
||||
| SendRegistrationRequest
|
||||
|
||||
-- | The possible errors come from either the login, email or password input.
|
||||
data Error
|
||||
= Login (Array L.Error)
|
||||
| Email (Array E.Error)
|
||||
| Password (Array P.Error)
|
||||
|
||||
-- | The whole registration form is composed of three strings: login, email and password.
|
||||
type StateRegistrationForm = { login :: String, email :: String, pass :: String }
|
||||
|
||||
-- | State is composed of the registration form, the errors and an indication whether
|
||||
-- | the websocket connection with `authd` is up or not.
|
||||
type State =
|
||||
{ registrationForm :: StateRegistrationForm
|
||||
, errors :: Array Error
|
||||
, wsUp :: Boolean
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _ =
|
||||
{ registrationForm: { login: "", email: "", pass: "" }
|
||||
, errors: []
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsUp, registrationForm }
|
||||
= Bulma.section_small
|
||||
[ case wsUp of
|
||||
false -> Bulma.p "You are disconnected."
|
||||
true -> Bulma.columns_ [ b registration_form ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
registration_form = [ Bulma.h3 "Register!", render_register_form ]
|
||||
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_register_form = HH.form
|
||||
[ HE.onSubmit ValidateInputs ]
|
||||
[ Bulma.box_input "loginREGISTER" "Login" "login" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_login) -- action
|
||||
registrationForm.login -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_input "emailREGISTER" "Email" "email@example.com" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_email) -- action
|
||||
registrationForm.email -- value
|
||||
should_be_disabled -- condition
|
||||
, Bulma.box_password "passwordREGISTER" "Password" "password" -- title, placeholder
|
||||
(HandleRegisterInput <<< REG_INP_pass) -- action
|
||||
registrationForm.pass -- value
|
||||
should_be_disabled -- condition
|
||||
, HH.div_
|
||||
[ HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
HandleRegisterInput reginp -> do
|
||||
case reginp of
|
||||
REG_INP_login v -> H.modify_ _ { registrationForm { login = v } }
|
||||
REG_INP_email v -> H.modify_ _ { registrationForm { email = v } }
|
||||
REG_INP_pass v -> H.modify_ _ { registrationForm { pass = v } }
|
||||
|
||||
-- Validate inputs (login, email, password) then send the request
|
||||
-- (via SendRegistrationRequest) or log errors.
|
||||
ValidateInputs ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ registrationForm } <- H.get
|
||||
let login = registrationForm.login
|
||||
email = registrationForm.email
|
||||
pass = registrationForm.pass
|
||||
|
||||
case login, email, pass of
|
||||
"", _, _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your login!"
|
||||
|
||||
_, "", _ ->
|
||||
H.raise $ Log $ UnableToSend "Write your email!"
|
||||
|
||||
_, _, "" ->
|
||||
H.raise $ Log $ UnableToSend "Write your password!"
|
||||
|
||||
_, _, _ -> do
|
||||
case L.login login, E.email email, P.password pass of
|
||||
Left errors, _, _ -> H.raise $ Log $ UnableToSend $ show_error $ Login errors
|
||||
_, Left errors, _ -> H.raise $ Log $ UnableToSend $ show_error $ Email errors
|
||||
_, _, Left errors -> H.raise $ Log $ UnableToSend $ show_error $ Password errors
|
||||
Right _, Right _, Right _ -> handleAction $ SendRegistrationRequest
|
||||
|
||||
SendRegistrationRequest -> do
|
||||
{ registrationForm } <- H.get
|
||||
let { login, email, pass } = registrationForm
|
||||
message <- H.liftEffect $ AuthD.serialize $
|
||||
AuthD.MkRegister { login, email: Just (Email.Email email), password: pass }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Trying to register (login: " <> login <> ")"
|
||||
|
||||
show_error :: Error -> String
|
||||
show_error = case _ of
|
||||
Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr)
|
||||
Email arr -> "Error with the Email: " <> (A.fold $ map show_error_email arr)
|
||||
Password arr -> "Error with the Password: " <> (A.fold $ map show_error_password arr)
|
||||
|
||||
show_error_login :: L.Error -> String
|
||||
show_error_login = case _ of
|
||||
L.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_login error
|
||||
|
||||
string_error_login :: L.LoginParsingError -> String
|
||||
string_error_login = case _ of
|
||||
L.CannotParse -> "cannot parse the login"
|
||||
L.CannotEntirelyParse -> "cannot entirely parse the login"
|
||||
L.Size min max n -> "login size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
show_error_email :: E.Error -> String
|
||||
show_error_email = case _ of
|
||||
E.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_email error
|
||||
|
||||
string_error_email :: E.EmailParsingError -> String
|
||||
string_error_email = case _ of
|
||||
E.CannotParse -> "cannot parse the email"
|
||||
E.CannotEntirelyParse -> "cannot entirely parse the email"
|
||||
E.Size min max n -> "email size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
show_error_password :: P.Error -> String
|
||||
show_error_password = case _ of
|
||||
P.ParsingError {error, position} ->
|
||||
"position " <> show position <> " " <> maybe "" string_error_password error
|
||||
|
||||
string_error_password :: P.PasswordParsingError -> String
|
||||
string_error_password = case _ of
|
||||
P.CannotParse -> "cannot parse the password"
|
||||
P.CannotEntirelyParse -> "cannot entirely parse the password"
|
||||
P.Size min max n -> "password size should be between "
|
||||
<> show min <> " and " <> show max
|
||||
<> " (currently: " <> show n <> ")"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
168
src/App/Page/Setup.purs
Normal file
168
src/App/Page/Setup.purs
Normal file
@ -0,0 +1,168 @@
|
||||
-- | `App.SetupInterface` allows users to change their password or their email address.
|
||||
-- | Users can also erase their account.
|
||||
module App.Page.Setup where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (==))
|
||||
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
|
||||
import Bulma as Bulma
|
||||
|
||||
import App.Type.LogMessage
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
|
||||
data Output
|
||||
= Log LogMessage
|
||||
| ChangePassword String
|
||||
| DeleteUserAccount
|
||||
|
||||
-- | The component's parent provides received messages.
|
||||
-- |
|
||||
-- | Also, the component is informed when the connection went up or down.
|
||||
data Query a
|
||||
= MessageReceived AuthD.AnswerMessage a
|
||||
| ConnectionIsDown a
|
||||
| ConnectionIsUp a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = String
|
||||
|
||||
data AuthenticationInput
|
||||
= AUTH_INP_login String
|
||||
| AUTH_INP_pass String
|
||||
|
||||
data NewPasswordInput
|
||||
= NEWPASS_INP_password String
|
||||
| NEWPASS_INP_confirmation String
|
||||
|
||||
data Action
|
||||
= HandleNewPassword NewPasswordInput
|
||||
| ChangePasswordAttempt Event
|
||||
| CancelModal
|
||||
| DeleteAccountPopup
|
||||
| DeleteAccount
|
||||
|
||||
type StateNewPasswordForm = { password :: String, confirmation :: String }
|
||||
|
||||
data Modal
|
||||
= NoModal
|
||||
| DeleteAccountModal
|
||||
|
||||
type State =
|
||||
{ newPasswordForm :: StateNewPasswordForm
|
||||
, token :: String
|
||||
, wsUp :: Boolean
|
||||
, modal :: Modal
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState token =
|
||||
{ newPasswordForm: { password: "", confirmation: "" }
|
||||
, token
|
||||
, modal: NoModal
|
||||
, wsUp: true
|
||||
}
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { modal, wsUp, newPasswordForm } =
|
||||
case modal of
|
||||
DeleteAccountModal -> render_delete_account_modal
|
||||
NoModal -> Bulma.columns_ [ b [ Bulma.h3 "Change password", render_new_password_form ]
|
||||
, b [ Bulma.h3 "Delete account", render_delete_account ]
|
||||
]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
|
||||
render_delete_account = Bulma.alert_btn "Delete my account" DeleteAccountPopup
|
||||
render_new_password_form = HH.form
|
||||
[ HE.onSubmit ChangePasswordAttempt ]
|
||||
[ Bulma.box_input "passwordNEWPASS" "Password" "password"
|
||||
(HandleNewPassword <<< NEWPASS_INP_password)
|
||||
newPasswordForm.password
|
||||
should_be_disabled
|
||||
, Bulma.box_input "confirmationNEWPASS" "Confirmation" "confirmation"
|
||||
(HandleNewPassword <<< NEWPASS_INP_confirmation)
|
||||
newPasswordForm.confirmation
|
||||
should_be_disabled
|
||||
, HH.button
|
||||
[ HP.style "padding: 0.5rem 1.25rem;"
|
||||
, HP.type_ HP.ButtonSubmit
|
||||
, (if wsUp then (HP.enabled true) else (HP.disabled true))
|
||||
]
|
||||
[ HH.text "Send Message to Server" ]
|
||||
]
|
||||
|
||||
render_delete_account_modal = Bulma.modal "Delete your account"
|
||||
[ Bulma.p "Your account and domains will be removed."
|
||||
, Bulma.strong "⚠ You won't be able to recover your data."
|
||||
]
|
||||
[ Bulma.alert_btn "GO AHEAD LOL" DeleteAccount
|
||||
, Bulma.cancel_button CancelModal
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
HandleNewPassword authinp -> do
|
||||
case authinp of
|
||||
NEWPASS_INP_password v -> H.modify_ _ { newPasswordForm { password = v } }
|
||||
NEWPASS_INP_confirmation v -> H.modify_ _ { newPasswordForm { confirmation = v } }
|
||||
|
||||
CancelModal -> do
|
||||
H.modify_ _ { modal = NoModal }
|
||||
DeleteAccountPopup -> do
|
||||
H.modify_ _ { modal = DeleteAccountModal }
|
||||
DeleteAccount -> do
|
||||
H.raise $ DeleteUserAccount
|
||||
handleAction $ CancelModal
|
||||
|
||||
ChangePasswordAttempt ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
{ newPasswordForm } <- H.get
|
||||
case newPasswordForm.password, newPasswordForm.confirmation of
|
||||
"" , _ -> H.raise $ Log $ UnableToSend "Write your password!"
|
||||
_ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!"
|
||||
pass, confirmation -> do
|
||||
if pass == confirmation
|
||||
then do H.raise $ Log $ SystemLog "Changing the password"
|
||||
H.raise $ ChangePassword pass
|
||||
else H.raise $ Log $ UnableToSend "Confirmation differs from password"
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
-- For now, no message actually needs to be handled here.
|
||||
-- Error messages are simply logged (see the code in the Container component).
|
||||
MessageReceived message _ -> do
|
||||
case message of
|
||||
_ -> do
|
||||
H.raise $ Log $ ErrorLog $ "Message not handled in SetupInterface."
|
||||
pure Nothing
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
H.modify_ _ { wsUp = false }
|
||||
pure (Just a)
|
||||
|
||||
ConnectionIsUp a -> do
|
||||
H.modify_ _ { wsUp = true }
|
||||
pure (Just a)
|
||||
1061
src/App/Page/Zone.purs
Normal file
1061
src/App/Page/Zone.purs
Normal file
File diff suppressed because it is too large
Load Diff
136
src/App/Text/Explanations.purs
Normal file
136
src/App/Text/Explanations.purs
Normal file
@ -0,0 +1,136 @@
|
||||
module App.Text.Explanations where
|
||||
import Halogen.HTML as HH
|
||||
import Bulma as Bulma
|
||||
|
||||
expl :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
expl content = Bulma.div_content [ Bulma.explanation content ]
|
||||
|
||||
tokens :: forall w i. HH.HTML w i
|
||||
tokens = HH.div_
|
||||
[ Bulma.h3 "What are tokens?"
|
||||
, expl [ Bulma.p """
|
||||
Tokens are a simple way to update a resource record (A or AAAA) with your current IP address.
|
||||
"""
|
||||
]
|
||||
, HH.p_ [ HH.text "Let's take an example: you have a A record (IPv4) pointing to your web server at home, "
|
||||
, HH.text "but your ISP changes your IP address from time to time. "
|
||||
, HH.text "You can ask for a token (which looks like "
|
||||
, HH.u_ [HH.text "53be0c45-61c4-4d29-8ae9-c2cc8767603d"]
|
||||
, HH.text ") for this specific entry, then make your server regularly visit the following website."
|
||||
]
|
||||
, expl [ HH.p_ [ HH.text "https://beta.netlib.re/token-update/"
|
||||
, HH.u_ [HH.text "<your-token>"]
|
||||
]
|
||||
]
|
||||
, Bulma.p "For example: https://beta.netlib.re/token-update/53be0c45-61c4-4d29-8ae9-c2cc8767603d"
|
||||
, Bulma.hr
|
||||
, Bulma.h3 "How to automate the update of my IP address?"
|
||||
, Bulma.p "On Linux, you can make your computer access the update link with the following command."
|
||||
, expl [ Bulma.strong "wget https://beta.netlib.re/token-update/<token>" ]
|
||||
, Bulma.p """
|
||||
No need for a more complex program. This works just fine.
|
||||
And you can run this command every hour.
|
||||
For example, in your crontab (Linux and Unix related):
|
||||
"""
|
||||
, expl [ Bulma.strong "0 * * * * wget <url>" ]
|
||||
, Bulma.p """
|
||||
Commands for other operating systems may differ, but you get the idea.
|
||||
"""
|
||||
, Bulma.hr
|
||||
, Bulma.h3 "The obvious trap ⚠"
|
||||
, Bulma.p """
|
||||
Make sure to access the website using the related IP address.
|
||||
To update an IPv6 address (AAAA), force your application to access the URL using an IPv6 address.
|
||||
"""
|
||||
, expl [ HH.p_ [ Bulma.strong "wget -6 <url>" ]
|
||||
, HH.p_ [ HH.text "To force the use of an IPv6 address." ]
|
||||
, HH.p_ [ Bulma.strong "wget -4 <url>" ]
|
||||
, HH.p_ [ HH.text "To force the use of an IPv4 address." ]
|
||||
]
|
||||
]
|
||||
|
||||
dkim_introduction :: forall w i. Array (HH.HTML w i)
|
||||
dkim_introduction =
|
||||
[ Bulma.p """
|
||||
DKIM is a way to share a public signature key for the domain.
|
||||
This allows emails to be signed by the sender, and for the receiver to prove the origin of the mail.
|
||||
"""
|
||||
, HH.p []
|
||||
[ HH.text """
|
||||
Default name is fine, change it only if you know what you are doing.
|
||||
For the configuration of your mail server, remember that your
|
||||
"""
|
||||
, HH.u_ [HH.text "selector"]
|
||||
, HH.text " is "
|
||||
, Bulma.strong "default"
|
||||
, HH.text "."
|
||||
]
|
||||
]
|
||||
|
||||
dkim_default_algorithms :: forall w i. Array (HH.HTML w i)
|
||||
dkim_default_algorithms =
|
||||
[ Bulma.p """
|
||||
Default values should be fine (RSA + SHA256), change them only if you know what you are doing.
|
||||
Just enter your public key.
|
||||
"""
|
||||
]
|
||||
|
||||
spf_introduction :: forall w i. Array (HH.HTML w i)
|
||||
spf_introduction =
|
||||
[ HH.p []
|
||||
[ HH.text "Sender Policy Framework (SPF) is a way to tell "
|
||||
, HH.u_ [HH.text "other mail servers"]
|
||||
, HH.text " what are mail servers susceptible to send mails with email addresses from "
|
||||
, HH.u_ [HH.text "our domain"]
|
||||
, HH.text ". "
|
||||
]
|
||||
, HH.p []
|
||||
[ HH.text """
|
||||
This way, we can mitigate spam.
|
||||
A server receiving a mail with our email address but coming from an IP address we didn't list as authorized will be discarded.
|
||||
This is not a bullet-proof technique, but it's simple enough and works great with the most basic forms of spam.
|
||||
"""
|
||||
]
|
||||
, HH.p []
|
||||
[ HH.text "A correctly configured domain with a mail server should only advertise the right IP addresses that can possibly send mails from the domain."
|
||||
]
|
||||
, HH.p []
|
||||
[ HH.u_ [HH.text "Advice for novice users"]
|
||||
, HH.text """
|
||||
: default values should work great with simple domains.
|
||||
"""
|
||||
]
|
||||
]
|
||||
|
||||
spf_default_behavior :: forall w i. Array (HH.HTML w i)
|
||||
spf_default_behavior = [Bulma.p """
|
||||
What should someone do when receiving a mail with your email address but not from a listed domain or IP address?
|
||||
"""
|
||||
, HH.text """
|
||||
By default, let's advise to drop the mail (a
|
||||
"""
|
||||
, HH.u_ [HH.text "hard fail"]
|
||||
, HH.text """).
|
||||
The only way for DKIM to be really meaningful is to block any mail not coming from the intended email servers.
|
||||
Otherwise, it's just a statu quo, and the spamming will continue.
|
||||
"""]
|
||||
|
||||
srv_introduction :: forall w i. Array (HH.HTML w i)
|
||||
srv_introduction =
|
||||
[ Bulma.p "The SRV record is a DNS RR for specifying the location of services."
|
||||
, HH.p_ [ HH.text "Given a specific "
|
||||
, HH.u_ [HH.text "service name"]
|
||||
, HH.text " (which may be arbitrary) and a "
|
||||
, HH.u_ [HH.text "protocol"]
|
||||
, HH.text " (such as TCP or UDP), you can tell where the server is (address name and port). "
|
||||
, HH.text """
|
||||
Both the names of the service and the protocol are used to construct the name of the RR.
|
||||
"""
|
||||
]
|
||||
, HH.p_ [ HH.text "For example, for a service named "
|
||||
, HH.u_ [HH.text "voip"]
|
||||
, HH.text " and given that this service uses the TCP protocol, you can specify that the target is "
|
||||
, HH.u_ [HH.text "server1.example.com."]
|
||||
, HH.text "."
|
||||
]
|
||||
]
|
||||
24
src/App/Type/AcceptedRRTypes.purs
Normal file
24
src/App/Type/AcceptedRRTypes.purs
Normal file
@ -0,0 +1,24 @@
|
||||
-- | The application accepts to add a few new entry types in a DNS zone.
|
||||
-- | Each resource record has a specific form, with dedicated inputs and
|
||||
-- | dedicated validation.
|
||||
module App.Type.AcceptedRRTypes where
|
||||
|
||||
import Prelude
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Show.Generic (genericShow)
|
||||
|
||||
data AcceptedRRTypes
|
||||
= A
|
||||
| AAAA
|
||||
| TXT
|
||||
| CNAME
|
||||
| NS
|
||||
| MX
|
||||
| SRV
|
||||
| SPF
|
||||
| DKIM
|
||||
|
||||
derive instance genericMyADT :: Generic AcceptedRRTypes _
|
||||
|
||||
instance showMyADT :: Show AcceptedRRTypes where
|
||||
show = genericShow
|
||||
89
src/App/Type/DKIM.purs
Normal file
89
src/App/Type/DKIM.purs
Normal file
@ -0,0 +1,89 @@
|
||||
module App.Type.DKIM where
|
||||
|
||||
import Data.Maybe (Maybe(..))
|
||||
|
||||
import Data.Codec.Argonaut (JsonCodec)
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Codec.Argonaut.Record as CAR
|
||||
|
||||
type PublicKey = String
|
||||
|
||||
type DKIM
|
||||
= { v :: Maybe Version -- v= "DKIM1", entirely optional (for now, even ignored).
|
||||
, k :: Maybe SignatureAlgorithm -- k= Key type (optional, default is "rsa").
|
||||
, h :: Maybe HashingAlgorithm -- h= hash algorigthm (optional, "sha1" or "sha256" from RFC6376)
|
||||
, p :: PublicKey -- p= Public-key data (base64; REQUIRED).
|
||||
-- The syntax and semantics of this tag value before being
|
||||
-- encoded in base64 are defined by the "k=" tag.
|
||||
, n :: Maybe String -- n= Notes that might be of interest to a human (optional)
|
||||
}
|
||||
|
||||
codec :: JsonCodec DKIM
|
||||
codec = CA.object "DKIM"
|
||||
(CAR.record
|
||||
{ v: CAR.optional codecVersion
|
||||
, k: CAR.optional codecSignatureAlgorithm
|
||||
, h: CAR.optional codecHashingAlgorithm
|
||||
, p: CA.string
|
||||
, n: CAR.optional CA.string
|
||||
})
|
||||
|
||||
emptyDKIMRR :: DKIM
|
||||
emptyDKIMRR = { v: Nothing, k: Just RSA, h: Just SHA256, p: "", n: Nothing }
|
||||
|
||||
-- RFC6376 section 3.6.2.1
|
||||
-- All DKIM keys are stored in a subdomain named "_domainkey". Given a
|
||||
-- DKIM-Signature field with a "d=" tag of "example.com" and an "s=" tag
|
||||
-- of "foo.bar", the DNS query will be for
|
||||
-- "foo.bar._domainkey.example.com".
|
||||
|
||||
data HashingAlgorithm = {- SHA1 | -} SHA256
|
||||
hash_algos = [ {- "sha1", -} SHA256] :: Array HashingAlgorithm
|
||||
|
||||
-- | Codec for just encoding a single value of type `HashingAlgorithm`.
|
||||
codecHashingAlgorithm :: CA.JsonCodec HashingAlgorithm
|
||||
codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm show_hashing_algorithm CA.string
|
||||
|
||||
str_to_hashing_algorithm :: String -> Maybe HashingAlgorithm
|
||||
str_to_hashing_algorithm = case _ of
|
||||
-- "sha1" -> Just SHA1
|
||||
"sha256" -> Just SHA256
|
||||
_ -> Nothing
|
||||
|
||||
show_hashing_algorithm :: HashingAlgorithm -> String
|
||||
show_hashing_algorithm = case _ of
|
||||
-- SHA1 -> "sha1"
|
||||
SHA256 -> "sha256"
|
||||
|
||||
data SignatureAlgorithm = RSA | ED25519
|
||||
sign_algos = [RSA, ED25519] :: Array SignatureAlgorithm
|
||||
|
||||
-- | Codec for just encoding a single value of type `SignatureAlgorithm`.
|
||||
codecSignatureAlgorithm :: CA.JsonCodec SignatureAlgorithm
|
||||
codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm show_signature_algorithm CA.string
|
||||
|
||||
str_to_signature_algorithm :: String -> Maybe SignatureAlgorithm
|
||||
str_to_signature_algorithm = case _ of
|
||||
"rsa" -> Just RSA
|
||||
"ed25519" -> Just ED25519
|
||||
_ -> Nothing
|
||||
|
||||
show_signature_algorithm :: SignatureAlgorithm -> String
|
||||
show_signature_algorithm = case _ of
|
||||
RSA -> "rsa"
|
||||
ED25519 -> "ed25519"
|
||||
|
||||
data Version = DKIM1
|
||||
|
||||
-- | Codec for just encoding a single value of type `Version`.
|
||||
codecVersion :: CA.JsonCodec Version
|
||||
codecVersion = CA.prismaticCodec "Version" str_to_version show_version CA.string
|
||||
|
||||
str_to_version :: String -> Maybe Version
|
||||
str_to_version = case _ of
|
||||
"dkim1" -> Just DKIM1
|
||||
_ -> Nothing
|
||||
|
||||
show_version :: Version -> String
|
||||
show_version = case _ of
|
||||
DKIM1 -> "dkim1"
|
||||
24
src/App/Type/DNSZone.purs
Normal file
24
src/App/Type/DNSZone.purs
Normal file
@ -0,0 +1,24 @@
|
||||
module App.Type.DNSZone where
|
||||
|
||||
import Data.Codec.Argonaut (JsonCodec)
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Codec.Argonaut.Record as CAR
|
||||
import App.Type.ResourceRecord as RR
|
||||
|
||||
type DNSZone
|
||||
= { domain :: String
|
||||
|
||||
-- List of all the zone's resource records.
|
||||
, resources :: Array RR.ResourceRecord
|
||||
|
||||
-- Each resource record has a number, this is the ID to give to a new RR.
|
||||
, current_rrid :: Int
|
||||
}
|
||||
|
||||
codec :: JsonCodec DNSZone
|
||||
codec = CA.object "DNSZone"
|
||||
(CAR.record
|
||||
{ domain: CA.string
|
||||
, resources: CA.array RR.codec
|
||||
, current_rrid: CA.int
|
||||
})
|
||||
20
src/App/Type/Email.purs
Normal file
20
src/App/Type/Email.purs
Normal file
@ -0,0 +1,20 @@
|
||||
-- | TODO: Email module should include at least some sort of smart
|
||||
-- | constructors, rejecting invalid email addresses.
|
||||
module App.Type.Email where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Codec.Argonaut (JsonCodec)
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Newtype (class Newtype)
|
||||
import Data.Profunctor (wrapIso)
|
||||
|
||||
newtype Email = Email String
|
||||
|
||||
derive instance newtypeEmail :: Newtype Email _
|
||||
derive instance eqEmail :: Eq Email
|
||||
derive instance ordEmail :: Ord Email
|
||||
|
||||
-- | Email.codec can be used to parse and encode email addresses.
|
||||
codec :: JsonCodec Email
|
||||
codec = wrapIso Email CA.string
|
||||
7
src/App/Type/LogMessage.purs
Normal file
7
src/App/Type/LogMessage.purs
Normal file
@ -0,0 +1,7 @@
|
||||
module App.Type.LogMessage where
|
||||
|
||||
data LogMessage
|
||||
= SystemLog String
|
||||
| UnableToSend String
|
||||
| ErrorLog String
|
||||
| SuccessLog String
|
||||
21
src/App/Type/MaintenanceSubject.purs
Normal file
21
src/App/Type/MaintenanceSubject.purs
Normal file
@ -0,0 +1,21 @@
|
||||
module App.Type.MaintenanceSubject where
|
||||
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Maybe (Maybe(..))
|
||||
|
||||
data MaintenanceSubject
|
||||
= Verbosity
|
||||
|
||||
-- | Codec for just encoding a single value of type `MaintenanceSubject`
|
||||
codec :: CA.JsonCodec MaintenanceSubject
|
||||
codec =
|
||||
CA.prismaticCodec "MaintenanceSubject" from to CA.string
|
||||
where
|
||||
from :: String -> Maybe MaintenanceSubject
|
||||
from = case _ of
|
||||
"verbosity" -> Just Verbosity
|
||||
_ -> Nothing
|
||||
|
||||
to :: MaintenanceSubject -> String
|
||||
to = case _ of
|
||||
Verbosity -> "verbosity"
|
||||
13
src/App/Type/Pages.purs
Normal file
13
src/App/Type/Pages.purs
Normal file
@ -0,0 +1,13 @@
|
||||
module App.Type.Pages where
|
||||
-- | This list will grow in a near future.
|
||||
-- |
|
||||
-- | TODO:
|
||||
data Page
|
||||
= Home -- | `Home`: presentation of the project.
|
||||
| Authentication -- | `Authentication`: authentication page.
|
||||
| Registration -- | `Registration`: to register new people.
|
||||
| MailValidation -- | `MailValidation`: to validate email addresses (via a token).
|
||||
| DomainList -- | `DomainList`: to list owned domains and to ask for new domains.
|
||||
| Zone String -- | `Zone`: to manage a zone.
|
||||
| Setup -- | `Setup`: user account administration page
|
||||
| Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).
|
||||
30
src/App/Type/PermissionLevel.purs
Normal file
30
src/App/Type/PermissionLevel.purs
Normal file
@ -0,0 +1,30 @@
|
||||
module App.Type.PermissionLevel where
|
||||
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Maybe (Maybe(..))
|
||||
|
||||
data PermissionLevel
|
||||
= None
|
||||
| Read
|
||||
| Edit
|
||||
| Admin
|
||||
|
||||
-- | Codec for just encoding a single value of type `PermissionLevel`
|
||||
codec :: CA.JsonCodec PermissionLevel
|
||||
codec =
|
||||
CA.prismaticCodec "PermissionLevel" from to CA.string
|
||||
where
|
||||
from :: String -> Maybe PermissionLevel
|
||||
from = case _ of
|
||||
"none" -> Just None
|
||||
"read" -> Just Read
|
||||
"edit" -> Just Edit
|
||||
"admin" -> Just Admin
|
||||
_ -> Nothing
|
||||
|
||||
to :: PermissionLevel -> String
|
||||
to = case _ of
|
||||
None -> "none"
|
||||
Read -> "read"
|
||||
Edit -> "edit"
|
||||
Admin -> "admin"
|
||||
253
src/App/Type/ResourceRecord.purs
Normal file
253
src/App/Type/ResourceRecord.purs
Normal file
@ -0,0 +1,253 @@
|
||||
module App.Type.ResourceRecord where
|
||||
|
||||
import Prelude ((<>), map, bind, pure)
|
||||
|
||||
import Data.Maybe (Maybe(..), maybe)
|
||||
|
||||
import Data.Codec.Argonaut (JsonCodec)
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Codec.Argonaut.Record as CAR
|
||||
|
||||
import App.Type.DKIM as DKIM
|
||||
|
||||
type ResourceRecord
|
||||
= { rrtype :: String
|
||||
, rrid :: Int
|
||||
, name :: String
|
||||
, ttl :: Int
|
||||
, target :: String
|
||||
, readonly :: Boolean
|
||||
|
||||
-- MX (and SRV) specific entry.
|
||||
, priority :: Maybe Int
|
||||
|
||||
-- SRV specific entries.
|
||||
, port :: Maybe Int
|
||||
, protocol :: Maybe String
|
||||
, weight :: Maybe Int
|
||||
|
||||
-- SOA specific entries.
|
||||
, mname :: Maybe String
|
||||
, rname :: Maybe String
|
||||
, serial :: Maybe Int
|
||||
, refresh :: Maybe Int
|
||||
, retry :: Maybe Int
|
||||
, expire :: Maybe Int
|
||||
, minttl :: Maybe Int
|
||||
|
||||
, token :: Maybe String
|
||||
|
||||
-- SPF specific entries.
|
||||
, v :: Maybe String -- Default: spf1
|
||||
, mechanisms :: Maybe (Array Mechanism)
|
||||
, modifiers :: Maybe (Array Modifier)
|
||||
, q :: Maybe Qualifier -- Qualifier for default mechanism (`all`).
|
||||
|
||||
, dkim :: Maybe DKIM.DKIM
|
||||
|
||||
-- TODO: DMARC specific entries.
|
||||
}
|
||||
|
||||
codec :: JsonCodec ResourceRecord
|
||||
codec = CA.object "ResourceRecord"
|
||||
(CAR.record
|
||||
{ rrtype: CA.string
|
||||
, rrid: CA.int
|
||||
, name: CA.string
|
||||
, ttl: CA.int
|
||||
, target: CA.string
|
||||
, readonly: CA.boolean
|
||||
|
||||
-- MX (and SRV) specific entry.
|
||||
, priority: CAR.optional CA.int
|
||||
|
||||
-- SRV specific entries.
|
||||
, port: CAR.optional CA.int
|
||||
, protocol: CAR.optional CA.string
|
||||
, weight: CAR.optional CA.int
|
||||
|
||||
-- SOA specific entries.
|
||||
, mname: CAR.optional CA.string
|
||||
, rname: CAR.optional CA.string
|
||||
, serial: CAR.optional CA.int
|
||||
, refresh: CAR.optional CA.int
|
||||
, retry: CAR.optional CA.int
|
||||
, expire: CAR.optional CA.int
|
||||
, minttl: CAR.optional CA.int
|
||||
|
||||
, token: CAR.optional CA.string
|
||||
|
||||
-- SPF specific entries.
|
||||
, v: CAR.optional CA.string
|
||||
, mechanisms: CAR.optional (CA.array codecMechanism)
|
||||
, modifiers: CAR.optional (CA.array codecModifier)
|
||||
, q: CAR.optional codecQualifier
|
||||
|
||||
, dkim: CAR.optional DKIM.codec
|
||||
})
|
||||
|
||||
type Mechanism
|
||||
= { q :: Maybe Qualifier
|
||||
, t :: MechanismType
|
||||
, v :: String -- Value (IP addresses or ranges, or domains).
|
||||
}
|
||||
|
||||
codecMechanism :: JsonCodec Mechanism
|
||||
codecMechanism = CA.object "Mechanism"
|
||||
(CAR.record
|
||||
{ q: CAR.optional codecQualifier
|
||||
, t: codecMechanismType
|
||||
, v: CA.string
|
||||
})
|
||||
|
||||
-- TODO: this is debug code, before actual validation.
|
||||
to_mechanism :: String -> String -> String -> Maybe Mechanism
|
||||
to_mechanism q t v = do
|
||||
mechanism_type <- str_to_mechanism_type t
|
||||
pure { q: str_to_qualifier q, t: mechanism_type, v }
|
||||
to_modifier :: String -> String -> Maybe Modifier
|
||||
to_modifier t v = do
|
||||
modifier_type <- str_to_modifier_type t
|
||||
pure { t: modifier_type, v }
|
||||
|
||||
-- | `show_modifier` acts like `show_mechanism` regarding the value (meaning: it can be discarded).
|
||||
-- | But this probably shouldn't since both values of modifiers actually NEED a value.
|
||||
show_modifier :: Modifier -> String
|
||||
show_modifier m =
|
||||
let mtype = show_modifier_type m.t
|
||||
value = case m.v of
|
||||
"" -> ""
|
||||
_ -> "=" <> m.v
|
||||
in mtype <> value
|
||||
|
||||
show_mechanism :: Mechanism -> String
|
||||
show_mechanism m =
|
||||
let qualifier = case maybe "" show_qualifier_char m.q of
|
||||
"+" -> ""
|
||||
v -> v
|
||||
mtype = show_mechanism_type m.t
|
||||
value = case m.v of
|
||||
"" -> ""
|
||||
_ -> "=" <> m.v
|
||||
in qualifier <> mtype <> value
|
||||
|
||||
show_qualifier_char :: Qualifier -> String
|
||||
show_qualifier_char = case _ of
|
||||
Pass -> "+"
|
||||
Neutral -> "?"
|
||||
SoftFail -> "~"
|
||||
HardFail -> "-"
|
||||
|
||||
data MechanismType = A | IP4 | IP6 | MX | PTR | EXISTS | INCLUDE
|
||||
mechanism_types :: Array String
|
||||
mechanism_types = map show_mechanism_type [ A, IP4, IP6, MX, PTR, EXISTS, INCLUDE ]
|
||||
|
||||
-- | Codec for just encoding a single value of type `MechanismType`.
|
||||
codecMechanismType :: CA.JsonCodec MechanismType
|
||||
codecMechanismType = CA.prismaticCodec "MechanismType" str_to_mechanism_type show_mechanism_type CA.string
|
||||
|
||||
str_to_mechanism_type :: String -> Maybe MechanismType
|
||||
str_to_mechanism_type = case _ of
|
||||
"a" -> Just A
|
||||
"ip4" -> Just IP4
|
||||
"ip6" -> Just IP6
|
||||
"mx" -> Just MX
|
||||
"ptr" -> Just PTR
|
||||
"exists" -> Just EXISTS
|
||||
"include" -> Just INCLUDE
|
||||
_ -> Nothing
|
||||
|
||||
show_mechanism_type :: MechanismType -> String
|
||||
show_mechanism_type = case _ of
|
||||
A -> "a"
|
||||
IP4 -> "ip4"
|
||||
IP6 -> "ip6"
|
||||
MX -> "mx"
|
||||
PTR -> "ptr"
|
||||
EXISTS -> "exists"
|
||||
INCLUDE -> "include"
|
||||
|
||||
data ModifierType = EXP | REDIRECT
|
||||
modifier_types :: Array String
|
||||
modifier_types = ["exp", "redirect"]
|
||||
|
||||
show_modifier_type :: ModifierType -> String
|
||||
show_modifier_type = case _ of
|
||||
EXP -> "exp"
|
||||
REDIRECT -> "redirect"
|
||||
|
||||
-- | Codec for just encoding a single value of type `ModifierType`.
|
||||
codecModifierType :: CA.JsonCodec ModifierType
|
||||
codecModifierType = CA.prismaticCodec "ModifierType" str_to_modifier_type show_modifier_type CA.string
|
||||
|
||||
str_to_modifier_type :: String -> Maybe ModifierType
|
||||
str_to_modifier_type = case _ of
|
||||
"exp" -> Just EXP
|
||||
"redirect" -> Just REDIRECT
|
||||
_ -> Nothing
|
||||
|
||||
type Modifier = { t :: ModifierType, v :: String {- Value (domain). -} }
|
||||
codecModifier :: JsonCodec Modifier
|
||||
codecModifier = CA.object "Modifier" (CAR.record { t: codecModifierType, v: CA.string })
|
||||
|
||||
emptyRR :: ResourceRecord
|
||||
emptyRR
|
||||
= { rrid: 0
|
||||
, readonly: false
|
||||
, rrtype: ""
|
||||
, name: ""
|
||||
, ttl: 1800
|
||||
, target: ""
|
||||
|
||||
-- MX + SRV
|
||||
, priority: Nothing
|
||||
|
||||
-- SRV
|
||||
, port: Nothing
|
||||
, protocol: Nothing
|
||||
, weight: Nothing
|
||||
|
||||
-- SOA
|
||||
, mname: Nothing
|
||||
, rname: Nothing
|
||||
, serial: Nothing
|
||||
, refresh: Nothing
|
||||
, retry: Nothing
|
||||
, expire: Nothing
|
||||
, minttl: Nothing
|
||||
|
||||
, token: Nothing
|
||||
|
||||
-- SPF specific entries.
|
||||
, v: Nothing
|
||||
, mechanisms: Nothing
|
||||
, modifiers: Nothing
|
||||
, q: Nothing
|
||||
|
||||
, dkim: Nothing
|
||||
}
|
||||
|
||||
data Qualifier = Pass | Neutral | SoftFail | HardFail
|
||||
all_qualifiers :: Array Qualifier
|
||||
all_qualifiers = [Pass, Neutral, SoftFail, HardFail]
|
||||
qualifier_types :: Array String
|
||||
qualifier_types = ["pass", "neutral", "soft_fail", "hard_fail"]
|
||||
|
||||
-- | Codec for just encoding a single value of type `Qualifier`.
|
||||
codecQualifier :: CA.JsonCodec Qualifier
|
||||
codecQualifier = CA.prismaticCodec "Qualifier" str_to_qualifier show_qualifier CA.string
|
||||
|
||||
str_to_qualifier :: String -> Maybe Qualifier
|
||||
str_to_qualifier = case _ of
|
||||
"pass" -> Just Pass -- +
|
||||
"neutral" -> Just Neutral -- ?
|
||||
"soft_fail" -> Just SoftFail -- ~
|
||||
"hard_fail" -> Just HardFail -- -
|
||||
_ -> Nothing
|
||||
|
||||
show_qualifier :: Qualifier -> String
|
||||
show_qualifier = case _ of
|
||||
Pass -> "pass"
|
||||
Neutral -> "neutral"
|
||||
SoftFail -> "soft_fail"
|
||||
HardFail -> "hard_fail"
|
||||
21
src/App/Type/UserPublic.purs
Normal file
21
src/App/Type/UserPublic.purs
Normal file
@ -0,0 +1,21 @@
|
||||
module App.Type.UserPublic where
|
||||
|
||||
import Data.Maybe (Maybe)
|
||||
|
||||
import Data.Codec.Argonaut (JsonCodec)
|
||||
import Data.Codec.Argonaut as CA
|
||||
import Data.Codec.Argonaut.Record as CAR
|
||||
|
||||
-- | Currently not the real type.
|
||||
-- | Lacks 'profile' attribute.
|
||||
-- TODO: add profile :: JSON any
|
||||
type UserPublic = { login :: String, uid :: Int, date_registration :: Maybe String }
|
||||
|
||||
-- | UserPublic.codec can be used to parse and encode public user info,
|
||||
-- | which can be exchanged in different messages.
|
||||
codec :: JsonCodec UserPublic
|
||||
codec = CA.object "UserPublic" (CAR.record { login: CA.string
|
||||
, uid: CA.int
|
||||
, date_registration: CAR.optional CA.string })
|
||||
|
||||
-- {"user":{"login":"a","uid": 1003,"date_registration":"2023-06-03T03:32:10+02:00"}}
|
||||
326
src/App/Validation/DNS.purs
Normal file
326
src/App/Validation/DNS.purs
Normal file
@ -0,0 +1,326 @@
|
||||
module App.Validation.DNS where
|
||||
|
||||
import Prelude (apply, between, bind, map, pure, ($), (-), (<), (<>), (==))
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Array as A
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..), maybe, fromMaybe)
|
||||
import Data.String.CodeUnits as CU
|
||||
import Data.String as S
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import App.Type.ResourceRecord (ResourceRecord, emptyRR, Mechanism, Modifier)
|
||||
import App.Type.ResourceRecord (MechanismType(..), ModifierType(..)) as RR
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
import GenericParser.DomainParser.Common (DomainError) as DomainParser
|
||||
import GenericParser.DomainParser (sub_eof) as DomainParser
|
||||
import GenericParser.IPAddress as IPAddress
|
||||
import GenericParser.RFC5234 as RFC5234
|
||||
|
||||
import App.Type.DKIM as DKIM
|
||||
|
||||
-- | **History:**
|
||||
-- | The module once used dedicated types for each type of RR.
|
||||
-- | That comes with several advantages.
|
||||
-- | First, type verification was a thing, and function were dedicated to a certain type of record.
|
||||
-- | Second, these dedicated types used strings for their fields,
|
||||
-- | which simplifies the typing when dealing with forms.
|
||||
-- | Finally, the validation was a way to convert dedicated types (used in forms)
|
||||
-- | to the general type (used for network serialization).
|
||||
-- | This ensures each resource record is verified before being sent to `dnsmanagerd`.
|
||||
-- |
|
||||
-- | The problem is that, with dedicated types, you are then required to have dedicated functions.
|
||||
-- | Conversion functions are also required.
|
||||
-- |
|
||||
-- | Maybe the code will change again in the future, but for now it will be enough.
|
||||
|
||||
data Error
|
||||
= UNKNOWN
|
||||
| VEIPv4 (G.Error IPAddress.IPv4Error)
|
||||
| VEIPv6 (G.Error IPAddress.IPv6Error)
|
||||
| VEName (G.Error DomainParser.DomainError)
|
||||
| VETTL Int Int Int
|
||||
| VETXT (G.Error TXTError)
|
||||
| VECNAME (G.Error DomainParser.DomainError)
|
||||
| VENS (G.Error DomainParser.DomainError)
|
||||
| VEMX (G.Error DomainParser.DomainError)
|
||||
| VEPriority Int Int Int
|
||||
| VESRV (G.Error DomainParser.DomainError)
|
||||
| VEProtocol (G.Error ProtocolError)
|
||||
| VEPort Int Int Int
|
||||
| VEWeight Int Int Int
|
||||
|
||||
-- SPF
|
||||
| VESPFMechanismName (G.Error DomainParser.DomainError)
|
||||
| VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error)
|
||||
| VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error)
|
||||
|
||||
| VESPFModifierName (G.Error DomainParser.DomainError)
|
||||
|
||||
| DKIMInvalidKeySize Int Int
|
||||
|
||||
type AVErrors = Array Error
|
||||
|
||||
-- | Current default values.
|
||||
min_ttl = 30 :: Int
|
||||
max_ttl = 86000 :: Int
|
||||
max_txt = 500 :: Int
|
||||
min_priority = 0 :: Int
|
||||
max_priority = 65535 :: Int
|
||||
min_port = 0 :: Int
|
||||
max_port = 65535 :: Int
|
||||
min_weight = 0 :: Int
|
||||
max_weight = 65535 :: Int
|
||||
|
||||
-- Functions handling network-related structures (ResourceRecord).
|
||||
|
||||
type RRPriority = Maybe Int
|
||||
type RRPort = Maybe Int
|
||||
type RRProtocol = Maybe String
|
||||
type RRWeight = Maybe Int
|
||||
type RRMname = Maybe String
|
||||
type RRRname = Maybe String
|
||||
type RRSerial = Maybe Int
|
||||
type RRRefresh = Maybe Int
|
||||
type RRRetry = Maybe Int
|
||||
type RRExpire = Maybe Int
|
||||
type RRMinttl = Maybe Int
|
||||
|
||||
data TXTError
|
||||
= TXTInvalidCharacter
|
||||
| TXTTooLong Int Int -- max current
|
||||
-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
|
||||
txt_parser :: G.Parser TXTError String
|
||||
txt_parser = do pos <- G.current_position
|
||||
v <- A.many (RFC5234.vchar <|> RFC5234.sp)
|
||||
e <- G.tryMaybe SomeParsers.eof
|
||||
pos2 <- G.current_position
|
||||
case e of
|
||||
Nothing -> G.errorParser $ Just TXTInvalidCharacter
|
||||
Just _ -> do
|
||||
let nbchar = pos2 - pos
|
||||
if nbchar < max_txt
|
||||
then pure $ CU.fromCharArray v
|
||||
else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar)
|
||||
|
||||
-- | `parse` allows to run any parser based on `GenericParser` and provide a validation error.
|
||||
-- | The actual validation error contains the parser's error including the position.
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
validationA :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationA form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse IPAddress.ipv4 form.target VEIPv4
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "A", name = name, ttl = ttl, target = target
|
||||
, token = form.token }
|
||||
|
||||
validationAAAA :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationAAAA form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
-- use read_input to get unaltered input (the IPv6 parser expands the input)
|
||||
target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "AAAA", name = name, ttl = ttl, target = target
|
||||
, token = form.token }
|
||||
|
||||
validationTXT :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationTXT form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse txt_parser form.target VETXT
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "TXT", name = name, ttl = ttl, target = target }
|
||||
|
||||
validationCNAME :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationCNAME form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse DomainParser.sub_eof form.target VECNAME
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CNAME", name = name, ttl = ttl, target = target }
|
||||
|
||||
validationNS :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationNS form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse DomainParser.sub_eof form.target VENS
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS", name = name, ttl = ttl, target = target }
|
||||
|
||||
data ProtocolError
|
||||
= InvalidProtocol
|
||||
|
||||
protocol_parser :: G.Parser ProtocolError String
|
||||
protocol_parser = do
|
||||
G.string "tcp" <|> G.string "udp" G.<:> \_ -> InvalidProtocol
|
||||
|
||||
is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> Error) -> V (Array Error) Int
|
||||
is_between min max n ve = if between min max n
|
||||
then pure n
|
||||
else invalid [ve min max n]
|
||||
|
||||
validationMX :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationMX form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse DomainParser.sub_eof form.target VEMX
|
||||
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "MX"
|
||||
, name = name, ttl = ttl, target = target, priority = Just priority }
|
||||
|
||||
validationSRV :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationSRV form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
target <- parse DomainParser.sub_eof form.target VESRV
|
||||
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
|
||||
protocol <- parse protocol_parser (maybe "" id form.protocol) VEProtocol
|
||||
port <- is_between min_port max_port (maybe 0 id form.port) VEPort
|
||||
weight <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV"
|
||||
, name = name, ttl = ttl, target = target
|
||||
, priority = Just priority, port = Just port, protocol = Just protocol, weight = Just weight }
|
||||
|
||||
-- My version of "map" lol.
|
||||
verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a)
|
||||
verification_loop _ [] = pure []
|
||||
verification_loop f arr =
|
||||
case A.head arr, A.tail arr of
|
||||
Nothing, _ -> pure []
|
||||
Just value, tail -> ado
|
||||
v <- f value
|
||||
following <- verification_loop f $ maybe [] id tail
|
||||
in [v] <> following
|
||||
|
||||
first :: forall a b. a -> b -> a
|
||||
first a _ = a
|
||||
|
||||
or_nothing :: forall e. G.Parser e String -> G.Parser e String
|
||||
or_nothing p = do v <- G.tryMaybe p
|
||||
e <- G.tryMaybe SomeParsers.eof
|
||||
case v, e of
|
||||
Just value, _ -> pure value
|
||||
_, Just _ -> pure ""
|
||||
Nothing, Nothing -> p -- at least give the right error results
|
||||
|
||||
-- | `validate_SPF_mechanism` validates the different values for each mechanism.
|
||||
-- | A and MX can both either doesn't have a value or a domain name.
|
||||
-- | EXISTS requires a domain name.
|
||||
-- |
|
||||
-- | **What differs from RFC7208**:
|
||||
-- | Some features of the mechanisms described in RFC7208 are lacking.
|
||||
-- | For instance, INCLUDE, A, MX, PTR and EXISTS accept domain *specs* not simply domain *names*.
|
||||
-- | Also, some of them should accept a CIDR, which currently isn't a thing.
|
||||
-- |
|
||||
-- | TODO: I don't intend to implement the full RFC7208, but accepting CIDR can be done.
|
||||
validate_SPF_mechanism :: Mechanism -> V (Array Error) Mechanism
|
||||
validate_SPF_mechanism m = case m.t of
|
||||
-- RFC: `a = "a" [ ":" domain-spec ] [ dual-cidr-length ]`
|
||||
RR.A -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
||||
|
||||
-- RFC: `mx = "mx" [ ":" domain-spec ] [ dual-cidr-length ]`
|
||||
RR.MX -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
||||
|
||||
-- RFC: `exists = "exists" ":" domain-spec`
|
||||
RR.EXISTS -> test DomainParser.sub_eof VESPFMechanismName
|
||||
|
||||
-- RFC: `ptr = "ptr" [ ":" domain-spec ]`
|
||||
RR.PTR -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
||||
|
||||
-- RFC: `ip4 = "ip4" ":" ip4-network [ ip4-cidr-length ]`
|
||||
RR.IP4 -> test (IPAddress.ipv4_range <|> IPAddress.ipv4) VESPFMechanismIPv4
|
||||
|
||||
-- RFC: `ip6 = "ip6" ":" ip6-network [ ip6-cidr-length ]`
|
||||
RR.IP6 -> test (IPAddress.ipv6_range <|> IPAddress.ipv6) VESPFMechanismIPv6
|
||||
|
||||
-- RFC: `include = "include" ":" domain-spec`
|
||||
RR.INCLUDE -> test DomainParser.sub_eof VESPFMechanismName
|
||||
|
||||
where
|
||||
test :: forall e. G.Parser e String -> ((G.Error e) -> Error) -> V (Array Error) Mechanism
|
||||
test p e = ado
|
||||
name <- parse p m.v e
|
||||
in first m name -- name is discarded
|
||||
|
||||
validate_SPF_modifier :: Modifier -> V (Array Error) Modifier
|
||||
validate_SPF_modifier m = case m.t of
|
||||
RR.EXP -> ado
|
||||
name <- parse DomainParser.sub_eof m.v VESPFModifierName
|
||||
in first m name -- name is discarded
|
||||
RR.REDIRECT -> ado
|
||||
name <- parse DomainParser.sub_eof m.v VESPFModifierName
|
||||
in first m name -- name is discarded
|
||||
|
||||
validationSPF :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationSPF form = ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
mechanisms <- verification_loop validate_SPF_mechanism (maybe [] id form.mechanisms)
|
||||
modifiers <- verification_loop validate_SPF_modifier (maybe [] id form.modifiers)
|
||||
-- No need to validate the target, actually, it will be completely discarded.
|
||||
-- The different specific entries replace `target` completely.
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SPF"
|
||||
, name = name, ttl = ttl, target = "" -- `target` is discarded!
|
||||
, v = form.v, mechanisms = Just mechanisms
|
||||
, modifiers = Just modifiers, q = form.q }
|
||||
|
||||
-- | Accepted RSA key sizes = 2048 or 4096 bits, 256 bits for ED25519.
|
||||
-- |
|
||||
-- | Since the public key representation for the RSA algorithm is in PKCS format (RFC 5958)
|
||||
-- | then converted in PEM (RFC 7468), and knowing this format allows some optional parameters,
|
||||
-- | it is not possible to expect an exact size for the public key input.
|
||||
-- | Consequently, we expect *at least* an input of 250 bytes for public key, loosely leading
|
||||
-- | to accept key sizes of at least 2048 bits. Maximum allowed key size is also arbitrary.
|
||||
rsa_min_key_size = 250 :: Int
|
||||
rsa_max_key_size = 1000 :: Int
|
||||
|
||||
-- | Contrary to RSA, ED25519 doesn't use a PEM-converted PKCS representation to exchange
|
||||
-- | public keys, and the key size is 256 bits (32 bytes).
|
||||
-- | This key is converted directly in base64, leading to a simple 44-byte key representation.
|
||||
ed25519_key_size = 44 :: Int
|
||||
|
||||
verify_public_key :: DKIM.SignatureAlgorithm -> DKIM.PublicKey -> V (Array Error) DKIM.PublicKey
|
||||
verify_public_key signalgo key = case signalgo of
|
||||
DKIM.RSA -> ado
|
||||
k <- if between rsa_min_key_size rsa_max_key_size (S.length key)
|
||||
then pure key
|
||||
else invalid [DKIMInvalidKeySize rsa_min_key_size rsa_max_key_size]
|
||||
in k
|
||||
DKIM.ED25519 -> ado
|
||||
k <- if S.length key == ed25519_key_size
|
||||
then pure key
|
||||
else invalid [DKIMInvalidKeySize ed25519_key_size ed25519_key_size]
|
||||
in k
|
||||
|
||||
validationDKIM :: ResourceRecord -> V (Array Error) ResourceRecord
|
||||
validationDKIM form =
|
||||
let dkim = fromMaybe DKIM.emptyDKIMRR form.dkim
|
||||
in ado
|
||||
name <- parse DomainParser.sub_eof form.name VEName
|
||||
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
||||
-- TODO: v n
|
||||
p <- verify_public_key (fromMaybe DKIM.RSA dkim.k) dkim.p
|
||||
-- No need to validate the target, actually, it will be completely discarded.
|
||||
-- The different specific entries replace `target` completely.
|
||||
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DKIM"
|
||||
, name = name, ttl = ttl, target = "" -- `target` is discarded!
|
||||
, dkim = Just $ dkim { p = p } }
|
||||
|
||||
validation :: ResourceRecord -> Either (Array Error) ResourceRecord
|
||||
validation entry = case entry.rrtype of
|
||||
"A" -> toEither $ validationA entry
|
||||
"AAAA" -> toEither $ validationAAAA entry
|
||||
"TXT" -> toEither $ validationTXT entry
|
||||
"CNAME" -> toEither $ validationCNAME entry
|
||||
"NS" -> toEither $ validationNS entry
|
||||
"MX" -> toEither $ validationMX entry
|
||||
"SRV" -> toEither $ validationSRV entry
|
||||
"SPF" -> toEither $ validationSPF entry
|
||||
"DKIM" -> toEither $ validationDKIM entry
|
||||
_ -> toEither $ invalid [UNKNOWN]
|
||||
|
||||
id :: forall a. a -> a
|
||||
id x = x
|
||||
44
src/App/Validation/Email.purs
Normal file
44
src/App/Validation/Email.purs
Normal file
@ -0,0 +1,44 @@
|
||||
module App.Validation.Email where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.RFC5322 as RFC5322
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
|
||||
data EmailParsingError
|
||||
= CannotParse
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error EmailParsingError)
|
||||
|
||||
min_email_size :: Int
|
||||
min_email_size = 5
|
||||
max_email_size :: Int
|
||||
max_email_size = 100
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
parse_full_email :: G.Parser EmailParsingError String
|
||||
parse_full_email = do
|
||||
email_address <- RFC5322.address G.<:> \_ -> CannotParse
|
||||
_ <- SomeParsers.eof G.<:> \_ -> CannotEntirelyParse
|
||||
pos <- G.current_position
|
||||
if between min_email_size max_email_size pos
|
||||
then pure email_address
|
||||
else G.errorParser $ Just $ Size min_email_size max_email_size pos
|
||||
|
||||
parserEmail :: String -> V (Array Error) String
|
||||
parserEmail str = parse parse_full_email str ParsingError
|
||||
|
||||
email :: String -> Either (Array Error) String
|
||||
email s = toEither $ parserEmail s
|
||||
41
src/App/Validation/Label.purs
Normal file
41
src/App/Validation/Label.purs
Normal file
@ -0,0 +1,41 @@
|
||||
module App.Validation.Label where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.Parser as G
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.DomainParser.Common (DomainError) as DomainParser
|
||||
import GenericParser.DomainParserRFC1035 (label) as RFC1035
|
||||
|
||||
data LabelParsingError
|
||||
= CannotParse (DomainParser.DomainError)
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error LabelParsingError)
|
||||
|
||||
min_label_size = 1 :: Int -- arbitrary
|
||||
max_label_size = 63 :: Int -- arbitrary
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
label_parser :: G.Parser LabelParsingError String
|
||||
label_parser = do
|
||||
input <- G.current_input
|
||||
_ <- RFC1035.label G.<:> \e -> CannotParse e
|
||||
_ <- SomeParsers.eof G.<:> \_ -> CannotEntirelyParse
|
||||
pos <- G.current_position
|
||||
if between min_label_size max_label_size pos
|
||||
then pure input.string
|
||||
else G.errorParser (Just $ Size min_label_size max_label_size pos)
|
||||
|
||||
label :: String -> Either (Array Error) String
|
||||
label s = toEither $ parse label_parser s ParsingError
|
||||
43
src/App/Validation/Login.purs
Normal file
43
src/App/Validation/Login.purs
Normal file
@ -0,0 +1,43 @@
|
||||
module App.Validation.Login where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.RFC5234 (alpha, digit)
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
|
||||
data LoginParsingError
|
||||
= CannotParse
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error LoginParsingError)
|
||||
|
||||
min_login_size :: Int
|
||||
min_login_size = 2
|
||||
max_login_size :: Int
|
||||
max_login_size = 50
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
login_parser :: G.Parser LoginParsingError String
|
||||
login_parser = do
|
||||
input <- G.current_input
|
||||
_ <- G.many1 (alpha <|> digit) G.<:> \_ -> CannotParse
|
||||
_ <- SomeParsers.eof G.<:> \_ -> CannotEntirelyParse
|
||||
pos <- G.current_position
|
||||
if between min_login_size max_login_size pos
|
||||
then pure input.string
|
||||
else G.errorParser (Just $ Size min_login_size max_login_size pos)
|
||||
|
||||
login :: String -> Either (Array Error) String
|
||||
login s = toEither $ parse login_parser s ParsingError
|
||||
43
src/App/Validation/Password.purs
Normal file
43
src/App/Validation/Password.purs
Normal file
@ -0,0 +1,43 @@
|
||||
module App.Validation.Password where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Either (Either(..))
|
||||
import Data.String.CodeUnits as CU
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.RFC5234 (vchar)
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
|
||||
data PasswordParsingError
|
||||
= CannotParse
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error PasswordParsingError)
|
||||
|
||||
min_password_size :: Int
|
||||
min_password_size = 2
|
||||
max_password_size :: Int
|
||||
max_password_size = 100
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
password_parser :: G.Parser PasswordParsingError String
|
||||
password_parser = do
|
||||
l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
|
||||
_ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
|
||||
pos <- G.current_position
|
||||
if pos < min_password_size || pos > max_password_size
|
||||
then G.Parser \i -> G.failureError i.position (Just $ Size min_password_size max_password_size pos)
|
||||
else pure $ CU.fromCharArray l
|
||||
|
||||
password :: String -> Either (Array Error) String
|
||||
password s = toEither $ parse password_parser s ParsingError
|
||||
44
src/App/Validation/Token.purs
Normal file
44
src/App/Validation/Token.purs
Normal file
@ -0,0 +1,44 @@
|
||||
module App.Validation.Token where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alt ((<|>))
|
||||
import Data.Either (Either(..))
|
||||
import Data.String.CodeUnits as CU
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.Validation.Semigroup (V, invalid, toEither)
|
||||
|
||||
import GenericParser.RFC5234 (vchar)
|
||||
import GenericParser.SomeParsers as SomeParsers
|
||||
import GenericParser.Parser as G
|
||||
|
||||
data TokenParsingError
|
||||
= CannotParse
|
||||
| CannotEntirelyParse
|
||||
| Size Int Int Int
|
||||
|
||||
data Error
|
||||
= ParsingError (G.Error TokenParsingError)
|
||||
|
||||
-- | TODO: this number should be exactly the size of the provided token.
|
||||
min_token_size :: Int
|
||||
min_token_size = 20
|
||||
max_token_size :: Int
|
||||
max_token_size = 60
|
||||
|
||||
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
||||
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
||||
Left x -> invalid $ [c x]
|
||||
Right x -> pure x.result
|
||||
|
||||
token_parser :: G.Parser TokenParsingError String
|
||||
token_parser = do
|
||||
l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse)
|
||||
_ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse)
|
||||
pos <- G.current_position
|
||||
if pos < min_token_size || pos > max_token_size
|
||||
then G.Parser \i -> G.failureError i.position (Just $ Size min_token_size max_token_size pos)
|
||||
else pure $ CU.fromCharArray l
|
||||
|
||||
token :: String -> Either (Array Error) String
|
||||
token s = toEither $ parse token_parser s ParsingError
|
||||
334
src/App/WS.purs
Normal file
334
src/App/WS.purs
Normal file
@ -0,0 +1,334 @@
|
||||
-- | This component handles all WS operations.
|
||||
-- | This includes telling when a connection is established or closed, and notify a message has been received.
|
||||
module App.WS where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, show, void, when
|
||||
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<))
|
||||
|
||||
import Control.Monad.Rec.Class (forever)
|
||||
import Control.Monad.Except (runExcept)
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Bifunctor (lmap)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..), isJust, isNothing)
|
||||
import Data.String as String
|
||||
import Data.Tuple (Tuple(..))
|
||||
import Effect.Aff as Aff
|
||||
import Effect.Aff (Milliseconds(..))
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Effect (Effect)
|
||||
import Foreign as F
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.Query.Event as HQE
|
||||
import Halogen.Subscription as HS
|
||||
import Web.Socket.BinaryType (BinaryType(ArrayBuffer))
|
||||
import Web.Socket.Event.CloseEvent as WSCE
|
||||
import Web.Socket.Event.EventTypes as WSET
|
||||
import Web.Socket.Event.MessageEvent as WSME
|
||||
import Web.Socket.ReadyState (ReadyState(Connecting, Open, Closing, Closed))
|
||||
import Web.Socket.WebSocket as WS
|
||||
|
||||
import App.Type.LogMessage
|
||||
|
||||
keepalive = 30000.0 :: Number
|
||||
|
||||
-- Input is the WS url.
|
||||
type Input = String
|
||||
|
||||
-- | The component can perform 4 actions: log messages, notify that a message has been received,
|
||||
-- | notify when a connection has been established or when it has been closed.
|
||||
data Output
|
||||
-- | MessageReceived (Tuple URL message)
|
||||
= MessageReceived (Tuple String ArrayBuffer) -- Provide a received message to the parent.
|
||||
| WSJustConnected -- Inform the parent the connection is up.
|
||||
| WSJustClosed -- Inform the parent the connection is down.
|
||||
| Log LogMessage
|
||||
| KeepAlive -- Ask the parent to handle a keep-alive message.
|
||||
|
||||
-- | The component can receive a single action from other components: sending a message throught the websocket.
|
||||
data Query a = ToSend ArrayBuffer a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
-- | `timer` triggers a `Tick` action every `keepalive` ms.
|
||||
timer :: forall m a. MonadAff m => a -> m (HS.Emitter a)
|
||||
timer val = do
|
||||
{ emitter, listener } <- H.liftEffect HS.create
|
||||
_ <- H.liftAff $ Aff.forkAff $ forever do
|
||||
Aff.delay $ Milliseconds keepalive
|
||||
H.liftEffect $ HS.notify listener val
|
||||
pure emitter
|
||||
|
||||
data Action
|
||||
-- | `Initialize` opens the connection (URL is received as an `input` of this component).
|
||||
= Initialize
|
||||
|
||||
-- | The component provides a log each time a message failed to be parsed.
|
||||
| WebSocketParseError String
|
||||
|
||||
-- | The component shows buttons when the connection is dropped for some reason.
|
||||
-- | To reconnect, the button is clicked, and the `ConnectWebSocket` action is performed.
|
||||
| ConnectWebSocket
|
||||
|
||||
-- | `SendMessage` effectively sends a message through the ws connection.
|
||||
| SendMessage ArrayBuffer
|
||||
|
||||
-- | `Finalize` is the action performed once the component is destroyed, ending the connection.
|
||||
| Finalize
|
||||
|
||||
-- | Tick: keep alive WS connections.
|
||||
| Tick
|
||||
|
||||
-- | Every received websocket message and notification is handled in `HandleWebSocket`.
|
||||
| HandleWebSocket (WebSocketEvent WebSocketMessageType)
|
||||
|
||||
-- | The type `WSInfo` helps handle a websocket.
|
||||
-- | `WSInfo` is composed of an URL, an actual socket and a boolean
|
||||
-- | to inform if the connection has to be re-established.
|
||||
type WSInfo
|
||||
= { url :: String
|
||||
, connection :: Maybe WS.WebSocket
|
||||
, reconnect :: Boolean
|
||||
}
|
||||
|
||||
-- | The state of this component only is composed of the websocket.
|
||||
type State = { wsInfo :: WSInfo }
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ initialize = Just Initialize
|
||||
, handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
, finalize = Just Finalize
|
||||
}
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState url =
|
||||
{ wsInfo: { url: url
|
||||
, connection: Nothing
|
||||
, reconnect: false
|
||||
}
|
||||
}
|
||||
|
||||
-- | The component shows a string when the connection is established, or a button when the connection has closed.
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render { wsInfo }
|
||||
= HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ]
|
||||
where
|
||||
renderFootnote :: String -> H.ComponentHTML Action () m
|
||||
renderFootnote txt =
|
||||
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
|
||||
|
||||
renderReconnectButton :: Boolean -> H.ComponentHTML Action () m
|
||||
renderReconnectButton cond =
|
||||
if cond
|
||||
then
|
||||
HH.p_
|
||||
[ HH.button
|
||||
[ HP.type_ HP.ButtonButton
|
||||
, HE.onClick \_ -> ConnectWebSocket
|
||||
]
|
||||
[ HH.text "Reconnect?" ]
|
||||
]
|
||||
else
|
||||
HH.p_
|
||||
[ renderFootnote $
|
||||
"NOTE: A 'Reconnect?' button will appear if the connection drops (for URL: '"
|
||||
<>
|
||||
wsInfo.url
|
||||
<>
|
||||
"')"
|
||||
]
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction action = do
|
||||
{ wsInfo } <- H.get
|
||||
case action of
|
||||
Initialize -> do
|
||||
_ <- H.subscribe =<< timer Tick
|
||||
handleAction ConnectWebSocket
|
||||
|
||||
Tick -> H.raise KeepAlive
|
||||
|
||||
Finalize -> do
|
||||
-- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
|
||||
case wsInfo.connection of
|
||||
Nothing -> H.raise $ Log $ SystemLog "No socket? How is that even possible?"
|
||||
Just socket -> H.liftEffect $ WS.close socket
|
||||
|
||||
WebSocketParseError error ->
|
||||
H.raise $ Log $ SystemLog $ renderError (UnknownError error)
|
||||
|
||||
ConnectWebSocket -> do
|
||||
-- H.raise $ Log $ SystemLog $ "Connecting to \"" <> wsInfo.url <> "\"..."
|
||||
webSocket <- H.liftEffect $ WS.create wsInfo.url []
|
||||
H.liftEffect $ WS.setBinaryType webSocket ArrayBuffer
|
||||
H.modify_ _ { wsInfo { connection = Just webSocket } }
|
||||
void $ H.subscribe (HandleWebSocket <$> webSocketEmitter webSocket)
|
||||
|
||||
SendMessage array_buffer_to_send -> do
|
||||
case wsInfo.connection of
|
||||
Nothing -> H.raise $ Log $ UnableToSend $ "Websocket is down!"
|
||||
Just webSocket -> H.liftEffect $ do
|
||||
sendArrayBuffer webSocket array_buffer_to_send
|
||||
|
||||
HandleWebSocket wsEvent -> do
|
||||
case wsEvent of
|
||||
WebSocketMessage received_message -> do
|
||||
H.raise $ MessageReceived $ Tuple wsInfo.url received_message.message
|
||||
|
||||
WebSocketOpen -> do
|
||||
H.raise $ WSJustConnected
|
||||
|
||||
WebSocketClose { code, reason, wasClean } -> do
|
||||
H.raise $ Log $ SystemLog $ renderCloseMessage code wasClean reason
|
||||
maybeCurrentConnection <- H.gets _.wsInfo.connection
|
||||
when (isJust maybeCurrentConnection) do
|
||||
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
|
||||
H.raise $ WSJustClosed
|
||||
|
||||
WebSocketError errorType -> do
|
||||
H.raise $ Log $ SystemLog $ renderError errorType
|
||||
H.raise $ WSJustClosed
|
||||
|
||||
where
|
||||
renderCloseMessage
|
||||
:: Int
|
||||
-> Boolean
|
||||
-> String
|
||||
-> String
|
||||
renderCloseMessage code wasClean = case _ of
|
||||
"" -> baseCloseMessage
|
||||
reason -> baseCloseMessage <> "Reason: " <> reason
|
||||
where
|
||||
baseCloseMessage :: String
|
||||
baseCloseMessage =
|
||||
String.joinWith " "
|
||||
[ "Connection to WebSocket closed"
|
||||
, "[ CODE:" , show code , "|" , if wasClean then "CLEAN" else "DIRTY" , "]"
|
||||
]
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
ToSend message a -> do
|
||||
send_message message
|
||||
pure (Just a)
|
||||
|
||||
send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
|
||||
send_message message = do
|
||||
{ wsInfo } <- H.get
|
||||
case wsInfo.connection of
|
||||
Nothing -> H.raise $ Log $ UnableToSend "Not connected to server."
|
||||
Just webSocket -> do
|
||||
H.liftEffect (WS.readyState webSocket) >>= case _ of
|
||||
Connecting -> H.raise $ Log $ UnableToSend "Still connecting to server."
|
||||
Closing -> H.raise $ Log $ UnableToSend "Connection to server is closing."
|
||||
Closed -> do
|
||||
H.raise $ Log $ UnableToSend "Connection to server has been closed."
|
||||
H.modify_ _ { wsInfo { connection = Nothing, reconnect = true } }
|
||||
Open -> H.liftEffect $ sendArrayBuffer webSocket message
|
||||
--------------------------------------------------------------------------------
|
||||
-- WebSocket mess.
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data WebSocketEvent :: Type -> Type
|
||||
data WebSocketEvent msg
|
||||
= WebSocketMessage { message :: msg, origin :: String, lastEventId :: String }
|
||||
| WebSocketOpen
|
||||
| WebSocketClose { code :: Int, reason :: String, wasClean :: Boolean }
|
||||
| WebSocketError ErrorType
|
||||
|
||||
webSocketEmitter :: WS.WebSocket -> HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
webSocketEmitter socket = do
|
||||
|
||||
HS.makeEmitter \push -> do
|
||||
|
||||
openId <- HS.subscribe openEmitter push
|
||||
errorId <- HS.subscribe errorEmitter push
|
||||
closeId <- HS.subscribe closeEmitter push
|
||||
messageId <- HS.subscribe messageEmitter push
|
||||
|
||||
pure do
|
||||
HS.unsubscribe openId
|
||||
HS.unsubscribe errorId
|
||||
HS.unsubscribe closeId
|
||||
HS.unsubscribe messageId
|
||||
|
||||
where
|
||||
target = WS.toEventTarget socket
|
||||
|
||||
openEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
openEmitter =
|
||||
HQE.eventListener WSET.onOpen target \_ ->
|
||||
Just WebSocketOpen
|
||||
|
||||
errorEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
errorEmitter =
|
||||
HQE.eventListener WSET.onError target \_ ->
|
||||
Just (WebSocketError UnknownWebSocketError)
|
||||
|
||||
closeEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
closeEmitter =
|
||||
HQE.eventListener WSET.onClose target \event ->
|
||||
WSCE.fromEvent event >>= \closeEvent ->
|
||||
Just $ WebSocketClose { code: WSCE.code closeEvent
|
||||
, reason: WSCE.reason closeEvent
|
||||
, wasClean: WSCE.wasClean closeEvent
|
||||
}
|
||||
|
||||
messageEmitter :: HS.Emitter (WebSocketEvent WebSocketMessageType)
|
||||
messageEmitter = HQE.eventListener WSET.onMessage target (WSME.fromEvent >=> decodeMessageEvent)
|
||||
|
||||
decodeMessageEvent :: WSME.MessageEvent -> Maybe (WebSocketEvent WebSocketMessageType)
|
||||
decodeMessageEvent = \msgEvent -> do
|
||||
let
|
||||
foreign' :: F.Foreign
|
||||
foreign' = WSME.data_ msgEvent
|
||||
case foreignToArrayBuffer foreign' of
|
||||
Left errs -> pure $ WebSocketError $ UnknownError errs
|
||||
Right arrayBuffer -> pure $ WebSocketMessage { message: arrayBuffer
|
||||
, origin: WSME.origin msgEvent
|
||||
, lastEventId: WSME.lastEventId msgEvent }
|
||||
|
||||
---------------------------
|
||||
-- Errors
|
||||
---------------------------
|
||||
|
||||
data ErrorType
|
||||
= UnknownError String
|
||||
| UnknownWebSocketError
|
||||
|
||||
renderError :: ErrorType -> String
|
||||
renderError = case _ of
|
||||
UnknownError str ->
|
||||
"Unknown error: " <> str
|
||||
UnknownWebSocketError ->
|
||||
"Unknown 'error' event has been fired by WebSocket event listener"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- WebSocket message type
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type WebSocketMessageType = ArrayBuffer
|
||||
|
||||
sendArrayBuffer :: WS.WebSocket -> ArrayBuffer -> Effect Unit
|
||||
sendArrayBuffer = WS.sendArrayBuffer
|
||||
|
||||
foreignToArrayBuffer :: F.Foreign -> Either String ArrayBuffer
|
||||
foreignToArrayBuffer
|
||||
= lmap renderForeignErrors
|
||||
<<< runExcept
|
||||
<<< F.unsafeReadTagged "ArrayBuffer"
|
||||
where
|
||||
renderForeignErrors :: F.MultipleErrors -> String
|
||||
renderForeignErrors =
|
||||
String.joinWith "; " <<< A.fromFoldable <<< map F.renderForeignError
|
||||
508
src/Bulma.purs
Normal file
508
src/Bulma.purs
Normal file
@ -0,0 +1,508 @@
|
||||
-- | The `Bulma` module is a wrapper around the BULMA css framework.
|
||||
module Bulma where
|
||||
import Prelude
|
||||
|
||||
import Halogen.HTML as HH
|
||||
import DOM.HTML.Indexed as DHI
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.HTML.Events as HE
|
||||
-- import MissingHTMLProperties as MissingProperties
|
||||
|
||||
import CSSClasses as C
|
||||
|
||||
import Halogen.HTML.Core (AttrName(..))
|
||||
-- import Web.Event.Event (type_, Event, EventType(..))
|
||||
-- import Web.UIEvent.MouseEvent (MouseEvent) -- package web-uievents
|
||||
|
||||
columns :: forall (w :: Type) (i :: Type).
|
||||
Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
columns classes = HH.div [ HP.classes (C.columns <> classes) ]
|
||||
|
||||
columns_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||
columns_ = columns []
|
||||
|
||||
column :: forall (w :: Type) (i :: Type).
|
||||
Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
column classes = HH.div [ HP.classes (C.column <> classes) ]
|
||||
|
||||
column_ :: forall (w :: Type) (i :: Type). Array (HH.HTML w i) -> HH.HTML w i
|
||||
column_ = column []
|
||||
|
||||
h1 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
h1 title = HH.h1 [ HP.classes (C.title) ] [ HH.text title ]
|
||||
|
||||
h3 :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
h3 title = HH.h3 [ HP.classes (C.title <> C.is5) ] [ HH.text title ]
|
||||
|
||||
zone_rr_title :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
zone_rr_title title
|
||||
= HH.h3 [ HP.classes (C.title <> C.is5 <> C.has_text_light <> C.has_background_dark) ]
|
||||
[ HH.text title ]
|
||||
|
||||
subtitle :: forall (w :: Type) (a :: Type). String -> HH.HTML w a
|
||||
subtitle title = HH.h2 [ HP.classes (C.subtitle <> C.is4) ] [ HH.text title ]
|
||||
|
||||
hdiv :: forall (w :: Type) (a :: Type). Array (HH.HTML w a) -> HH.HTML w a
|
||||
hdiv = HH.div [ HP.classes [HH.ClassName "mt-5"] ]
|
||||
|
||||
--offcolumn :: forall (w :: Type) (a :: Type).
|
||||
-- Int -> Int -> Array (HH.HTML w a) -> HH.HTML w a
|
||||
--offcolumn 0 size = HH.div [ HP.classes [HH.ClassName ("mt-"<>show size)] ]
|
||||
--offcolumn offset size
|
||||
-- = column [ HH.ClassName ("is-offset-" <> (show offset) <> " is-" <> (show size)) ]
|
||||
|
||||
input_classes :: Array HH.ClassName
|
||||
input_classes = C.input <> C.is_small <> C.is_info
|
||||
|
||||
table :: forall w i. HH.Node DHI.HTMLtable w i
|
||||
table prop xs = HH.table ([ HP.classes $ C.table ] <> prop) xs
|
||||
|
||||
table_ :: forall w i. Array HH.ClassName -> HH.Node DHI.HTMLtable w i
|
||||
table_ classes prop xs = HH.table ([ HP.classes $ C.table <> classes] <> prop) xs
|
||||
|
||||
mechanism_table_header :: forall w i. HH.HTML w i
|
||||
mechanism_table_header
|
||||
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Policy" ]
|
||||
, HH.th_ [ HH.text "Type" ]
|
||||
, HH.th_ [ HH.text "Value" ]
|
||||
, HH.th_ [ HH.text "" ]
|
||||
]
|
||||
]
|
||||
|
||||
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
|
||||
, HP.value value
|
||||
, HP.placeholder placeholder
|
||||
, HP.classes $ C.textarea <> classes
|
||||
]
|
||||
|
||||
textarea :: forall w i. String -> String -> (String -> i) -> HH.HTML w i
|
||||
textarea placeholder value action = textarea_ [] placeholder value action
|
||||
|
||||
btn_modify :: forall w i. i -> HH.HTML w i
|
||||
btn_modify action = btn_ (C.is_small <> C.is_info) "⚒" action
|
||||
|
||||
btn_save :: forall w i. i -> HH.HTML w i
|
||||
btn_save action = btn_ C.is_info "Save" action
|
||||
|
||||
btn_add :: forall w i. i -> HH.HTML w i
|
||||
btn_add action = btn_ C.is_info "Add" action
|
||||
|
||||
btn_delete :: forall w i. i -> HH.HTML w i
|
||||
btn_delete action = btn_ (C.is_small <> C.is_danger) "✖" action
|
||||
|
||||
btn_modify_ro :: forall w i. HH.HTML w i
|
||||
btn_modify_ro = btn_ro (C.is_small <> C.is_warning) "modify"
|
||||
|
||||
btn_readonly :: forall w i. HH.HTML w i
|
||||
btn_readonly = btn_ro (C.is_small <> C.is_warning) "read only"
|
||||
|
||||
btn_delete_ro :: forall w i. HH.HTML w i
|
||||
btn_delete_ro = btn_ro (C.is_small <> C.is_warning) "remove"
|
||||
|
||||
btn_ro :: forall w i. Array HH.ClassName -> String -> HH.HTML w i
|
||||
btn_ro classes title
|
||||
= HH.button
|
||||
[ HP.classes $ C.button <> classes
|
||||
] [ HH.text title ]
|
||||
|
||||
-- | Create a `level`, different components that should appear on the same horizontal line.
|
||||
-- | First argument, elements that should appear on the left, second on the right.
|
||||
level :: forall w i. Array (HH.HTML w i) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
level left right = HH.nav [ HP.classes C.level ]
|
||||
[ HH.div [ HP.classes C.level_left ] $ itemize left
|
||||
, HH.div [ HP.classes C.level_right ] $ itemize right
|
||||
]
|
||||
where itemize = map (\v -> HH.div [ HP.classes C.level_item ] [v])
|
||||
|
||||
btn_ :: forall w action. Array HH.ClassName -> String -> action -> HH.HTML w action
|
||||
btn_ classes title action
|
||||
= HH.button
|
||||
[ HE.onClick \_ -> action
|
||||
, HP.classes $ C.button <> classes
|
||||
] [ HH.text title ]
|
||||
|
||||
btn :: forall w action. String -> action -> HH.HTML w action
|
||||
btn title action = btn_ [] title action
|
||||
|
||||
alert_btn :: forall w action. String -> action -> HH.HTML w action
|
||||
alert_btn title action = btn_ C.is_danger title action
|
||||
|
||||
render_input :: forall w i.
|
||||
Boolean -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
||||
render_input password id placeholder action value cond
|
||||
= HH.input $
|
||||
[ HE.onValueInput action
|
||||
, HP.value value
|
||||
, HP.placeholder placeholder
|
||||
, HP.classes $ input_classes
|
||||
, HP.id id
|
||||
, cond
|
||||
] <> case password of
|
||||
false -> []
|
||||
true -> [ HP.type_ HP.InputPassword ]
|
||||
|
||||
div_field :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
div_field = HH.div [HP.classes (C.field <> C.is_horizontal)]
|
||||
|
||||
div_field_label :: forall w i. String -> String -> HH.HTML w i
|
||||
div_field_label id title = HH.div [HP.classes (C.field_label <> C.normal)]
|
||||
[HH.label [ HP.classes C.label, HP.for id ] [ HH.text title ]]
|
||||
|
||||
div_field_content :: forall w i. HH.HTML w i -> HH.HTML w i
|
||||
div_field_content content
|
||||
= HH.div [ HP.classes C.field_body ]
|
||||
[ HH.div [HP.classes C.field ] [ HH.div [HP.classes C.control ] [ content ] ] ]
|
||||
|
||||
field_inner :: forall w i.
|
||||
Boolean -> String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
||||
field_inner ispassword id title placeholder action value cond
|
||||
= div_field
|
||||
[ div_field_label id title
|
||||
, div_field_content $ render_input ispassword id placeholder action value cond
|
||||
]
|
||||
|
||||
div_field_ :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
div_field_ classes = HH.div [ HP.classes (C.field <> classes) ]
|
||||
|
||||
btn_labeled :: forall w i. String -> String -> String -> i -> HH.HTML w i
|
||||
btn_labeled id title button_text action
|
||||
= div_field
|
||||
[ div_field_label id title
|
||||
, div_field_content $ HH.button
|
||||
[ HE.onClick \_ -> action
|
||||
, HP.classes $ C.button <> C.is_small <> C.is_info
|
||||
, HP.id id
|
||||
] [ HH.text button_text ]
|
||||
]
|
||||
|
||||
labeled_field :: forall w i. String -> String -> HH.HTML w i -> HH.HTML w i
|
||||
labeled_field id title content
|
||||
= div_field
|
||||
[ div_field_label id title
|
||||
, div_field_content content
|
||||
]
|
||||
|
||||
box_input :: forall w i.
|
||||
String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
||||
box_input = field_inner false
|
||||
|
||||
box_password :: forall w i.
|
||||
String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
||||
box_password = field_inner true
|
||||
|
||||
section_small :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
section_small = HH.section [ HP.classes (C.section <> C.is_small) ]
|
||||
|
||||
section_medium :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
section_medium = HH.section [ HP.classes (C.section <> C.medium) ]
|
||||
|
||||
new_domain_field :: forall w i.
|
||||
(String -> i) -> String -> Array (HP.IProp DHI.HTMLselect i) -> Array String -> HH.HTML w i
|
||||
new_domain_field inputaction text_ selectaction accepted_domains
|
||||
= div_field_ C.has_addons
|
||||
[ HH.p
|
||||
[ HP.classes C.control ]
|
||||
[ HH.input $
|
||||
[ HE.onValueInput inputaction
|
||||
, HP.placeholder "www"
|
||||
, HP.value text_
|
||||
, HP.type_ HP.InputText
|
||||
, HP.classes (C.is_primary <> C.input)
|
||||
]
|
||||
]
|
||||
, HH.p
|
||||
[ HP.classes C.control ]
|
||||
[ select selectaction $ map option accepted_domains ]
|
||||
]
|
||||
|
||||
code :: forall w i. String -> HH.HTML w i
|
||||
code str = HH.code_ [ HH.text str ]
|
||||
|
||||
text :: forall w i. String -> HH.HTML w i
|
||||
text = HH.text
|
||||
|
||||
p :: forall w i. String -> HH.HTML w i
|
||||
p str = HH.p_ [ HH.text str ]
|
||||
|
||||
p_ :: forall w i. Array HH.ClassName -> String -> HH.HTML w i
|
||||
p_ classes str = HH.p [HP.classes classes] [ HH.text str ]
|
||||
|
||||
box :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
box = HH.div [HP.classes C.box]
|
||||
|
||||
box_ :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
box_ classes = HH.div [HP.classes $ C.box <> classes]
|
||||
|
||||
option :: forall w i. String -> HH.HTML w i
|
||||
option value = HH.option_ [HH.text value]
|
||||
|
||||
select :: forall w i. HH.Node DHI.HTMLselect w i
|
||||
select action options
|
||||
= HH.div [ HP.classes (C.select <> C.is_primary) ]
|
||||
[ HH.select action options]
|
||||
|
||||
hero :: forall w i. String -> String -> HH.HTML w i
|
||||
hero _title _subtitle
|
||||
= HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
|
||||
[ HH.div [ HP.classes C.hero_body ]
|
||||
[ HH.p [ HP.classes C.title ] [ HH.text _title ]
|
||||
, HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
|
||||
]
|
||||
]
|
||||
|
||||
small_hero :: forall w i. String -> String -> HH.HTML w i
|
||||
small_hero _title _subtitle =
|
||||
HH.section [ HP.classes (C.hero <> C.is_info <> C.is_small) ]
|
||||
[ HH.div [ HP.classes C.hero_body ]
|
||||
[ HH.div [ HP.classes $ C.container <> C.has_text_centered ]
|
||||
[ HH.p [ HP.classes C.title ] [ HH.text _title ]
|
||||
, HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
|
||||
]
|
||||
]
|
||||
]
|
||||
|
||||
hero_danger :: forall w i. String -> String -> HH.HTML w i
|
||||
hero_danger _title _subtitle
|
||||
= HH.section [ HP.classes (C.hero <> C.is_danger <> C.is_small) ]
|
||||
[ HH.div [ HP.classes C.hero_body ]
|
||||
[ HH.p [ HP.classes C.title ] [ HH.text _title ]
|
||||
, HH.p [ HP.classes C.subtitle ] [ HH.text _subtitle ]
|
||||
]
|
||||
]
|
||||
|
||||
header :: forall w i. String -> String -> HH.HTML w i
|
||||
header = hero
|
||||
|
||||
container :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
container = HH.div [HP.classes (C.container <> C.is_info)]
|
||||
|
||||
data_target :: forall r i. String -> HP.IProp r i
|
||||
data_target = HP.attr (AttrName "data-target")
|
||||
|
||||
modal_ :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
modal_ = HH.div [HP.classes (C.modal <> C.is_active)]
|
||||
modal_background :: forall w i. HH.HTML w i
|
||||
modal_background = HH.div [HP.classes C.modal_background] []
|
||||
modal_card :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
modal_card = HH.div [HP.classes C.modal_card]
|
||||
modal_header :: forall w i. String -> HH.HTML w i
|
||||
modal_header title = HH.header [HP.classes C.modal_card_head]
|
||||
[ HH.p [HP.classes C.modal_card_title] [HH.text title]
|
||||
]
|
||||
modal_body :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
modal_body = HH.section [HP.classes C.modal_card_body]
|
||||
modal_foot :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
modal_foot = HH.div [HP.classes C.modal_card_foot]
|
||||
|
||||
cancel_button :: forall w i. i -> HH.HTML w i
|
||||
cancel_button action
|
||||
= HH.button [ HP.classes C.button
|
||||
, HE.onClick \_ -> action
|
||||
] [HH.text "Cancel"]
|
||||
|
||||
strong :: forall w i. String -> HH.HTML w i
|
||||
strong str = HH.strong_ [ HH.text str ]
|
||||
|
||||
hr :: forall w i. HH.HTML w i
|
||||
hr = HH.hr_
|
||||
|
||||
tile :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
tile classes = HH.div [HP.classes (C.tile <> classes)]
|
||||
|
||||
tile_ :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
tile_ = tile []
|
||||
|
||||
tile_danger :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
tile_danger classes = tile (C.is_danger <> C.notification <> classes)
|
||||
|
||||
tile_warning :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
tile_warning classes = tile (C.is_warning <> C.notification <> classes)
|
||||
|
||||
article_ :: forall w i. Array HH.ClassName -> HH.HTML w i -> HH.HTML w i -> HH.HTML w i
|
||||
article_ classes head body = HH.article [HP.classes (C.message <> classes)]
|
||||
[ HH.div [HP.classes C.message_header] [head]
|
||||
, HH.div [HP.classes C.message_body ] [body]
|
||||
]
|
||||
|
||||
article :: forall w i. HH.HTML w i -> HH.HTML w i -> HH.HTML w i
|
||||
article head body = article_ [] head body
|
||||
|
||||
error_message :: forall w i. HH.HTML w i -> HH.HTML w i -> HH.HTML w i
|
||||
error_message head body = article_ C.is_danger head body
|
||||
|
||||
input_with_side_text :: forall w i.
|
||||
String -> String -> String -> (String -> i) -> String -> String -> HH.HTML w i
|
||||
input_with_side_text id title placeholder action value sidetext
|
||||
= HH.div [HP.classes $ C.has_addons <> C.field <> C.is_horizontal]
|
||||
[ HH.div [ HP.classes (C.field_label <> C.normal) ]
|
||||
[HH.label [ HP.classes C.label, HP.for id ] [ HH.text title ]]
|
||||
, HH.div [ HP.classes C.field_body ]
|
||||
[ HH.p [HP.classes C.control]
|
||||
[ HH.input $
|
||||
[ HE.onValueInput action
|
||||
, HP.value value
|
||||
, HP.placeholder placeholder
|
||||
, HP.classes $ input_classes
|
||||
, HP.id id
|
||||
]
|
||||
]
|
||||
, HH.p [HP.classes C.control]
|
||||
[ HH.a [HP.classes $ C.button <> C.is_small <> C.is_static]
|
||||
[HH.text sidetext] ]
|
||||
]
|
||||
]
|
||||
|
||||
-- | `modal`: create a modal by providing a few things:
|
||||
-- | - a title (a simple String)
|
||||
-- | - a body (`HTML` content)
|
||||
-- | - a footer (`HTML` content)
|
||||
modal :: forall w i. String -> Array (HH.HTML w i) -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
modal title body foot =
|
||||
modal_
|
||||
[ modal_background
|
||||
, modal_card [modal_header title, modal_body body]
|
||||
, modal_foot foot
|
||||
]
|
||||
|
||||
-- selection: create a "select" input.
|
||||
-- Get the changes with "onSelectedIndexChange" which provides an index.
|
||||
selection :: forall w i. (Int -> i) -> Array String -> String -> HH.HTML w i
|
||||
selection action values selected = HH.div [HP.classes $ C.select <> C.is_normal]
|
||||
[ HH.select [ HE.onSelectedIndexChange action ]
|
||||
$ map (\n -> HH.option [HP.value n, HP.selected (n == selected)] [HH.text n]) values
|
||||
]
|
||||
|
||||
selection_field :: forall w i. String -> String -> (Int -> i) -> Array String -> String -> HH.HTML w i
|
||||
selection_field id title action values selected
|
||||
= div_field
|
||||
[ div_field_label id title
|
||||
, div_field_content $ selection action values selected
|
||||
]
|
||||
|
||||
tag_light_info :: forall w i. String -> HH.HTML w i
|
||||
tag_light_info str = HH.span [HP.classes (C.tag <> C.is_info <> C.is_light)] [HH.text str]
|
||||
|
||||
div_large_content :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
div_large_content content = HH.div [HP.classes (C.is_large <> C.content)] content
|
||||
|
||||
div_content :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
div_content content = HH.div [HP.classes (C.content)] content
|
||||
|
||||
explanation :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
explanation content = HH.blockquote [HP.classes [HH.ClassName "justified"]] content
|
||||
|
||||
|
||||
tabs :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
|
||||
tabs classes tab_list = HH.div [HP.classes $ C.tabs <> classes] [HH.ul_ tab_list]
|
||||
|
||||
fancy_tabs :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
|
||||
fancy_tabs arr = tabs (C.is_medium <> C.is_boxed <> C.is_centered) arr
|
||||
|
||||
tab_entry :: forall w i. Boolean -> String -> i -> HH.HTML w i
|
||||
tab_entry active name action =
|
||||
HH.li (if active then [HP.classes C.is_active] else [])
|
||||
[ HH.a [HE.onClick \_ -> action] [HH.text name] ]
|
||||
123
src/CSSClasses.purs
Normal file
123
src/CSSClasses.purs
Normal file
@ -0,0 +1,123 @@
|
||||
module CSSClasses where
|
||||
|
||||
import Prelude (show, ($), (<>))
|
||||
|
||||
import Halogen.HTML as HH
|
||||
|
||||
margin_left :: Int -> Array HH.ClassName
|
||||
margin_left size = [HH.ClassName $ "ml-" <> show size]
|
||||
|
||||
is :: Int -> Array HH.ClassName
|
||||
is size = [HH.ClassName $ "is-" <> show size]
|
||||
|
||||
is_size :: Int -> Array HH.ClassName
|
||||
is_size size = [HH.ClassName $ "is-size-" <> show size]
|
||||
|
||||
padding_left :: Int -> Array HH.ClassName
|
||||
padding_left size = [HH.ClassName $ "pl-" <> show size]
|
||||
|
||||
box = [HH.ClassName "box"] :: Array HH.ClassName
|
||||
breadcrumb = [HH.ClassName "breadcrumb"] :: Array HH.ClassName
|
||||
button = [HH.ClassName "button"] :: Array HH.ClassName
|
||||
buttons = [HH.ClassName "buttons"] :: Array HH.ClassName
|
||||
column = [HH.ClassName "column"] :: Array HH.ClassName
|
||||
columns = [HH.ClassName "columns"] :: Array HH.ClassName
|
||||
container = [HH.ClassName "container"] :: Array HH.ClassName
|
||||
content = [HH.ClassName "content"] :: Array HH.ClassName
|
||||
control = [HH.ClassName "control"] :: Array HH.ClassName
|
||||
delete = [HH.ClassName "delete"] :: Array HH.ClassName
|
||||
field_body = [HH.ClassName "field-body"] :: Array HH.ClassName
|
||||
field = [HH.ClassName "field"] :: Array HH.ClassName
|
||||
field_label = [HH.ClassName "field-label"] :: Array HH.ClassName
|
||||
has_addons = [HH.ClassName "has-addons"] :: Array HH.ClassName
|
||||
has_background_danger_dark = [HH.ClassName "has-background-danger-dark"] :: Array HH.ClassName
|
||||
has_background_danger = [HH.ClassName "has-background-danger"] :: Array HH.ClassName
|
||||
has_background_danger_light = [HH.ClassName "has-background-danger-light"] :: Array HH.ClassName
|
||||
has_background_dark = [HH.ClassName "has-background-dark"] :: Array HH.ClassName
|
||||
has_background_info_dark = [HH.ClassName "has-background-info-dark"] :: Array HH.ClassName
|
||||
has_background_info_light = [HH.ClassName "has-background-info-light"] :: Array HH.ClassName
|
||||
has_background_link_dark = [HH.ClassName "has-background-link-dark"] :: Array HH.ClassName
|
||||
has_background_link_light = [HH.ClassName "has-background-link-light"] :: Array HH.ClassName
|
||||
has_background_primary_dark = [HH.ClassName "has-background-primary-dark"] :: Array HH.ClassName
|
||||
has_background_primary_light = [HH.ClassName "has-background-primary-light"] :: Array HH.ClassName
|
||||
has_background_success_dark = [HH.ClassName "has-background-success-dark"] :: Array HH.ClassName
|
||||
has_background_success_light = [HH.ClassName "has-background-success-light"] :: Array HH.ClassName
|
||||
has_background_warning_dark = [HH.ClassName "has-background-warning-dark"] :: Array HH.ClassName
|
||||
has_background_warning = [HH.ClassName "has-background-warning"] :: Array HH.ClassName
|
||||
has_background_warning_light = [HH.ClassName "has-background-warning-light"] :: Array HH.ClassName
|
||||
has_dropdown = [HH.ClassName "has-dropdown"] :: Array HH.ClassName
|
||||
has_succeeds_separator = [HH.ClassName "has-succeeds-separator"] :: Array HH.ClassName
|
||||
has_text_centered = [HH.ClassName "has-text-centered"] :: Array HH.ClassName
|
||||
has_text_dark = [HH.ClassName "has-text-dark"] :: Array HH.ClassName
|
||||
has_text_light = [HH.ClassName "has-text-light"] :: Array HH.ClassName
|
||||
help = [HH.ClassName "help"] :: Array HH.ClassName
|
||||
hero_body = [HH.ClassName "hero-body"] :: Array HH.ClassName
|
||||
hero = [HH.ClassName "hero"] :: Array HH.ClassName
|
||||
input = [HH.ClassName "input"] :: Array HH.ClassName
|
||||
is4 = [HH.ClassName "is-4"] :: Array HH.ClassName
|
||||
is5 = [HH.ClassName "is-5"] :: Array HH.ClassName
|
||||
is_active = [HH.ClassName "is-active"] :: Array HH.ClassName
|
||||
is_ancestor = [HH.ClassName "is-ancestor"] :: Array HH.ClassName
|
||||
is_boxed = [HH.ClassName "is-boxed"] :: Array HH.ClassName
|
||||
is_centered = [HH.ClassName "is-centered"] :: Array HH.ClassName
|
||||
is_child = [HH.ClassName "is-child"] :: Array HH.ClassName
|
||||
is_danger = [HH.ClassName "is-danger"] :: Array HH.ClassName
|
||||
is_dark = [HH.ClassName "is-dark"] :: Array HH.ClassName
|
||||
is_horizontal = [HH.ClassName "is-horizontal"] :: Array HH.ClassName
|
||||
is_hoverable = [HH.ClassName "is-hoverable"] :: Array HH.ClassName
|
||||
is_info = [HH.ClassName "is-info"] :: Array HH.ClassName
|
||||
is_large = [HH.ClassName "is-large"] :: Array HH.ClassName
|
||||
is_light = [HH.ClassName "is-light"] :: Array HH.ClassName
|
||||
is_medium = [HH.ClassName "is-medium"] :: Array HH.ClassName
|
||||
is_normal = [HH.ClassName "is-normal"] :: Array HH.ClassName
|
||||
is_parent = [HH.ClassName "is-parent"] :: Array HH.ClassName
|
||||
is_primary = [HH.ClassName "is-primary"] :: Array HH.ClassName
|
||||
is_selected = [HH.ClassName "is-selected"] :: Array HH.ClassName
|
||||
is_small = [HH.ClassName "is-small"] :: Array HH.ClassName
|
||||
is_spaced = [HH.ClassName "is-spaced"] :: Array HH.ClassName
|
||||
is_static = [HH.ClassName "is-static"] :: Array HH.ClassName
|
||||
is_success = [HH.ClassName "is-success"] :: Array HH.ClassName
|
||||
is_vertical = [HH.ClassName "is-vertical"] :: Array HH.ClassName
|
||||
is_warning = [HH.ClassName "is-warning"] :: Array HH.ClassName
|
||||
label = [HH.ClassName "label"] :: Array HH.ClassName
|
||||
level = [HH.ClassName "level"] :: Array HH.ClassName
|
||||
level_item = [HH.ClassName "level-item"] :: Array HH.ClassName
|
||||
level_left = [HH.ClassName "level-left"] :: Array HH.ClassName
|
||||
level_right = [HH.ClassName "level-right"] :: Array HH.ClassName
|
||||
medium = [HH.ClassName "is-medium"] :: Array HH.ClassName
|
||||
message_body = [HH.ClassName "message-body"] :: Array HH.ClassName
|
||||
message_header = [HH.ClassName "message-header"] :: Array HH.ClassName
|
||||
message = [HH.ClassName "message"] :: Array HH.ClassName
|
||||
modal_background = [HH.ClassName "modal-background"] :: Array HH.ClassName
|
||||
modal_card_body = [HH.ClassName "modal-card-body"] :: Array HH.ClassName
|
||||
modal_card_foot = [HH.ClassName "modal-card-foot"] :: Array HH.ClassName
|
||||
modal_card_head = [HH.ClassName "modal-card-head"] :: Array HH.ClassName
|
||||
modal_card = [HH.ClassName "modal-card"] :: Array HH.ClassName
|
||||
modal_card_title = [HH.ClassName "modal-card-title"] :: Array HH.ClassName
|
||||
modal = [HH.ClassName "modal"] :: Array HH.ClassName
|
||||
navbar_brand = [HH.ClassName "navbar-brand"] :: Array HH.ClassName
|
||||
navbar_burger = [HH.ClassName "navbar-burger"] :: Array HH.ClassName
|
||||
navbar_divider = [HH.ClassName "navbar-divider"] :: Array HH.ClassName
|
||||
navbar_dropdown = [HH.ClassName "navbar-dropdown"] :: Array HH.ClassName
|
||||
navbar_end = [HH.ClassName "navbar-end"] :: Array HH.ClassName
|
||||
navbar = [HH.ClassName "navbar"] :: Array HH.ClassName
|
||||
navbar_item = [HH.ClassName "navbar-item"] :: Array HH.ClassName
|
||||
navbar_link = [HH.ClassName "navbar-link"] :: Array HH.ClassName
|
||||
navbar_menu = [HH.ClassName "navbar-menu"] :: Array HH.ClassName
|
||||
navbar_start = [HH.ClassName "navbar-start"] :: Array HH.ClassName
|
||||
no_margin_bottom = [HH.ClassName "mb-0"] :: Array HH.ClassName
|
||||
no_padding_bottom = [HH.ClassName "pb-0"] :: Array HH.ClassName
|
||||
no_padding_left = [HH.ClassName "pl-0"] :: Array HH.ClassName
|
||||
no_padding_top = [HH.ClassName "pt-0"] :: Array HH.ClassName
|
||||
normal = [HH.ClassName "is-normal"] :: Array HH.ClassName
|
||||
notification = [HH.ClassName "notification"] :: Array HH.ClassName
|
||||
section = [HH.ClassName "section"] :: Array HH.ClassName
|
||||
select = [HH.ClassName "select"] :: Array HH.ClassName
|
||||
subtitle = [HH.ClassName "subtitle"] :: Array HH.ClassName
|
||||
table = [HH.ClassName "table"] :: Array HH.ClassName
|
||||
tabs = [HH.ClassName "tabs"] :: Array HH.ClassName
|
||||
tag = [HH.ClassName "tag"] :: Array HH.ClassName
|
||||
tags = [HH.ClassName "tags"] :: Array HH.ClassName
|
||||
textarea = [HH.ClassName "textarea"] :: Array HH.ClassName
|
||||
tile = [HH.ClassName "tile"] :: Array HH.ClassName
|
||||
title = [HH.ClassName "title"] :: Array HH.ClassName
|
||||
12
src/Main.purs
Normal file
12
src/Main.purs
Normal file
@ -0,0 +1,12 @@
|
||||
module Main where
|
||||
|
||||
import Prelude
|
||||
import Effect (Effect)
|
||||
import Halogen.Aff as HA
|
||||
import Halogen.VDom.Driver (runUI)
|
||||
import App.Container as Container
|
||||
|
||||
main :: Effect Unit
|
||||
main = HA.runHalogenAff do
|
||||
body <- HA.awaitBody
|
||||
runUI Container.component unit body
|
||||
12
src/MissingHTMLProperties.purs
Normal file
12
src/MissingHTMLProperties.purs
Normal file
@ -0,0 +1,12 @@
|
||||
-- | `MissingHTMLProperties` provides missing properties.
|
||||
-- | This shall pretty soon be removed.
|
||||
module MissingHTMLProperties where
|
||||
|
||||
import Halogen.HTML.Properties as HP
|
||||
import Halogen.HTML.Core (PropName(..),AttrName(..))
|
||||
|
||||
aria_current :: forall r i. String -> HP.IProp r i
|
||||
aria_current = HP.attr (AttrName "aria-current")
|
||||
|
||||
size :: forall r i. Int -> HP.IProp (size :: Int | r) i
|
||||
size = HP.prop (PropName "size")
|
||||
10
test/Main.purs
Normal file
10
test/Main.purs
Normal file
@ -0,0 +1,10 @@
|
||||
module Test.Main where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Effect (Effect)
|
||||
import Effect.Class.Console (log)
|
||||
|
||||
main :: Effect Unit
|
||||
main = do
|
||||
log "You should add some tests."
|
||||
Loading…
Reference in New Issue
Block a user