Baguette/dnsmanager-webclient
3
1
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: Baguette:103fb0d6431a1d4c9222739aca4b69973bcf3ad6
Branches Tags
Baguette:master
Baguette:local
Baguette:display
..
compare: Baguette:b13d323e966070e0c2ffa46a49e80a5cce2b1343
Branches Tags
Baguette:local
Baguette:master
Baguette:display

No commits in common. "103fb0d6431a1d4c9222739aca4b69973bcf3ad6" and "b13d323e966070e0c2ffa46a49e80a5cce2b1343" have entirely different histories.
103fb0d643 ... b13d323e96

23 changed files with 568 additions and 1416 deletions
Show Stats Expand all files Collapse all files

227
src/App/Container.purs
View File

@ -93,10 +93,8 @@ type Password = String
type LogInfo = Tuple Login Password
data Action
= Initialize
-- | Handle events from `AuthenticationInterface`.
| AuthenticationInterfaceEvent AI.Output
= AuthenticationInterfaceEvent AI.Output
-- | Handle events from `RegistrationInterface`.
| RegistrationInterfaceEvent RI.Output
@ -164,14 +162,6 @@ data Action
-- | Currently, this handles the navigation bar.
| ToggleAuthenticated (Maybe Token)
-- | Add a main notification, at the top of the page.
| AddNotif Notification
-- | Close the main notification, at the top of the page.
| CloseNotif
data Notification = NoNotification | GoodNotification String | BadNotification String
-- | The component's state is composed of:
-- | a potential authentication token,
-- | the current page,
@ -181,8 +171,6 @@ type State = { token :: Maybe String
, current_page :: Page
, store_DomainListInterface_state :: Maybe DomainListInterface.State
, store_AuthenticationDaemonAdmin_state :: Maybe AdminInterface.State
, notif :: Notification
, login :: Maybe String
}
-- | The list of child components: log, `WS` twice (once for each ws connection),
@ -221,9 +209,7 @@ component =
H.mkComponent
{ initialState
, render
, eval: H.mkEval $ H.defaultEval { initialize = Just Initialize
, handleAction = handleAction
}
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
}
-- | Initial state is simple: the user is on the home page, nothing else is stored.
@ -232,8 +218,6 @@ initialState _ = { token: Nothing
, current_page: Home
, store_DomainListInterface_state: Nothing
, store_AuthenticationDaemonAdmin_state: Nothing
, notif: NoNotification
, login: Nothing
}
render :: forall m. MonadAff m => State -> H.ComponentHTML Action ChildSlots m
@ -241,7 +225,6 @@ render state
= HH.div_ $
[ render_header
, render_nav
, render_notifications
, case state.current_page of
Home -> render_home
Authentication -> render_auth_form
@ -253,15 +236,10 @@ render state
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.columns_ [ Bulma.column_ [ Bulma.h3 "Logs (watch this if something fails! 😅)", render_logs ]
, Bulma.column_ [ render_auth_WS, render_dnsmanager_WS ] ]
]
where
render_notifications =
case state.notif of
NoNotification -> HH.div_ []
GoodNotification v -> Bulma.box [Bulma.notification_success v CloseNotif]
BadNotification v -> Bulma.box [Bulma.notification_danger v CloseNotif]
render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_home = HH.slot_ _ho unit HomeInterface.component unit
@ -274,7 +252,7 @@ render state
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. Please, reconnect."
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
@ -309,39 +287,22 @@ render state
handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Action ChildSlots o monad Unit
handleAction = case _ of
Initialize -> do
handleAction $ Log $ SystemLog "Hello, welcome to this application. 🥳"
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
case token of
Nothing -> revert_old_page
Just _ -> pure unit -- Authentication will happen when web sockets are up!
login_name <- H.liftEffect $ Storage.getItem "user-login" sessionstorage
case login_name of
Nothing -> pure unit
Just name -> do H.modify_ _ { login = Just name }
H.tell _nav unit $ NavigationInterface.TellLogin (Just name)
Routing page -> do
-- Store the current page we are on and restore it when we reload.
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
H.liftEffect $ Storage.setItem "current-page" (case page of
Zone _ -> "Zone"
_ -> show page) sessionstorage
_ <- case page of
Zone zone -> H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
_ -> pure unit
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 -> do
_ <- case message of
UnableToSend err -> handleAction $ AddNotif $ BadNotification err
ErrorLog err -> handleAction $ AddNotif $ BadNotification err
_ -> pure unit
H.tell _log unit $ AppLog.Log message
Log message -> H.tell _log unit $ AppLog.Log message
ToggleAuthenticated maybe_token -> case maybe_token of
Nothing -> H.tell _nav unit $ NavigationInterface.ToggleLogged false
@ -357,7 +318,7 @@ handleAction = case _ of
AuthenticateToAuthd v -> case v of
Left token -> do
handleAction $ Log $ SystemLog "Authenticate to authd with a token."
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
@ -374,13 +335,13 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
case token of
Nothing -> pure unit
Nothing -> handleAction $ Log $ ErrorLog "no token!"
Just t -> do
H.modify_ _ { token = Just t }
handleAction AuthenticateToDNSManager
NavigationInterfaceEvent ev -> case ev of
NavigationInterface.Log message -> handleAction $ Log message
NavigationInterface.Log message -> H.tell _log unit (AppLog.Log message)
NavigationInterface.Routing page -> handleAction $ Routing page
NavigationInterface.Disconnection -> handleAction $ Disconnection
@ -389,11 +350,11 @@ handleAction = case _ of
AI.AskPasswordRecovery e -> case e of
Left email -> do
message <- H.liftEffect $ AuthD.serialize $
AuthD.MkAskPasswordRecovery { login: Nothing, email: Just (Email.Email email) }
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 { login: (Just login), email: Nothing }
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
@ -403,20 +364,15 @@ handleAction = case _ of
H.tell _ws_auth unit (WS.ToSend message)
AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
AI.Log message -> handleAction $ Log message
AI.UserLogin login -> do
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
_ <- H.liftEffect $ Storage.setItem "user-login" login sessionstorage
H.modify_ _ { login = Just login }
H.tell _nav unit $ NavigationInterface.TellLogin (Just login)
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 -> handleAction $ Log 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 -> handleAction $ Log message
MVI.Log message -> H.tell _log unit (AppLog.Log message)
SetupInterfaceEvent ev -> case ev of
SetupInterface.DeleteUserAccount -> do
@ -439,11 +395,11 @@ handleAction = case _ of
}
H.tell _ws_auth unit (WS.ToSend message)
SetupInterface.Log message -> handleAction $ Log 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 -> handleAction $ Log 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
@ -462,11 +418,11 @@ handleAction = case _ of
ZoneInterfaceEvent ev -> case ev of
ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
ZoneInterface.Log message -> handleAction $ Log 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 -> handleAction $ Log 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
@ -477,20 +433,25 @@ handleAction = case _ of
-- | `authd websocket component` wants to do something.
AuthenticationDaemonEvent ev -> case ev of
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeAuthMessage message
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 -> pure unit
Nothing -> handleAction $ Log $ ErrorLog "no token!"
Just t -> do
handleAction $ Log $ SystemLog "Let's authenticate to authd"
handleAction $ AuthenticateToAuthd (Left t)
WS.WSJustClosed -> handleAction $ Log $ ErrorLog "You just got disconnected from authd."
WS.Log message -> handleAction $ Log message
WS.KeepAlive -> handleAction $ KeepAlive $ Left unit
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
@ -518,29 +479,24 @@ handleAction = case _ of
{ current_page } <- H.get
case current_page of
Registration -> do
let successlog = """
You are now registered. Please verify your email address with the token we sent you.
handleAction $ Log $ SuccessLog """
You are now registered, copy the token we sent you by email to finish your registration.
"""
handleAction $ Log $ SuccessLog successlog
handleAction $ AddNotif $ GoodNotification successlog
handleAction $ Routing MailValidation
_ -> handleAction $ DispatchAuthDaemonMessage m
(AuthD.GotUserEdited u) -> do
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified."
handleAction $ Log $ SuccessLog $ "User (" <> show u.uid <> ") was modified!"
(AuthD.GotUserValidated _) -> do
handleAction $ Log $ SuccessLog "User got validated. You can now log in."
handleAction $ Log $ SuccessLog "User got validated! You can now log in!"
handleAction $ Routing Authentication
handleAction $ AddNotif $ GoodNotification "User got validated. You can now log in."
(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."
m@(AuthD.GotPasswordRecovered _) -> do
handleAction $ Log $ SuccessLog "your new password is now valid."
handleAction $ DispatchAuthDaemonMessage m
handleAction $ AddNotif $ GoodNotification "Your new password is now valid."
(AuthD.GotPasswordRecovered _) -> do
handleAction $ Log $ SuccessLog "your new password is now valid!"
m@(AuthD.GotMatchingUsers _) -> do
{ current_page } <- H.get
case current_page of
@ -551,67 +507,49 @@ handleAction = case _ of
{ current_page } <- H.get
case current_page of
Administration -> handleAction $ DispatchAuthDaemonMessage m
_ -> pure unit
_ -> handleAction $ Log $ ErrorLog
"received a GotUserDeleted message while not on authd admin page."
(AuthD.GotErrorMustBeAuthenticated _) -> do
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
handleAction $ AddNotif $ BadNotification "Sorry, you must be authenticated to perform this action."
(AuthD.GotErrorAlreadyUsedLogin _) -> do
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
handleAction $ AddNotif $ BadNotification "Sorry, your login is already taken."
(AuthD.GotErrorUserNotFound _) -> do
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
handleAction $ AddNotif $ BadNotification "User hasn't been found."
-- The authentication failed.
(AuthD.GotError errmsg) -> do
handleAction $ Log $ ErrorLog $ " generic error message: "
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
handleAction $ AddNotif $ BadNotification $ "Sorry, authd sent an error message. "
<> maybe "The server didn't tell why." (\v -> "Message was: " <> v) errmsg.reason
m@(AuthD.GotPasswordRecoverySent _) -> do
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
handleAction $ DispatchAuthDaemonMessage m
(AuthD.GotPasswordRecoverySent _) -> do
handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
(AuthD.GotErrorPasswordTooShort _) -> do
handleAction $ Log $ ErrorLog "Password too short!"
handleAction $ AddNotif $ BadNotification "The server told that your password is too short."
(AuthD.GotErrorMailRequired _) -> do
handleAction $ Log $ ErrorLog "Email required!"
handleAction $ AddNotif $ BadNotification "An email is required."
(AuthD.GotErrorInvalidCredentials _) -> do
handleAction $ Log $ ErrorLog "Invalid credentials!"
handleAction $ ToggleAuthenticated Nothing
handleAction $ AddNotif $ BadNotification "Invalid credentials!"
(AuthD.GotErrorRegistrationsClosed _) -> do
handleAction $ Log $ ErrorLog "Registration closed. Try another time or contact an administrator."
handleAction $ AddNotif $ BadNotification "Registration are closed at the moment."
handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator."
(AuthD.GotErrorInvalidLoginFormat _) -> do
handleAction $ Log $ ErrorLog "Invalid login format!"
handleAction $ AddNotif $ BadNotification "Invalid login format."
(AuthD.GotErrorInvalidEmailFormat _) -> do
handleAction $ Log $ ErrorLog "Invalid email format!"
handleAction $ AddNotif $ BadNotification "Invalid email format."
(AuthD.GotErrorAlreadyUsersInDB _) -> do
handleAction $ Log $ ErrorLog "GotErrorAlreadyUsersInDB"
handleAction $ AddNotif $ BadNotification "Login already taken!"
handleAction $ Log $ ErrorLog "Login already taken!"
(AuthD.GotErrorReadOnlyProfileKeys _) -> do
handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys!"
handleAction $ AddNotif $ BadNotification "Trying to add a profile with some invalid (read-only) keys!"
(AuthD.GotErrorInvalidActivationKey _) -> do
handleAction $ Log $ ErrorLog "Invalid activation key!"
handleAction $ AddNotif $ BadNotification "Invalid activation key!"
(AuthD.GotErrorUserAlreadyValidated _) -> do
handleAction $ Log $ ErrorLog "User already validated!"
handleAction $ AddNotif $ BadNotification "User already validated!"
(AuthD.GotErrorCannotContactUser _) -> do
handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
handleAction $ AddNotif $ BadNotification "User cannot be contacted. Email address may be invalid."
(AuthD.GotErrorInvalidRenewKey _) -> do
handleAction $ Log $ ErrorLog "Invalid renew key!"
handleAction $ AddNotif $ BadNotification "Invalid renew key!"
-- The authentication was a success!
(AuthD.GotToken msg) -> do
handleAction $ Log $ SuccessLog $ "Authenticated to authd."
handleAction $ Log $ SuccessLog $ "Authenticated to authd!"
H.modify_ _ { token = Just msg.token }
handleAction $ ToggleAuthenticated (Just msg.token)
@ -619,42 +557,39 @@ handleAction = case _ of
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
handleAction AuthenticateToDNSManager
(AuthD.GotKeepAlive _) -> pure unit
(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
Authentication -> H.tell _ai unit (AI.MessageReceived message)
Administration -> H.tell _admini unit (AdminInterface.MessageReceived message)
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
pure unit
AddNotif n -> do
H.modify_ _ { notif = n }
CloseNotif -> do
H.modify_ _ { notif = NoNotification }
Disconnection -> do
handleAction $ Routing Home
H.put $ initialState unit
handleAction $ ToggleAuthenticated Nothing
-- 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) -> handleAction $ DecodeDNSMessage message
WS.WSJustConnected -> handleAction AuthenticateToDNSManager
WS.WSJustClosed -> handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
WS.Log message -> handleAction $ Log message
WS.KeepAlive -> handleAction $ KeepAlive $ Right unit
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
@ -677,28 +612,22 @@ handleAction = case _ of
case received_msg of
(DNSManager.MkDomainNotFound _) -> do
handleAction $ Log $ ErrorLog $ "DomainNotFound"
handleAction $ AddNotif $ BadNotification $ "The domain doesn't exist."
(DNSManager.MkRRNotFound _) -> do
handleAction $ Log $ ErrorLog $ "RRNotFound"
handleAction $ AddNotif $ BadNotification $ "The resource record doesn't exist."
(DNSManager.MkInvalidZone _) -> do
handleAction $ Log $ ErrorLog $ "InvalidZone"
handleAction $ AddNotif $ BadNotification $ "The domain zone is invalid."
(DNSManager.MkDomainChanged _) -> do
handleAction $ Log $ ErrorLog $ "DomainChanged"
(DNSManager.MkUnknownZone _) -> do
handleAction $ Log $ ErrorLog $ "UnknownZone"
handleAction $ AddNotif $ BadNotification $ "The domain zone is unknown."
(DNSManager.MkDomainList _) -> do
handleAction $ Log $ ErrorLog $ "MkDomainList"
(DNSManager.MkUnknownUser _) -> do
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
(DNSManager.MkNoOwnership _) -> do
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
handleAction $ AddNotif $ BadNotification $ "You don't own this domain."
(DNSManager.MkInsufficientRights _) -> do
handleAction $ Log $ ErrorLog $ "You do not have sufficient rights."
handleAction $ AddNotif $ BadNotification $ "You do not have sufficient rights."
-- The authentication failed.
(DNSManager.MkError errmsg) -> do
handleAction $ Log $ ErrorLog $ "reason is: " <> errmsg.reason
@ -713,29 +642,24 @@ handleAction = case _ of
handleAction $ ToggleAuthenticated Nothing
(DNSManager.MkDomainAlreadyExists _) -> do
handleAction $ Log $ ErrorLog $ "The domain already exists."
handleAction $ AddNotif $ BadNotification $ "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 $ Log $ SuccessLog $ "Received the list of accepted domains!"
handleAction $ DispatchDNSMessage m
m@(DNSManager.MkLogged logged_message) -> do
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd."
H.tell _nav unit $ NavigationInterface.ToggleAdmin logged_message.admin
handleAction $ AddNotif $ GoodNotification "You are now authenticated."
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 $ AddNotif $ GoodNotification $ "You have just registered the domain \""
<> response.domain <> "\". 🥳 You can now manage it (click on its button)."
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 $ Log $ SuccessLog $ "Resource updated!"
handleAction $ DispatchDNSMessage m
m@(DNSManager.MkRRAdded response) -> do
handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
@ -744,25 +668,20 @@ handleAction = case _ of
handleAction $ Log $ SuccessLog $ "Received zonefile for " <> response.domain
handleAction $ DispatchDNSMessage m
(DNSManager.MkInvalidDomainName _) -> do
handleAction $ Log $ ErrorLog $ "The domain is not valid."
handleAction $ AddNotif $ BadNotification $ "Invalid domain name."
handleAction $ Log $ ErrorLog $ "The domain is not valid!"
m@(DNSManager.MkDomainDeleted response) -> do
let successlog = "The domain \"" <> response.domain <> "\" has been deleted."
handleAction $ Log $ SuccessLog successlog
handleAction $ AddNotif $ GoodNotification successlog
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 $ Log $ SuccessLog $ "RR (rrid: '" <> show response.rrid <> "') has been deleted!"
handleAction $ DispatchDNSMessage m
m@(DNSManager.MkZone _) -> do
handleAction $ Log $ SuccessLog $ "Zone received."
handleAction $ Log $ SuccessLog $ "Zone received!"
handleAction $ DispatchDNSMessage m
(DNSManager.MkInvalidRR response) -> do
let errorlog = "Invalid resource record: " <> A.intercalate ", " response.errors
handleAction $ Log $ ErrorLog errorlog
handleAction $ AddNotif $ BadNotification errorlog
handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors
(DNSManager.MkSuccess _) -> do
handleAction $ Log $ SuccessLog $ "(generic) Success."
handleAction $ Log $ SuccessLog $ "(generic) Success!"
DNSManager.MkOrphanDomainList response -> do
handleAction $ Log $ SuccessLog "Received orphan domain list."
H.tell _admini unit (AdminInterface.GotOrphanDomainList response.domains)

104
src/App/DisplayErrors.purs
View File

@ -8,13 +8,9 @@ import Data.Maybe (Maybe(..), maybe)
import Halogen.HTML as HH
import App.Validation.DNS as ValidationDNS
import App.Validation.Login as L
import App.Validation.Email as E
import App.Validation.Password as P
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
@ -24,15 +20,8 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
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.VEDMARCpct min max n ->
Bulma.p $ "DMARC sample rate should have a value between "
<> show min <> " and " <> show max <> ", current value: " <> show n <> "."
ValidationDNS.VEDMARCri min max n ->
Bulma.p $ "DMARC report interval should have a value between "
<> show min <> " and " <> show max <> ", current value: " <> show n <> "."
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
@ -40,7 +29,7 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
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 protocol_error show_error_protocol 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
@ -55,7 +44,6 @@ error_to_paragraph v = Bulma.error_message (Bulma.p $ show_error_title v)
ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max
)
where default_error = Bulma.p ""
protocol_error = Bulma.p "Accepted protocols are: tcp, udp. You need more? Contact us."
show_error_key_sizes :: forall w i. Int -> Int -> HH.HTML w i
show_error_key_sizes min max
@ -65,30 +53,28 @@ show_error_key_sizes min max
-- | `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 _ -> "Invalid IPv4 address"
ValidationDNS.VEIPv6 _ -> "Invalid IPv6 address"
ValidationDNS.VEName _ -> "Invalid Name (domain label)"
ValidationDNS.VETTL _ _ _ -> "Invalid TTL"
ValidationDNS.VEDMARCpct _ _ _ -> "Invalid DMARC sample rate"
ValidationDNS.VEDMARCri _ _ _ -> "Invalid DMARC report interval"
ValidationDNS.VETXT _ -> "Invalid TXT"
ValidationDNS.VECNAME _ -> "Invalid CNAME"
ValidationDNS.VENS _ -> "Invalid NS Target"
ValidationDNS.VEMX _ -> "Invalid MX Target"
ValidationDNS.VEPriority _ _ _ -> "Invalid Priority"
ValidationDNS.VESRV _ -> "Invalid SRV Target"
ValidationDNS.VEProtocol _ -> "Invalid Protocol"
ValidationDNS.VEPort _ _ _ -> "Invalid Port"
ValidationDNS.VEWeight _ _ _ -> "Invalid Weight"
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 _ -> "The domain name in a SPF mechanism is wrong"
ValidationDNS.VESPFMechanismIPv4 _ -> "The IPv4 address in a SPF mechanism is wrong"
ValidationDNS.VESPFMechanismIPv6 _ -> "The IPv6 address in a SPF mechanism is wrong"
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 _ -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong"
ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length"
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
@ -101,7 +87,7 @@ show_error_domain e = case e of
_ -> 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 ("-"),
then eventually a series of letters, digits and hyphenations ('-'),
and must finish with either a letter or a digit.
"""
@ -116,7 +102,7 @@ show_error_ip6 e = case e of
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".
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."
@ -161,46 +147,10 @@ error_to_paragraph_label v = Bulma.error_message (Bulma.p $ show_error_title_lab
show_error_title_label :: ValidationLabel.Error -> String
show_error_title_label v = case v of
ValidationLabel.ParsingError x -> case x.error of
Nothing -> "Invalid label"
Nothing -> "Cannot parse the label (position: " <> show x.position <> ")."
Just (ValidationLabel.CannotParse _) ->
"Invalid label"
Just (ValidationLabel.CannotEntirelyParse) -> "Invalid label (cannot entirely parse the label)"
"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 <> ")."
show_error_login :: L.Error -> String
show_error_login = case _ of
L.ParsingError {error} -> 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} -> 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} -> 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 <> ")"

