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:master
Baguette:local
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

223
src/App/Container.purs
View File

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

102
src/App/DisplayErrors.purs
View File

@ -8,13 +8,9 @@ import Data.Maybe (Maybe(..), maybe)
import Halogen.HTML as HH import Halogen.HTML as HH
import App.Validation.DNS as ValidationDNS 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 App.Validation.Label as ValidationLabel
import GenericParser.DomainParser.Common (DomainError(..)) as DomainParser import GenericParser.DomainParser.Common (DomainError(..)) as DomainParser
import GenericParser.IPAddress as IPAddress import GenericParser.IPAddress as IPAddress
import Bulma as Bulma import Bulma as Bulma
error_to_paragraph :: forall w i. ValidationDNS.Error -> HH.HTML w i 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.VEIPv4 err -> maybe default_error show_error_ip4 err.error
ValidationDNS.VEIPv6 err -> maybe default_error show_error_ip6 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.VEName err -> maybe default_error show_error_domain err.error
ValidationDNS.VETTL min max n -> ValidationDNS.VETTL min max n -> Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
Bulma.p $ "TTL should have a value between " <> ", current value: " <> show n <> "."
<> 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.VETXT err -> maybe default_error show_error_txt err.error ValidationDNS.VETXT err -> maybe default_error show_error_txt err.error
ValidationDNS.VECNAME err -> maybe default_error show_error_domain err.error ValidationDNS.VECNAME err -> maybe default_error show_error_domain err.error
ValidationDNS.VENS err -> maybe default_error show_error_domain err.error ValidationDNS.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 ValidationDNS.VEPriority min max n -> Bulma.p $ "Priority should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
ValidationDNS.VESRV err -> maybe default_error show_error_domain err.error 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 ValidationDNS.VEPort min max n -> Bulma.p $ "Port should have a value between " <> show min <> " and " <> show max
<> ", current value: " <> show n <> "." <> ", current value: " <> show n <> "."
ValidationDNS.VEWeight min max n -> Bulma.p $ "Weight should have a value between " <> show min <> " and " <> show max 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 ValidationDNS.DKIMInvalidKeySize min max -> show_error_key_sizes min max
) )
where default_error = Bulma.p "" 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 :: forall w i. Int -> Int -> HH.HTML w i
show_error_key_sizes min max show_error_key_sizes min max
@ -66,29 +54,27 @@ show_error_key_sizes min max
show_error_title :: ValidationDNS.Error -> String show_error_title :: ValidationDNS.Error -> String
show_error_title v = case v of show_error_title v = case v of
ValidationDNS.UNKNOWN -> "Unknown" ValidationDNS.UNKNOWN -> "Unknown"
ValidationDNS.VEIPv4 _ -> "Invalid IPv4 address" ValidationDNS.VEIPv4 err -> "The IPv4 address is wrong (position: " <> show err.position <> ")"
ValidationDNS.VEIPv6 _ -> "Invalid IPv6 address" ValidationDNS.VEIPv6 err -> "The IPv6 address is wrong (position: " <> show err.position <> ")"
ValidationDNS.VEName _ -> "Invalid Name (domain label)" ValidationDNS.VEName err -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
ValidationDNS.VETTL _ _ _ -> "Invalid TTL" ValidationDNS.VETTL min max n -> "Invalid TTL (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
ValidationDNS.VEDMARCpct _ _ _ -> "Invalid DMARC sample rate" ValidationDNS.VETXT err -> "The TXT input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VEDMARCri _ _ _ -> "Invalid DMARC report interval" ValidationDNS.VECNAME err -> "The CNAME input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VETXT _ -> "Invalid TXT" ValidationDNS.VENS err -> "The NS input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VECNAME _ -> "Invalid CNAME" ValidationDNS.VEMX err -> "The MX target input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VENS _ -> "Invalid NS Target" ValidationDNS.VEPriority min max n -> "Invalid Priority (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
ValidationDNS.VEMX _ -> "Invalid MX Target" ValidationDNS.VESRV err -> "The SRV target input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VEPriority _ _ _ -> "Invalid Priority" ValidationDNS.VEProtocol err -> "The Protocol input is wrong (position: " <> show err.position <> ")"
ValidationDNS.VESRV _ -> "Invalid SRV Target" ValidationDNS.VEPort min max n -> "Invalid Port (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
ValidationDNS.VEProtocol _ -> "Invalid Protocol" ValidationDNS.VEWeight min max n -> "Invalid Weight (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
ValidationDNS.VEPort _ _ _ -> "Invalid Port"
ValidationDNS.VEWeight _ _ _ -> "Invalid Weight"
-- SPF dedicated RR -- SPF dedicated RR
ValidationDNS.VESPFMechanismName _ -> "The domain name in a SPF mechanism is wrong" ValidationDNS.VESPFMechanismName err -> "The domain name in a SPF mechanism is wrong (position: " <> show err.position <> ")"
ValidationDNS.VESPFMechanismIPv4 _ -> "The IPv4 address in a SPF mechanism is wrong" ValidationDNS.VESPFMechanismIPv4 err -> "The IPv4 address in a SPF mechanism is wrong (position: " <> show err.position <> ")"
ValidationDNS.VESPFMechanismIPv6 _ -> "The IPv6 address in a SPF mechanism is wrong" 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.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" ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length."
show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i show_error_domain :: forall w i. DomainParser.DomainError -> HH.HTML w i
show_error_domain e = case e of show_error_domain e = case e of
@ -101,7 +87,7 @@ show_error_domain e = case e of
_ -> Bulma.p """ _ -> Bulma.p """
The domain (or label) contains invalid characters. The domain (or label) contains invalid characters.
A domain label should start with a letter, 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. and must finish with either a letter or a digit.
""" """
@ -116,7 +102,7 @@ show_error_ip6 e = case e of
IPAddress.IP6NotEnoughChunks -> IPAddress.IP6NotEnoughChunks ->
Bulma.p """ Bulma.p """
The IPv6 representation is erroneous, it should contain 8 groups of hexadecimal characters or 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 -> IPAddress.IP6TooManyChunks ->
Bulma.p "The IPv6 representation is erroneous. It should contain only up to 8 groups of hexadecimal characters." 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 :: ValidationLabel.Error -> String
show_error_title_label v = case v of show_error_title_label v = case v of
ValidationLabel.ParsingError x -> case x.error of ValidationLabel.ParsingError x -> case x.error of
Nothing -> "Invalid label" Nothing -> "Cannot parse the label (position: " <> show x.position <> ")."
Just (ValidationLabel.CannotParse _) -> Just (ValidationLabel.CannotParse _) ->
"Invalid label" "Cannot parse the label (position: " <> show x.position <> ")."
Just (ValidationLabel.CannotEntirelyParse) -> "Invalid label (cannot entirely parse the label)" Just (ValidationLabel.CannotEntirelyParse) -> "Cannot entirely parse the label."
Just (ValidationLabel.Size min max n) -> Just (ValidationLabel.Size min max n) ->
"Label size should be between " <> show min <> " and " <> show max "Label size should be between " <> show min <> " and " <> show max
<> " (current size: " <> show n <> ")." <> " (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, {- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID,
but they'll be used as login since the user has to type it. -} but they'll be used as login since the user has to type it. -}
{- 3 -} {- 3 -}
type AskPasswordRecovery = { login :: Maybe String, email :: Maybe Email.Email } type AskPasswordRecovery = { user :: Maybe String, email :: Maybe Email.Email }
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
codecAskPasswordRecovery codecAskPasswordRecovery
= CA.object "AskPasswordRecovery" = 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 -} {- 4 -}
type PasswordRecovery = { user :: String 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 }) codecAcceptedDomains = CA.object "AcceptedDomains" (CAR.record { domains: CA.array CA.string })
{- 16 -} {- 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.JsonCodec Logged
codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string
, my_domains: CA.array CA.string , my_domains: CA.array CA.string })
, admin: CA.boolean
})
{- 17 -} {- 17 -}
type DomainAdded = { domain :: String } type DomainAdded = { domain :: String }

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

@ -1,5 +1,5 @@
{- Administration interface. {- Administration interface.
Enables to: Allows to:
- add, remove, search users - add, remove, search users
- TODO: validate users - TODO: validate users
- TODO: change user password - TODO: change user password
@ -10,7 +10,7 @@
-} -}
module App.Page.Administration where 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 Data.Eq (class Eq)
import Bulma as Bulma import Bulma as Bulma
@ -21,6 +21,7 @@ import Effect.Aff.Class (class MonadAff)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event (Event) import Web.Event.Event (Event)
import Web.Event.Event as Event import Web.Event.Event as Event
@ -53,6 +54,8 @@ data Output
data Query a data Query a
= MessageReceived AuthD.AnswerMessage a = MessageReceived AuthD.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
| GotOrphanDomainList (Array String) a | GotOrphanDomainList (Array String) a
| ProvideState (Maybe State) a | ProvideState (Maybe State) a
@ -101,6 +104,7 @@ type State =
{ addUserForm :: StateAddUserForm { addUserForm :: StateAddUserForm
, searchUserForm :: StateSearchUserForm , searchUserForm :: StateSearchUserForm
, current_tab :: Tab , current_tab :: Tab
, wsUp :: Boolean
, matching_users :: Array UserPublic , matching_users :: Array UserPublic
, orphan_domains :: Array String , orphan_domains :: Array String
} }
@ -124,10 +128,11 @@ initialState _ = { addUserForm: { login: "", admin: false, email: "", pass: "
, matching_users: [] , matching_users: []
, orphan_domains: [] , orphan_domains: []
, current_tab: Home , current_tab: Home
, wsUp: true
} }
render :: forall m. State -> H.ComponentHTML Action () m 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 = Bulma.section_small
[ fancy_tab_bar [ fancy_tab_bar
, case current_tab of , 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) , Bulma.btn_ (C.is_small) domain (ShowDomain domain)
] ]
up x = HandleAddUserInput <<< x up x = HandleAddUserInput <<< x
active = (if wsUp then (HP.enabled true) else (HP.disabled true))
render_adduser_form = render_adduser_form =
HH.form HH.form
[ HE.onSubmit PreventSubmit ] [ 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.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_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 , Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass active
, Bulma.btn "Send" AddUserAttempt , Bulma.btn "Send" AddUserAttempt
] ]
@ -178,13 +184,13 @@ render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domain
[ HE.onSubmit PreventSubmit ] [ HE.onSubmit PreventSubmit ]
[ Bulma.p """ [ Bulma.p """
Following input accepts any regex. 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) --, Bulma.btn_labeled "adminbtn" "Admin" (show searchUserForm.admin)
-- (HandleAddUserInput SEARCHUSER_toggle_admin) -- (HandleAddUserInput SEARCHUSER_toggle_admin)
--, Bulma.box_input "domain" "Domain owned" "blah.netlib.re." --, 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 , Bulma.btn "Send" SearchUserAttempt
] ]
@ -195,7 +201,7 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
old_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage old_tab <- H.liftEffect $ Storage.getItem "current-ada-tab" sessionstorage
case old_tab of 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 Just current_tab -> case current_tab of
"Home" -> handleAction $ ChangeTab Home "Home" -> handleAction $ ChangeTab Home
"Search" -> handleAction $ ChangeTab Search "Search" -> handleAction $ ChangeTab Search
@ -306,9 +312,19 @@ handleQuery = case _ of
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users } H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
-- Unexpected message. -- 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) pure (Just a)
GotOrphanDomainList domains a -> do GotOrphanDomainList domains a -> do
H.raise $ Log $ SuccessLog "Got orphan domain list!"
H.modify_ _ { orphan_domains = domains } H.modify_ _ { orphan_domains = domains }
pure (Just a) pure (Just a)

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

