Compare commits
79 Commits
b13d323e96
...
103fb0d643
Author | SHA1 | Date | |
---|---|---|---|
103fb0d643 | |||
27bfb682be | |||
f5b063bdf3 | |||
9dfbc12e80 | |||
915e779511 | |||
6dd342d952 | |||
d38c7cb653 | |||
a45fc80ee8 | |||
23471752e4 | |||
e9419f9ba5 | |||
b70874a621 | |||
1beab72cde | |||
9cba4f7daf | |||
f29265fe8b | |||
a57f7cd026 | |||
3370d3344d | |||
b86e00ec23 | |||
080b8c042c | |||
14477e5a1f | |||
338b3c0811 | |||
e3bbe9ad33 | |||
5cc38c7269 | |||
42bd692077 | |||
f21a7dd3cf | |||
aca29458a0 | |||
c4735e9efc | |||
1e19f664a5 | |||
a6bc098d93 | |||
538547d1cc | |||
41098eed8b | |||
40c8f71346 | |||
ddeb55ff19 | |||
57b3dd6644 | |||
28f5e3091b | |||
9039c43ab9 | |||
af4dca3a50 | |||
c6a7511143 | |||
35bda9c01b | |||
5d6c1b33e6 | |||
f71bae55a0 | |||
3ed1988231 | |||
22f78dc475 | |||
c0a1d2000f | |||
95be116d07 | |||
30fcfb8ce9 | |||
15e43dea3b | |||
a189d931dc | |||
d348d4e03d | |||
c5e8e91d47 | |||
7f83836163 | |||
83393df37e | |||
4d93cbc79f | |||
7d94cf587d | |||
e6d6a2bb20 | |||
d4d183034f | |||
55f39c070c | |||
044578a501 | |||
ac4f8469ce | |||
9456ebda82 | |||
c4f5f81b63 | |||
b23b507f98 | |||
46c6acea6b | |||
86eee44661 | |||
d4e3275625 | |||
a5c7d13450 | |||
9ffeebabaa | |||
a61e723811 | |||
177e3f307f | |||
c7bd61ce36 | |||
71a27d2a35 | |||
45931a37f7 | |||
de039e5e6c | |||
041546279e | |||
f19d3f0f85 | |||
a5756e41af | |||
f9a471c580 | |||
0dce7e5762 | |||
848d93e846 | |||
85cda46d63 |
@ -93,8 +93,10 @@ 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
|
||||||
@ -162,6 +164,14 @@ 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,
|
||||||
@ -171,6 +181,8 @@ 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),
|
||||||
@ -209,7 +221,9 @@ component =
|
|||||||
H.mkComponent
|
H.mkComponent
|
||||||
{ initialState
|
{ initialState
|
||||||
, render
|
, render
|
||||||
, eval: H.mkEval $ H.defaultEval { handleAction = handleAction }
|
, eval: H.mkEval $ H.defaultEval { initialize = Just Initialize
|
||||||
|
, 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.
|
||||||
@ -218,6 +232,8 @@ 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
|
||||||
@ -225,6 +241,7 @@ 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
|
||||||
@ -236,10 +253,15 @@ 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
|
||||||
@ -252,7 +274,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. Reconnect!"
|
Nothing -> Bulma.p "You shouldn't see this page. Please, 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
|
||||||
@ -287,22 +309,39 @@ 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
|
||||||
Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
|
Zone zone -> H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
|
||||||
Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
|
_ -> pure unit
|
||||||
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 -> H.tell _log unit $ AppLog.Log message
|
Log message -> do
|
||||||
|
_ <- case message of
|
||||||
|
UnableToSend err -> handleAction $ AddNotif $ BadNotification err
|
||||||
|
ErrorLog err -> handleAction $ AddNotif $ BadNotification err
|
||||||
|
_ -> pure unit
|
||||||
|
H.tell _log unit $ AppLog.Log message
|
||||||
|
|
||||||
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
|
||||||
@ -318,7 +357,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
|
||||||
@ -335,13 +374,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 -> handleAction $ Log $ ErrorLog "no token!"
|
Nothing -> pure unit
|
||||||
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 -> H.tell _log unit (AppLog.Log message)
|
NavigationInterface.Log message -> handleAction $ Log message
|
||||||
NavigationInterface.Routing page -> handleAction $ Routing page
|
NavigationInterface.Routing page -> handleAction $ Routing page
|
||||||
NavigationInterface.Disconnection -> handleAction $ Disconnection
|
NavigationInterface.Disconnection -> handleAction $ Disconnection
|
||||||
|
|
||||||
@ -350,11 +389,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 { user: Nothing, email: Just (Email.Email email) }
|
AuthD.MkAskPasswordRecovery { login: 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 { user: (Just login), email: Nothing }
|
AuthD.MkAskPasswordRecovery { login: (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
|
||||||
@ -364,15 +403,20 @@ 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 -> H.tell _log unit (AppLog.Log message)
|
AI.Log message -> handleAction $ Log message
|
||||||
|
AI.UserLogin login -> do
|
||||||
|
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||||
|
_ <- H.liftEffect $ Storage.setItem "user-login" login sessionstorage
|
||||||
|
H.modify_ _ { login = Just login }
|
||||||
|
H.tell _nav unit $ NavigationInterface.TellLogin (Just login)
|
||||||
|
|
||||||
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 -> H.tell _log unit (AppLog.Log message)
|
RI.Log message -> handleAction $ 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 -> H.tell _log unit (AppLog.Log message)
|
MVI.Log message -> handleAction $ Log message
|
||||||
|
|
||||||
SetupInterfaceEvent ev -> case ev of
|
SetupInterfaceEvent ev -> case ev of
|
||||||
SetupInterface.DeleteUserAccount -> do
|
SetupInterface.DeleteUserAccount -> do
|
||||||
@ -395,11 +439,11 @@ handleAction = case _ of
|
|||||||
}
|
}
|
||||||
H.tell _ws_auth unit (WS.ToSend message)
|
H.tell _ws_auth unit (WS.ToSend message)
|
||||||
|
|
||||||
SetupInterface.Log message -> H.tell _log unit (AppLog.Log message)
|
SetupInterface.Log message -> handleAction $ 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 -> H.tell _log unit (AppLog.Log message)
|
AdminInterface.Log message -> handleAction $ 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
|
||||||
@ -418,11 +462,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 -> H.tell _log unit (AppLog.Log message)
|
ZoneInterface.Log message -> handleAction $ 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 -> H.tell _log unit (AppLog.Log message)
|
DomainListInterface.Log message -> handleAction $ 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
|
||||||
@ -433,24 +477,19 @@ 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) -> do
|
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeAuthMessage message
|
||||||
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 -> handleAction $ Log $ ErrorLog "no token!"
|
Nothing -> pure unit
|
||||||
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 -> do
|
WS.WSJustClosed -> handleAction $ Log $ ErrorLog "You just got disconnected from authd."
|
||||||
H.tell _ai unit AI.ConnectionIsDown
|
WS.Log message -> handleAction $ Log message
|
||||||
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
|
||||||
@ -479,24 +518,29 @@ handleAction = case _ of
|
|||||||
{ current_page } <- H.get
|
{ current_page } <- H.get
|
||||||
case current_page of
|
case current_page of
|
||||||
Registration -> do
|
Registration -> do
|
||||||
handleAction $ Log $ SuccessLog """
|
let successlog = """
|
||||||
You are now registered, copy the token we sent you by email to finish your registration.
|
You are now registered. Please verify your email address with the token we sent you.
|
||||||
"""
|
"""
|
||||||
|
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."
|
||||||
(AuthD.GotPasswordRecovered _) -> do
|
m@(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
|
||||||
@ -507,49 +551,67 @@ 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
|
||||||
_ -> handleAction $ Log $ ErrorLog
|
_ -> pure unit
|
||||||
"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
|
||||||
(AuthD.GotPasswordRecoverySent _) -> do
|
handleAction $ AddNotif $ BadNotification $ "Sorry, authd sent an error message. "
|
||||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
|
<> maybe "The server didn't tell why." (\v -> "Message was: " <> v) errmsg.reason
|
||||||
|
m@(AuthD.GotPasswordRecoverySent _) -> do
|
||||||
|
handleAction $ Log $ SuccessLog $ "Password recovery: email sent."
|
||||||
|
handleAction $ AddNotif $ GoodNotification "Your password recovery mail has been sent."
|
||||||
|
handleAction $ DispatchAuthDaemonMessage m
|
||||||
(AuthD.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 "Login already taken!"
|
handleAction $ Log $ ErrorLog "GotErrorAlreadyUsersInDB"
|
||||||
|
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)
|
||||||
|
|
||||||
@ -557,38 +619,41 @@ 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 _) -> do
|
(AuthD.GotKeepAlive _) -> pure unit
|
||||||
-- 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) -> do
|
WS.MessageReceived (Tuple _ message) -> handleAction $ DecodeDNSMessage message
|
||||||
handleAction $ DecodeDNSMessage message
|
WS.WSJustConnected -> handleAction AuthenticateToDNSManager
|
||||||
WS.WSJustConnected -> do
|
WS.WSJustClosed -> handleAction $ Log $ ErrorLog "You just got disconnected from dnsmanagerd."
|
||||||
handleAction $ Log $ SystemLog "Connection with dnsmanagerd was closed, let's re-authenticate"
|
WS.Log message -> handleAction $ Log message
|
||||||
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`.
|
||||||
@ -612,22 +677,28 @@ 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
|
||||||
@ -642,24 +713,29 @@ 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 _) -> do
|
m@(DNSManager.MkLogged logged_message) -> 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
|
||||||
@ -668,20 +744,25 @@ 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
|
||||||
handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!"
|
let 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
|
||||||
handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors
|
let 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)
|
||||||
|
@ -8,9 +8,13 @@ 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
|
||||||
@ -20,8 +24,15 @@ 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 -> Bulma.p $ "TTL should have a value between " <> show min <> " and " <> show max
|
ValidationDNS.VETTL min max n ->
|
||||||
<> ", current value: " <> show n <> "."
|
Bulma.p $ "TTL should have a value between "
|
||||||
|
<> show min <> " and " <> show max <> ", current value: " <> show n <> "."
|
||||||
|
ValidationDNS.VEDMARCpct min max n ->
|
||||||
|
Bulma.p $ "DMARC sample rate should have a value between "
|
||||||
|
<> show min <> " and " <> show max <> ", current value: " <> show n <> "."
|
||||||
|
ValidationDNS.VEDMARCri min max n ->
|
||||||
|
Bulma.p $ "DMARC report interval should have a value between "
|
||||||
|
<> show min <> " and " <> show max <> ", current value: " <> show n <> "."
|
||||||
ValidationDNS.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
|
||||||
@ -29,7 +40,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 default_error show_error_protocol err.error
|
ValidationDNS.VEProtocol err -> maybe protocol_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
|
||||||
@ -44,6 +55,7 @@ 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
|
||||||
@ -54,27 +66,29 @@ 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 err -> "The IPv4 address is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEIPv4 _ -> "Invalid IPv4 address"
|
||||||
ValidationDNS.VEIPv6 err -> "The IPv6 address is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEIPv6 _ -> "Invalid IPv6 address"
|
||||||
ValidationDNS.VEName err -> "The name (domain label) is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEName _ -> "Invalid Name (domain label)"
|
||||||
ValidationDNS.VETTL min max n -> "Invalid TTL (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
ValidationDNS.VETTL _ _ _ -> "Invalid TTL"
|
||||||
ValidationDNS.VETXT err -> "The TXT input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEDMARCpct _ _ _ -> "Invalid DMARC sample rate"
|
||||||
ValidationDNS.VECNAME err -> "The CNAME input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEDMARCri _ _ _ -> "Invalid DMARC report interval"
|
||||||
ValidationDNS.VENS err -> "The NS input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VETXT _ -> "Invalid TXT"
|
||||||
ValidationDNS.VEMX err -> "The MX target input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VECNAME _ -> "Invalid CNAME"
|
||||||
ValidationDNS.VEPriority min max n -> "Invalid Priority (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
ValidationDNS.VENS _ -> "Invalid NS Target"
|
||||||
ValidationDNS.VESRV err -> "The SRV target input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEMX _ -> "Invalid MX Target"
|
||||||
ValidationDNS.VEProtocol err -> "The Protocol input is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VEPriority _ _ _ -> "Invalid Priority"
|
||||||
ValidationDNS.VEPort min max n -> "Invalid Port (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
ValidationDNS.VESRV _ -> "Invalid SRV Target"
|
||||||
ValidationDNS.VEWeight min max n -> "Invalid Weight (min: " <> show min <> ", max: " <> show max <> ", n: " <> show n <> ")"
|
ValidationDNS.VEProtocol _ -> "Invalid Protocol"
|
||||||
|
ValidationDNS.VEPort _ _ _ -> "Invalid Port"
|
||||||
|
ValidationDNS.VEWeight _ _ _ -> "Invalid Weight"
|
||||||
|
|
||||||
-- SPF dedicated RR
|
-- SPF dedicated RR
|
||||||
ValidationDNS.VESPFMechanismName err -> "The domain name in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VESPFMechanismName _ -> "The domain name in a SPF mechanism is wrong"
|
||||||
ValidationDNS.VESPFMechanismIPv4 err -> "The IPv4 address in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VESPFMechanismIPv4 _ -> "The IPv4 address in a SPF mechanism is wrong"
|
||||||
ValidationDNS.VESPFMechanismIPv6 err -> "The IPv6 address in a SPF mechanism is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VESPFMechanismIPv6 _ -> "The IPv6 address in a SPF mechanism is wrong"
|
||||||
|
|
||||||
ValidationDNS.VESPFModifierName err -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong (position: " <> show err.position <> ")"
|
ValidationDNS.VESPFModifierName _ -> "The domain name in a SPF modifier (EXP or REDIRECT) is wrong"
|
||||||
ValidationDNS.DKIMInvalidKeySize _ _ -> "Public key has an invalid length."
|
ValidationDNS.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
|
||||||
@ -87,7 +101,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.
|
||||||
"""
|
"""
|
||||||
|
|
||||||
@ -102,7 +116,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."
|
||||||
@ -147,10 +161,46 @@ 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 -> "Cannot parse the label (position: " <> show x.position <> ")."
|
Nothing -> "Invalid label"
|
||||||
Just (ValidationLabel.CannotParse _) ->
|
Just (ValidationLabel.CannotParse _) ->
|
||||||
"Cannot parse the label (position: " <> show x.position <> ")."
|
"Invalid label"
|
||||||
Just (ValidationLabel.CannotEntirelyParse) -> "Cannot entirely parse the label."
|
Just (ValidationLabel.CannotEntirelyParse) -> "Invalid label (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 <> ")"
|
||||||
|
@ -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 = { user :: Maybe String, email :: Maybe Email.Email }
|
type AskPasswordRecovery = { login :: Maybe String, email :: Maybe Email.Email }
|
||||||
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
codecAskPasswordRecovery ∷ CA.JsonCodec AskPasswordRecovery
|
||||||
codecAskPasswordRecovery
|
codecAskPasswordRecovery
|
||||||
= CA.object "AskPasswordRecovery"
|
= CA.object "AskPasswordRecovery"
|
||||||
(CAR.record { user: CAR.optional CA.string, email: CAR.optional Email.codec })
|
(CAR.record { login: CAR.optional CA.string, email: CAR.optional Email.codec })
|
||||||
|
|
||||||
{- 4 -}
|
{- 4 -}
|
||||||
type PasswordRecovery = { user :: String
|
type PasswordRecovery = { user :: String
|
||||||
|
@ -208,10 +208,12 @@ 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 }
|
type Logged = { accepted_domains :: Array String, my_domains :: Array String, admin :: Boolean }
|
||||||
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 }
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
{- Administration interface.
|
{- Administration interface.
|
||||||
Allows to:
|
Enables 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, (/=), (==))
|
import Prelude (Unit, bind, discard, not, pure, show, ($), (<<<), (<>), (=<<), map, (/=), (==), unit)
|
||||||
import Data.Eq (class Eq)
|
import Data.Eq (class Eq)
|
||||||
|
|
||||||
import Bulma as Bulma
|
import Bulma as Bulma
|
||||||
@ -21,7 +21,6 @@ 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
|
||||||
|
|
||||||
@ -54,8 +53,6 @@ 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
|
||||||
|
|
||||||
@ -104,7 +101,6 @@ 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
|
||||||
}
|
}
|
||||||
@ -128,11 +124,10 @@ 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, wsUp }
|
render { addUserForm, searchUserForm, matching_users, current_tab, orphan_domains }
|
||||||
= Bulma.section_small
|
= Bulma.section_small
|
||||||
[ fancy_tab_bar
|
[ fancy_tab_bar
|
||||||
, case current_tab of
|
, case current_tab of
|
||||||
@ -167,15 +162,14 @@ 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 active
|
[ Bulma.box_input "login" "User login" "login" (up ADDUSER_INP_login) addUserForm.login
|
||||||
, 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 active
|
, Bulma.box_input "email" "User email" "email" (up ADDUSER_INP_email) addUserForm.email
|
||||||
, Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass active
|
, Bulma.box_password "password" "User password" "password" (up ADDUSER_INP_pass) addUserForm.pass
|
||||||
, Bulma.btn "Send" AddUserAttempt
|
, Bulma.btn "Send" AddUserAttempt
|
||||||
]
|
]
|
||||||
|
|
||||||
@ -184,13 +178,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 will be used to search an user based on his login, full name or email address.
|
This is used to search for a user based on their login, full name or email address.
|
||||||
"""
|
"""
|
||||||
, Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex active
|
, Bulma.box_input "regex" "Regex" "regex" (up SEARCHUSER_INP_regex) searchUserForm.regex
|
||||||
--, 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 active
|
-- (up SEARCHUSER_INP_domain) searchUserForm.domain
|
||||||
, Bulma.btn "Send" SearchUserAttempt
|
, Bulma.btn "Send" SearchUserAttempt
|
||||||
]
|
]
|
||||||
|
|
||||||
@ -201,7 +195,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 -> H.raise $ Log $ ErrorLog "We hadn't changed tab before reload apparently."
|
Nothing -> pure unit
|
||||||
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
|
||||||
@ -312,19 +306,9 @@ 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.
|
||||||
_ -> do
|
_ -> H.raise $ Log $ ErrorLog $ "Authentication server didn't send a valid message."
|
||||||
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)
|
||||||
|
@ -2,23 +2,27 @@
|
|||||||
-- | TODO: token validation.
|
-- | TODO: token validation.
|
||||||
module App.Page.Authentication where
|
module App.Page.Authentication where
|
||||||
|
|
||||||
import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), (>), (==), map, show)
|
import Prelude (Unit, bind, discard, pure, ($), (<<<), (=<<), (<>), (>), (==), map, show, unit)
|
||||||
|
|
||||||
import Data.Array as A
|
import Data.Array as A
|
||||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||||
import Data.Maybe (Maybe(..), maybe)
|
|
||||||
import Data.Either (Either(..))
|
import Data.Either (Either(..))
|
||||||
|
import Data.Eq (class Eq)
|
||||||
|
import Data.Maybe (Maybe(..), maybe)
|
||||||
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
|
||||||
|
|
||||||
@ -47,6 +51,7 @@ 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)
|
||||||
|
|
||||||
@ -55,8 +60,6 @@ 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
|
||||||
|
|
||||||
@ -77,7 +80,8 @@ data NewPasswordInput
|
|||||||
| NEWPASS_INP_confirmation String
|
| NEWPASS_INP_confirmation String
|
||||||
|
|
||||||
data Action
|
data Action
|
||||||
= HandleAuthenticationInput AuthenticationInput
|
= Initialize
|
||||||
|
| HandleAuthenticationInput AuthenticationInput
|
||||||
| HandlePasswordRecovery PasswordRecoveryInput
|
| HandlePasswordRecovery PasswordRecoveryInput
|
||||||
| HandleNewPassword NewPasswordInput
|
| HandleNewPassword NewPasswordInput
|
||||||
--
|
--
|
||||||
@ -85,6 +89,14 @@ 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 }
|
||||||
@ -94,7 +106,7 @@ type State =
|
|||||||
, passwordRecoveryForm :: StatePasswordRecoveryForm
|
, passwordRecoveryForm :: StatePasswordRecoveryForm
|
||||||
, newPasswordForm :: StateNewPasswordForm
|
, newPasswordForm :: StateNewPasswordForm
|
||||||
, errors :: Array Error
|
, errors :: Array Error
|
||||||
, wsUp :: Boolean
|
, current_tab :: Tab
|
||||||
}
|
}
|
||||||
|
|
||||||
initialState :: Input -> State
|
initialState :: Input -> State
|
||||||
@ -102,8 +114,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
|
||||||
@ -112,26 +124,33 @@ component =
|
|||||||
{ initialState
|
{ initialState
|
||||||
, render
|
, render
|
||||||
, eval: H.mkEval $ H.defaultEval
|
, eval: H.mkEval $ H.defaultEval
|
||||||
{ handleAction = handleAction
|
{ initialize = Just Initialize
|
||||||
|
, handleAction = handleAction
|
||||||
, handleQuery = handleQuery
|
, handleQuery = handleQuery
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
render :: forall m. State -> H.ComponentHTML Action () m
|
render :: forall m. State -> H.ComponentHTML Action () m
|
||||||
render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
|
render { current_tab, authenticationForm, passwordRecoveryForm, newPasswordForm, errors } =
|
||||||
Bulma.section_small
|
Bulma.section_small
|
||||||
[ case wsUp of
|
[ fancy_tab_bar
|
||||||
false -> Bulma.p "You are disconnected."
|
, if A.length errors > 0
|
||||||
true ->
|
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ] ]
|
||||||
if A.length errors > 0
|
else HH.div_ []
|
||||||
then HH.div_ [ Bulma.box [ HH.text (A.fold $ map show_error errors) ]
|
, case current_tab of
|
||||||
, Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
Auth -> Bulma.box auth_form
|
||||||
]
|
ILostMyPassword -> Bulma.box passrecovery_form
|
||||||
else Bulma.columns_ [ b auth_form, b passrecovery_form, b newpass_form ]
|
Recovery -> Bulma.box newpass_form
|
||||||
]
|
]
|
||||||
|
|
||||||
where
|
where
|
||||||
b e = Bulma.column_ [ Bulma.box e ]
|
fancy_tab_bar =
|
||||||
|
Bulma.fancy_tabs
|
||||||
|
[ Bulma.tab_entry (is_tab_active Auth) "Authentication" (ChangeTab Auth)
|
||||||
|
, Bulma.tab_entry (is_tab_active ILostMyPassword) "I lost my password! 😟" (ChangeTab ILostMyPassword)
|
||||||
|
, Bulma.tab_entry (is_tab_active Recovery) "Recover with a token" (ChangeTab Recovery)
|
||||||
|
]
|
||||||
|
is_tab_active tab = current_tab == tab
|
||||||
|
|
||||||
show_error :: Error -> String
|
show_error :: Error -> String
|
||||||
show_error = case _ of
|
show_error = case _ of
|
||||||
@ -178,27 +197,31 @@ render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors
|
|||||||
<> " (currently: " <> show n <> ")"
|
<> " (currently: " <> show n <> ")"
|
||||||
|
|
||||||
auth_form = [ Bulma.h3 "Authentication", render_auth_form ]
|
auth_form = [ Bulma.h3 "Authentication", render_auth_form ]
|
||||||
passrecovery_form = [ Bulma.h3 "Password Recovery", render_password_recovery_form ]
|
passrecovery_form =
|
||||||
newpass_form = [ Bulma.h3 "New password", render_new_password_form ]
|
[ Bulma.h3 "You forgot your password (or your login)"
|
||||||
|
, Bulma.div_content
|
||||||
should_be_disabled = (if wsUp then (HP.enabled true) else (HP.disabled true))
|
[ Bulma.p "Enter either your login or email and you'll receive a recovery token."
|
||||||
|
]
|
||||||
|
, render_password_recovery_form
|
||||||
|
]
|
||||||
|
newpass_form =
|
||||||
|
[ Bulma.h3 "You got the password recovery mail"
|
||||||
|
, Bulma.div_content
|
||||||
|
[ Bulma.p "Nice! You get to choose your new password."
|
||||||
|
]
|
||||||
|
, render_new_password_form
|
||||||
|
]
|
||||||
|
|
||||||
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
|
||||||
should_be_disabled -- condition
|
, Bulma.btn_validation
|
||||||
, 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
|
||||||
@ -206,17 +229,10 @@ render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors
|
|||||||
[ 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
|
||||||
should_be_disabled -- condition
|
, Bulma.btn_validation
|
||||||
, 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
|
||||||
@ -224,30 +240,32 @@ render { wsUp, authenticationForm, passwordRecoveryForm, newPasswordForm, errors
|
|||||||
[ 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
|
||||||
should_be_disabled
|
, Bulma.btn_validation
|
||||||
, 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 } }
|
||||||
@ -271,6 +289,7 @@ 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!"
|
||||||
@ -307,7 +326,6 @@ 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
|
||||||
|
|
||||||
@ -315,13 +333,28 @@ 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 of
|
then case L.login login, P.password password of
|
||||||
Left errors -> H.modify_ _ { errors = [ Login errors ] }
|
Left errors, _ -> H.modify_ _ { errors = [ Login errors ] }
|
||||||
Right _ -> do H.modify_ _ { errors = [] }
|
_, Left errors -> H.modify_ _ { errors = [ Password errors ] }
|
||||||
|
_, _ -> do H.modify_ _ { errors = [] }
|
||||||
|
H.raise $ Log $ SystemLog $ "Sending a new password"
|
||||||
H.raise $ PasswordRecovery login token password
|
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
|
||||||
@ -329,14 +362,10 @@ 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)
|
|
||||||
|
@ -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 allows to:
|
-- | This interface enables 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,6 +16,7 @@ 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)
|
||||||
@ -23,7 +24,6 @@ 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,7 +32,6 @@ 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
|
||||||
|
|
||||||
@ -65,8 +64,6 @@ 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
|
||||||
@ -123,7 +120,6 @@ 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
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -153,20 +149,19 @@ 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, wsUp, active_modal }
|
render { accepted_domains, my_domains, newDomainForm, active_modal }
|
||||||
= Bulma.section_small
|
= Bulma.section_small
|
||||||
[ case wsUp of
|
[ case active_modal of
|
||||||
false -> Bulma.p "You are disconnected."
|
|
||||||
true -> case active_modal of
|
|
||||||
Nothing -> Bulma.columns_
|
Nothing -> Bulma.columns_
|
||||||
[ Bulma.column_ [ Bulma.h3 "Add a domain!", render_add_domain_form]
|
[ Bulma.column_ [ Bulma.h3 "New domain", render_add_domain_form]
|
||||||
, Bulma.column_ [ Bulma.h3 "My domains"
|
, Bulma.column_ [ Bulma.h3 "My domains"
|
||||||
, HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) my_domains
|
, if A.length my_domains > 0
|
||||||
|
then HH.ul_ $ map (\domain -> HH.li_ (domain_buttons domain)) $ A.sort my_domains
|
||||||
|
else Bulma.p "No domain yet."
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
Just domain -> Bulma.modal "Deleting a domain"
|
Just domain -> Bulma.modal "Deleting a domain"
|
||||||
@ -176,9 +171,9 @@ render { accepted_domains, my_domains, newDomainForm, wsUp, 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 "."
|
||||||
]
|
]
|
||||||
@ -194,12 +189,8 @@ render { accepted_domains, my_domains, newDomainForm, wsUp, active_modal }
|
|||||||
(HandleNewDomainInput <<< INP_newdomain)
|
(HandleNewDomainInput <<< INP_newdomain)
|
||||||
newDomainForm.new_domain
|
newDomainForm.new_domain
|
||||||
[ HHE.onSelectedIndexChange domain_choice ]
|
[ HHE.onSelectedIndexChange domain_choice ]
|
||||||
accepted_domains
|
(map (\v -> "." <> v) accepted_domains)
|
||||||
, HH.button
|
, Bulma.btn_validation_ "add a new domain"
|
||||||
[ 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_ [ ]
|
||||||
@ -230,7 +221,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 = v } }
|
H.modify_ _ { newDomainForm { new_domain = toLower 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
|
||||||
@ -256,18 +247,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._errors, new_domain of
|
case newDomainForm.new_domain, 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 $ "You didn't enter a valid new domain"
|
H.raise $ Log $ UnableToSend $ "The new domain name is invalid."
|
||||||
|
|
||||||
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
|
||||||
@ -296,20 +287,12 @@ 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 = response.my_domains
|
, my_domains = A.sort response.my_domains
|
||||||
}
|
}
|
||||||
_ -> s1
|
_ -> s1
|
||||||
|
|
||||||
|
@ -41,25 +41,27 @@ 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 AN ALPHA RELEASE"
|
"THIS IS A BETA RELEASE"
|
||||||
"You can register, login and play a bit with the tool! Please, report errors and suggestions"
|
"You can register, login and play a bit with the tool. Feel free to 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"
|
, Bulma.subtitle "Free domain names for the common folks"
|
||||||
, Bulma.hr
|
, Bulma.hr
|
||||||
, render_description
|
, render_description
|
||||||
, render_second_line
|
, render_update_why_and_contact
|
||||||
, 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_description = Bulma.columns_ [ render_basics, render_no_expert, render_no_housing ]
|
||||||
|
render_update_why_and_contact = Bulma.columns_ [ render_updates, render_why, render_contact ]
|
||||||
|
|
||||||
render_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."
|
||||||
@ -71,7 +73,6 @@ 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 """
|
||||||
@ -83,12 +84,10 @@ 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://beta.netlib.re/token-update/<token>" ]
|
, expl [ Bulma.strong "wget https://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."
|
||||||
@ -116,9 +115,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/dnsmanagerd" "dnsmanagerd"
|
, link "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanagerd"
|
||||||
"""
|
"""
|
||||||
the dns manager daemon, used as an interactive database, allowing clients
|
the dns manager daemon, used as an interactive database, enabling 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"
|
||||||
@ -138,7 +137,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, allowing to store serialized objects
|
the Document Oriented DataBase, enabling 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.
|
||||||
"""
|
"""
|
||||||
|
@ -3,17 +3,16 @@
|
|||||||
-- | 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, pure, ($), (<<<), (<>), map, show)
|
import Prelude (Unit, bind, discard, ($), (<<<), (<>), 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(..), maybe)
|
import Data.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)
|
||||||
|
|
||||||
@ -30,9 +29,7 @@ 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
|
data Query a = DoNothing a
|
||||||
= ConnectionIsDown a
|
|
||||||
| ConnectionIsUp a
|
|
||||||
|
|
||||||
type Slot = H.Slot Query Output
|
type Slot = H.Slot Query Output
|
||||||
|
|
||||||
@ -65,7 +62,6 @@ 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
|
||||||
@ -75,7 +71,6 @@ component =
|
|||||||
, render
|
, render
|
||||||
, eval: H.mkEval $ H.defaultEval
|
, eval: H.mkEval $ H.defaultEval
|
||||||
{ handleAction = handleAction
|
{ handleAction = handleAction
|
||||||
, handleQuery = handleQuery
|
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -83,41 +78,25 @@ 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 { wsUp, mailValidationForm }
|
render { mailValidationForm }
|
||||||
= Bulma.section_small
|
= Bulma.section_small [ Bulma.columns_ [ b mail_validation_form ] ]
|
||||||
[ 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
|
||||||
should_be_disabled -- condition
|
, Bulma.btn_validation
|
||||||
, 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
|
||||||
@ -185,13 +164,3 @@ 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)
|
|
||||||
|
@ -31,7 +31,10 @@ 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 = ToggleLogged Boolean a
|
data Query a
|
||||||
|
= ToggleLogged Boolean a
|
||||||
|
| ToggleAdmin Boolean a
|
||||||
|
| TellLogin (Maybe String) a
|
||||||
|
|
||||||
type Slot = H.Slot Query Output
|
type Slot = H.Slot Query Output
|
||||||
|
|
||||||
@ -53,7 +56,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, active :: Boolean, admin :: Boolean }
|
type State = { logged :: Boolean, login :: Maybe String, 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 =
|
||||||
@ -66,13 +69,16 @@ component =
|
|||||||
}
|
}
|
||||||
|
|
||||||
initialState :: Input -> State
|
initialState :: Input -> State
|
||||||
initialState _ = { logged: false, active: false, admin: true }
|
initialState _ = { logged: false, login: Nothing, active: false, admin: false }
|
||||||
|
|
||||||
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 -> H.raise $ Routing page
|
Navigate page -> do
|
||||||
|
-- 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 }
|
||||||
@ -82,6 +88,12 @@ 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.
|
||||||
@ -93,7 +105,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 } =
|
render { logged, active, admin, login } =
|
||||||
main_nav
|
main_nav
|
||||||
[ nav_brand [ logo, burger_menu ]
|
[ nav_brand [ logo, burger_menu ]
|
||||||
, nav_menu
|
, nav_menu
|
||||||
@ -112,7 +124,7 @@ render { logged, active, admin } =
|
|||||||
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 ]
|
||||||
_ -> [ link_setup, link_disconnection ]
|
_ -> render_login login <> [ link_setup, link_disconnection ]
|
||||||
|
|
||||||
navbar_color = C.is_success
|
navbar_color = C.is_success
|
||||||
|
|
||||||
@ -122,7 +134,7 @@ render { logged, active, admin } =
|
|||||||
, 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]]
|
||||||
|
|
||||||
@ -153,6 +165,8 @@ render { logged, active, admin } =
|
|||||||
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
|
||||||
|
|
||||||
@ -160,7 +174,6 @@ render { logged, active, admin } =
|
|||||||
= 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 ])
|
||||||
@ -179,6 +192,10 @@ render { logged, active, admin } =
|
|||||||
, 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
|
||||||
@ -186,13 +203,13 @@ render { logged, active, admin } =
|
|||||||
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 "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
|
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/authd" "authentication daemon"
|
||||||
, dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager daemon"
|
, dropdown_element_primary "https://git.baguette.netlib.re/Baguette/dnsmanager" "dnsmanager daemon"
|
||||||
, dropdown_element "https://git.baguette.netlib.re/Baguette/dnsmanager-webclient" "dnsmanager web client"
|
, dropdown_element_primary "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 "https://git.baguette.netlib.re/Baguette/libipc" "libIPC: communication library"
|
, dropdown_element_secondary "https://git.baguette.netlib.re/Baguette/libipc" "libIPC: communication library"
|
||||||
, dropdown_element "https://git.baguette.netlib.re/Baguette/dodb.cr" "DoDB: document-oriented database"
|
, dropdown_element_secondary "https://git.baguette.netlib.re/Baguette/dodb.cr" "DoDB: document-oriented database"
|
||||||
]
|
]
|
||||||
|
|
||||||
--btn c action str
|
--btn c action str
|
||||||
|
@ -2,17 +2,16 @@
|
|||||||
-- | 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, pure, ($), (<<<), (<>), map, show)
|
import Prelude (Unit, bind, discard, ($), (<<<), (<>), map)
|
||||||
|
|
||||||
import Data.Array as A
|
import Data.Array as A
|
||||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||||
import Data.Maybe (Maybe(..), maybe)
|
import Data.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)
|
||||||
|
|
||||||
@ -22,6 +21,8 @@ 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
|
||||||
@ -30,10 +31,7 @@ data Output
|
|||||||
= MessageToSend ArrayBuffer
|
= MessageToSend ArrayBuffer
|
||||||
| Log LogMessage
|
| Log LogMessage
|
||||||
|
|
||||||
-- | The component is informed when the connection went up or down.
|
data Query a = DoNothing a
|
||||||
data Query a
|
|
||||||
= ConnectionIsDown a
|
|
||||||
| ConnectionIsUp a
|
|
||||||
|
|
||||||
type Slot = H.Slot Query Output
|
type Slot = H.Slot Query Output
|
||||||
|
|
||||||
@ -68,14 +66,12 @@ 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
|
||||||
@ -85,46 +81,29 @@ 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 { wsUp, registrationForm }
|
render { registrationForm }
|
||||||
= Bulma.section_small
|
= Bulma.section_small [Bulma.columns_ [ b registration_form ]]
|
||||||
[ 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
|
||||||
should_be_disabled -- condition
|
, Bulma.btn_validation
|
||||||
, 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
|
||||||
@ -175,52 +154,3 @@ 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)
|
|
||||||
|
@ -1,20 +1,23 @@
|
|||||||
-- | `App.SetupInterface` allows users to change their password or their email address.
|
-- | `App.SetupInterface` enables 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, ($), (<<<), (==))
|
import Prelude (Unit, bind, discard, pure, ($), (<<<), (==), (<>), show, map)
|
||||||
|
|
||||||
import Data.Maybe (Maybe(..))
|
import Data.Array as A
|
||||||
|
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
|
||||||
|
|
||||||
@ -24,12 +27,8 @@ 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
|
||||||
|
|
||||||
@ -46,6 +45,7 @@ data NewPasswordInput
|
|||||||
data Action
|
data Action
|
||||||
= HandleNewPassword NewPasswordInput
|
= HandleNewPassword NewPasswordInput
|
||||||
| ChangePasswordAttempt Event
|
| ChangePasswordAttempt Event
|
||||||
|
| SendChangePasswordMessage
|
||||||
| CancelModal
|
| CancelModal
|
||||||
| DeleteAccountPopup
|
| DeleteAccountPopup
|
||||||
| DeleteAccount
|
| DeleteAccount
|
||||||
@ -59,7 +59,6 @@ data Modal
|
|||||||
type State =
|
type State =
|
||||||
{ newPasswordForm :: StateNewPasswordForm
|
{ newPasswordForm :: StateNewPasswordForm
|
||||||
, token :: String
|
, token :: String
|
||||||
, wsUp :: Boolean
|
|
||||||
, modal :: Modal
|
, modal :: Modal
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -79,38 +78,31 @@ 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, wsUp, newPasswordForm } =
|
render { modal, newPasswordForm } =
|
||||||
case modal of
|
Bulma.section_small
|
||||||
|
[ 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_ [ Bulma.box e ]
|
b e = Bulma.column_ 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_input "passwordNEWPASS" "Password" "password"
|
[ Bulma.box_password "passwordNEWPASS" "New 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_input "confirmationNEWPASS" "Confirmation" "confirmation"
|
|
||||||
(HandleNewPassword <<< NEWPASS_INP_confirmation)
|
(HandleNewPassword <<< NEWPASS_INP_confirmation)
|
||||||
newPasswordForm.confirmation
|
newPasswordForm.confirmation
|
||||||
should_be_disabled
|
, Bulma.btn_validation
|
||||||
, 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"
|
||||||
@ -145,10 +137,31 @@ 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 do H.raise $ Log $ SystemLog "Changing the password"
|
then case P.password pass of
|
||||||
H.raise $ ChangePassword pass
|
Left errors -> H.raise $ Log $ UnableToSend $ A.fold $ map show_error_password errors
|
||||||
|
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.
|
||||||
@ -158,11 +171,3 @@ 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)
|
|
||||||
|
@ -1,28 +1,33 @@
|
|||||||
-- | `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 allows to:
|
-- | This interface enables 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)
|
||||||
-- | - TODO: dedicated interfaces for: SPF, DKIM, DMARC
|
-- | - provide dedicated interfaces for SPF and DKIM (TODO: 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
|
-- | This includes explaining use cases and displaying an appropriate interface for the task at hand.
|
||||||
-- | 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
|
, not, comparing, discard, map, show, class 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
|
||||||
@ -31,6 +36,7 @@ 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)
|
||||||
@ -53,8 +59,9 @@ 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)
|
import App.DisplayErrors (error_to_paragraph, show_error_email)
|
||||||
|
|
||||||
import App.Type.LogMessage (LogMessage(..))
|
import App.Type.LogMessage (LogMessage(..))
|
||||||
import App.Message.DNSManagerDaemon as DNSManager
|
import App.Message.DNSManagerDaemon as DNSManager
|
||||||
@ -76,13 +83,9 @@ 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
|
||||||
|
|
||||||
@ -148,6 +151,9 @@ 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
|
||||||
|
|
||||||
@ -178,6 +184,34 @@ 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
|
||||||
@ -189,18 +223,6 @@ 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
|
||||||
@ -212,14 +234,17 @@ 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 | TokenExplanation
|
data Tab = Zone | TheBasics | 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
|
||||||
@ -231,6 +256,7 @@ 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
|
||||||
@ -239,7 +265,11 @@ 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
|
||||||
|
|
||||||
@ -273,8 +303,7 @@ default_qualifier_str = "hard_fail" :: String
|
|||||||
|
|
||||||
initialState :: Input -> State
|
initialState :: Input -> State
|
||||||
initialState domain =
|
initialState domain =
|
||||||
{ wsUp: true
|
{ rr_modal: NoModal
|
||||||
, rr_modal: NoModal
|
|
||||||
|
|
||||||
, _domain: domain
|
, _domain: domain
|
||||||
|
|
||||||
@ -285,6 +314,7 @@ 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"
|
||||||
@ -292,7 +322,12 @@ 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
|
||||||
}
|
}
|
||||||
@ -305,23 +340,24 @@ 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.wsUp, state.rr_modal of
|
case state.rr_modal of
|
||||||
false, _ -> Bulma.p "You are disconnected."
|
RemoveRRModal rr_id -> modal_rr_delete rr_id
|
||||||
true, RemoveRRModal rr_id -> modal_rr_delete rr_id
|
NewRRModal _ -> render_current_rr_modal
|
||||||
true, NewRRModal _ -> render_current_rr_modal
|
UpdateRRModal -> render_current_rr_modal
|
||||||
true, UpdateRRModal -> render_current_rr_modal
|
NoModal -> HH.div_
|
||||||
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
|
||||||
@ -341,7 +377,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"
|
||||||
@ -360,6 +396,7 @@ 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
|
||||||
@ -377,11 +414,12 @@ 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)
|
||||||
should_be_disabled
|
, case state._currentRR.rrtype of
|
||||||
, Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5"
|
"AAAA" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "2001:db8::1" (updateForm Field_Target) state._currentRR.target
|
||||||
(updateForm Field_Target)
|
"TXT" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Your text" "blah blah" (updateForm Field_Target) state._currentRR.target
|
||||||
state._currentRR.target
|
"CNAME" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "www" (updateForm Field_Target) state._currentRR.target
|
||||||
should_be_disabled
|
"NS" -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "ns0.example.com." (updateForm Field_Target) state._currentRR.target
|
||||||
|
_ -> Bulma.box_input ("target" <> state._currentRR.rrtype) "Target" "198.51.100.5" (updateForm Field_Target) state._currentRR.target
|
||||||
] <> 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"]
|
||||||
@ -400,15 +438,12 @@ 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 =
|
||||||
@ -417,31 +452,24 @@ 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 =
|
||||||
@ -454,32 +482,31 @@ 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 should_be_disabled
|
-- Just v -> Bulma.box_input "vSPF" "Version" "spf1" (updateForm Field_SPF_v) v
|
||||||
, Bulma.hr
|
, Bulma.hr
|
||||||
, maybe (Bulma.p "no mechanism") display_mechanisms state._currentRR.mechanisms
|
|
||||||
, Bulma.box
|
, Bulma.box
|
||||||
[ Bulma.h3 "New mechanism"
|
[ Bulma.h3 "Current mechanisms"
|
||||||
|
, 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
|
||||||
should_be_disabled
|
, Bulma.btn "Add a mechanism" SPF_Mechanism_Add
|
||||||
, 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 "New modifier"
|
[ Bulma.h3 "Current modifiers"
|
||||||
|
, 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
|
||||||
should_be_disabled
|
, Bulma.btn "Add a modifier" SPF_Modifier_Add
|
||||||
, Bulma.btn "Add" SPF_Modifier_Add
|
|
||||||
]
|
]
|
||||||
, Bulma.hr
|
, Bulma.hr
|
||||||
, Bulma.box
|
, Bulma.box
|
||||||
@ -499,28 +526,80 @@ 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 DKIM.show_signature_algorithm DKIM.sign_algos)
|
(map show DKIM.sign_algos)
|
||||||
(DKIM.show_signature_algorithm $ fromMaybe DKIM.RSA state.dkim.k)
|
(show $ 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 DKIM.show_hashing_algorithm DKIM.hash_algos)
|
(map show DKIM.hash_algos)
|
||||||
(DKIM.show_hashing_algorithm $ fromMaybe DKIM.SHA256 state.dkim.h)
|
(show $ fromMaybe DKIM.SHA256 state.dkim.h)
|
||||||
, Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as 'MIIBIjANBgqh...'"
|
, Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as \"MIIBIjANBgqh...\"" DKIM_pubkey state.dkim.p
|
||||||
DKIM_pubkey state.dkim.p should_be_disabled
|
, Bulma.box_input "noteDKIM" "Note" "Note for fellow administrators." DKIM_note (fromMaybe "" state.dkim.n)
|
||||||
, 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)
|
||||||
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
|
newtokenbtn = Bulma.btn (maybe "🏁 Ask for a token" (\_ -> "🏁 Ask for a new token") state._currentRR.token) (NewToken state._currentRR.rrid)
|
||||||
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)]
|
||||||
@ -533,11 +612,14 @@ 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_accepted_type t_ <> " resource record"
|
NewRRModal t_ -> "New " <> show t_ <> " resource record"
|
||||||
UpdateRRModal -> "Update RR " <> show state._currentRR.rrid
|
UpdateRRModal -> "Update " <> state._currentRR.rrtype <> " Resource Record"
|
||||||
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.
|
||||||
@ -545,6 +627,8 @@ 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
|
||||||
@ -552,6 +636,9 @@ 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.
|
||||||
@ -563,6 +650,7 @@ 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 }
|
||||||
|
|
||||||
@ -583,6 +671,7 @@ 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 }
|
||||||
@ -594,6 +683,7 @@ 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
|
||||||
@ -602,6 +692,16 @@ 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
|
||||||
@ -612,6 +712,7 @@ 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
|
||||||
@ -621,7 +722,11 @@ 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 = [], dkim = DKIM.emptyDKIMRR }
|
H.modify_ _ { _currentRR_errors = []
|
||||||
|
, _dmarc_mail_errors = []
|
||||||
|
, dkim = DKIM.emptyDKIMRR
|
||||||
|
, dmarc = DMARC.emptyDMARCRR
|
||||||
|
}
|
||||||
handleAction $ AddRR t newrr
|
handleAction $ AddRR t newrr
|
||||||
handleAction CancelModal
|
handleAction CancelModal
|
||||||
|
|
||||||
@ -630,6 +735,7 @@ 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 }
|
||||||
@ -650,6 +756,7 @@ 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
|
||||||
@ -657,20 +764,34 @@ 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 = [] }
|
H.modify_ _ { _currentRR_errors = [], _dmarc_mail_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
|
||||||
@ -726,6 +847,7 @@ 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
|
||||||
@ -737,6 +859,67 @@ 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 } }
|
||||||
@ -774,14 +957,6 @@ 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
|
||||||
@ -826,6 +1001,7 @@ 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
|
||||||
@ -836,14 +1012,16 @@ 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 RRs (A, AAAA, PTR, NS, TXT)"]
|
tag_basic = tags [tag "Basic Resource Records (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_basic_ro = tags [tag_ro "Basic RRs", tag_ro "read only"]
|
tag_dmarc = tags [tag "DMARC"]
|
||||||
|
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
|
||||||
@ -917,15 +1095,36 @@ 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 "" DKIM.show_hashing_algorithm dkim.h ]
|
HH.td_ [ Bulma.p $ maybe "" show dkim.h ]
|
||||||
, HH.td_ [ Bulma.p $ maybe "" DKIM.show_signature_algorithm dkim.k ]
|
, HH.td_ [ Bulma.p $ maybe "" show dkim.k ]
|
||||||
, HH.td_ [ Bulma.p $ CP.take 5 dkim.p ]
|
, HH.td_ [ Bulma.p $ CP.take 20 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 ]
|
||||||
@ -956,6 +1155,7 @@ 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] ]
|
||||||
@ -969,6 +1169,7 @@ 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] ]
|
||||||
@ -980,6 +1181,19 @@ 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" ]
|
||||||
|
|
||||||
@ -1000,16 +1214,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 (soon)"
|
, Bulma.h1 "Special records about the mail system"
|
||||||
-- 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_ro (C.is_small <> C.is_warning) "DMARC"
|
, Bulma.btn "DMARC" (CreateNewRRModal 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. ⚠"]
|
||||||
]
|
]
|
||||||
|
|
||||||
@ -1034,7 +1248,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 = val }
|
Field_Domain val -> rr { name = toLower 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 }
|
||||||
|
@ -1,18 +1,25 @@
|
|||||||
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 [ Bulma.p """
|
, expl' """
|
||||||
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"]
|
||||||
@ -26,7 +33,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/<token>" ]
|
, expl [ Bulma.strong "wget https://beta.netlib.re/token-update/<your-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.
|
||||||
@ -49,11 +56,110 @@ 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 allows emails to be signed by the sender, and for the receiver to prove the origin of the mail.
|
This enables emails to be signed by the sender and for the receiver to verify the origin of the mail.
|
||||||
"""
|
"""
|
||||||
, HH.p []
|
, HH.p []
|
||||||
[ HH.text """
|
[ HH.text """
|
||||||
@ -67,6 +173,100 @@ 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 """
|
||||||
@ -78,16 +278,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 "
|
[ HH.text "Sender Policy Framework (SPF) is a way to tell the "
|
||||||
, HH.u_ [HH.text "other mail servers"]
|
, HH.u_ [HH.text "other mail servers"]
|
||||||
, HH.text " what are mail servers susceptible to send mails with email addresses from "
|
, HH.text " which are the mail servers supposed to send mails from "
|
||||||
, HH.u_ [HH.text "our domain"]
|
, HH.u_ [HH.text "your 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 with our email address but coming from an IP address we didn't list as authorized will be discarded.
|
A server receiving a mail from your 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.
|
||||||
"""
|
"""
|
||||||
]
|
]
|
||||||
@ -95,9 +295,11 @@ 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 novice users"]
|
[ HH.u_ [HH.text "Advice for beginners"]
|
||||||
, 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. 🥳
|
||||||
"""
|
"""
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
@ -107,7 +309,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 advise to drop the mail (a
|
By default, let's opt for dropping the mail (a
|
||||||
"""
|
"""
|
||||||
, HH.u_ [HH.text "hard fail"]
|
, HH.u_ [HH.text "hard fail"]
|
||||||
, HH.text """).
|
, HH.text """).
|
||||||
@ -117,20 +319,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 RR for specifying the location of services."
|
[ Bulma.p "The SRV record is a DNS resource record 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 RR.
|
Both the names of the service and the protocol are used to construct the name of the resource record.
|
||||||
"""
|
"""
|
||||||
]
|
]
|
||||||
, 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, you can specify that the target is "
|
, HH.text " and given that this service uses the TCP protocol, the target "
|
||||||
, HH.u_ [HH.text "server1.example.com."]
|
, HH.u_ [HH.text "server1.example.com."]
|
||||||
, HH.text "."
|
, HH.text " could be specified."
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
|
@ -17,8 +17,9 @@ data AcceptedRRTypes
|
|||||||
| SRV
|
| SRV
|
||||||
| SPF
|
| SPF
|
||||||
| DKIM
|
| DKIM
|
||||||
|
| DMARC
|
||||||
|
|
||||||
derive instance genericMyADT :: Generic AcceptedRRTypes _
|
derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _
|
||||||
|
|
||||||
instance showMyADT :: Show AcceptedRRTypes where
|
instance showAcceptedRRTypes :: Show AcceptedRRTypes where
|
||||||
show = genericShow
|
show = genericShow
|
||||||
|
@ -1,5 +1,10 @@
|
|||||||
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)
|
||||||
@ -39,10 +44,13 @@ 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 show_hashing_algorithm CA.string
|
codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm generic_serialization 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
|
||||||
@ -50,17 +58,15 @@ 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 show_signature_algorithm CA.string
|
codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm generic_serialization 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
|
||||||
@ -68,22 +74,16 @@ 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 show_version CA.string
|
codecVersion = CA.prismaticCodec "Version" str_to_version generic_serialization 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
Normal file
251
src/App/Type/DMARC.purs
Normal file
@ -0,0 +1,251 @@
|
|||||||
|
-- | 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
Normal file
6
src/App/Type/GenericSerialization.purs
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
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
|
@ -1,4 +1,8 @@
|
|||||||
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:
|
||||||
@ -11,3 +15,8 @@ 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
|
||||||
|
@ -9,6 +9,7 @@ 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
|
||||||
@ -44,6 +45,7 @@ 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.
|
||||||
}
|
}
|
||||||
@ -84,6 +86,7 @@ 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
|
||||||
@ -225,6 +228,7 @@ emptyRR
|
|||||||
, q: Nothing
|
, q: Nothing
|
||||||
|
|
||||||
, dkim: Nothing
|
, dkim: Nothing
|
||||||
|
, dmarc: Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
data Qualifier = Pass | Neutral | SoftFail | HardFail
|
data Qualifier = Pass | Neutral | SoftFail | HardFail
|
||||||
|
@ -20,6 +20,7 @@ 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.
|
||||||
@ -51,6 +52,8 @@ 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)
|
||||||
@ -105,7 +108,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` allows to run any parser based on `GenericParser` and provide a validation error.
|
-- | `parse` enables 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
|
||||||
@ -270,7 +273,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 allows some optional parameters,
|
-- | then converted in PEM (RFC 7468), and knowing this format enables 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.
|
||||||
@ -309,6 +312,20 @@ 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
|
||||||
@ -320,6 +337,7 @@ 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
|
||||||
|
@ -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, (=<<))
|
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<), unit)
|
||||||
|
|
||||||
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 -> H.raise $ Log $ UnableToSend "Still connecting to server."
|
Connecting -> pure unit -- 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
110
src/Bulma.purs
@ -2,6 +2,7 @@
|
|||||||
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
|
||||||
@ -77,6 +78,14 @@ 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" ]
|
||||||
@ -147,6 +156,24 @@ 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 ]
|
||||||
@ -258,8 +285,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 -> String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
Boolean -> (HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i
|
||||||
field_inner ispassword id title placeholder action value cond
|
field_inner ispassword cond id title placeholder action value
|
||||||
= 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
|
||||||
@ -286,13 +313,19 @@ labeled_field id title content
|
|||||||
, div_field_content content
|
, div_field_content content
|
||||||
]
|
]
|
||||||
|
|
||||||
box_input :: forall w i.
|
box_input_ :: forall w i.
|
||||||
String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> HH.HTML w i
|
||||||
box_input = field_inner false
|
box_input_ = field_inner false
|
||||||
|
|
||||||
box_password :: forall w i.
|
box_password_ :: forall w i.
|
||||||
String -> String -> String -> (String -> i) -> String -> (HP.IProp DHI.HTMLinput i) -> HH.HTML w i
|
(HP.IProp DHI.HTMLinput i) -> String -> String -> String -> (String -> i) -> String -> 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) ]
|
||||||
@ -483,6 +516,22 @@ 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]
|
||||||
|
|
||||||
@ -506,3 +555,48 @@ 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"
|
||||||
|
Loading…
Reference in New Issue
Block a user