4
src/App/Message/AuthenticationDaemon.purs
View File

@ -70,11 +70,11 @@ codecValidateUser
{- 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 = { login :: Maybe String, email :: Maybe Email.Email }
type AskPasswordRecovery = { user :: Maybe String, email :: Maybe Email.Email }
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
codecAskPasswordRecovery
= CA.object "AskPasswordRecovery"
(CAR.record { login: CAR.optional CA.string, email: CAR.optional Email.codec })
(CAR.record { user: CAR.optional CA.string, email: CAR.optional Email.codec })
{- 4 -}
type PasswordRecovery = { user :: String

6
src/App/Message/DNSManagerDaemon.purs
View File

@ -208,12 +208,10 @@ 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, admin :: Boolean }
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
, admin: CA.boolean
})
, my_domains: CA.array CA.string })
{- 17 -}
type DomainAdded = { domain :: String }

38
src/App/Page/Administration.purs
View File

@ -1,5 +1,5 @@
{- Administration interface.
Enables to:
Allows to:
- add, remove, search users
- TODO: validate users
- TODO: change user password
@ -10,7 +10,7 @@
-}
module App.Page.Administration where
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==), unit)
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==))
import Data.Eq (class Eq)
import Bulma as Bulma
@ -21,6 +21,7 @@ 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
@ -53,6 +54,8 @@ data Output
data Query a
= MessageReceived AuthD.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
| GotOrphanDomainList (Array String) a
| ProvideState (Maybe State) a
@ -101,6 +104,7 @@ type State =
{ addUserForm :: StateAddUserForm
, searchUserForm :: StateSearchUserForm
, current_tab :: Tab
, wsUp :: Boolean
, matching_users :: Array UserPublic
, orphan_domains :: Array String
}
@ -124,10 +128,11 @@ initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "
, 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 }
render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domains, wsUp }
= Bulma.section_small
[ fancy_tab_bar
, case current_tab of
@ -162,14 +167,15 @@ render { addUserForm, searchUserForm, matching_users, current_tab, orphan_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
[ 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
, Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass
, 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
]
@ -178,13 +184,13 @@ render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domain
[ HE.onSubmit PreventSubmit ]
[ Bulma.p """
Following input accepts any regex.
This is used to search for a user based on their login, full name or email address.
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
, 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
-- (up SEARCHUSER_INP_domain) searchUserForm.domain active
, Bulma.btn "Send" SearchUserAttempt
]
@ -195,7 +201,7 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
old_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage
case old_tab of
Nothing -> pure unit
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
@ -306,9 +312,19 @@ handleQuery = case _ of
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
-- Unexpected message.
_ -> H.raise $ Log $ ErrorLog $ "Authentication server didn't send a valid 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)

159
src/App/Page/Authentication.purs
View File

@ -2,27 +2,23 @@
-- | TODO: token validation.
module App.Page.Authentication where
import Prelude (Unit, bind, discard, pure, ($), (<<<), (=<<), (<>), (>), (==), map, show, unit)
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (>), (==), map, show)
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Eq (class Eq)
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 Web.HTML (window) as HTML
import Web.HTML.Window (sessionStorage) as Window
import Web.Storage.Storage as Storage
import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
@ -51,7 +47,6 @@ data Output
= MessageToSend ArrayBuffer
| AuthenticateToAuthd (Tuple Login Password)
| Log LogMessage
| UserLogin String
| PasswordRecovery Login PasswordRecoveryToken Password
| AskPasswordRecovery (Either Email Login)
@ -60,6 +55,8 @@ data Output
-- | 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
@ -80,8 +77,7 @@ data NewPasswordInput
| NEWPASS_INP_confirmation String
data Action
= Initialize
| HandleAuthenticationInput AuthenticationInput
= HandleAuthenticationInput AuthenticationInput
| HandlePasswordRecovery PasswordRecoveryInput
| HandleNewPassword NewPasswordInput
--
@ -89,14 +85,6 @@ data Action
| PasswordRecoveryAttempt Event
| NewPasswordAttempt Event
-- | Change the displayed tab.
| ChangeTab Tab
-- | There are different tabs in the administration page.
-- | For example, users can be searched (`authd`) and a list is provided.
data Tab = Auth | ILostMyPassword | Recovery
derive instance eqTab :: Eq Tab
type StateAuthenticationForm = { login :: String, pass :: String }
type StatePasswordRecoveryForm = { login :: String, email :: String }
type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String }
@ -106,7 +94,7 @@ type State =
, passwordRecoveryForm :: StatePasswordRecoveryForm
, newPasswordForm :: StateNewPasswordForm
, errors :: Array Error
, current_tab :: Tab
, wsUp :: Boolean
}
initialState :: Input -> State
@ -114,8 +102,8 @@ initialState _ =
{ authenticationForm: { login: "", pass: "" }
, passwordRecoveryForm: { login: "", email: "" }
, newPasswordForm: { login: "", token: "", password: "", confirmation: "" }
, wsUp: true
, errors: []
, current_tab: Auth
}
component :: forall m. MonadAff m => H.Component Query Input Output m
@ -124,33 +112,26 @@ component =
{ initialState
, render
, eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize
, handleAction = handleAction
{ handleAction = handleAction
, handleQuery = handleQuery
}
}
render :: forall m. State -> H.ComponentHTML Action () m
render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
Bulma.section_small
[ fancy_tab_bar
, if A.length errors > 0
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ] ]
else HH.div_ []
, case current_tab of
Auth -> Bulma.box auth_form
ILostMyPassword -> Bulma.box passrecovery_form
Recovery -> Bulma.box newpass_form
[ 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
fancy_tab_bar =
Bulma.fancy_tabs
[ Bulma.tab_entry (is_tab_active Auth) "Authentication" (ChangeTab Auth)
, Bulma.tab_entry (is_tab_active ILostMyPassword) "I lost my password! 😟" (ChangeTab ILostMyPassword)
, Bulma.tab_entry (is_tab_active Recovery) "Recover with a token" (ChangeTab Recovery)
]
is_tab_active tab = current_tab == tab
b e = Bulma.column_ [ Bulma.box e ]
show_error :: Error -> String
show_error = case _ of
@ -196,32 +177,28 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
<> show min <> " and " <> show max
<> " (currently: " <> show n <> ")"
auth_form = [ Bulma.h3 "Authentication", render_auth_form ]
passrecovery_form =
[ Bulma.h3 "You forgot your password (or your login)"
, Bulma.div_content
[ Bulma.p "Enter either your login or email and you'll receive a recovery token."
]
, render_password_recovery_form
]
newpass_form =
[ Bulma.h3 "You got the password recovery mail"
, Bulma.div_content
[ Bulma.p "Nice! You get to choose your new password."
]
, render_new_password_form
]
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
, Bulma.btn_validation
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
@ -229,10 +206,17 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
[ 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
, Bulma.btn_validation
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
@ -240,32 +224,30 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
[ 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
, Bulma.btn_validation
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
Initialize -> do
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
old_tab <- H.liftEffect $ Storage.getItem "current-auth-tab" sessionstorage
case old_tab of
Nothing -> pure unit
Just current_tab -> case current_tab of
"Auth" -> handleAction $ ChangeTab Auth
"ILostMyPassword" -> handleAction $ ChangeTab ILostMyPassword
"Recovery" -> handleAction $ ChangeTab Recovery
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
HandleAuthenticationInput authinp -> do
case authinp of
AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
@ -289,7 +271,6 @@ handleAction = case _ of
{ authenticationForm } <- H.get
let { login, pass } = authenticationForm
H.raise $ UserLogin login
case login, pass of
"" , _ ->
H.raise $ Log $ UnableToSend "Write your login!"
@ -326,6 +307,7 @@ handleAction = case _ of
_ -> do H.modify_ _ { errors = [] }
H.raise $ AskPasswordRecovery (Left email)
-- TODO: verify the login?
NewPasswordAttempt ev -> do
H.liftEffect $ Event.preventDefault ev
@ -333,28 +315,13 @@ handleAction = case _ of
let { login, token, password, confirmation} = newPasswordForm
if A.any (_ == "") [ login, token, password, confirmation ]
then H.raise $ Log $ ErrorLog "All entries are required."
then H.raise $ Log $ ErrorLog "All entries are required!"
else if password == confirmation
then case L.login login, P.password password of
Left errors, _ -> H.modify_ _ { errors = [ Login errors ] }
_, Left errors -> H.modify_ _ { errors = [ Password errors ] }
_, _ -> do H.modify_ _ { errors = [] }
H.raise $ Log $ SystemLog $ "Sending a new password"
H.raise $ PasswordRecovery login token password
else H.raise $ Log $ UnableToSend "Confirmation differs from password"
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
Auth -> do
H.modify_ \state -> state { authenticationForm { login = state.newPasswordForm.login } }
H.liftEffect $ Storage.setItem "current-auth-tab" "Auth" sessionstorage
ILostMyPassword -> H.liftEffect $ Storage.setItem "current-auth-tab" "ILostMyPassword" sessionstorage
Recovery -> do
H.modify_ \state -> state { newPasswordForm { login = state.passwordRecoveryForm.login } }
H.liftEffect $ Storage.setItem "current-auth-tab" "Recovery" sessionstorage
H.modify_ _ { current_tab = current_tab }
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
@ -362,10 +329,14 @@ handleQuery = case _ of
-- Error messages are simply logged (see the code in the Container component).
MessageReceived message _ -> do
case message of
AuthD.GotPasswordRecovered _ -> do
handleAction $ ChangeTab Auth
AuthD.GotPasswordRecoverySent _ -> do
handleAction $ ChangeTab Recovery
_ -> 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)

67
src/App/Page/DomainList.purs
View File

@ -1,7 +1,7 @@
-- | `App.DomainListInterface` is a simple component with the list of own domains
-- | and a form to add a new domain.
-- |
-- | This interface enables to:
-- | This interface allows to:
-- | - display the list of own domains
-- | - show and select accepted domains (TLDs)
-- | - create new domains
@ -16,7 +16,6 @@ import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.String (toLower)
import Data.Maybe (Maybe(..), maybe)
import Data.String.Utils (endsWith)
import Effect.Aff.Class (class MonadAff)
@ -24,6 +23,7 @@ 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
@ -32,6 +32,7 @@ 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
@ -64,6 +65,8 @@ data Output
data Query a
= MessageReceived DNSManager.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
| ProvideState (Maybe State) a
type Slot = H.Slot Query Output
@ -120,6 +123,7 @@ type State =
, accepted_domains :: Array String
, my_domains :: Array String
, wsUp :: Boolean
, active_modal :: Maybe String
}
@ -149,31 +153,32 @@ initialState _ =
}
, 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, active_modal }
render { accepted_domains, my_domains, newDomainForm, wsUp, active_modal }
= Bulma.section_small
[ case active_modal of
Nothing -> Bulma.columns_
[ Bulma.column_ [ Bulma.h3 "New domain", render_add_domain_form]
, Bulma.column_ [ Bulma.h3 "My domains"
, if A.length my_domains > 0
then HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) $ A.sort my_domains
else Bulma.p "No domain yet."
]
]
Just domain -> Bulma.modal "Deleting a domain"
[warning_message domain] [modal_delete_button domain, modal_cancel_button]
[ 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 \""
= HH.p [] [ HH.text $ "You are about to delete your domain '"
<> domain
<> "\". Are you sure you want to do this? This is "
<> "'. Are you sure you want to do this? This is "
, HH.strong_ [ HH.text "irreversible" ]
, HH.text "."
]
@ -189,8 +194,12 @@ render { accepted_domains, my_domains, newDomainForm, active_modal }
(HandleNewDomainInput <<< INP_newdomain)
newDomainForm.new_domain
[ HHE.onSelectedIndexChange domain_choice ]
(map (\v -> "." <> v) accepted_domains)
, Bulma.btn_validation_ "add a new domain"
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_ [ ]
@ -221,7 +230,7 @@ handleAction = case _ of
HandleNewDomainInput adduserinp -> do
case adduserinp of
INP_newdomain v -> do
H.modify_ _ { newDomainForm { new_domain = toLower v } }
H.modify_ _ { newDomainForm { new_domain = v } }
case v of
"" -> H.modify_ _ { newDomainForm { _errors = [] } }
_ -> case Validation.label v of
@ -247,18 +256,18 @@ handleAction = case _ of
{ newDomainForm } <- H.get
let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain
case newDomainForm.new_domain, newDomainForm._errors, new_domain of
"", _, _ ->
case newDomainForm._errors, new_domain of
_, "" ->
H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
_, [], _ -> do
[], _ -> 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 $ "The new domain name is invalid."
_, _ ->
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
@ -287,12 +296,20 @@ handleQuery = case _ of
_ -> 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 = A.sort response.my_domains
, my_domains = response.my_domains
}
_ -> s1

25
src/App/Page/Home.purs
View File

@ -41,27 +41,25 @@ initialState _ = unit
render :: forall m. State -> H.ComponentHTML Action () m
render _ = HH.div_
[ Bulma.hero_danger
"THIS IS A BETA RELEASE"
"You can register, login and play a bit with the tool. Feel free to report errors and suggestions!"
"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 for the common folks"
, Bulma.subtitle "Free domain names"
, Bulma.hr
, render_description
, render_update_why_and_contact
, render_second_line
, render_why_and_contact
, Bulma.hr
, render_how_and_code
]
]
where
title = Bulma.h3
expl content = Bulma.div_content [ Bulma.explanation content ]
p = Bulma.p
b x = Bulma.column_ [ Bulma.box [ Bulma.div_content x ] ]
render_description = Bulma.columns_ [ render_basics, render_no_expert, render_no_housing ]
render_update_why_and_contact = Bulma.columns_ [ render_updates, render_why, render_contact ]
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."
@ -73,6 +71,7 @@ render _ = HH.div_
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 """
@ -84,10 +83,12 @@ render _ = HH.div_
render_updates
= b [ title "Automatic updates"
, p "Update your records with a single, stupidly simple command. For example:"
, expl [ Bulma.strong "wget https://netlib.re/token-update/<token>" ]
, 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."
@ -115,9 +116,9 @@ render _ = HH.div_
the authentication (and authorization) daemon, used to authenticate
clients through different services;
"""
, link "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanagerd"
, link "https://git.baguette.netlib.re/Baguette/dnsmanagerd" "dnsmanagerd"
"""
the dns manager daemon, used as an interactive database, enabling clients
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"
@ -137,7 +138,7 @@ render _ = HH.div_
"""
, link "https://git.baguette.netlib.re/Baguette/dodb.cr" "dodb"
"""
the Document Oriented DataBase, enabling to store serialized objects
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.
"""

43
src/App/Page/MailValidation.purs
View File

@ -3,16 +3,17 @@
-- | This token has to be used to validate the email address.
module App.Page.MailValidation where
import Prelude (Unit, bind, discard, ($), (<<<), (<>), map, show)
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (maybe)
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)
@ -29,7 +30,9 @@ data Output
| Log LogMessage
-- | The component is informed when the connection went up or down.
data Query a = DoNothing a
data Query a
= ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output
@ -62,6 +65,7 @@ type MailValidationForm = { login :: String, token :: String }
type State =
{ mailValidationForm :: MailValidationForm
, errors :: Array Error
, wsUp :: Boolean
}
component :: forall m. MonadAff m => H.Component Query Input Output m
@ -71,6 +75,7 @@ component =
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
}
}
@ -78,25 +83,41 @@ initialState :: Input -> State
initialState _ =
{ mailValidationForm: { login: "", token: "" }
, errors: []
, wsUp: true
}
render :: forall m. State -> H.ComponentHTML Action () m
render { mailValidationForm }
= Bulma.section_small [ Bulma.columns_ [ b mail_validation_form ] ]
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
, Bulma.btn_validation
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
@ -164,3 +185,13 @@ string_error_token = case _ of
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)

43
src/App/Page/Navigation.purs
View File

@ -31,10 +31,7 @@ data Output
| Disconnection
-- | The component needs to know when the user is logged or not.
data Query a
= ToggleLogged Boolean a
| ToggleAdmin Boolean a
| TellLogin (Maybe String) a
data Query a = ToggleLogged Boolean a
type Slot = H.Slot Query Output
@ -56,7 +53,7 @@ data Action
-- | - `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, login :: Maybe String, active :: Boolean, admin :: Boolean }
type State = { logged :: Boolean, active :: Boolean, admin :: Boolean }
component :: forall m. MonadAff m => H.Component Query Input Output m
component =
@ -69,16 +66,13 @@ component =
}
initialState :: Input -> State
initialState _ = { logged: false, login: Nothing, active: false, admin: false }
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 -> do
-- Automatically close the menu.
H.modify_ \state -> state { active = false }
H.raise $ Routing page
Navigate page -> H.raise $ Routing page
UnLog -> do
H.raise $ Disconnection
H.modify_ _ { logged = false }
@ -88,12 +82,6 @@ handleQuery = case _ of
ToggleLogged islogged a -> do
H.modify_ _ { logged = islogged }
pure (Just a)
ToggleAdmin isadmin a -> do
H.modify_ _ { admin = isadmin }
pure (Just a)
TellLogin login a -> do
H.modify_ _ { login = login }
pure (Just a)
-- | The navigation bar is a complex component to render.
@ -105,7 +93,7 @@ handleQuery = case _ of
-- | Also, when clicked again, the list disappears.
render :: forall m. State -> H.ComponentHTML Action () m
render { logged, active, admin, login } =
render { logged, active, admin } =
main_nav
[ nav_brand [ logo, burger_menu ]
, nav_menu
@ -124,7 +112,7 @@ render { logged, active, admin, login } =
right_bar_div =
case logged of
false -> [ link_auth, link_register, link_mail_validation ]
_ -> render_login login <> [ link_setup, link_disconnection ]
_ -> [ link_setup, link_disconnection ]
navbar_color = C.is_success
@ -134,7 +122,7 @@ render { logged, active, admin, login } =
, ARIA.role "navigation"
]
logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🍉"]
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]]
@ -165,8 +153,6 @@ render { logged, active, admin, login } =
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)
render_login Nothing = []
render_login (Just l)= [nav_link ("logged as " <> l) (Navigate Setup)]
link_disconnection =
nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog
@ -174,6 +160,7 @@ render { logged, active, admin, login } =
= 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 ])
@ -192,10 +179,6 @@ render { logged, active, admin, login } =
, HE.onClick (\_ -> action)
] [ (HH.text str) ]
dropdown_element classes link str = HH.a [HP.classes (C.navbar_item <> classes), HP.href link] [HH.text str]
dropdown_element_primary link str = dropdown_element C.has_background_info_light link str
dropdown_element_secondary link str = dropdown_element C.has_background_warning_light link str
dropdown_section_primary t
= HH.p [HP.classes $ C.has_background_info <> C.has_text_light <> C.navbar_item] [HH.text t]
dropdown_section_secondary t
@ -203,13 +186,13 @@ render { logged, active, admin, login } =
code_dropdown =
dropdown "Source code"
[ dropdown_section_primary "Main parts of this service"
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager daemon"
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient" "dnsmanager web client"
, dropdown_element "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
, dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager daemon"
, dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient" "dnsmanager web client"
, dropdown_separator
, dropdown_section_secondary "A few more links (for nerds)"
, dropdown_element_secondary "https://git.baguette.netlib.re/Baguette/libipc" "libIPC: communication library"
, dropdown_element_secondary "https://git.baguette.netlib.re/Baguette/dodb.cr" "DoDB: document-oriented database"
, dropdown_element "https://git.baguette.netlib.re/Baguette/libipc" "libIPC: communication library"
, dropdown_element "https://git.baguette.netlib.re/Baguette/dodb.cr" "DoDB: document-oriented database"
]
--btn c action str

88
src/App/Page/Registration.purs
View File

@ -2,16 +2,17 @@
-- | Registration requires a login, an email address and a password.
module App.Page.Registration where
import Prelude (Unit, bind, discard, ($), (<<<), (<>), map)
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show)
import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (Maybe(..))
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)
@ -21,8 +22,6 @@ import App.Type.Email as Email
import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
import App.DisplayErrors (show_error_login, show_error_email, show_error_password)
import App.Validation.Login as L
import App.Validation.Email as E
import App.Validation.Password as P
@ -31,7 +30,10 @@ data Output
= MessageToSend ArrayBuffer
| Log LogMessage
data Query a = DoNothing a
-- | The component is informed when the connection went up or down.
data Query a
= ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output
@ -66,12 +68,14 @@ type StateRegistrationForm = { login :: String, email :: String, pass :: String
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
@ -81,29 +85,46 @@ component =
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
}
}
render :: forall m. State -> H.ComponentHTML Action () m
render { registrationForm }
= Bulma.section_small [Bulma.columns_ [ b registration_form ]]
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 ]
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
, Bulma.btn_validation
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
@ -154,3 +175,52 @@ 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)

81
src/App/Page/Setup.purs
View File

@ -1,23 +1,20 @@
-- | `App.SetupInterface` enables users to change their password or their email address.
-- | `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, ($), (<<<), (==), (<>), show, map)
import Prelude (Unit, bind, discard, pure, ($), (<<<), (==))
import Data.Array as A
import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..))
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.Validation.Password as P
import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD
@ -27,8 +24,12 @@ data Output
| 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
@ -45,7 +46,6 @@ data NewPasswordInput
data Action
= HandleNewPassword NewPasswordInput
| ChangePasswordAttempt Event
| SendChangePasswordMessage
| CancelModal
| DeleteAccountPopup
| DeleteAccount
@ -59,6 +59,7 @@ data Modal
type State =
{ newPasswordForm :: StateNewPasswordForm
, token :: String
, wsUp :: Boolean
, modal :: Modal
}
@ -78,31 +79,38 @@ initialState token =
{ newPasswordForm: { password: "", confirmation: "" }
, token
, modal: NoModal
, wsUp: true
}
render :: forall m. State -> H.ComponentHTML Action () m
render { modal, newPasswordForm } =
Bulma.section_small
[ 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 ]
]
]
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_ e
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_password "passwordNEWPASS" "New Password" "password"
[ Bulma.box_input "passwordNEWPASS" "Password" "password"
(HandleNewPassword <<< NEWPASS_INP_password)
newPasswordForm.password
, Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation"
should_be_disabled
, Bulma.box_input "confirmationNEWPASS" "Confirmation" "confirmation"
(HandleNewPassword <<< NEWPASS_INP_confirmation)
newPasswordForm.confirmation
, Bulma.btn_validation
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"
@ -137,31 +145,10 @@ handleAction = case _ of
_ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!"
pass, confirmation -> do
if pass == confirmation
then case P.password pass of
Left errors -> H.raise $ Log $ UnableToSend $ A.fold $ map show_error_password errors
Right _ -> handleAction SendChangePasswordMessage
then do H.raise $ Log $ SystemLog "Changing the password"
H.raise $ ChangePassword pass
else H.raise $ Log $ UnableToSend "Confirmation differs from password"
SendChangePasswordMessage -> do
state <- H.get
H.raise $ Log $ SystemLog "Changing the password"
H.raise $ ChangePassword state.newPasswordForm.password
where
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
-- For now, no message actually needs to be handled here.
@ -171,3 +158,11 @@ handleQuery = case _ 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)

418
src/App/Page/Zone.purs
View File

@ -1,33 +1,28 @@
-- | `App.ZoneInterface` provides an interface to display and modify a DNS zone.
-- |
-- | This interface enables to:
-- | This interface allows to:
-- | - display all resource records of a zone (SOA, NS, A, AAAA, CNAME, TXT, MX, SRV)
-- | - provide dedicated interfaces for SPF and DKIM (TODO: DMARC)
-- | - TODO: dedicated interfaces for: SPF, DKIM, DMARC
-- | - add, modify, remove resource records
-- |
-- | **WIP**: Display relevant information for each record type in the (add/mod) modal.
-- | This includes explaining use cases and displaying an appropriate interface for the task at hand.
-- | This includes explaining use cases and displaying an appropriate interface for the
-- | task at hand. For example, having a dedicated interface for DKIM.
-- |
-- | TODO: display errors not only for a record but for the whole zone.
-- | A DNS zone is bound by a set of rules, the whole zone must be consistent.
-- | For example, a CNAME `target` has to point to the `name` of an existing record.
-- |
-- | TODO: do not allow for the modification of read-only resource records.
-- |
-- | TODO: move all serialization code to a single module.
module App.Page.Zone where
import Prelude (Unit, unit, void
, bind, pure
, not, comparing, discard, map, show, class Show
, (+), (&&), ($), (/=), (<<<), (<>), (==), (>), (#), (=<<), (-))
, not, comparing, discard, map, show
, (+), (&&), ($), (/=), (<<<), (<>), (==), (>), (#))
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
import Web.HTML (window) as HTML
import Web.HTML.Window (sessionStorage) as Window
import Web.Storage.Storage as Storage
import App.Validation.Email as Email
import Data.Eq (class Eq)
import Data.Array as A
@ -36,7 +31,6 @@ import Data.Tuple (Tuple(..))
import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Array.NonEmpty as NonEmpty
import Data.Either (Either(..))
import Data.String (toLower)
import Data.String.CodePoints as CP
-- import Data.Foldable as Foldable
import Data.Maybe (Maybe(..), fromMaybe, maybe)
@ -59,9 +53,8 @@ import App.Type.ResourceRecord (ResourceRecord, emptyRR
, mechanism_types, qualifier_types, modifier_types)
import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..)) as RR
import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC
import App.DisplayErrors (error_to_paragraph, show_error_email)
import App.DisplayErrors (error_to_paragraph)
import App.Type.LogMessage (LogMessage(..))
import App.Message.DNSManagerDaemon as DNSManager
@ -83,9 +76,13 @@ data Output
| Log LogMessage
-- | `App.ZoneInterface` can receive messages from `dnsmanagerd`.
-- |
-- | The component is also informed when the connection is lost or up again.
data Query a
= MessageReceived DNSManager.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output
@ -151,9 +148,6 @@ data Action
-- | Add a new resource record to the zone.
| AddRR AcceptedRRTypes ResourceRecord
-- | Reset the different temporary values, such as SPF mechanisms or DMARC mail entry.
| ResetTemporaryValues
-- | Save the changes done in an already existing resource record.
| SaveRR ResourceRecord
@ -184,34 +178,6 @@ data Action
-- | Add a SPF modifier to the currently modified (SPF) entry (see `_currentRR`).
| SPF_Modifier_Add
-- | Change the temporary mail address for DMARC.
| DMARC_mail String
-- | Change the temporary report size limit for DMARC.
| DMARC_mail_limit String
-- | Change the requested report interval.
| DMARC_ri String
-- | Add a new mail address to the DMARC rua list.
| DMARC_rua_Add
-- | Add a new mail address to the DMARC ruf list.
| DMARC_ruf_Add
-- | Remove a mail address of the DMARC rua list.
| DMARC_remove_rua Int
-- | Remove a mail address of the DMARC ruf list.
| DMARC_remove_ruf Int
| DMARC_policy Int
| DMARC_sp_policy Int
| DMARC_adkim Int
| DMARC_aspf Int
| DMARC_pct String
| DMARC_fo Int
| DKIM_hash_algo Int
| DKIM_sign_algo Int
| DKIM_pubkey String
@ -223,6 +189,18 @@ data RRModal
| UpdateRRModal
| RemoveRRModal RRId
show_accepted_type :: AcceptedRRTypes -> String
show_accepted_type = case _ of
A -> "A"
AAAA -> "AAAA"
TXT -> "TXT"
CNAME -> "CNAME"
NS -> "NS"
MX -> "MX"
SRV -> "SRV"
SPF -> "SPF"
DKIM -> "DKIM"
string_to_acceptedtype :: String -> Maybe AcceptedRRTypes
string_to_acceptedtype str = case str of
"A" -> Just A
@ -234,17 +212,14 @@ string_to_acceptedtype str = case str of
"SRV" -> Just SRV
"SPF" -> Just SPF
"DKIM" -> Just DKIM
"DMARC" -> Just DMARC
_ -> Nothing
data Tab = Zone | TheBasics | TokenExplanation
data Tab = Zone | TokenExplanation
derive instance eqTab :: Eq Tab
derive instance genericTab :: Generic Tab _
instance showTab :: Show Tab where
show = genericShow
type State =
{ _domain :: String
, wsUp :: Boolean
-- A modal to present a form for adding a new RR.
, rr_modal :: RRModal
@ -256,7 +231,6 @@ type State =
-- Unique RR form.
, _currentRR :: ResourceRecord
, _currentRR_errors :: Array Validation.Error
, _dmarc_mail_errors :: Array Email.Error
-- SPF details.
, spf_mechanism_q :: String
@ -265,11 +239,7 @@ type State =
, spf_modifier_t :: String
, spf_modifier_v :: String
, dmarc_mail :: String
, dmarc_mail_limit :: Maybe Int
, dkim :: DKIM.DKIM
, dmarc :: DMARC.DMARC
, _zonefile :: Maybe String
@ -303,7 +273,8 @@ default_qualifier_str = "hard_fail" :: String
initialState :: Input -> State
initialState domain =
{ rr_modal: NoModal
{ wsUp: true
, rr_modal: NoModal
, _domain: domain
@ -314,7 +285,6 @@ initialState domain =
, _currentRR: default_empty_rr
-- List of errors within the form in new RR modal.
, _currentRR_errors: []
, _dmarc_mail_errors: []
, _zonefile: Nothing
, spf_mechanism_q: "pass"
@ -322,12 +292,7 @@ initialState domain =
, spf_mechanism_v: ""
, spf_modifier_t: "redirect"
, spf_modifier_v: ""
, dkim: DKIM.emptyDKIMRR
, dmarc: DMARC.emptyDMARCRR
, dmarc_mail: ""
, dmarc_mail_limit: Nothing
, current_tab: Zone
}
@ -340,24 +305,23 @@ render state
[ fancy_tab
, case state.current_tab of
Zone -> render_zone
TheBasics -> Explanations.basics
TokenExplanation -> Explanations.tokens
]
where
fancy_tab =
Bulma.fancy_tabs
[ Bulma.tab_entry (is_tab_active Zone) "Zone" (ChangeTab Zone)
, Bulma.tab_entry (is_tab_active TheBasics) "The basics 🧠" (ChangeTab TheBasics)
, Bulma.tab_entry (is_tab_active TokenExplanation) "Tokens? 🤨" (ChangeTab TokenExplanation)
[ Bulma.tab_entry (is_tab_active Zone) "Zone" (ChangeTab Zone)
, Bulma.tab_entry (is_tab_active TokenExplanation) "Tokens? 🤨" (ChangeTab TokenExplanation)
]
is_tab_active tab = state.current_tab == tab
render_zone =
case state.rr_modal of
RemoveRRModal rr_id -> modal_rr_delete rr_id
NewRRModal _ -> render_current_rr_modal
UpdateRRModal -> render_current_rr_modal
NoModal -> HH.div_
case state.wsUp, state.rr_modal of
false, _ -> Bulma.p "You are disconnected."
true, RemoveRRModal rr_id -> modal_rr_delete rr_id
true, NewRRModal _ -> render_current_rr_modal
true, UpdateRRModal -> render_current_rr_modal
true, NoModal -> HH.div_
[ Bulma.h1 state._domain
, Bulma.hr
, render_resources $ sorted state._resources
@ -377,7 +341,7 @@ render state
modal_rr_delete rr_id = Bulma.modal "Deleting a resource record"
[warning_message] [modal_delete_button, Bulma.cancel_button CancelModal]
where
modal_delete_button = Bulma.alert_btn "Delete the resource record" (RemoveRR rr_id)
modal_delete_button = Bulma.alert_btn "Delete the resource record." (RemoveRR rr_id)
warning_message
= HH.p [] [ HH.text "You are about to delete a resource record, this actions is "
, Bulma.strong "irreversible"
@ -396,7 +360,6 @@ render state
"SRV" -> template modal_content_srv (foot_content SRV)
"SPF" -> template modal_content_spf (foot_content SPF)
"DKIM" -> template modal_content_dkim (foot_content DKIM)
"DMARC" -> template modal_content_dmarc (foot_content DMARC)
_ -> Bulma.p $ "Invalid type: " <> state._currentRR.rrtype
where
-- DRY
@ -414,12 +377,11 @@ render state
, Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600"
(updateForm Field_TTL)
(show state._currentRR.ttl)
, case state._currentRR.rrtype of
"AAAA" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "2001:db8::1" (updateForm Field_Target) state._currentRR.target
"TXT" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Your text" "blah blah" (updateForm Field_Target) state._currentRR.target
"CNAME" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "www" (updateForm Field_Target) state._currentRR.target
"NS" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "ns0.example.com." (updateForm Field_Target) state._currentRR.target
_ -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5" (updateForm Field_Target) state._currentRR.target
should_be_disabled
, Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5"
(updateForm Field_Target)
state._currentRR.target
should_be_disabled
] <> case state.rr_modal of
UpdateRRModal ->
if A.elem state._currentRR.rrtype ["A", "AAAA"]
@ -438,12 +400,15 @@ render state
, Bulma.box_input ("ttlMX") "TTL" "600"
(updateForm Field_TTL)
(show state._currentRR.ttl)
should_be_disabled
, Bulma.box_input ("targetMX") "Target" "www"
(updateForm Field_Target)
state._currentRR.target
should_be_disabled
, Bulma.box_input ("priorityMX") "Priority" "10"
(updateForm Field_Priority)
(maybe "" show state._currentRR.priority)
should_be_disabled
]
modal_content_srv :: Array (HH.HTML w Action)
modal_content_srv =
@ -452,24 +417,31 @@ render state
, Bulma.box_input "domainSRV" "Service name" "service name"
(updateForm Field_Domain)
state._currentRR.name
should_be_disabled
, Bulma.box_input ("protocolSRV") "Protocol" "tcp"
(updateForm Field_Protocol)
(fromMaybe "tcp" state._currentRR.protocol)
should_be_disabled
, Bulma.box_input ("targetSRV") "Where the server is" "www"
(updateForm Field_Target)
state._currentRR.target
should_be_disabled
, Bulma.box_input ("portSRV") "Port of the service" "5061"
(updateForm Field_Port)
(maybe "" show state._currentRR.port)
should_be_disabled
, Bulma.box_input ("prioritySRV") "Priority" "10"
(updateForm Field_Priority)
(maybe "" show state._currentRR.priority)
should_be_disabled
, Bulma.box_input ("ttlSRV") "TTL" "600"
(updateForm Field_TTL)
(show state._currentRR.ttl)
should_be_disabled
, Bulma.box_input ("weightSRV") "Weight" "100"
(updateForm Field_Weight)
(maybe "" show state._currentRR.weight)
should_be_disabled
]
modal_content_spf :: Array (HH.HTML w Action)
modal_content_spf =
@ -482,31 +454,32 @@ render state
, Bulma.box_input "ttlSPF" "TTL" "600"
(updateForm Field_TTL)
(show state._currentRR.ttl)
should_be_disabled
--, case state._currentRR.v of
-- Nothing -> Bulma.p "default value for the version (spf1)"
-- Just v -> Bulma.box_input "vSPF" "Version" "spf1" (updateForm Field_SPF_v) v
-- Just v -> Bulma.box_input "vSPF" "Version" "spf1" (updateForm Field_SPF_v) v should_be_disabled
, Bulma.hr
, maybe (Bulma.p "no mechanism") display_mechanisms state._currentRR.mechanisms
, Bulma.box
[ Bulma.h3 "Current mechanisms"
, maybe (Bulma.p "You don't have any mechanism.") display_mechanisms state._currentRR.mechanisms
, Bulma.h3 "New mechanism"
[ Bulma.h3 "New mechanism"
, Bulma.selection_field "idMechanismQ" "Policy" SPF_Mechanism_q qualifier_types state.spf_mechanism_q
, Bulma.selection_field "idMechanismT" "Type" SPF_Mechanism_t mechanism_types state.spf_mechanism_t
, Bulma.box_input "valueNewMechanismSPF" "Value" ""
SPF_Mechanism_v
state.spf_mechanism_v
, Bulma.btn "Add a mechanism" SPF_Mechanism_Add
should_be_disabled
, Bulma.btn "Add" SPF_Mechanism_Add
]
, Bulma.hr
, maybe (Bulma.p "no modifier") display_modifiers state._currentRR.modifiers
, Bulma.box
[ Bulma.h3 "Current modifiers"
, maybe (Bulma.p "You don't have any modifier.") display_modifiers state._currentRR.modifiers
, Bulma.h3 "New modifier"
[ Bulma.h3 "New modifier"
, Bulma.selection_field "idModifierT" "Modifier" SPF_Modifier_t modifier_types state.spf_modifier_t
, Bulma.box_input "valueNewModifierSPF" "Value" ""
SPF_Modifier_v
state.spf_modifier_v
, Bulma.btn "Add a modifier" SPF_Modifier_Add
should_be_disabled
, Bulma.btn "Add" SPF_Modifier_Add
]
, Bulma.hr
, Bulma.box
@ -526,80 +499,28 @@ render state
, Bulma.box_input "ttlDKIM" "TTL" "600"
(updateForm Field_TTL)
(show state._currentRR.ttl)
should_be_disabled
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dkim_default_algorithms]
, Bulma.selection_field "idDKIMSignature" "Signature algo"
DKIM_sign_algo
(map show DKIM.sign_algos)
(show $ fromMaybe DKIM.RSA state.dkim.k)
(map DKIM.show_signature_algorithm DKIM.sign_algos)
(DKIM.show_signature_algorithm $ fromMaybe DKIM.RSA state.dkim.k)
, Bulma.selection_field "idDKIMHash" "Hash algo"
DKIM_hash_algo
(map show DKIM.hash_algos)
(show $ fromMaybe DKIM.SHA256 state.dkim.h)
, Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as \"MIIBIjANBgqh...\"" DKIM_pubkey state.dkim.p
, Bulma.box_input "noteDKIM" "Note" "Note for fellow administrators." DKIM_note (fromMaybe "" state.dkim.n)
(map DKIM.show_hashing_algorithm DKIM.hash_algos)
(DKIM.show_hashing_algorithm $ fromMaybe DKIM.SHA256 state.dkim.h)
, Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as 'MIIBIjANBgqh...'"
DKIM_pubkey state.dkim.p should_be_disabled
, Bulma.box_input "noteDKIM" "Note" "Note for fellow administrators."
DKIM_note
(fromMaybe "" state.dkim.n)
should_be_disabled
]
modal_content_dmarc :: Array (HH.HTML w Action)
modal_content_dmarc =
[ Bulma.div_content [Bulma.explanation Explanations.dmarc_introduction]
, render_errors
, Bulma.input_with_side_text "domainDMARC" "Name" "_dmarc"
(updateForm Field_Domain)
state._currentRR.name
display_domain_side
, Bulma.box_input "ttlDMARC" "TTL" "600" (updateForm Field_TTL) (show state._currentRR.ttl)
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dmarc_policy]
, Bulma.selection_field "idDMARCPolicy" "Policy" DMARC_policy (map show DMARC.policies) (show state.dmarc.p)
, Bulma.div_content [Bulma.explanation Explanations.dmarc_sp_policy]
, Bulma.selection_field "idDMARCPolicy_sp" "Policy for subdomains" DMARC_sp_policy
(["do not provide policy advice"] <> map show DMARC.policies) (maybe "-" show state.dmarc.sp)
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dmarc_adkim]
, Bulma.selection_field "idDMARCadkim" "Consistency Policy for DKIM" DMARC_adkim DMARC.consistency_policies_txt (maybe "-" show state.dmarc.adkim)
, Bulma.div_content [Bulma.explanation Explanations.dmarc_aspf]
, Bulma.selection_field "idDMARCaspf" "Consistency Policy for SPF" DMARC_aspf DMARC.consistency_policies_txt (maybe "-" show state.dmarc.aspf)
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dmarc_pct]
, Bulma.box_input "idDMARCpct" "Sample rate [0..100]" "100" DMARC_pct (maybe "100" show state.dmarc.pct)
, Bulma.hr
, Bulma.selection_field' "idDMARCfo" "When to send a report" DMARC_fo
(zip_nullable DMARC.report_occasions_txt DMARC.report_occasions_raw)
(maybe "-" show state.dmarc.fo)
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dmarc_contact]
, maybe (Bulma.p "There is no address to send aggregated reports to.")
(display_dmarc_mail_addresses "Addresses to contact for aggregated reports" DMARC_remove_rua) state.dmarc.rua
, maybe (Bulma.p "There is no address to send detailed reports to.")
(display_dmarc_mail_addresses "Addresses to contact for detailed reports" DMARC_remove_ruf) state.dmarc.ruf
, Bulma.hr
, render_dmarc_mail_errors
, Bulma.box_input "idDMARCmail" "Address to contact" "admin@example.com" DMARC_mail state.dmarc_mail
, Bulma.box_input "idDMARCmaillimit" "Report size limit (in KB)" "2000" DMARC_mail_limit (maybe "0" show state.dmarc_mail_limit)
, Bulma.level [ Bulma.btn "New address for aggregated report" DMARC_rua_Add
, Bulma.btn "New address for specific report" DMARC_ruf_Add
] []
, Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dmarc_ri]
, Bulma.box_input "idDMARCri" "Report interval (in seconds)" "86400" DMARC_ri (maybe "0" show state.dmarc.ri)
]
render_dmarc_mail_errors
= if A.length state._dmarc_mail_errors > 0
then Bulma.notification_danger_block'
$ [ Bulma.h3 "Invalid mail 😥" ] <> map (Bulma.p <<< show_error_email) state._dmarc_mail_errors
else HH.div_ [ ]
display_domain_side = (if state._currentRR.name == (state._domain <> ".") then "" else "." <> state._domain)
newtokenbtn = Bulma.btn (maybe "🏁​ Ask for a token" (\_ -> "🏁​ Ask for a new token") state._currentRR.token) (NewToken state._currentRR.rrid)
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
newtokenbtn = Bulma.btn "🏁​ Ask for a token!" (NewToken state._currentRR.rrid)
foot_content x =
case state.rr_modal of
NewRRModal _ -> [Bulma.btn_add (ValidateRR x)]
@ -612,14 +533,11 @@ render state
where
title = case state.rr_modal of
NoModal -> "Error: no modal should be displayed"
NewRRModal t_ -> "New " <> show t_ <> " resource record"
UpdateRRModal -> "Update " <> state._currentRR.rrtype <> " Resource Record"
NewRRModal t_ -> "New " <> show_accepted_type t_ <> " resource record"
UpdateRRModal -> "Update RR " <> show state._currentRR.rrid
RemoveRRModal rr_id -> "Error: should display removal modal instead (for RR " <> show rr_id <> ")"
foot = foot_ <> [Bulma.cancel_button CancelModal]
zip_nullable :: forall a. Array a -> Array String -> Array (Tuple a String)
zip_nullable txt raw = A.zip txt ([""] <> raw)
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
-- | Cancel the current modal being presented.
@ -627,8 +545,6 @@ handleAction = case _ of
CancelModal -> do
H.modify_ _ { rr_modal = NoModal }
H.modify_ _ { _currentRR_errors = [] }
H.modify_ _ { _dmarc_mail_errors = [] }
handleAction $ ResetTemporaryValues
-- | Create the RR modal.
DeleteRRModal rr_id -> do
@ -636,9 +552,6 @@ handleAction = case _ of
-- | Change the current tab.
ChangeTab new_tab -> do
-- Store the current tab we are on and restore it when we reload.
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
H.liftEffect $ Storage.setItem "current-zone-tab" (show new_tab) sessionstorage
H.modify_ _ { current_tab = new_tab }
-- | Create modal (a form) for a resource record to update.
@ -649,8 +562,7 @@ handleAction = case _ of
Just rr -> do
H.modify_ _ { _currentRR = rr }
_ <- case rr.rrtype of
"DKIM" -> H.modify_ _ { dkim = fromMaybe DKIM.emptyDKIMRR rr.dkim }
"DMARC" -> H.modify_ _ { dmarc = fromMaybe DMARC.emptyDMARCRR rr.dmarc }
"DKIM" -> H.modify_ _ { dkim = fromMaybe DKIM.emptyDKIMRR rr.dkim }
_ -> pure unit
H.modify_ _ { rr_modal = UpdateRRModal }
@ -671,7 +583,6 @@ handleAction = case _ of
, q = Just RR.HardFail
}
default_rr_DKIM = emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" }
default_rr_DMARC = emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" }
case t of
A -> H.modify_ _ { _currentRR = default_rr_A }
@ -683,7 +594,6 @@ handleAction = case _ of
SRV -> H.modify_ _ { _currentRR = default_rr_SRV }
SPF -> H.modify_ _ { _currentRR = default_rr_SPF }
DKIM -> H.modify_ _ { _currentRR = default_rr_DKIM }
DMARC -> H.modify_ _ { _currentRR = default_rr_DMARC }
-- | Initialize the ZoneInterface component: ask for the domain zone to `dnsmanagerd`.
Initialize -> do
@ -692,16 +602,6 @@ handleAction = case _ of
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain }
H.raise $ MessageToSend message
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
old_tab <- H.liftEffect $ Storage.getItem "current-zone-tab" sessionstorage
case old_tab of
Nothing -> pure unit
Just current_tab -> case current_tab of
"Zone" -> handleAction $ ChangeTab Zone
"TheBasics" -> handleAction $ ChangeTab TheBasics
"TokenExplanation" -> handleAction $ ChangeTab TokenExplanation
_ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old current_tab: " <> current_tab
-- | Perform validation. In case the record is valid, it is added to the zone then the modal is closed.
-- | Else, the different errors are added to the state.
ValidateRR t -> do
@ -712,7 +612,6 @@ handleAction = case _ of
-- Since _currentRR.dkim isn't modified directly, it is copied from `State`.
_ <- case t of
DKIM -> H.modify_ \state -> state { _currentRR { dkim = Just state.dkim } }
DMARC -> H.modify_ \state -> state { _currentRR { dmarc = Just state.dmarc } }
_ -> pure unit
state <- H.get
@ -722,11 +621,7 @@ handleAction = case _ of
-- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
H.modify_ _ { _currentRR_errors = actual_errors }
Right newrr -> do
H.modify_ _ { _currentRR_errors = []
, _dmarc_mail_errors = []
, dkim = DKIM.emptyDKIMRR
, dmarc = DMARC.emptyDMARCRR
}
H.modify_ _ { _currentRR_errors = [], dkim = DKIM.emptyDKIMRR }
handleAction $ AddRR t newrr
handleAction CancelModal
@ -735,7 +630,6 @@ handleAction = case _ of
AddRR t newrr -> do
state <- H.get
H.raise $ Log $ SystemLog $ "Add new " <> show t
H.modify_ _ { _zonefile = Nothing }
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
@ -755,8 +649,7 @@ handleAction = case _ of
-- Since _currentRR.dkim isn't modified directly, it is copied from `State`.
state0 <- H.get
_ <- case state0._currentRR.rrtype of
"DKIM" -> H.modify_ _ { _currentRR { dkim = Just state0.dkim } }
"DMARC" -> H.modify_ _ { _currentRR { dmarc = Just state0.dmarc } }
"DKIM" -> H.modify_ _ { _currentRR { dkim = Just state0.dkim } }
_ -> pure unit
state <- H.get
@ -764,34 +657,20 @@ handleAction = case _ of
Left actual_errors -> do
H.modify_ _ { _currentRR_errors = actual_errors }
Right rr -> do
H.modify_ _ { _currentRR_errors = [], _dmarc_mail_errors = [] }
H.modify_ _ { _currentRR_errors = [] }
handleAction $ SaveRR rr
ResetTemporaryValues -> do
H.modify_ _ { spf_mechanism_q = "pass"
, spf_mechanism_t = "a"
, spf_mechanism_v = ""
, spf_modifier_t = "redirect"
, spf_modifier_v = ""
, dmarc_mail = ""
, dmarc_mail_limit = Nothing
, _dmarc_mail_errors = []
}
SaveRR rr -> do
state <- H.get
H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid
H.modify_ _ { _zonefile = Nothing }
message <- H.liftEffect
$ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
H.raise $ MessageToSend message
handleAction $ ResetTemporaryValues
RemoveRR rr_id -> do
{ _domain } <- H.get
H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")"
H.modify_ _ { _zonefile = Nothing }
-- Send a removal message.
message <- H.liftEffect
$ DNSManager.serialize
@ -847,7 +726,6 @@ handleAction = case _ of
[] -> Nothing
v -> Just v
H.modify_ _ { _currentRR { mechanisms = new_value }}
handleAction $ ResetTemporaryValues
SPF_Modifier_Add -> do
state <- H.get
@ -859,67 +737,6 @@ handleAction = case _ of
[] -> Nothing
v -> Just v
H.modify_ _ { _currentRR { modifiers = new_value }}
handleAction $ ResetTemporaryValues
DMARC_mail v -> H.modify_ _ { dmarc_mail = v }
DMARC_mail_limit v -> H.modify_ _ { dmarc_mail_limit = Just $ fromMaybe 0 $ fromString v }
DMARC_ri v -> H.modify_ _ { dmarc { ri = fromString v } }
DMARC_rua_Add -> do
state <- H.get
case Email.email state.dmarc_mail of
Left errors -> H.modify_ _ { _dmarc_mail_errors = errors }
Right _ -> do
let current_ruas = fromMaybe [] state.dmarc.rua
dmarc_mail = state.dmarc_mail
dmarc_mail_limit = state.dmarc_mail_limit
new_list = current_ruas <> [ {mail: dmarc_mail, limit: dmarc_mail_limit} ]
H.modify_ _ { dmarc { rua = Just new_list }}
handleAction $ ResetTemporaryValues
DMARC_ruf_Add -> do
state <- H.get
case Email.email state.dmarc_mail of
Left errors -> H.modify_ _ { _dmarc_mail_errors = errors }
Right _ -> do
let current_rufs = fromMaybe [] state.dmarc.ruf
dmarc_mail = state.dmarc_mail
dmarc_mail_limit = state.dmarc_mail_limit
new_list = current_rufs <> [ {mail: dmarc_mail, limit: dmarc_mail_limit} ]
H.modify_ _ { dmarc { ruf = Just new_list } }
handleAction $ ResetTemporaryValues
DMARC_remove_rua i -> do
state <- H.get
let current_ruas = case state._currentRR.dmarc of
Nothing -> []
Just dmarc -> fromMaybe [] dmarc.rua
new_value = case (remove_id i $ attach_id 0 current_ruas) of
[] -> Nothing
v -> Just v
new_dmarc = case state._currentRR.dmarc of
Nothing -> DMARC.emptyDMARCRR { rua = new_value }
Just dmarc -> dmarc { rua = new_value }
H.modify_ \s -> s { _currentRR { dmarc = Just new_dmarc } }
DMARC_remove_ruf i -> do
state <- H.get
let current_rufs = case state._currentRR.dmarc of
Nothing -> []
Just dmarc -> fromMaybe [] dmarc.ruf
new_value = case (remove_id i $ attach_id 0 current_rufs) of
[] -> Nothing
v -> Just v
new_dmarc = case state._currentRR.dmarc of
Nothing -> DMARC.emptyDMARCRR { ruf = new_value }
Just dmarc -> dmarc { ruf = new_value }
H.modify_ \s -> s { _currentRR { dmarc = Just new_dmarc } }
DMARC_policy v -> H.modify_ _ { dmarc { p = fromMaybe DMARC.None $ DMARC.policies A.!! v } }
DMARC_sp_policy v -> H.modify_ _ { dmarc { sp = DMARC.policies A.!! (v - 1) } }
DMARC_adkim v -> H.modify_ _ { dmarc { adkim = DMARC.consistency_policies A.!! (v - 1) } }
DMARC_aspf v -> H.modify_ _ { dmarc { aspf = DMARC.consistency_policies A.!! (v - 1) } }
DMARC_pct v -> H.modify_ _ { dmarc { pct = Just $ fromMaybe 100 (fromString v) } }
DMARC_fo v -> H.modify_ _ { dmarc { fo = DMARC.report_occasions A.!! (v - 1) } }
DKIM_hash_algo v -> H.modify_ _ { dkim { h = DKIM.hash_algos A.!! v } }
DKIM_sign_algo v -> H.modify_ _ { dkim { k = DKIM.sign_algos A.!! v } }
@ -957,6 +774,14 @@ handleQuery = case _ of
_ -> H.raise $ Log $ ErrorLog $ "Message not handled in ZoneInterface."
pure (Just a)
ConnectionIsDown a -> do
H.modify_ _ { wsUp = false }
pure (Just a)
ConnectionIsUp a -> do
H.modify_ _ { wsUp = true }
pure (Just a)
where
-- replace_entry :: ResourceRecord
replace_entry new_rr = do
@ -1001,7 +826,6 @@ render_resources records
<> (rr_box tag_srv [] Bulma.srv_table_header table_content all_srv_rr)
<> (rr_box tag_spf [] Bulma.spf_table_header table_content all_spf_rr)
<> (rr_box tag_dkim [] Bulma.dkim_table_header table_content all_dkim_rr)
<> (rr_box tag_dmarc [] Bulma.dmarc_table_header table_content all_dmarc_rr)
<> (rr_box tag_basic_ro bg_color_ro Bulma.simple_table_header_ro table_content_w_seps all_basic_ro_rr)
where
all_basic_rr = A.filter (\rr -> A.elem rr.rrtype baseRecords && not rr.readonly) records
@ -1012,16 +836,14 @@ render_resources records
all_srv_rr = all_XX_rr "SRV"
all_spf_rr = all_XX_rr "SPF"
all_dkim_rr = all_XX_rr "DKIM"
all_dmarc_rr = all_XX_rr "DMARC"
tag_soa = tags [tag_ro "SOA", tag_ro "read only"]
tag_basic = tags [tag "Basic Resource Records (A, AAAA, PTR, NS, TXT)"]
tag_basic = tags [tag "Basic RRs (A, AAAA, PTR, NS, TXT)"]
tag_mx = tags [tag "MX"]
tag_srv = tags [tag "SRV"]
tag_spf = tags [tag "SPF"]
tag_dkim = tags [tag "DKIM"]
tag_dmarc = tags [tag "DMARC"]
tag_basic_ro = tags [tag_ro "Basic Resource Records", tag_ro "read only"]
tag_basic_ro = tags [tag_ro "Basic RRs", tag_ro "read only"]
rr_box :: HH.HTML w Action -- box title (type of data)
-> Array HH.ClassName
@ -1095,36 +917,15 @@ render_resources records
Just dkim ->
[
-- , HH.td_ [ Bulma.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed. Assume DKIM1.
HH.td_ [ Bulma.p $ maybe "" show dkim.h ]
, HH.td_ [ Bulma.p $ maybe "" show dkim.k ]
, HH.td_ [ Bulma.p $ CP.take 20 dkim.p ]
, HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ]
HH.td_ [ Bulma.p $ maybe "" DKIM.show_hashing_algorithm dkim.h ]
, HH.td_ [ Bulma.p $ maybe "" DKIM.show_signature_algorithm dkim.k ]
, HH.td_ [ Bulma.p $ CP.take 5 dkim.p ]
, HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ]
, if rr.readonly
then HH.td_ [ Bulma.btn_readonly ]
else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid), Bulma.btn_delete (DeleteRRModal rr.rrid) ]
]
Nothing -> [Bulma.p "Problem: there is no DKIM data." ]
"DMARC" ->
[ HH.td_ [ Bulma.p rr.name ]
, HH.td_ [ Bulma.p $ show rr.ttl ]
] <> case rr.dmarc of
Just dmarc ->
[
-- , HH.td_ [ Bulma.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed. Assume DMARC1.
HH.td_ [ Bulma.p $ show dmarc.p ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.sp ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.adkim ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.aspf ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.pct ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.fo ]
, HH.td_ [ Bulma.p $ maybe "" show dmarc.ri ]
-- TODO? rua & ruf
-- , HH.td_ [ ] -- For now, assume AFRF.
, if rr.readonly
then HH.td_ [ Bulma.btn_readonly ]
else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid), Bulma.btn_delete (DeleteRRModal rr.rrid) ]
]
Nothing -> [Bulma.p "Problem: there is no DMARC data." ]
"MX" ->
[ HH.td_ [ Bulma.p rr.name ]
, HH.td_ [ Bulma.p $ show rr.ttl ]
@ -1155,7 +956,6 @@ render_resources records
fancy_qualifier_display qualifier = "(" <> show_qualifier_char qualifier <> ") " <> show_qualifier qualifier
display_mechanisms :: forall w. Array RR.Mechanism -> HH.HTML w Action
display_mechanisms [] = Bulma.p "You don't have any mechanism."
display_mechanisms ms =
Bulma.box_ C.has_background_warning_light
[ Bulma.table [] [ Bulma.mechanism_table_header, HH.tbody_ $ map render_mechanism_row $ attach_id 0 ms] ]
@ -1169,7 +969,6 @@ display_mechanisms ms =
]
display_modifiers :: forall w. Array RR.Modifier -> HH.HTML w Action
display_modifiers [] = Bulma.p "You don't have any modifier."
display_modifiers ms =
Bulma.box_ C.has_background_warning_light
[ Bulma.table [] [ Bulma.modifier_table_header, HH.tbody_ $ map render_modifier_row $ attach_id 0 ms] ]
@ -1181,19 +980,6 @@ display_modifiers ms =
, HH.td_ [ Bulma.alert_btn "x" (SPF_remove_modifier i) ]
]
display_dmarc_mail_addresses :: forall w. String -> (Int -> Action) -> Array DMARC.DMARCURI -> HH.HTML w Action
display_dmarc_mail_addresses t f ms =
Bulma.box_ C.has_background_warning_light
[ Bulma.h3 t
, Bulma.table [] [ Bulma.dmarc_dmarcuri_table_header, HH.tbody_ $ map render_dmarcuri_row $ attach_id 0 ms] ]
where
render_dmarcuri_row :: (Tuple Int DMARC.DMARCURI) -> HH.HTML w Action
render_dmarcuri_row (Tuple i m) = HH.tr_
[ HH.td_ [ Bulma.p m.mail ]
, HH.td_ [ Bulma.p $ maybe "(no size limit)" show m.limit ]
, HH.td_ [ Bulma.alert_btn "x" (f i) ]
]
baseRecords :: Array String
baseRecords = [ "A", "AAAA", "CNAME", "TXT", "NS" ]
@ -1214,16 +1000,16 @@ render_new_records _
, Bulma.btn "SRV" (CreateNewRRModal SRV)
] []
, Bulma.hr
, Bulma.h1 "Special records about the mail system"
, Bulma.h1 "Special records about the mail system (soon)"
-- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
, Bulma.level [
Bulma.btn "SPF" (CreateNewRRModal SPF)
, Bulma.btn "DKIM" (CreateNewRRModal DKIM)
, Bulma.btn "DMARC" (CreateNewRRModal DMARC)
Bulma.btn "SPF" (CreateNewRRModal SPF)
, Bulma.btn "DKIM" (CreateNewRRModal DKIM)
, Bulma.btn_ro (C.is_small <> C.is_warning) "DMARC"
] []
, Bulma.hr
, Bulma.level [
Bulma.btn "Get the final zone file" AskZoneFile
Bulma.btn "Get the final zone file." AskZoneFile
] [HH.text "For debug purposes. ⚠"]
]
@ -1248,7 +1034,7 @@ loopE f a = case (A.head a) of
update_field :: ResourceRecord -> Field -> ResourceRecord
update_field rr updated_field = case updated_field of
Field_Domain val -> rr { name = toLower val }
Field_Domain val -> rr { name = val }
Field_Target val -> rr { target = val }
Field_TTL val -> rr { ttl = fromMaybe 0 (fromString val) }
Field_Priority val -> rr { priority = fromString val }

232
src/App/Text/Explanations.purs
View File

@ -1,25 +1,18 @@
module App.Text.Explanations where
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Bulma as Bulma
expl' :: forall w i. String -> HH.HTML w i
expl' text = expl [Bulma.p text]
expl :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
expl content = Bulma.div_content [ Bulma.explanation content ]
expl_txt :: forall w i. String -> HH.HTML w i
expl_txt content = Bulma.explanation [ Bulma.p content ]
col :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
col arr = Bulma.column_ [ Bulma.box arr ]
tokens :: forall w i. HH.HTML w i
tokens = HH.div_
[ Bulma.h3 "What are tokens?"
, expl' """
, 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 an A record (IPv4) pointing to your web server at home, "
]
, 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"]
@ -33,7 +26,7 @@ tokens = HH.div_
, 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/<your-token>" ]
, 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.
@ -56,110 +49,11 @@ tokens = HH.div_
]
]
basics :: forall w i. HH.HTML w i
basics = HH.div_
[ Bulma.h3 "Basics of DNS"
, Bulma.p """
The domain name system (DNS) enables people share a name instead of an address to find a website or service.
"""
, Bulma.p """
To configure a zone, the first steps are trivial.
"""
, Bulma.hr
, Bulma.h3 "I have something to host (A and AAAA records)."
, expl' "Let's assume you have a web server and you host your website somewhere."
, Bulma.p """
You want an A (IPv4) or AAAA (IPv6) record pointing to your server, named "enigma" for example.
"""
, Bulma.hr
, Bulma.h3 "You need other names pointing to your server (CNAME records)."
, Bulma.p """
You may not want to use the name of your server "enigma" directly.
Instead, you may want the usual names for your services, such as "www" or "blog".
CNAME records are basically aliases, exactly to that end.
"""
, Bulma.hr
, Bulma.h3 "If you have other servers, just add more A or AAAA records."
, Bulma.p """
Tip: choose relevant names for your servers then add CNAME records.
For example, you can have an A record named "server1" and a CNAME "www" pointing to it.
The service isn't pointing to an actual IP address directly,
but to the name of the physical server providing the service.
You don't need to remember the IP address of each of your servers.
"""
, Bulma.hr
, Bulma.h3 "I want an email server."
, expl' """
Hosting a mail server is quite complex.
This section will focus on the main parts regarding the DNS.
"""
, Bulma.notification_danger' """
The actual configuration of your mail server is complex and depends on your choice of software.
This won't be covered here.
"""
, Bulma.p """
You need an MX record pointing to your "www" A (or AAAA) record.
"""
, Bulma.p """
Having an MX record isn't enough to handle a mail server.
You need to use a few spam mitigation mechanisms.
"""
, Bulma.columns_
[ col
[ expl' """
Spam mitigation 1: tell what are the right mail servers for your domain with Sender Policy Framework (SPF).
"""
, expl_txt """
You need a SPF record to tell other mail servers what are the acceptable mail servers for your domain.
"""
]
, col
[ expl' """
Spam mitigation 2: prove that the mails come from your mail server with DomainKeys Identified Mail (DKIM).
"""
, expl_txt """
You will have to configure your mail server to sign the emails you send.
This involves creating a pair of keys (public and private).
Your mail server will sign the mails with the private key,
and other mail servers will verify the signature with the public key.
So, you need to publish the public key in a DKIM record.
"""
]
, col
[ expl' """
Spam mitigation 3: mitigate fraud (impersonators) with Domain-based Message Authentication Reporting and Conformance (DMARC).
Tell other mail servers to only accept emails from your domain which actually are coming from your domain (SPF) and sent by your mail server (DKIM).
"""
, expl_txt """
Last but not least, DMARC.
"""
, Bulma.hr
, Bulma.p """
DMARC enables to check the "From:" field of a mail, based on the SPF and DKIM mechanisms.
Thus, domains with a DMARC record enable to only allow verified mails.
Valid emails come from an authorized IP address (SPF), are signed by the verified email server (DKIM) and have an email address coming from a verified domain (DMARC) related to the two previous spam mitigation mechanisms.
"""
, Bulma.hr
, Bulma.p """
With DMARC, you won't accept an email from "hacker@example.com" because it was sent by another domain with a valid SPF and DKIM.
"""
]
]
, Bulma.hr
, Bulma.h3 "How to automate the update of my IP address?"
, Bulma.p "Check out the \"Tokens? 🤨\" tab."
]
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 enables emails to be signed by the sender and for the receiver to verify the origin of the mail.
This allows emails to be signed by the sender, and for the receiver to prove the origin of the mail.
"""
, HH.p []
[ HH.text """
@ -173,100 +67,6 @@ dkim_introduction =
]
]
dmarc_introduction :: forall w i. Array (HH.HTML w i)
dmarc_introduction =
[ Bulma.p """
DMARC is a spam mitigation mechanism on top of SPF and DKIM.
Upon receiving a mail, the server checks whether the "From:" field of the mail is consistent with the SPF and DKIM
records of the sender's domain.
The DMARC record tells what to do with the mail in case of an inconsistency, and DMARC enables to define email
addresses that should receive error reports.
"""
]
dmarc_policy :: forall w i. Array (HH.HTML w i)
dmarc_policy =
[ Bulma.p """
DMARC record enables to tell receivers what to do with a non-conforming message;
a message that wasn't properly secured with SPF and DKIM.
"""
, Bulma.p """
This message can either be accepted ("None") or rejected, or even quarantined, meaning to be considered as suspicious.
This can take different forms, such as being flagged, marked as spam or have a high "spam score", it's up to the receiver.
"""
]
dmarc_sp_policy :: forall w i. Array (HH.HTML w i)
dmarc_sp_policy =
[ Bulma.p """
Same as the previous entry, but for sub-domains.
"""
]
dmarc_adkim :: forall w i. Array (HH.HTML w i)
dmarc_adkim =
[ Bulma.p """
Consistency policy for DKIM. Tell what should be considered acceptable.
"""
, Bulma.p """
This is about the relation between the email "From:" field and the domain field of the DKIM signature ("d:").
"""
, Bulma.p """
The policy can be either strict (both should be identical) or relaxed (both in the same Organizational Domain).
"""
]
dmarc_aspf :: forall w i. Array (HH.HTML w i)
dmarc_aspf =
[ Bulma.p """
Consistency policy for SPF. Tell what should be considered acceptable.
"""
, Bulma.p """
First, SPF should produce a passing result.
Then, the "From:" and the "MailFrom:" fields of the received email are checked.
"""
, Bulma.p """
In strict mode, both fields should be identical.
In relaxed mode, they can be different, but in the same Organizational Domain.
"""
, Bulma.p """
From RFC7489: For example, if a message passes an SPF check with an
RFC5321.MailFrom domain of "cbg.bounces.example.com", and the address
portion of the RFC5322.From field contains "payments@example.com",
the Authenticated RFC5321.MailFrom domain identifier and the
RFC5322.From domain are considered to be "in alignment" in relaxed
mode, but not in strict mode.
"""
, HH.p_
[ HH.text "See "
, HH.a [HP.href "https://publicsuffix.org/"] [ HH.text "publicsuffix.org" ]
, HH.text " for a list of organizational domains."
]
]
dmarc_contact :: forall w i. Array (HH.HTML w i)
dmarc_contact =
[ Bulma.p """
In case you want to receive error reports, enter email addresses that should receive either an aggregated report or a detailed report of the occurring errors.
"""
]
dmarc_ri :: forall w i. Array (HH.HTML w i)
dmarc_ri =
[ Bulma.p """
Requested report interval. Default is 86400.
"""
]
dmarc_pct :: forall w i. Array (HH.HTML w i)
dmarc_pct =
[ Bulma.p """
Sampling rate.
Percentage of messages subjected to the requested policy.
"""
]
dkim_default_algorithms :: forall w i. Array (HH.HTML w i)
dkim_default_algorithms =
[ Bulma.p """
@ -278,16 +78,16 @@ dkim_default_algorithms =
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 the "
[ HH.text "Sender Policy Framework (SPF) is a way to tell "
, HH.u_ [HH.text "other mail servers"]
, HH.text " which are the mail servers supposed to send mails from "
, HH.u_ [HH.text "your domain"]
, 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 from your email address but coming from an IP address we didn't list as authorized will be discarded.
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.
"""
]
@ -295,11 +95,9 @@ spf_introduction =
[ 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 beginners"]
[ HH.u_ [HH.text "Advice for novice users"]
, HH.text """
: default values should work great with simple domains.
Don't change anything, just click on the "Add" button below.
In addition, make sure to have an MX record, which should be pointing to an A or AAAA record, and that will do it. 🥳
"""
]
]
@ -309,7 +107,7 @@ 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 opt for dropping the mail (a
By default, let's advise to drop the mail (a
"""
, HH.u_ [HH.text "hard fail"]
, HH.text """).
@ -319,20 +117,20 @@ spf_default_behavior = [Bulma.p """
srv_introduction :: forall w i. Array (HH.HTML w i)
srv_introduction =
[ Bulma.p "The SRV record is a DNS resource record for specifying the location of services."
[ 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 resource record.
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, the target "
, 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 " could be specified."
, HH.text "."
]
]

5
src/App/Type/AcceptedRRTypes.purs
View File

@ -17,9 +17,8 @@ data AcceptedRRTypes
| SRV
| SPF
| DKIM
| DMARC
derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _
derive instance genericMyADT :: Generic AcceptedRRTypes _
instance showAcceptedRRTypes :: Show AcceptedRRTypes where
instance showMyADT :: Show AcceptedRRTypes where
show = genericShow

38
src/App/Type/DKIM.purs
View File

@ -1,10 +1,5 @@
module App.Type.DKIM where
import Prelude
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
import App.Type.GenericSerialization (generic_serialization)
import Data.Maybe (Maybe(..))
import Data.Codec.Argonaut (JsonCodec)
@ -44,13 +39,10 @@ emptyDKIMRR = { v: Nothing, k: Just RSA, h: Just SHA256, p: "", n: Nothing }
data HashingAlgorithm = {- SHA1 | -} SHA256
hash_algos = [ {- "sha1", -} SHA256] :: Array HashingAlgorithm
derive instance genericHashingAlgorithm :: Generic HashingAlgorithm _
instance showHashingAlgorithm :: Show HashingAlgorithm where
show = genericShow
-- | Codec for just encoding a single value of type `HashingAlgorithm`.
codecHashingAlgorithm :: CA.JsonCodec HashingAlgorithm
codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm generic_serialization CA.string
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
@ -58,15 +50,17 @@ str_to_hashing_algorithm = case _ of
"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
derive instance genericSignatureAlgorithm :: Generic SignatureAlgorithm _
instance showSignatureAlgorithm :: Show SignatureAlgorithm where
show = genericShow
-- | Codec for just encoding a single value of type `SignatureAlgorithm`.
codecSignatureAlgorithm :: CA.JsonCodec SignatureAlgorithm
codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm generic_serialization CA.string
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
@ -74,16 +68,22 @@ str_to_signature_algorithm = case _ of
"ed25519" -> Just ED25519
_ -> Nothing
show_signature_algorithm :: SignatureAlgorithm -> String
show_signature_algorithm = case _ of
RSA -> "rsa"
ED25519 -> "ed25519"
data Version = DKIM1
derive instance genericVersion :: Generic Version _
instance showVersion :: Show Version where
show = genericShow
-- | Codec for just encoding a single value of type `Version`.
codecVersion :: CA.JsonCodec Version
codecVersion = CA.prismaticCodec "Version" str_to_version generic_serialization CA.string
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
"dkim1" -> Just DKIM1
_ -> Nothing
show_version :: Version -> String
show_version = case _ of
DKIM1 -> "dkim1"

251
src/App/Type/DMARC.purs
View File

@ -1,251 +0,0 @@
-- | DMARC is a spam mitigation mechanism described in RFC7489.
-- | DMARC is built on top of DKIM and SPF.
module App.Type.DMARC where
import Prelude
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
import App.Type.GenericSerialization (generic_serialization)
import Data.Maybe (Maybe(..))
import Data.Codec.Argonaut (JsonCodec)
import Data.Codec.Argonaut as CA
import Data.Codec.Argonaut.Record as CAR
type DMARC
= {
-- | adkim= Optional.
-- | Consistency policy for DKIM.
-- | Either strict (dkim signature domain = "From:" field) or relaxed (both in the same Organizational Domain).
adkim :: Maybe ConsistencyPolicy
-- | aspf= Optional.
-- | Consistency policy for SPF.
-- | Either strict ("MailFrom:" same as "From:") or relaxed (both in the same Organizational Domain).
, aspf :: Maybe ConsistencyPolicy
-- | v= Required. Default is "DMARC1", so the implementation doesn't actually require it.
, v :: Maybe Version
-- | pct= Optional. Percentage of messages subjected to the requested policy [0...100], 100 by default.
, pct :: Maybe Int
-- | p= Required. Requested Mail Receiver policy (None, Quarantine, Reject).
, p :: Policy
-- | sp= Optional. Requested Mail Receiver policy for all subdomains.
, sp :: Maybe Policy
-- | fo= Optional. When to send a report (on DKIM or SPF error? Any? Both?).
, fo :: Maybe ReportOccasion
-- | rua= Optional. Addresses to which aggregate feedback is to be sent.
, rua :: Maybe (Array DMARCURI)
-- | ruf= Optional. Addresses to which message-specific failure information is to be reported.
, ruf :: Maybe (Array DMARCURI)
-- | rf= Optional. List of accepted report format, AFRF by default.
, rf :: Maybe (Array ReportFormat)
-- | ri= Optional. Interval requested between aggregate reports. Default is 86400.
, ri :: Maybe Int
}
emptyDMARCRR :: DMARC
emptyDMARCRR =
{ adkim: Nothing
, aspf: Nothing
, v: Nothing -- default: DMARC1
, pct: Nothing -- default: 100%
, p: Reject
, sp: Nothing
, fo: Nothing
, rua: Nothing
, ruf: Nothing
, rf: Nothing -- default: AFRF
, ri: Nothing -- default: 86400
}
codec :: JsonCodec DMARC
codec = CA.object "DMARC"
(CAR.record
{ v: CAR.optional codecVersion
, adkim: CAR.optional codecConsistencyPolicy
, aspf: CAR.optional codecConsistencyPolicy
, pct: CAR.optional CA.int
, p: codecPolicy
, sp: CAR.optional codecPolicy
, fo: CAR.optional codecReportOccasion
, rua: CAR.optional (CA.array codecDMARCURI)
, ruf: CAR.optional (CA.array codecDMARCURI)
, rf: CAR.optional (CA.array codecReportFormat)
, ri: CAR.optional CA.int
})
-- | DMARCURI is both an email and an eventual size.
-- | This is a simplification of the actual specs, but that's good enough.
type DMARCURI = { mail :: String, limit :: Maybe Int }
-- | Codec for just encoding a single value of type `DMARCURI`.
codecDMARCURI :: JsonCodec DMARCURI
codecDMARCURI = CA.object "DMARCURI" (CAR.record { mail: CA.string, limit: CAR.optional CA.int })
data ReportOccasion
-- | Both DKIM and SPF should be in error to have a report.
= Both
-- | DKIM should be erroneous to produce a report.
| DKIMonly
-- | SPF should be erroneous to produce a report.
| SPFonly
-- | Produce a report whether SPF or DKIM is erroneous.
| Any
report_occasions :: Array ReportOccasion
report_occasions = [Both, DKIMonly, SPFonly, Any]
report_occasions_txt :: Array String
report_occasions_txt
= [ "Do not tell when to send reports (default: when both fail)"
, "When both SPF and DKIM fail"
, "Upon a DKIM error"
, "Upon an SPF error"
, "Upon any error"
]
report_occasions_raw :: Array String
report_occasions_raw = map show report_occasions
-- | Codec for just encoding a single value of type `ReportOccasion`.
codecReportOccasion :: CA.JsonCodec ReportOccasion
codecReportOccasion = CA.prismaticCodec "ReportOccasion" str_to_report_occasion generic_serialization CA.string
str_to_report_occasion :: String -> Maybe ReportOccasion
str_to_report_occasion = case _ of
"both" -> Just Both
"dkimonly" -> Just DKIMonly
"spfonly" -> Just SPFonly
"any" -> Just Any
_ -> Nothing
derive instance genericReportOccasion :: Generic ReportOccasion _
instance showReportOccasion :: Show ReportOccasion where
show = genericShow
data ConsistencyPolicy
-- | s = strict.
-- |
-- | For DKIM: DKIM signature should first be verified.
-- | Then, the "From:" field should be the exact same domain as the DKIM signature domain.
-- |
-- | For SPF: first, SPF should produce a passing result. Then, the "From:" and the "MailFrom:" fields are checked.
-- | In strict mode, Both "MailFrom:" and "From:" fields should have the same value.
-- |
-- | From RFC7489: For example, if a message passes an SPF check with an
-- | RFC5321.MailFrom domain of "cbg.bounces.example.com", and the address
-- | portion of the RFC5322.From field contains "payments@example.com",
-- | the Authenticated RFC5321.MailFrom domain identifier and the
-- | RFC5322.From domain are considered to be "in alignment" in relaxed
-- | mode, but not in strict mode.
-- | See https://publicsuffix.org/ for a list of organizational domains.
= Strict
-- | r = relaxed, default.
-- |
-- | For DKIM: DKIM signature should first be verified.
-- | Then, the "From:" field should have the same domain as the DKIM signature domain or be in the same
-- | Organizational Domain.
-- | Example: "From:" is example@foo.example.org, DKIM signature can be d=example.org or d=bar.example.org.
-- |
-- | For SPF: as for "strict" policy, SPF should first produce a passing result.
-- | Then, the "From:" and the "MailFrom:" fields should be checked.
-- | In relaxed mode, they can be different, but in the same Organizational Domain.
-- | See https://publicsuffix.org/ for a list of organizational domains.
| Relaxed
consistency_policies :: Array ConsistencyPolicy
consistency_policies = [Strict, Relaxed]
consistency_policies_txt :: Array String
consistency_policies_txt
= [ "Do not provide policy advice"
, "Strict"
, "Relaxed"
]
-- | Codec for just encoding a single value of type `ConsistencyPolicy`.
codecConsistencyPolicy :: CA.JsonCodec ConsistencyPolicy
codecConsistencyPolicy
= CA.prismaticCodec "ConsistencyPolicy" str_to_consistency_policy generic_serialization CA.string
str_to_consistency_policy :: String -> Maybe ConsistencyPolicy
str_to_consistency_policy = case _ of
"relaxed" -> Just Relaxed
"strict" -> Just Strict
_ -> Nothing
derive instance genericConsistencyPolicy :: Generic ConsistencyPolicy _
instance showConsistencyPolicy :: Show ConsistencyPolicy where
show = genericShow
data ReportFormat
-- | Authentication Failure Reporting Format, see RFC6591. Currently the only format referenced in RFC7489.
= AFRF
-- | Codec for just encoding a single value of type `ReportFormat`.
codecReportFormat :: CA.JsonCodec ReportFormat
codecReportFormat = CA.prismaticCodec "ReportFormat" str_to_report_format generic_serialization CA.string
str_to_report_format :: String -> Maybe ReportFormat
str_to_report_format = case _ of
"afrf" -> Just AFRF
_ -> Nothing
derive instance genericFormat :: Generic ReportFormat _
instance showFormat :: Show ReportFormat where
show = genericShow
data Version
-- | Version of DMARC only accepts DMARC1 currently.
-- | So, for dnsmanager, this field is just ignored for now.
= DMARC1
-- | Codec for just encoding a single value of type `Version`.
codecVersion :: CA.JsonCodec Version
codecVersion = CA.prismaticCodec "Version" str_to_version generic_serialization CA.string
str_to_version :: String -> Maybe Version
str_to_version = case _ of
"dmarc1" -> Just DMARC1
_ -> Nothing
derive instance genericVersion :: Generic Version _
instance showVersion :: Show Version where
show = genericShow
data Policy
-- | "None" means to basically just accept the mail.
= None
-- | "Quarantine" means to consider the mail as suspicious, by giving it a bad spam score or something like that.
| Quarantine
-- | "Reject" means to not accept any failure of DKIM or SPF.
| Reject
policies :: Array Policy
policies = [None, Quarantine, Reject]
-- | Codec for just encoding a single value of type `Policy`.
codecPolicy :: CA.JsonCodec Policy
codecPolicy = CA.prismaticCodec "Policy" str_to_policy generic_serialization CA.string
str_to_policy :: String -> Maybe Policy
str_to_policy = case _ of
"none" -> Just None
"quarantine" -> Just Quarantine
"reject" -> Just Reject
_ -> Nothing
derive instance genericPolicy :: Generic Policy _
instance showPolicy :: Show Policy where
show = genericShow

6
src/App/Type/GenericSerialization.purs
View File

@ -1,6 +0,0 @@
module App.Type.GenericSerialization where
import Prelude (show, class Show, (<<<))
import Data.String (toLower)
generic_serialization :: forall a. Show a => a -> String
generic_serialization = toLower <<< show

9
src/App/Type/Pages.purs
View File

@ -1,8 +1,4 @@
module App.Type.Pages where
import Prelude
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
-- | This list will grow in a near future.
-- |
-- | TODO:
@ -15,8 +11,3 @@ data Page
| Zone String -- | `Zone`: to manage a zone.
| Setup -- | `Setup`: user account administration page
| Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).
derive instance genericPage :: Generic Page _
instance showPage :: Show Page where
show = genericShow

4
src/App/Type/ResourceRecord.purs
View File

@ -9,7 +9,6 @@ import Data.Codec.Argonaut as CA
import Data.Codec.Argonaut.Record as CAR
import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC
type ResourceRecord
= { rrtype :: String
@ -45,7 +44,6 @@ type ResourceRecord
, q :: Maybe Qualifier -- Qualifier for default mechanism (`all`).
, dkim :: Maybe DKIM.DKIM
, dmarc :: Maybe DMARC.DMARC
-- TODO: DMARC specific entries.
}
@ -86,7 +84,6 @@ codec = CA.object "ResourceRecord"
, q: CAR.optional codecQualifier
, dkim: CAR.optional DKIM.codec
, dmarc: CAR.optional DMARC.codec
})
type Mechanism
@ -228,7 +225,6 @@ emptyRR
, q: Nothing
, dkim: Nothing
, dmarc: Nothing
}
data Qualifier = Pass | Neutral | SoftFail | HardFail