@ -2,27 +2,23 @@
-- | TODO: token validation. -- | TODO: token validation.
module App.Page.Authentication where 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.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..))
import Data.Eq (class Eq)
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..))
import Data.Tuple (Tuple(..)) import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Event.Event (Event) import Web.Event.Event (Event)
import Bulma as Bulma 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.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD import App.Message.AuthenticationDaemon as AuthD
@ -51,7 +47,6 @@ data Output
= MessageToSend ArrayBuffer = MessageToSend ArrayBuffer
| AuthenticateToAuthd (Tuple Login Password) | AuthenticateToAuthd (Tuple Login Password)
| Log LogMessage | Log LogMessage
| UserLogin String
| PasswordRecovery Login PasswordRecoveryToken Password | PasswordRecovery Login PasswordRecoveryToken Password
| AskPasswordRecovery (Either Email Login) | AskPasswordRecovery (Either Email Login)
@ -60,6 +55,8 @@ data Output
-- | Also, the component is informed when the connection went up or down. -- | Also, the component is informed when the connection went up or down.
data Query a data Query a
= MessageReceived AuthD.AnswerMessage a = MessageReceived AuthD.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
@ -80,8 +77,7 @@ data NewPasswordInput
| NEWPASS_INP_confirmation String | NEWPASS_INP_confirmation String
data Action data Action
= Initialize = HandleAuthenticationInput AuthenticationInput
| HandleAuthenticationInput AuthenticationInput
| HandlePasswordRecovery PasswordRecoveryInput | HandlePasswordRecovery PasswordRecoveryInput
| HandleNewPassword NewPasswordInput | HandleNewPassword NewPasswordInput
-- --
@ -89,14 +85,6 @@ data Action
| PasswordRecoveryAttempt Event | PasswordRecoveryAttempt Event
| NewPasswordAttempt 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 StateAuthenticationForm = { login :: String, pass :: String }
type StatePasswordRecoveryForm = { login :: String, email :: String } type StatePasswordRecoveryForm = { login :: String, email :: String }
type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String } type StateNewPasswordForm = { login :: String, token :: String, password :: String, confirmation :: String }
@ -106,7 +94,7 @@ type State =
, passwordRecoveryForm :: StatePasswordRecoveryForm , passwordRecoveryForm :: StatePasswordRecoveryForm
, newPasswordForm :: StateNewPasswordForm , newPasswordForm :: StateNewPasswordForm
, errors :: Array Error , errors :: Array Error
, current_tab :: Tab , wsUp :: Boolean
} }
initialState :: Input -> State initialState :: Input -> State
@ -114,8 +102,8 @@ initialState _ =
{ authenticationForm: { login: "", pass: "" } { authenticationForm: { login: "", pass: "" }
, passwordRecoveryForm: { login: "", email: "" } , passwordRecoveryForm: { login: "", email: "" }
, newPasswordForm: { login: "", token: "", password: "", confirmation: "" } , newPasswordForm: { login: "", token: "", password: "", confirmation: "" }
, wsUp: true
, errors: [] , errors: []
, current_tab: Auth
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -124,33 +112,26 @@ component =
{ initialState { initialState
, render , render
, eval: H.mkEval $ H.defaultEval , eval: H.mkEval $ H.defaultEval
{ initialize = Just Initialize { handleAction = handleAction
, handleAction = handleAction
, handleQuery = handleQuery , handleQuery = handleQuery
} }
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } = render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
Bulma.section_small Bulma.section_small
[ fancy_tab_bar [ case wsUp of
, if A.length errors > 0 false -> Bulma.p "You are disconnected."
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ] ] true ->
else HH.div_ [] if A.length errors > 0
, case current_tab of then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ]
Auth -> Bulma.box auth_form , Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
ILostMyPassword -> Bulma.box passrecovery_form ]
Recovery -> Bulma.box newpass_form else Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
] ]
where where
fancy_tab_bar = b e = Bulma.column_ [ Bulma.box e ]
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
show_error :: Error -> String show_error :: Error -> String
show_error = case _ of show_error = case _ of
@ -196,32 +177,28 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
<> show min <> " and " <> show max <> show min <> " and " <> show max
<> " (currently: " <> show n <> ")" <> " (currently: " <> show n <> ")"
auth_form = [ Bulma.h3 "Authentication", render_auth_form ] auth_form = [ Bulma.h3 "Authentication" , render_auth_form ]
passrecovery_form = passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
[ Bulma.h3 "You forgot your password (or your login)" newpass_form = [ Bulma.h3 "New password", render_new_password_form ]
, Bulma.div_content
[ Bulma.p "Enter either your login or email and you'll receive a recovery token." should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
]
, 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
]
render_auth_form = HH.form render_auth_form = HH.form
[ HE.onSubmit AuthenticationAttempt ] [ HE.onSubmit AuthenticationAttempt ]
[ Bulma.box_input "loginLOGIN" "Login" "login" -- title, placeholder [ Bulma.box_input "loginLOGIN" "Login" "login" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_login) -- action (HandleAuthenticationInput <<< AUTH_INP_login) -- action
authenticationForm.login -- value authenticationForm.login -- value
should_be_disabled -- condition
, Bulma.box_password "passwordLOGIN" "Password" "password" -- title, placeholder , Bulma.box_password "passwordLOGIN" "Password" "password" -- title, placeholder
(HandleAuthenticationInput <<< AUTH_INP_pass) -- action (HandleAuthenticationInput <<< AUTH_INP_pass) -- action
authenticationForm.pass -- value 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 render_password_recovery_form = HH.form
@ -229,10 +206,17 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
[ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder [ Bulma.box_input "loginPASSR" "Login" "login" -- title, placeholder
(HandlePasswordRecovery <<< PASSR_INP_login) -- action (HandlePasswordRecovery <<< PASSR_INP_login) -- action
passwordRecoveryForm.login -- value passwordRecoveryForm.login -- value
should_be_disabled -- condition
, Bulma.box_input "emailPASSR" "Email" "email" -- title, placeholder , Bulma.box_input "emailPASSR" "Email" "email" -- title, placeholder
(HandlePasswordRecovery <<< PASSR_INP_email) -- action (HandlePasswordRecovery <<< PASSR_INP_email) -- action
passwordRecoveryForm.email -- value 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 render_new_password_form = HH.form
@ -240,32 +224,30 @@ render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm,
[ Bulma.box_input "loginNEWPASS" "Login" "login" [ Bulma.box_input "loginNEWPASS" "Login" "login"
(HandleNewPassword <<< NEWPASS_INP_login) (HandleNewPassword <<< NEWPASS_INP_login)
newPasswordForm.login newPasswordForm.login
should_be_disabled
, Bulma.box_input "tokenNEWPASS" "Token" "token" , Bulma.box_input "tokenNEWPASS" "Token" "token"
(HandleNewPassword <<< NEWPASS_INP_token) (HandleNewPassword <<< NEWPASS_INP_token)
newPasswordForm.token newPasswordForm.token
should_be_disabled
, Bulma.box_password "passwordNEWPASS" "Password" "password" , Bulma.box_password "passwordNEWPASS" "Password" "password"
(HandleNewPassword <<< NEWPASS_INP_password) (HandleNewPassword <<< NEWPASS_INP_password)
newPasswordForm.password newPasswordForm.password
should_be_disabled
, Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation" , Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation"
(HandleNewPassword <<< NEWPASS_INP_confirmation) (HandleNewPassword <<< NEWPASS_INP_confirmation)
newPasswordForm.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 :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of 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 HandleAuthenticationInput authinp -> do
case authinp of case authinp of
AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } } AUTH_INP_login v -> H.modify_ _ { authenticationForm { login = v } }
@ -289,7 +271,6 @@ handleAction = case _ of
{ authenticationForm } <- H.get { authenticationForm } <- H.get
let { login, pass } = authenticationForm let { login, pass } = authenticationForm
H.raise $ UserLogin login
case login, pass of case login, pass of
"" , _ -> "" , _ ->
H.raise $ Log $ UnableToSend "Write your login!" H.raise $ Log $ UnableToSend "Write your login!"
@ -326,6 +307,7 @@ handleAction = case _ of
_ -> do H.modify_ _ { errors = [] } _ -> do H.modify_ _ { errors = [] }
H.raise $ AskPasswordRecovery (Left email) H.raise $ AskPasswordRecovery (Left email)
-- TODO: verify the login?
NewPasswordAttempt ev -> do NewPasswordAttempt ev -> do
H.liftEffect $ Event.preventDefault ev H.liftEffect $ Event.preventDefault ev
@ -333,28 +315,13 @@ handleAction = case _ of
let { login, token, password, confirmation} = newPasswordForm let { login, token, password, confirmation} = newPasswordForm
if A.any (_ == "") [ login, token, password, confirmation ] 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 else if password == confirmation
then case L.login login, P.password password of then case L.login login of
Left errors, _ -> H.modify_ _ { errors = [ Login errors ] } Left errors -> H.modify_ _ { errors = [ Login errors ] }
_, Left errors -> H.modify_ _ { errors = [ Password errors ] } Right _ -> do H.modify_ _ { errors = [] }
_, _ -> do H.modify_ _ { errors = [] }
H.raise $ Log $ SystemLog $ "Sending a new password"
H.raise $ PasswordRecovery login token password H.raise $ PasswordRecovery login token password
else H.raise $ Log $ UnableToSend "Confirmation differs from 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 }
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a) handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of handleQuery = case _ of
@ -362,10 +329,14 @@ handleQuery = case _ of
-- Error messages are simply logged (see the code in the Container component). -- Error messages are simply logged (see the code in the Container component).
MessageReceived message _ -> do MessageReceived message _ -> do
case message of case message of
AuthD.GotPasswordRecovered _ -> do
handleAction $ ChangeTab Auth
AuthD.GotPasswordRecoverySent _ -> do
handleAction $ ChangeTab Recovery
_ -> do _ -> do
H.raise $ Log $ ErrorLog $ "Message not handled in AuthenticationInterface." H.raise $ Log $ ErrorLog $ "Message not handled in AuthenticationInterface."
pure Nothing pure Nothing
ConnectionIsDown a -> do
H.modify_ _ { wsUp = false }
pure (Just a)
ConnectionIsUp a -> do
H.modify_ _ { wsUp = true }
pure (Just a)

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

@ -1,7 +1,7 @@
-- | `App.DomainListInterface` is a simple component with the list of own domains -- | `App.DomainListInterface` is a simple component with the list of own domains
-- | and a form to add a new domain. -- | and a form to add a new domain.
-- | -- |
-- | This interface enables to: -- | This interface allows to:
-- | - display the list of own domains -- | - display the list of own domains
-- | - show and select accepted domains (TLDs) -- | - show and select accepted domains (TLDs)
-- | - create new domains -- | - create new domains
@ -16,7 +16,6 @@ import Prelude (Unit, bind, discard, map, otherwise, pure, ($), (/=), (<<<), (<>
import Data.Array as A import Data.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.String (toLower)
import Data.Maybe (Maybe(..), maybe) import Data.Maybe (Maybe(..), maybe)
import Data.String.Utils (endsWith) import Data.String.Utils (endsWith)
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
@ -24,6 +23,7 @@ import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Events as HHE import Halogen.HTML.Events as HHE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Event.Event (Event) import Web.Event.Event (Event)
import Bulma as Bulma import Bulma as Bulma
@ -32,6 +32,7 @@ import App.DisplayErrors (error_to_paragraph_label)
import App.Validation.Label as Validation import App.Validation.Label as Validation
import CSSClasses as C
import App.Type.LogMessage import App.Type.LogMessage
import App.Message.DNSManagerDaemon as DNSManager import App.Message.DNSManagerDaemon as DNSManager
@ -64,6 +65,8 @@ data Output
data Query a data Query a
= MessageReceived DNSManager.AnswerMessage a = MessageReceived DNSManager.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
| ProvideState (Maybe State) a | ProvideState (Maybe State) a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
@ -120,6 +123,7 @@ type State =
, accepted_domains :: Array String , accepted_domains :: Array String
, my_domains :: Array String , my_domains :: Array String
, wsUp :: Boolean
, active_modal :: Maybe String , active_modal :: Maybe String
} }
@ -149,19 +153,20 @@ initialState _ =
} }
, accepted_domains: [ default_domain ] , accepted_domains: [ default_domain ]
, my_domains: [ ] , my_domains: [ ]
, wsUp: true
, active_modal: Nothing , active_modal: Nothing
} }
render :: forall m. State -> H.ComponentHTML Action () m 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 = Bulma.section_small
[ case active_modal of [ case wsUp of
false -> Bulma.p "You are disconnected."
true -> case active_modal of
Nothing -> Bulma.columns_ Nothing -> Bulma.columns_
[ Bulma.column_ [ Bulma.h3 "New domain", render_add_domain_form] [ Bulma.column_ [ Bulma.h3 "Add a domain!", render_add_domain_form]
, Bulma.column_ [ Bulma.h3 "My domains" , Bulma.column_ [ Bulma.h3 "My domains"
, if A.length my_domains > 0 , HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains
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" Just domain -> Bulma.modal "Deleting a domain"
@ -171,9 +176,9 @@ render { accepted_domains, my_domains, newDomainForm, active_modal }
modal_delete_button domain = Bulma.alert_btn "Delete the domain" (RemoveDomain domain) modal_delete_button domain = Bulma.alert_btn "Delete the domain" (RemoveDomain domain)
modal_cancel_button = Bulma.cancel_button CancelModal modal_cancel_button = Bulma.cancel_button CancelModal
warning_message domain 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 <> 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.strong_ [ HH.text "irreversible" ]
, HH.text "." , HH.text "."
] ]
@ -189,8 +194,12 @@ render { accepted_domains, my_domains, newDomainForm, active_modal }
(HandleNewDomainInput <<< INP_newdomain) (HandleNewDomainInput <<< INP_newdomain)
newDomainForm.new_domain newDomainForm.new_domain
[ HHE.onSelectedIndexChange domain_choice ] [ HHE.onSelectedIndexChange domain_choice ]
(map (\v -> "." <> v) accepted_domains) accepted_domains
, Bulma.btn_validation_ "add a new domain" , HH.button
[ HP.type_ HP.ButtonSubmit
, HP.classes C.button
]
[ HH.text "add a new domain!" ]
, if A.length newDomainForm._errors > 0 , if A.length newDomainForm._errors > 0
then HH.div_ $ map error_to_paragraph_label newDomainForm._errors then HH.div_ $ map error_to_paragraph_label newDomainForm._errors
else HH.div_ [ ] else HH.div_ [ ]
@ -221,7 +230,7 @@ handleAction = case _ of
HandleNewDomainInput adduserinp -> do HandleNewDomainInput adduserinp -> do
case adduserinp of case adduserinp of
INP_newdomain v -> do INP_newdomain v -> do
H.modify_ _ { newDomainForm { new_domain = toLower v } } H.modify_ _ { newDomainForm { new_domain = v } }
case v of case v of
"" -> H.modify_ _ { newDomainForm { _errors = [] } } "" -> H.modify_ _ { newDomainForm { _errors = [] } }
_ -> case Validation.label v of _ -> case Validation.label v of
@ -247,18 +256,18 @@ handleAction = case _ of
{ newDomainForm } <- H.get { newDomainForm } <- H.get
let new_domain = build_new_domain newDomainForm.new_domain newDomainForm.selected_domain 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!" H.raise $ Log $ UnableToSend "You didn't enter the new domain!"
_, [], _ -> do [], _ -> do
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkNewDomain { domain: new_domain } $ DNSManager.MkNewDomain { domain: new_domain }
H.raise $ MessageToSend message H.raise $ MessageToSend message
H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")" H.raise $ Log $ SystemLog $ "Add a new domain (" <> new_domain <> ")"
handleAction $ HandleNewDomainInput $ INP_newdomain "" 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 :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of handleQuery = case _ of
@ -287,12 +296,20 @@ handleQuery = case _ of
_ -> H.raise $ Log $ ErrorLog $ "Message not handled in DomainListInterface." _ -> H.raise $ Log $ ErrorLog $ "Message not handled in DomainListInterface."
pure (Just a) 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 :: State -> DNSManager.AnswerMessage -> State
page_reload s1 message = page_reload s1 message =
case message of case message of
DNSManager.MkLogged response -> DNSManager.MkLogged response ->
s1 { accepted_domains = response.accepted_domains s1 { accepted_domains = response.accepted_domains
, my_domains = A.sort response.my_domains , my_domains = response.my_domains
} }
_ -> s1 _ -> s1

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

@ -41,27 +41,25 @@ initialState _ = unit
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render _ = HH.div_ render _ = HH.div_
[ Bulma.hero_danger [ Bulma.hero_danger
"THIS IS A BETA RELEASE" "THIS IS AN ALPHA RELEASE"
"You can register, login and play a bit with the tool. Feel free to report errors and suggestions!" "You can register, login and play a bit with the tool! Please, report errors and suggestions"
, Bulma.section_small , Bulma.section_small
[ Bulma.h1 "Welcome to netlib.re" [ Bulma.h1 "Welcome to netlib.re"
, Bulma.subtitle "Free domain names for the common folks" , Bulma.subtitle "Free domain names"
, Bulma.hr , Bulma.hr
, render_description , render_description
, render_update_why_and_contact , render_second_line
, render_why_and_contact
, Bulma.hr , Bulma.hr
, render_how_and_code , render_how_and_code
] ]
] ]
where where
title = Bulma.h3 title = Bulma.h3
expl content = Bulma.div_content [ Bulma.explanation content ]
p = Bulma.p p = Bulma.p
b x = Bulma.column_ [ Bulma.box [ Bulma.div_content x ] ] b x = Bulma.column_ [ Bulma.box [ Bulma.div_content x ] ]
render_description = Bulma.columns_ [ render_basics, render_no_expert, render_no_housing ] render_description = Bulma.columns_ [ render_basics, render_no_expert ]
render_update_why_and_contact = Bulma.columns_ [ render_updates, render_why, render_contact ]
render_basics render_basics
= b [ title "What is provided?" = b [ title "What is provided?"
, p "Reserve a domain name in <something>.netlib.re for free." , 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. 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 render_no_housing
= b [ title "No housing, just a name" = b [ title "No housing, just a name"
, p """ , p """
@ -84,10 +83,12 @@ render _ = HH.div_
render_updates render_updates
= b [ title "Automatic updates" = b [ title "Automatic updates"
, p "Update your records with a single, stupidly simple command. For example:" , 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!" , 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 render_why
= b [ title "Why?" = b [ title "Why?"
, p "Because everyone should be able to have a place on the Internet." , 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 the authentication (and authorization) daemon, used to authenticate
clients through different services; 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; to ask for domains, then handle the domain zones;
""" """
, link "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient" , 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" , 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 (a Zone, a User, etc.) in simple files as opposed to the usual complexity of
traditional databases. 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. -- | This token has to be used to validate the email address.
module App.Page.MailValidation where 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.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (maybe) import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Event.Event (Event) import Web.Event.Event (Event)
@ -29,7 +30,9 @@ data Output
| Log LogMessage | Log LogMessage
-- | The component is informed when the connection went up or down. -- | 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 type Slot = H.Slot Query Output
@ -62,6 +65,7 @@ type MailValidationForm = { login :: String, token :: String }
type State = type State =
{ mailValidationForm :: MailValidationForm { mailValidationForm :: MailValidationForm
, errors :: Array Error , errors :: Array Error
, wsUp :: Boolean
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -71,6 +75,7 @@ component =
, render , render
, eval: H.mkEval $ H.defaultEval , eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction { handleAction = handleAction
, handleQuery = handleQuery
} }
} }
@ -78,25 +83,41 @@ initialState :: Input -> State
initialState _ = initialState _ =
{ mailValidationForm: { login: "", token: "" } { mailValidationForm: { login: "", token: "" }
, errors: [] , errors: []
, wsUp: true
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { mailValidationForm } render { wsUp, mailValidationForm }
= Bulma.section_small [ Bulma.columns_ [ b mail_validation_form ] ] = Bulma.section_small
[ case wsUp of
false -> Bulma.p "You are disconnected."
true -> Bulma.columns_ [ b mail_validation_form ]
]
where where
b e = Bulma.column_ [ Bulma.box e ] b e = Bulma.column_ [ Bulma.box e ]
mail_validation_form = [ Bulma.h3 "Verify your account", render_register_form ] 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 render_register_form = HH.form
[ HE.onSubmit ValidateInputs ] [ HE.onSubmit ValidateInputs ]
[ Bulma.box_input "loginValidation" "Login" "login" -- title, placeholder [ Bulma.box_input "loginValidation" "Login" "login" -- title, placeholder
(HandleValidationInput <<< VALIDATION_INP_login) -- action (HandleValidationInput <<< VALIDATION_INP_login) -- action
mailValidationForm.login -- value mailValidationForm.login -- value
should_be_disabled -- condition
, Bulma.box_input "tokenValidation" "Token" "token" -- title, placeholder , Bulma.box_input "tokenValidation" "Token" "token" -- title, placeholder
(HandleValidationInput <<< VALIDATION_INP_token) -- action (HandleValidationInput <<< VALIDATION_INP_token) -- action
mailValidationForm.token -- value 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 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 " T.Size min max n -> "token size should be between "
<> show min <> " and " <> show max <> show min <> " and " <> show max
<> " (currently: " <> show n <> ")" <> " (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 | Disconnection
-- | The component needs to know when the user is logged or not. -- | The component needs to know when the user is logged or not.
data Query a data Query a = ToggleLogged Boolean a
= ToggleLogged Boolean a
| ToggleAdmin Boolean a
| TellLogin (Maybe String) a
type Slot = H.Slot Query Output 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. -- | - `logged`, a boolean to toggle the display of some parts of the menu.
-- | - `active`, a boolean to toggle the display of the menu. -- | - `active`, a boolean to toggle the display of the menu.
-- | - `admin`, a boolean to toggle the display of administration page link. -- | - `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 :: forall m. MonadAff m => H.Component Query Input Output m
component = component =
@ -69,16 +66,13 @@ component =
} }
initialState :: Input -> State 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 :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of handleAction = case _ of
ToggleMenu -> H.modify_ \state -> state { active = not state.active } ToggleMenu -> H.modify_ \state -> state { active = not state.active }
-- | Page change. -- | Page change.
Navigate page -> do Navigate page -> H.raise $ Routing page
-- Automatically close the menu.
H.modify_ \state -> state { active = false }
H.raise $ Routing page
UnLog -> do UnLog -> do
H.raise $ Disconnection H.raise $ Disconnection
H.modify_ _ { logged = false } H.modify_ _ { logged = false }
@ -88,12 +82,6 @@ handleQuery = case _ of
ToggleLogged islogged a -> do ToggleLogged islogged a -> do
H.modify_ _ { logged = islogged } H.modify_ _ { logged = islogged }
pure (Just a) 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. -- | The navigation bar is a complex component to render.
@ -105,7 +93,7 @@ handleQuery = case _ of
-- | Also, when clicked again, the list disappears. -- | Also, when clicked again, the list disappears.
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { logged, active, admin, login } = render { logged, active, admin } =
main_nav main_nav
[ nav_brand [ logo, burger_menu ] [ nav_brand [ logo, burger_menu ]
, nav_menu , nav_menu
@ -124,7 +112,7 @@ render { logged, active, admin, login } =
right_bar_div = right_bar_div =
case logged of case logged of
false -> [ link_auth, link_register, link_mail_validation ] false -> [ link_auth, link_register, link_mail_validation ]
_ -> render_login login <> [ link_setup, link_disconnection ] _ -> [ link_setup, link_disconnection ]
navbar_color = C.is_success navbar_color = C.is_success
@ -134,7 +122,7 @@ render { logged, active, admin, login } =
, ARIA.role "navigation" , 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.a [HP.classes C.navbar_item, HP.href "/"]
-- [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]] -- [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_register = nav_link_strong "Register" (Navigate Registration)
link_mail_validation = nav_link "Mail verification" (Navigate MailValidation) link_mail_validation = nav_link "Mail verification" (Navigate MailValidation)
link_setup = nav_link_warn "⚒ Setup" (Navigate Setup) link_setup = nav_link_warn "⚒ Setup" (Navigate Setup)
render_login Nothing = []
render_login (Just l)= [nav_link ("logged as " <> l) (Navigate Setup)]
link_disconnection = link_disconnection =
nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog 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] = 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 title, HH.div [HP.classes C.navbar_dropdown] dropdown_elements ]
dropdown_title str = HH.a [HP.classes C.navbar_link] [HH.text str] 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] dropdown_separator = HH.hr [HP.classes C.navbar_divider]
--nav_button_strong str action = btn C.is_primary action (HH.strong [] [ HH.text str ]) --nav_button_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) , HE.onClick (\_ -> action)
] [ (HH.text str) ] ] [ (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 dropdown_section_primary t
= HH.p [HP.classes $ C.has_background_info <> C.has_text_light <> C.navbar_item] [HH.text t] = HH.p [HP.classes $ C.has_background_info <> C.has_text_light <> C.navbar_item] [HH.text t]
dropdown_section_secondary t dropdown_section_secondary t
@ -203,13 +186,13 @@ render { logged, active, admin, login } =
code_dropdown = code_dropdown =
dropdown "Source code" dropdown "Source code"
[ dropdown_section_primary "Main parts of this service" [ dropdown_section_primary "Main parts of this service"
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon" , dropdown_element "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager daemon" , dropdown_element "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/dnsmanager-webclient" "dnsmanager web client"
, dropdown_separator , dropdown_separator
, dropdown_section_secondary "A few more links (for nerds)" , dropdown_section_secondary "A few more links (for nerds)"
, dropdown_element_secondary "https://git.baguette.netlib.re/Baguette/libipc" "libIPC: communication library" , dropdown_element "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/dodb.cr" "DoDB: document-oriented database"
] ]
--btn c action str --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. -- | Registration requires a login, an email address and a password.
module App.Page.Registration where 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.Array as A
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Event.Event (Event) import Web.Event.Event (Event)
@ -21,8 +22,6 @@ import App.Type.Email as Email
import App.Type.LogMessage import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD 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.Login as L
import App.Validation.Email as E import App.Validation.Email as E
import App.Validation.Password as P import App.Validation.Password as P
@ -31,7 +30,10 @@ data Output
= MessageToSend ArrayBuffer = MessageToSend ArrayBuffer
| Log LogMessage | 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 type Slot = H.Slot Query Output
@ -66,12 +68,14 @@ type StateRegistrationForm = { login :: String, email :: String, pass :: String
type State = type State =
{ registrationForm :: StateRegistrationForm { registrationForm :: StateRegistrationForm
, errors :: Array Error , errors :: Array Error
, wsUp :: Boolean
} }
initialState :: Input -> State initialState :: Input -> State
initialState _ = initialState _ =
{ registrationForm: { login: "", email: "", pass: "" } { registrationForm: { login: "", email: "", pass: "" }
, errors: [] , errors: []
, wsUp: true
} }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
@ -81,29 +85,46 @@ component =
, render , render
, eval: H.mkEval $ H.defaultEval , eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction { handleAction = handleAction
, handleQuery = handleQuery
} }
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { registrationForm } render { wsUp, registrationForm }
= Bulma.section_small [Bulma.columns_ [ b registration_form ]] = Bulma.section_small
[ case wsUp of
false -> Bulma.p "You are disconnected."
true -> Bulma.columns_ [ b registration_form ]
]
where where
b e = Bulma.column_ [ Bulma.box e ] 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 render_register_form = HH.form
[ HE.onSubmit ValidateInputs ] [ HE.onSubmit ValidateInputs ]
[ Bulma.box_input "loginREGISTER" "Login" "login" -- title, placeholder [ Bulma.box_input "loginREGISTER" "Login" "login" -- title, placeholder
(HandleRegisterInput <<< REG_INP_login) -- action (HandleRegisterInput <<< REG_INP_login) -- action
registrationForm.login -- value registrationForm.login -- value
should_be_disabled -- condition
, Bulma.box_input "emailREGISTER" "Email" "email@example.com" -- title, placeholder , Bulma.box_input "emailREGISTER" "Email" "email@example.com" -- title, placeholder
(HandleRegisterInput <<< REG_INP_email) -- action (HandleRegisterInput <<< REG_INP_email) -- action
registrationForm.email -- value registrationForm.email -- value
should_be_disabled -- condition
, Bulma.box_password "passwordREGISTER" "Password" "password" -- title, placeholder , Bulma.box_password "passwordREGISTER" "Password" "password" -- title, placeholder
(HandleRegisterInput <<< REG_INP_pass) -- action (HandleRegisterInput <<< REG_INP_pass) -- action
registrationForm.pass -- value 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 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) 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) 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) 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)

73
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. -- | Users can also erase their account.
module App.Page.Setup where 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(..))
import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Halogen as H import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Events as HE import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Web.Event.Event as Event import Web.Event.Event as Event
import Web.Event.Event (Event) import Web.Event.Event (Event)
import Bulma as Bulma import Bulma as Bulma
import App.Validation.Password as P
import App.Type.LogMessage import App.Type.LogMessage
import App.Message.AuthenticationDaemon as AuthD import App.Message.AuthenticationDaemon as AuthD
@ -27,8 +24,12 @@ data Output
| DeleteUserAccount | DeleteUserAccount
-- | The component's parent provides received messages. -- | The component's parent provides received messages.
-- |
-- | Also, the component is informed when the connection went up or down.
data Query a data Query a
= MessageReceived AuthD.AnswerMessage a = MessageReceived AuthD.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
@ -45,7 +46,6 @@ data NewPasswordInput
data Action data Action
= HandleNewPassword NewPasswordInput = HandleNewPassword NewPasswordInput
| ChangePasswordAttempt Event | ChangePasswordAttempt Event
| SendChangePasswordMessage
| CancelModal | CancelModal
| DeleteAccountPopup | DeleteAccountPopup
| DeleteAccount | DeleteAccount
@ -59,6 +59,7 @@ data Modal
type State = type State =
{ newPasswordForm :: StateNewPasswordForm { newPasswordForm :: StateNewPasswordForm
, token :: String , token :: String
, wsUp :: Boolean
, modal :: Modal , modal :: Modal
} }
@ -78,31 +79,38 @@ initialState token =
{ newPasswordForm: { password: "", confirmation: "" } { newPasswordForm: { password: "", confirmation: "" }
, token , token
, modal: NoModal , modal: NoModal
, wsUp: true
} }
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { modal, newPasswordForm } = render { modal, wsUp, newPasswordForm } =
Bulma.section_small case modal of
[ case modal of
DeleteAccountModal -> render_delete_account_modal DeleteAccountModal -> render_delete_account_modal
NoModal -> Bulma.columns_ [ b [ Bulma.h3 "Change password", render_new_password_form ] NoModal -> Bulma.columns_ [ b [ Bulma.h3 "Change password", render_new_password_form ]
, b [ Bulma.h3 "Delete account", render_delete_account ] , b [ Bulma.h3 "Delete account", render_delete_account ]
] ]
]
where 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_delete_account = Bulma.alert_btn "Delete my account" DeleteAccountPopup
render_new_password_form = HH.form render_new_password_form = HH.form
[ HE.onSubmit ChangePasswordAttempt ] [ HE.onSubmit ChangePasswordAttempt ]
[ Bulma.box_password "passwordNEWPASS" "New Password" "password" [ Bulma.box_input "passwordNEWPASS" "Password" "password"
(HandleNewPassword <<< NEWPASS_INP_password) (HandleNewPassword <<< NEWPASS_INP_password)
newPasswordForm.password newPasswordForm.password
, Bulma.box_password "confirmationNEWPASS" "Confirmation" "confirmation" should_be_disabled
, Bulma.box_input "confirmationNEWPASS" "Confirmation" "confirmation"
(HandleNewPassword <<< NEWPASS_INP_confirmation) (HandleNewPassword <<< NEWPASS_INP_confirmation)
newPasswordForm.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" render_delete_account_modal = Bulma.modal "Delete your account"
@ -137,31 +145,10 @@ handleAction = case _ of
_ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!" _ , "" -> H.raise $ Log $ UnableToSend "Confirm your password!"
pass, confirmation -> do pass, confirmation -> do
if pass == confirmation if pass == confirmation
then case P.password pass of then do H.raise $ Log $ SystemLog "Changing the password"
Left errors -> H.raise $ Log $ UnableToSend $ A.fold $ map show_error_password errors H.raise $ ChangePassword pass
Right _ -> handleAction SendChangePasswordMessage
else H.raise $ Log $ UnableToSend "Confirmation differs from password" 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 :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
handleQuery = case _ of handleQuery = case _ of
-- For now, no message actually needs to be handled here. -- For now, no message actually needs to be handled here.
@ -171,3 +158,11 @@ handleQuery = case _ of
_ -> do _ -> do
H.raise $ Log $ ErrorLog $ "Message not handled in SetupInterface." H.raise $ Log $ ErrorLog $ "Message not handled in SetupInterface."
pure Nothing pure Nothing
ConnectionIsDown a -> do
H.modify_ _ { wsUp = false }
pure (Just a)
ConnectionIsUp a -> do
H.modify_ _ { wsUp = true }
pure (Just a)

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

@ -1,33 +1,28 @@
-- | `App.ZoneInterface` provides an interface to display and modify a DNS zone. -- | `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) -- | - 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 -- | - add, modify, remove resource records
-- | -- |
-- | **WIP**: Display relevant information for each record type in the (add/mod) modal. -- | **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. -- | 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. -- | 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. -- | 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. -- | TODO: move all serialization code to a single module.
module App.Page.Zone where module App.Page.Zone where
import Prelude (Unit, unit, void import Prelude (Unit, unit, void
, bind, pure , 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.Eq (class Eq)
import Data.Array as A import Data.Array as A
@ -36,7 +31,6 @@ import Data.Tuple (Tuple(..))
import Data.ArrayBuffer.Types (ArrayBuffer) import Data.ArrayBuffer.Types (ArrayBuffer)
import Data.Array.NonEmpty as NonEmpty import Data.Array.NonEmpty as NonEmpty
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.String (toLower)
import Data.String.CodePoints as CP import Data.String.CodePoints as CP
-- import Data.Foldable as Foldable -- import Data.Foldable as Foldable
import Data.Maybe (Maybe(..), fromMaybe, maybe) import Data.Maybe (Maybe(..), fromMaybe, maybe)
@ -59,9 +53,8 @@ import App.Type.ResourceRecord (ResourceRecord, emptyRR
, mechanism_types, qualifier_types, modifier_types) , mechanism_types, qualifier_types, modifier_types)
import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..)) as RR import App.Type.ResourceRecord (Mechanism, Modifier, Qualifier(..)) as RR
import App.Type.DKIM as DKIM 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.Type.LogMessage (LogMessage(..))
import App.Message.DNSManagerDaemon as DNSManager import App.Message.DNSManagerDaemon as DNSManager
@ -83,9 +76,13 @@ data Output
| Log LogMessage | Log LogMessage
-- | `App.ZoneInterface` can receive messages from `dnsmanagerd`. -- | `App.ZoneInterface` can receive messages from `dnsmanagerd`.
-- |
-- | The component is also informed when the connection is lost or up again.
data Query a data Query a
= MessageReceived DNSManager.AnswerMessage a = MessageReceived DNSManager.AnswerMessage a
| ConnectionIsDown a
| ConnectionIsUp a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
@ -151,9 +148,6 @@ data Action
-- | Add a new resource record to the zone. -- | Add a new resource record to the zone.
| AddRR AcceptedRRTypes ResourceRecord | 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. -- | Save the changes done in an already existing resource record.
| SaveRR ResourceRecord | SaveRR ResourceRecord
@ -184,34 +178,6 @@ data Action
-- | Add a SPF modifier to the currently modified (SPF) entry (see `_currentRR`). -- | Add a SPF modifier to the currently modified (SPF) entry (see `_currentRR`).
| SPF_Modifier_Add | 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_hash_algo Int
| DKIM_sign_algo Int | DKIM_sign_algo Int
| DKIM_pubkey String | DKIM_pubkey String
@ -223,6 +189,18 @@ data RRModal
| UpdateRRModal | UpdateRRModal
| RemoveRRModal RRId | 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 :: String -> Maybe AcceptedRRTypes
string_to_acceptedtype str = case str of string_to_acceptedtype str = case str of
"A" -> Just A "A" -> Just A
@ -234,17 +212,14 @@ string_to_acceptedtype str = case str of
"SRV" -> Just SRV "SRV" -> Just SRV
"SPF" -> Just SPF "SPF" -> Just SPF
"DKIM" -> Just DKIM "DKIM" -> Just DKIM
"DMARC" -> Just DMARC
_ -> Nothing _ -> Nothing
data Tab = Zone | TheBasics | TokenExplanation data Tab = Zone | TokenExplanation
derive instance eqTab :: Eq Tab derive instance eqTab :: Eq Tab
derive instance genericTab :: Generic Tab _
instance showTab :: Show Tab where
show = genericShow
type State = type State =
{ _domain :: String { _domain :: String
, wsUp :: Boolean
-- A modal to present a form for adding a new RR. -- A modal to present a form for adding a new RR.
, rr_modal :: RRModal , rr_modal :: RRModal
@ -256,7 +231,6 @@ type State =
-- Unique RR form. -- Unique RR form.
, _currentRR :: ResourceRecord , _currentRR :: ResourceRecord
, _currentRR_errors :: Array Validation.Error , _currentRR_errors :: Array Validation.Error
, _dmarc_mail_errors :: Array Email.Error
-- SPF details. -- SPF details.
, spf_mechanism_q :: String , spf_mechanism_q :: String
@ -265,11 +239,7 @@ type State =
, spf_modifier_t :: String , spf_modifier_t :: String
, spf_modifier_v :: String , spf_modifier_v :: String
, dmarc_mail :: String
, dmarc_mail_limit :: Maybe Int
, dkim :: DKIM.DKIM , dkim :: DKIM.DKIM
, dmarc :: DMARC.DMARC
, _zonefile :: Maybe String , _zonefile :: Maybe String
@ -303,7 +273,8 @@ default_qualifier_str = "hard_fail" :: String
initialState :: Input -> State initialState :: Input -> State
initialState domain = initialState domain =
{ rr_modal: NoModal { wsUp: true
, rr_modal: NoModal
, _domain: domain , _domain: domain
@ -314,7 +285,6 @@ initialState domain =
, _currentRR: default_empty_rr , _currentRR: default_empty_rr
-- List of errors within the form in new RR modal. -- List of errors within the form in new RR modal.
, _currentRR_errors: [] , _currentRR_errors: []
, _dmarc_mail_errors: []
, _zonefile: Nothing , _zonefile: Nothing
, spf_mechanism_q: "pass" , spf_mechanism_q: "pass"
@ -322,12 +292,7 @@ initialState domain =
, spf_mechanism_v: "" , spf_mechanism_v: ""
, spf_modifier_t: "redirect" , spf_modifier_t: "redirect"
, spf_modifier_v: "" , spf_modifier_v: ""
, dkim: DKIM.emptyDKIMRR , dkim: DKIM.emptyDKIMRR
, dmarc: DMARC.emptyDMARCRR
, dmarc_mail: ""
, dmarc_mail_limit: Nothing
, current_tab: Zone , current_tab: Zone
} }
@ -340,24 +305,23 @@ render state
[ fancy_tab [ fancy_tab
, case state.current_tab of , case state.current_tab of
Zone -> render_zone Zone -> render_zone
TheBasics -> Explanations.basics
TokenExplanation -> Explanations.tokens TokenExplanation -> Explanations.tokens
] ]
where where
fancy_tab = fancy_tab =
Bulma.fancy_tabs Bulma.fancy_tabs
[ Bulma.tab_entry (is_tab_active Zone) "Zone" (ChangeTab Zone) [ 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 TokenExplanation) "Tokens? 🤨" (ChangeTab TokenExplanation)
] ]
is_tab_active tab = state.current_tab == tab is_tab_active tab = state.current_tab == tab
render_zone = render_zone =
case state.rr_modal of case state.wsUp, state.rr_modal of
RemoveRRModal rr_id -> modal_rr_delete rr_id false, _ -> Bulma.p "You are disconnected."
NewRRModal _ -> render_current_rr_modal true, RemoveRRModal rr_id -> modal_rr_delete rr_id
UpdateRRModal -> render_current_rr_modal true, NewRRModal _ -> render_current_rr_modal
NoModal -> HH.div_ true, UpdateRRModal -> render_current_rr_modal
true, NoModal -> HH.div_
[ Bulma.h1 state._domain [ Bulma.h1 state._domain
, Bulma.hr , Bulma.hr
, render_resources $ sorted state._resources , render_resources $ sorted state._resources
@ -377,7 +341,7 @@ render state
modal_rr_delete rr_id = Bulma.modal "Deleting a resource record" modal_rr_delete rr_id = Bulma.modal "Deleting a resource record"
[warning_message] [modal_delete_button, Bulma.cancel_button CancelModal] [warning_message] [modal_delete_button, Bulma.cancel_button CancelModal]
where 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 warning_message
= HH.p [] [ HH.text "You are about to delete a resource record, this actions is " = HH.p [] [ HH.text "You are about to delete a resource record, this actions is "
, Bulma.strong "irreversible" , Bulma.strong "irreversible"
@ -396,7 +360,6 @@ render state
"SRV" -> template modal_content_srv (foot_content SRV) "SRV" -> template modal_content_srv (foot_content SRV)
"SPF" -> template modal_content_spf (foot_content SPF) "SPF" -> template modal_content_spf (foot_content SPF)
"DKIM" -> template modal_content_dkim (foot_content DKIM) "DKIM" -> template modal_content_dkim (foot_content DKIM)
"DMARC" -> template modal_content_dmarc (foot_content DMARC)
_ -> Bulma.p $ "Invalid type: " <> state._currentRR.rrtype _ -> Bulma.p $ "Invalid type: " <> state._currentRR.rrtype
where where
-- DRY -- DRY
@ -414,12 +377,11 @@ render state
, Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600" , Bulma.box_input ("ttl" <> state._currentRR.rrtype) "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
, case state._currentRR.rrtype of should_be_disabled
"AAAA" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "2001:db8::1" (updateForm Field_Target) state._currentRR.target , Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5"
"TXT" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Your text" "blah blah" (updateForm Field_Target) state._currentRR.target (updateForm Field_Target)
"CNAME" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "www" (updateForm Field_Target) state._currentRR.target state._currentRR.target
"NS" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "ns0.example.com." (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
] <> case state.rr_modal of ] <> case state.rr_modal of
UpdateRRModal -> UpdateRRModal ->
if A.elem state._currentRR.rrtype ["A", "AAAA"] if A.elem state._currentRR.rrtype ["A", "AAAA"]
@ -438,12 +400,15 @@ render state
, Bulma.box_input ("ttlMX") "TTL" "600" , Bulma.box_input ("ttlMX") "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
should_be_disabled
, Bulma.box_input ("targetMX") "Target" "www" , Bulma.box_input ("targetMX") "Target" "www"
(updateForm Field_Target) (updateForm Field_Target)
state._currentRR.target state._currentRR.target
should_be_disabled
, Bulma.box_input ("priorityMX") "Priority" "10" , Bulma.box_input ("priorityMX") "Priority" "10"
(updateForm Field_Priority) (updateForm Field_Priority)
(maybe "" show state._currentRR.priority) (maybe "" show state._currentRR.priority)
should_be_disabled
] ]
modal_content_srv :: Array (HH.HTML w Action) modal_content_srv :: Array (HH.HTML w Action)
modal_content_srv = modal_content_srv =
@ -452,24 +417,31 @@ render state
, Bulma.box_input "domainSRV" "Service name" "service name" , Bulma.box_input "domainSRV" "Service name" "service name"
(updateForm Field_Domain) (updateForm Field_Domain)
state._currentRR.name state._currentRR.name
should_be_disabled
, Bulma.box_input ("protocolSRV") "Protocol" "tcp" , Bulma.box_input ("protocolSRV") "Protocol" "tcp"
(updateForm Field_Protocol) (updateForm Field_Protocol)
(fromMaybe "tcp" state._currentRR.protocol) (fromMaybe "tcp" state._currentRR.protocol)
should_be_disabled
, Bulma.box_input ("targetSRV") "Where the server is" "www" , Bulma.box_input ("targetSRV") "Where the server is" "www"
(updateForm Field_Target) (updateForm Field_Target)
state._currentRR.target state._currentRR.target
should_be_disabled
, Bulma.box_input ("portSRV") "Port of the service" "5061" , Bulma.box_input ("portSRV") "Port of the service" "5061"
(updateForm Field_Port) (updateForm Field_Port)
(maybe "" show state._currentRR.port) (maybe "" show state._currentRR.port)
should_be_disabled
, Bulma.box_input ("prioritySRV") "Priority" "10" , Bulma.box_input ("prioritySRV") "Priority" "10"
(updateForm Field_Priority) (updateForm Field_Priority)
(maybe "" show state._currentRR.priority) (maybe "" show state._currentRR.priority)
should_be_disabled
, Bulma.box_input ("ttlSRV") "TTL" "600" , Bulma.box_input ("ttlSRV") "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
should_be_disabled
, Bulma.box_input ("weightSRV") "Weight" "100" , Bulma.box_input ("weightSRV") "Weight" "100"
(updateForm Field_Weight) (updateForm Field_Weight)
(maybe "" show state._currentRR.weight) (maybe "" show state._currentRR.weight)
should_be_disabled
] ]
modal_content_spf :: Array (HH.HTML w Action) modal_content_spf :: Array (HH.HTML w Action)
modal_content_spf = modal_content_spf =
@ -482,31 +454,32 @@ render state
, Bulma.box_input "ttlSPF" "TTL" "600" , Bulma.box_input "ttlSPF" "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
should_be_disabled
--, case state._currentRR.v of --, case state._currentRR.v of
-- Nothing -> Bulma.p "default value for the version (spf1)" -- 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 , Bulma.hr
, maybe (Bulma.p "no mechanism") display_mechanisms state._currentRR.mechanisms
, Bulma.box , Bulma.box
[ Bulma.h3 "Current mechanisms" [ Bulma.h3 "New mechanism"
, maybe (Bulma.p "You don't have any mechanism.") display_mechanisms state._currentRR.mechanisms
, Bulma.h3 "New mechanism"
, Bulma.selection_field "idMechanismQ" "Policy" SPF_Mechanism_q qualifier_types state.spf_mechanism_q , 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.selection_field "idMechanismT" "Type" SPF_Mechanism_t mechanism_types state.spf_mechanism_t
, Bulma.box_input "valueNewMechanismSPF" "Value" "" , Bulma.box_input "valueNewMechanismSPF" "Value" ""
SPF_Mechanism_v SPF_Mechanism_v
state.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 , Bulma.hr
, maybe (Bulma.p "no modifier") display_modifiers state._currentRR.modifiers
, Bulma.box , Bulma.box
[ Bulma.h3 "Current modifiers" [ Bulma.h3 "New modifier"
, maybe (Bulma.p "You don't have any modifier.") display_modifiers state._currentRR.modifiers
, Bulma.h3 "New modifier"
, Bulma.selection_field "idModifierT" "Modifier" SPF_Modifier_t modifier_types state.spf_modifier_t , Bulma.selection_field "idModifierT" "Modifier" SPF_Modifier_t modifier_types state.spf_modifier_t
, Bulma.box_input "valueNewModifierSPF" "Value" "" , Bulma.box_input "valueNewModifierSPF" "Value" ""
SPF_Modifier_v SPF_Modifier_v
state.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.hr
, Bulma.box , Bulma.box
@ -526,80 +499,28 @@ render state
, Bulma.box_input "ttlDKIM" "TTL" "600" , Bulma.box_input "ttlDKIM" "TTL" "600"
(updateForm Field_TTL) (updateForm Field_TTL)
(show state._currentRR.ttl) (show state._currentRR.ttl)
should_be_disabled
, Bulma.hr , Bulma.hr
, Bulma.div_content [Bulma.explanation Explanations.dkim_default_algorithms] , Bulma.div_content [Bulma.explanation Explanations.dkim_default_algorithms]
, Bulma.selection_field "idDKIMSignature" "Signature algo" , Bulma.selection_field "idDKIMSignature" "Signature algo"
DKIM_sign_algo DKIM_sign_algo
(map show DKIM.sign_algos) (map DKIM.show_signature_algorithm DKIM.sign_algos)
(show $ fromMaybe DKIM.RSA state.dkim.k) (DKIM.show_signature_algorithm $ fromMaybe DKIM.RSA state.dkim.k)
, Bulma.selection_field "idDKIMHash" "Hash algo" , Bulma.selection_field "idDKIMHash" "Hash algo"
DKIM_hash_algo DKIM_hash_algo
(map show DKIM.hash_algos) (map DKIM.show_hashing_algorithm DKIM.hash_algos)
(show $ fromMaybe DKIM.SHA256 state.dkim.h) (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 , Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as 'MIIBIjANBgqh...'"
, Bulma.box_input "noteDKIM" "Note" "Note for fellow administrators." DKIM_note (fromMaybe "" state.dkim.n) 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) 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 = foot_content x =
case state.rr_modal of case state.rr_modal of
NewRRModal _ -> [Bulma.btn_add (ValidateRR x)] NewRRModal _ -> [Bulma.btn_add (ValidateRR x)]
@ -612,14 +533,11 @@ render state
where where
title = case state.rr_modal of title = case state.rr_modal of
NoModal -> "Error: no modal should be displayed" NoModal -> "Error: no modal should be displayed"
NewRRModal t_ -> "New " <> show t_ <> " resource record" NewRRModal t_ -> "New " <> show_accepted_type t_ <> " resource record"
UpdateRRModal -> "Update " <> state._currentRR.rrtype <> " Resource Record" UpdateRRModal -> "Update RR " <> show state._currentRR.rrid
RemoveRRModal rr_id -> "Error: should display removal modal instead (for RR " <> show rr_id <> ")" RemoveRRModal rr_id -> "Error: should display removal modal instead (for RR " <> show rr_id <> ")"
foot = foot_ <> [Bulma.cancel_button CancelModal] 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 :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of handleAction = case _ of
-- | Cancel the current modal being presented. -- | Cancel the current modal being presented.
@ -627,8 +545,6 @@ handleAction = case _ of
CancelModal -> do CancelModal -> do
H.modify_ _ { rr_modal = NoModal } H.modify_ _ { rr_modal = NoModal }
H.modify_ _ { _currentRR_errors = [] } H.modify_ _ { _currentRR_errors = [] }
H.modify_ _ { _dmarc_mail_errors = [] }
handleAction $ ResetTemporaryValues
-- | Create the RR modal. -- | Create the RR modal.
DeleteRRModal rr_id -> do DeleteRRModal rr_id -> do
@ -636,9 +552,6 @@ handleAction = case _ of
-- | Change the current tab. -- | Change the current tab.
ChangeTab new_tab -> do 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 } H.modify_ _ { current_tab = new_tab }
-- | Create modal (a form) for a resource record to update. -- | Create modal (a form) for a resource record to update.
@ -650,7 +563,6 @@ handleAction = case _ of
H.modify_ _ { _currentRR = rr } H.modify_ _ { _currentRR = rr }
_ <- case rr.rrtype of _ <- case rr.rrtype of
"DKIM" -> H.modify_ _ { dkim = fromMaybe DKIM.emptyDKIMRR rr.dkim } "DKIM" -> H.modify_ _ { dkim = fromMaybe DKIM.emptyDKIMRR rr.dkim }
"DMARC" -> H.modify_ _ { dmarc = fromMaybe DMARC.emptyDMARCRR rr.dmarc }
_ -> pure unit _ -> pure unit
H.modify_ _ { rr_modal = UpdateRRModal } H.modify_ _ { rr_modal = UpdateRRModal }
@ -671,7 +583,6 @@ handleAction = case _ of
, q = Just RR.HardFail , q = Just RR.HardFail
} }
default_rr_DKIM = emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" } default_rr_DKIM = emptyRR { rrtype = "DKIM", name = "default._domainkey", target = "" }
default_rr_DMARC = emptyRR { rrtype = "DMARC", name = "_dmarc", target = "" }
case t of case t of
A -> H.modify_ _ { _currentRR = default_rr_A } A -> H.modify_ _ { _currentRR = default_rr_A }
@ -683,7 +594,6 @@ handleAction = case _ of
SRV -> H.modify_ _ { _currentRR = default_rr_SRV } SRV -> H.modify_ _ { _currentRR = default_rr_SRV }
SPF -> H.modify_ _ { _currentRR = default_rr_SPF } SPF -> H.modify_ _ { _currentRR = default_rr_SPF }
DKIM -> H.modify_ _ { _currentRR = default_rr_DKIM } 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 the ZoneInterface component: ask for the domain zone to `dnsmanagerd`.
Initialize -> do Initialize -> do
@ -692,16 +602,6 @@ handleAction = case _ of
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain } message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain }
H.raise $ MessageToSend message 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. -- | 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. -- | Else, the different errors are added to the state.
ValidateRR t -> do ValidateRR t -> do
@ -712,7 +612,6 @@ handleAction = case _ of
-- Since _currentRR.dkim isn't modified directly, it is copied from `State`. -- Since _currentRR.dkim isn't modified directly, it is copied from `State`.
_ <- case t of _ <- case t of
DKIM -> H.modify_ \state -> state { _currentRR { dkim = Just state.dkim } } DKIM -> H.modify_ \state -> state { _currentRR { dkim = Just state.dkim } }
DMARC -> H.modify_ \state -> state { _currentRR { dmarc = Just state.dmarc } }
_ -> pure unit _ -> pure unit
state <- H.get state <- H.get
@ -722,11 +621,7 @@ handleAction = case _ of
-- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors -- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
H.modify_ _ { _currentRR_errors = actual_errors } H.modify_ _ { _currentRR_errors = actual_errors }
Right newrr -> do Right newrr -> do
H.modify_ _ { _currentRR_errors = [] H.modify_ _ { _currentRR_errors = [], dkim = DKIM.emptyDKIMRR }
, _dmarc_mail_errors = []
, dkim = DKIM.emptyDKIMRR
, dmarc = DMARC.emptyDMARCRR
}
handleAction $ AddRR t newrr handleAction $ AddRR t newrr
handleAction CancelModal handleAction CancelModal
@ -735,7 +630,6 @@ handleAction = case _ of
AddRR t newrr -> do AddRR t newrr -> do
state <- H.get state <- H.get
H.raise $ Log $ SystemLog $ "Add new " <> show t H.raise $ Log $ SystemLog $ "Add new " <> show t
H.modify_ _ { _zonefile = Nothing }
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr } $ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
@ -756,7 +650,6 @@ handleAction = case _ of
state0 <- H.get state0 <- H.get
_ <- case state0._currentRR.rrtype of _ <- case state0._currentRR.rrtype of
"DKIM" -> H.modify_ _ { _currentRR { dkim = Just state0.dkim } } "DKIM" -> H.modify_ _ { _currentRR { dkim = Just state0.dkim } }
"DMARC" -> H.modify_ _ { _currentRR { dmarc = Just state0.dmarc } }
_ -> pure unit _ -> pure unit
state <- H.get state <- H.get
@ -764,34 +657,20 @@ handleAction = case _ of
Left actual_errors -> do Left actual_errors -> do
H.modify_ _ { _currentRR_errors = actual_errors } H.modify_ _ { _currentRR_errors = actual_errors }
Right rr -> do Right rr -> do
H.modify_ _ { _currentRR_errors = [], _dmarc_mail_errors = [] } H.modify_ _ { _currentRR_errors = [] }
handleAction $ SaveRR rr 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 SaveRR rr -> do
state <- H.get state <- H.get
H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid
H.modify_ _ { _zonefile = Nothing }
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._domain, rr: rr } $ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
H.raise $ MessageToSend message H.raise $ MessageToSend message
handleAction $ ResetTemporaryValues
RemoveRR rr_id -> do RemoveRR rr_id -> do
{ _domain } <- H.get { _domain } <- H.get
H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")" H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")"
H.modify_ _ { _zonefile = Nothing }
-- Send a removal message. -- Send a removal message.
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
@ -847,7 +726,6 @@ handleAction = case _ of
[] -> Nothing [] -> Nothing
v -> Just v v -> Just v
H.modify_ _ { _currentRR { mechanisms = new_value }} H.modify_ _ { _currentRR { mechanisms = new_value }}
handleAction $ ResetTemporaryValues
SPF_Modifier_Add -> do SPF_Modifier_Add -> do
state <- H.get state <- H.get
@ -859,67 +737,6 @@ handleAction = case _ of
[] -> Nothing [] -> Nothing
v -> Just v v -> Just v
H.modify_ _ { _currentRR { modifiers = new_value }} 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_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 } } 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." _ -> H.raise $ Log $ ErrorLog $ "Message not handled in ZoneInterface."
pure (Just a) pure (Just a)
ConnectionIsDown a -> do
H.modify_ _ { wsUp = false }
pure (Just a)
ConnectionIsUp a -> do
H.modify_ _ { wsUp = true }
pure (Just a)
where where
-- replace_entry :: ResourceRecord -- replace_entry :: ResourceRecord
replace_entry new_rr = do 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_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_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_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) <> (rr_box tag_basic_ro bg_color_ro Bulma.simple_table_header_ro table_content_w_seps all_basic_ro_rr)
where where
all_basic_rr = A.filter (\rr -> A.elem rr.rrtype baseRecords && not rr.readonly) records 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_srv_rr = all_XX_rr "SRV"
all_spf_rr = all_XX_rr "SPF" all_spf_rr = all_XX_rr "SPF"
all_dkim_rr = all_XX_rr "DKIM" 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_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_mx = tags [tag "MX"]
tag_srv = tags [tag "SRV"] tag_srv = tags [tag "SRV"]
tag_spf = tags [tag "SPF"] tag_spf = tags [tag "SPF"]
tag_dkim = tags [tag "DKIM"] tag_dkim = tags [tag "DKIM"]
tag_dmarc = tags [tag "DMARC"] tag_basic_ro = tags [tag_ro "Basic RRs", tag_ro "read only"]
tag_basic_ro = tags [tag_ro "Basic Resource Records", tag_ro "read only"]
rr_box :: HH.HTML w Action -- box title (type of data) rr_box :: HH.HTML w Action -- box title (type of data)
-> Array HH.ClassName -> Array HH.ClassName
@ -1095,36 +917,15 @@ render_resources records
Just dkim -> Just dkim ->
[ [
-- , HH.td_ [ Bulma.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed. Assume DKIM1. -- , 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 "" DKIM.show_hashing_algorithm dkim.h ]
, HH.td_ [ Bulma.p $ maybe "" show dkim.k ] , HH.td_ [ Bulma.p $ maybe "" DKIM.show_signature_algorithm dkim.k ]
, HH.td_ [ Bulma.p $ CP.take 20 dkim.p ] , HH.td_ [ Bulma.p $ CP.take 5 dkim.p ]
, HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ] , HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ]
, if rr.readonly , if rr.readonly
then HH.td_ [ Bulma.btn_readonly ] then HH.td_ [ Bulma.btn_readonly ]
else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid), Bulma.btn_delete (DeleteRRModal rr.rrid) ] else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid), Bulma.btn_delete (DeleteRRModal rr.rrid) ]
] ]
Nothing -> [Bulma.p "Problem: there is no DKIM data." ] 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" -> "MX" ->
[ HH.td_ [ Bulma.p rr.name ] [ HH.td_ [ Bulma.p rr.name ]
, HH.td_ [ Bulma.p $ show rr.ttl ] , 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 fancy_qualifier_display qualifier = "(" <> show_qualifier_char qualifier <> ") " <> show_qualifier qualifier
display_mechanisms :: forall w. Array RR.Mechanism -> HH.HTML w Action display_mechanisms :: forall w. Array RR.Mechanism -> HH.HTML w Action
display_mechanisms [] = Bulma.p "You don't have any mechanism."
display_mechanisms ms = display_mechanisms ms =
Bulma.box_ C.has_background_warning_light Bulma.box_ C.has_background_warning_light
[ Bulma.table [] [ Bulma.mechanism_table_header, HH.tbody_ $ map render_mechanism_row $ attach_id 0 ms] ] [ 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 :: forall w. Array RR.Modifier -> HH.HTML w Action
display_modifiers [] = Bulma.p "You don't have any modifier."
display_modifiers ms = display_modifiers ms =
Bulma.box_ C.has_background_warning_light Bulma.box_ C.has_background_warning_light
[ Bulma.table [] [ Bulma.modifier_table_header, HH.tbody_ $ map render_modifier_row $ attach_id 0 ms] ] [ 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) ] , 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 :: Array String
baseRecords = [ "A", "AAAA", "CNAME", "TXT", "NS" ] baseRecords = [ "A", "AAAA", "CNAME", "TXT", "NS" ]
@ -1214,16 +1000,16 @@ render_new_records _
, Bulma.btn "SRV" (CreateNewRRModal SRV) , Bulma.btn "SRV" (CreateNewRRModal SRV)
] [] ] []
, Bulma.hr , 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) -- use "level" to get horizontal buttons next to each other (probably vertical on mobile)
, Bulma.level [ , Bulma.level [
Bulma.btn "SPF" (CreateNewRRModal SPF) Bulma.btn "SPF" (CreateNewRRModal SPF)
, Bulma.btn "DKIM" (CreateNewRRModal DKIM) , Bulma.btn "DKIM" (CreateNewRRModal DKIM)
, Bulma.btn "DMARC" (CreateNewRRModal DMARC) , Bulma.btn_ro (C.is_small <> C.is_warning) "DMARC"
] [] ] []
, Bulma.hr , Bulma.hr
, Bulma.level [ , Bulma.level [
Bulma.btn "Get the final zone file" AskZoneFile Bulma.btn "Get the final zone file." AskZoneFile
] [HH.text "For debug purposes. ⚠"] ] [HH.text "For debug purposes. ⚠"]
] ]
@ -1248,7 +1034,7 @@ loopE f a = case (A.head a) of
update_field :: ResourceRecord -> Field -> ResourceRecord update_field :: ResourceRecord -> Field -> ResourceRecord
update_field rr updated_field = case updated_field of 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_Target val -> rr { target = val }
Field_TTL val -> rr { ttl = fromMaybe 0 (fromString val) } Field_TTL val -> rr { ttl = fromMaybe 0 (fromString val) }
Field_Priority val -> rr { priority = 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 module App.Text.Explanations where
import Halogen.HTML as HH import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Bulma as Bulma 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 :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
expl content = Bulma.div_content [ Bulma.explanation content ] 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 :: forall w i. HH.HTML w i
tokens = HH.div_ tokens = HH.div_
[ Bulma.h3 "What are tokens?" [ 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. 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 "but your ISP changes your IP address from time to time. "
, HH.text "You can ask for a token (which looks like " , HH.text "You can ask for a token (which looks like "
, HH.u_ [HH.text "53be0c45-61c4-4d29-8ae9-c2cc8767603d"] , HH.u_ [HH.text "53be0c45-61c4-4d29-8ae9-c2cc8767603d"]
@ -33,7 +26,7 @@ tokens = HH.div_
, Bulma.hr , Bulma.hr
, Bulma.h3 "How to automate the update of my IP address?" , 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." , 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 """ , Bulma.p """
No need for a more complex program. This works just fine. No need for a more complex program. This works just fine.
And you can run this command every hour. 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 :: forall w i. Array (HH.HTML w i)
dkim_introduction = dkim_introduction =
[ Bulma.p """ [ Bulma.p """
DKIM is a way to share a public signature key for the domain. 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.p []
[ HH.text """ [ 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 :: forall w i. Array (HH.HTML w i)
dkim_default_algorithms = dkim_default_algorithms =
[ Bulma.p """ [ Bulma.p """
@ -278,16 +78,16 @@ dkim_default_algorithms =
spf_introduction :: forall w i. Array (HH.HTML w i) spf_introduction :: forall w i. Array (HH.HTML w i)
spf_introduction = spf_introduction =
[ HH.p [] [ 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.u_ [HH.text "other mail servers"]
, HH.text " which are the mail servers supposed to send mails from " , HH.text " what are mail servers susceptible to send mails with email addresses from "
, HH.u_ [HH.text "your domain"] , HH.u_ [HH.text "our domain"]
, HH.text ". " , HH.text ". "
] ]
, HH.p [] , HH.p []
[ HH.text """ [ HH.text """
This way, we can mitigate spam. 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. 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.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.p []
[ HH.u_ [HH.text "Advice for beginners"] [ HH.u_ [HH.text "Advice for novice users"]
, HH.text """ , HH.text """
: default values should work great with simple domains. : 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? What should someone do when receiving a mail with your email address but not from a listed domain or IP address?
""" """
, HH.text """ , 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.u_ [HH.text "hard fail"]
, HH.text """). , HH.text """).
@ -319,20 +117,20 @@ spf_default_behavior = [Bulma.p """
srv_introduction :: forall w i. Array (HH.HTML w i) srv_introduction :: forall w i. Array (HH.HTML w i)
srv_introduction = 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.p_ [ HH.text "Given a specific "
, HH.u_ [HH.text "service name"] , HH.u_ [HH.text "service name"]
, HH.text " (which may be arbitrary) and a " , HH.text " (which may be arbitrary) and a "
, HH.u_ [HH.text "protocol"] , 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 " (such as TCP or UDP), you can tell where the server is (address name and port). "
, HH.text """ , 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.p_ [ HH.text "For example, for a service named "
, HH.u_ [HH.text "voip"] , 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.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 | SRV
| SPF | SPF
| DKIM | DKIM
| DMARC
derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _ derive instance genericMyADT :: Generic AcceptedRRTypes _
instance showAcceptedRRTypes :: Show AcceptedRRTypes where instance showMyADT :: Show AcceptedRRTypes where
show = genericShow show = genericShow

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

@ -1,10 +1,5 @@
module App.Type.DKIM where 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.Maybe (Maybe(..))
import Data.Codec.Argonaut (JsonCodec) 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 data HashingAlgorithm = {- SHA1 | -} SHA256
hash_algos = [ {- "sha1", -} SHA256] :: Array HashingAlgorithm 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`. -- | Codec for just encoding a single value of type `HashingAlgorithm`.
codecHashingAlgorithm :: CA.JsonCodec 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 :: String -> Maybe HashingAlgorithm
str_to_hashing_algorithm = case _ of str_to_hashing_algorithm = case _ of
@ -58,15 +50,17 @@ str_to_hashing_algorithm = case _ of
"sha256" -> Just SHA256 "sha256" -> Just SHA256
_ -> Nothing _ -> Nothing
show_hashing_algorithm :: HashingAlgorithm -> String
show_hashing_algorithm = case _ of
-- SHA1 -> "sha1"
SHA256 -> "sha256"
data SignatureAlgorithm = RSA | ED25519 data SignatureAlgorithm = RSA | ED25519
sign_algos = [RSA, ED25519] :: Array SignatureAlgorithm 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`. -- | Codec for just encoding a single value of type `SignatureAlgorithm`.
codecSignatureAlgorithm :: CA.JsonCodec 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 :: String -> Maybe SignatureAlgorithm
str_to_signature_algorithm = case _ of str_to_signature_algorithm = case _ of
@ -74,16 +68,22 @@ str_to_signature_algorithm = case _ of
"ed25519" -> Just ED25519 "ed25519" -> Just ED25519
_ -> Nothing _ -> Nothing
show_signature_algorithm :: SignatureAlgorithm -> String
show_signature_algorithm = case _ of
RSA -> "rsa"
ED25519 -> "ed25519"
data Version = DKIM1 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`. -- | Codec for just encoding a single value of type `Version`.
codecVersion :: CA.JsonCodec 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 :: String -> Maybe Version
str_to_version = case _ of str_to_version = case _ of
"dkim1" -> Just DKIM1 "dkim1" -> Just DKIM1
_ -> Nothing _ -> 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 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. -- | This list will grow in a near future.
-- | -- |
-- | TODO: -- | TODO:
@ -15,8 +11,3 @@ data Page
| Zone String -- | `Zone`: to manage a zone. | Zone String -- | `Zone`: to manage a zone.
| Setup -- | `Setup`: user account administration page | Setup -- | `Setup`: user account administration page
| Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`). | 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 Data.Codec.Argonaut.Record as CAR
import App.Type.DKIM as DKIM import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC
type ResourceRecord type ResourceRecord
= { rrtype :: String = { rrtype :: String
@ -45,7 +44,6 @@ type ResourceRecord
, q :: Maybe Qualifier -- Qualifier for default mechanism (`all`). , q :: Maybe Qualifier -- Qualifier for default mechanism (`all`).
, dkim :: Maybe DKIM.DKIM , dkim :: Maybe DKIM.DKIM
, dmarc :: Maybe DMARC.DMARC
-- TODO: DMARC specific entries. -- TODO: DMARC specific entries.
} }
@ -86,7 +84,6 @@ codec = CA.object "ResourceRecord"
, q: CAR.optional codecQualifier , q: CAR.optional codecQualifier
, dkim: CAR.optional DKIM.codec , dkim: CAR.optional DKIM.codec
, dmarc: CAR.optional DMARC.codec
}) })
type Mechanism type Mechanism
@ -228,7 +225,6 @@ emptyRR
, q: Nothing , q: Nothing
, dkim: Nothing , dkim: Nothing
, dmarc: Nothing
} }
data Qualifier = Pass | Neutral | SoftFail | HardFail 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 GenericParser.RFC5234 as RFC5234
import App.Type.DKIM as DKIM import App.Type.DKIM as DKIM
import App.Type.DMARC as DMARC
-- | **History:** -- | **History:**
-- | The module once used dedicated types for each type of RR. -- | The module once used dedicated types for each type of RR.
@ -52,8 +51,6 @@ data Error
| VEProtocol (G.Error ProtocolError) | VEProtocol (G.Error ProtocolError)
| VEPort Int Int Int | VEPort Int Int Int
| VEWeight Int Int Int | VEWeight Int Int Int
| VEDMARCpct Int Int Int
| VEDMARCri Int Int Int
-- SPF -- SPF
| VESPFMechanismName (G.Error DomainParser.DomainError) | VESPFMechanismName (G.Error DomainParser.DomainError)
@ -108,7 +105,7 @@ txt_parser = do pos <- G.current_position
then pure $ CU.fromCharArray v then pure $ CU.fromCharArray v
else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar) 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. -- | 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 :: 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 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. -- | 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) -- | 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. -- | 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 -- | 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. -- | 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! , name = name, ttl = ttl, target = "" -- `target` is discarded!
, dkim = Just $ dkim { p = p } } , 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 :: ResourceRecord -> Either (Array Error) ResourceRecord
validation entry = case entry.rrtype of validation entry = case entry.rrtype of
"A" -> toEither $ validationA entry "A" -> toEither $ validationA entry
@ -337,7 +320,6 @@ validation entry = case entry.rrtype of
"SRV" -> toEither $ validationSRV entry "SRV" -> toEither $ validationSRV entry
"SPF" -> toEither $ validationSPF entry "SPF" -> toEither $ validationSPF entry
"DKIM" -> toEither $ validationDKIM entry "DKIM" -> toEither $ validationDKIM entry
"DMARC" -> toEither $ validationDMARC entry
_ -> toEither $ invalid [UNKNOWN] _ -> toEither $ invalid [UNKNOWN]
id :: forall a. a -> a id :: forall a. a -> a

4
src/App/WS.purs
View File

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

110
src/Bulma.purs
View File

@ -2,7 +2,6 @@
module Bulma where module Bulma where
import Prelude import Prelude
import Data.Tuple (Tuple, fst, snd)
import Halogen.HTML as HH import Halogen.HTML as HH
import DOM.HTML.Indexed as DHI import DOM.HTML.Indexed as DHI
import Halogen.HTML.Properties as HP import Halogen.HTML.Properties as HP
@ -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 :: forall w i. HH.HTML w i
simple_table_header simple_table_header
= HH.thead_ [ HH.tr_ [ HH.th_ [ HH.text "Type" ] = 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 :: forall w i. HH.HTML w i
soa_table_header soa_table_header
= HH.thead_ [ HH.tr [ HP.classes C.has_background_warning_light ] = 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 ] ] ] [ HH.div [HP.classes C.field ] [ HH.div [HP.classes C.control ] [ content ] ] ]
field_inner :: forall w i. field_inner :: forall w i.
Boolean -> (HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i Boolean -> String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
field_inner ispassword cond id title placeholder action value field_inner ispassword id title placeholder action value cond
= div_field = div_field
[ div_field_label id title [ div_field_label id title
, div_field_content $ render_input ispassword id placeholder action value cond , div_field_content $ render_input ispassword id placeholder action value cond
@ -313,19 +286,13 @@ labeled_field id title content
, div_field_content content , div_field_content content
] ]
box_input_ :: forall w i. box_input :: forall w i.
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
box_input_ = field_inner false box_input = field_inner false
box_password_ :: forall w i. box_password :: forall w i.
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
box_password_ = field_inner true 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)
section_small :: forall w i. Array (HH.HTML w i) -> HH.HTML w i section_small :: forall w i. Array (HH.HTML w i) -> HH.HTML w i
section_small = HH.section [ HP.classes (C.section <> C.is_small) ] section_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 , 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 :: 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] 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 = tab_entry active name action =
HH.li (if active then [HP.classes C.is_active] else []) HH.li (if active then [HP.classes C.is_active] else [])
[ HH.a [HE.onClick \_ -> action] [HH.text name] ] [ 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"