22
src/App/Validation/DNS.purs
View File

@ -20,7 +20,6 @@ import GenericParser.IPAddress as IPAddress
import GenericParser.RFC5234 as RFC5234
import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC
-- | **History:**
-- | The module once used dedicated types for each type of RR.
@ -52,8 +51,6 @@ data Error
| VEProtocol (G.Error ProtocolError)
| VEPort Int Int Int
| VEWeight Int Int Int
| VEDMARCpct Int Int Int
| VEDMARCri Int Int Int
-- SPF
| VESPFMechanismName (G.Error DomainParser.DomainError)
@ -108,7 +105,7 @@ txt_parser = do pos <- G.current_position
then pure $ CU.fromCharArray v
else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar)
-- | `parse` enables to run any parser based on `GenericParser` and provide a validation error.
-- | `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
@ -273,7 +270,7 @@ validationSPF form = ado
-- | 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 enables some optional parameters,
-- | 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.
@ -312,20 +309,6 @@ validationDKIM form =
, name = name, ttl = ttl, target = "" -- `target` is discarded!
, dkim = Just $ dkim { p = p } }
validationDMARC :: ResourceRecord -> V (Array Error) ResourceRecord
validationDMARC form =
let dmarc = fromMaybe DMARC.emptyDMARCRR form.dmarc
in ado
name <- parse DomainParser.sub_eof form.name VEName
ttl <- is_between min_ttl max_ttl form.ttl VETTL
pct <- is_between 0 100 (fromMaybe 100 dmarc.pct) VEDMARCpct
ri <- is_between 0 1000000 (fromMaybe 86400 dmarc.ri) VEDMARCri
-- 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 = "DMARC"
, name = name, ttl = ttl, target = "" -- `target` is discarded!
, dmarc = Just $ dmarc { pct = Just pct, ri = Just ri } }
validation :: ResourceRecord -> Either (Array Error) ResourceRecord
validation entry = case entry.rrtype of
"A" -> toEither $ validationA entry
@ -337,7 +320,6 @@ validation entry = case entry.rrtype of
"SRV" -> toEither $ validationSRV entry
"SPF" -> toEither $ validationSPF entry
"DKIM" -> toEither $ validationDKIM entry
"DMARC" -> toEither $ validationDMARC entry
_ -> toEither $ invalid [UNKNOWN]
id :: forall a. a -> a

4
src/App/WS.purs
View File

@ -3,7 +3,7 @@
module App.WS where
import Prelude (Unit, bind, discard, pure, show, void, when
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<), unit)
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<))
import Control.Monad.Rec.Class (forever)
import Control.Monad.Except (runExcept)
@ -230,7 +230,7 @@ send_message message = do
Nothing -> H.raise $ Log $ UnableToSend "Not connected to server."
Just webSocket -> do
H.liftEffect (WS.readyState webSocket) >>= case _ of
Connecting -> pure unit -- H.raise $ Log $ UnableToSend "Still connecting to server."
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."

110
src/Bulma.purs
View File

@ -2,7 +2,6 @@
module Bulma where
import Prelude
import Data.Tuple (Tuple, fst, snd)
import Halogen.HTML as HH
import DOM.HTML.Indexed as DHI
import Halogen.HTML.Properties as HP
@ -78,14 +77,6 @@ modifier_table_header
]
]
dmarc_dmarcuri_table_header :: forall w i. HH.HTML w i
dmarc_dmarcuri_table_header
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Email address" ]
, HH.th_ [ HH.text "Report size limit" ]
, 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" ]
@ -156,24 +147,6 @@ dkim_table_header
]
]
dmarc_table_header :: forall w i. HH.HTML w i
dmarc_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 DMARC1.
, HH.th_ [ HH.text "Policy" ] -- p
, HH.th_ [ HH.text "Subdomain Policy" ] -- sp
, HH.th_ [ HH.text "DKIM policy" ] -- adkim
, HH.th_ [ HH.text "SPF policy" ] -- aspf
, HH.th_ [ HH.text "Sample rate" ] -- pct
, HH.th_ [ HH.text "Report on" ] -- fo
, HH.th_ [ HH.text "Report interval" ] -- ri
-- TODO? rua & ruf
-- , HH.th_ [ HH.text "Accepted report formats" ] -- For now, assume AFRF.
, 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 ]
@ -285,8 +258,8 @@ div_field_content content
[ HH.div [HP.classes C.field ] [ HH.div [HP.classes C.control ] [ content ] ] ]
field_inner :: forall w i.
Boolean -> (HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i
field_inner ispassword cond id title placeholder action value
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
@ -313,19 +286,13 @@ labeled_field id title content
, div_field_content content
]
box_input_ :: forall w i.
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i
box_input_ = field_inner false
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.
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i
box_password_ = field_inner true
box_input :: forall w i. String -> String -> String -> (String -> i) -> String -> HH.HTML w i
box_input = box_input_ (HP.enabled true)
box_password :: forall w i. String -> String -> String -> (String -> i) -> String -> HH.HTML w i
box_password = box_password_ (HP.enabled true)
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) ]
@ -516,22 +483,6 @@ selection_field id title action values selected
, div_field_content $ selection action values selected
]
selection_field' :: forall w i.
String -> String -> (Int -> i) -> Array (Tuple String 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
]
-- | selection': as `selection` but takes an array of tuple as values.
-- | First value in the tuple is what to display, the second one is what to match on.
selection' :: forall w i. (Int -> i) -> Array (Tuple String 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 (snd n), HP.selected ((snd n) == selected)] [HH.text (fst n)]) values
]
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]
@ -555,48 +506,3 @@ 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] ]
delete_btn :: forall w i. i -> HH.HTML w i
delete_btn action = HH.button [HE.onClick \_ -> action, HP.classes C.delete] []
notification :: forall w i. Array HH.ClassName -> String -> i -> HH.HTML w i
notification classes value deleteaction =
HH.div [HP.classes (C.notification <> classes)]
[ delete_btn deleteaction
, HH.text value
]
notification_primary :: forall w i. String -> i -> HH.HTML w i
notification_primary value deleteaction = notification C.is_primary value deleteaction
notification_success :: forall w i. String -> i -> HH.HTML w i
notification_success value deleteaction = notification C.is_success value deleteaction
notification_danger :: forall w i. String -> i -> HH.HTML w i
notification_danger value deleteaction = notification C.is_danger value deleteaction
notification_block' :: forall w i. Array HH.ClassName -> Array (HH.HTML w i) -> HH.HTML w i
notification_block' classes content =
HH.div [HP.classes (C.notification <> classes)] content
notification' :: forall w i. Array HH.ClassName -> String -> HH.HTML w i
notification' classes value =
HH.div [HP.classes (C.notification <> classes)]
[ HH.text value ]
notification_danger' :: forall w i. String -> HH.HTML w i
notification_danger' value = notification' C.is_danger value
notification_danger_block' :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
notification_danger_block' content = notification_block' C.is_danger content
btn_validation_ :: forall w i. String -> HH.HTML w i
btn_validation_ str = HH.button
-- [ HP.style "padding: 0.5rem 1.25rem;"
[ HP.type_ HP.ButtonSubmit
, HP.classes $ C.button <> C.is_primary
]
[ HH.text str ]
btn_validation :: forall w i. HH.HTML w i
btn_validation = btn_validation_ "Validate"