WIP: new page for the migration.
parent
d7e7832555
commit
78a652807c
|
|
@ -31,16 +31,14 @@
|
|||
-- |
|
||||
-- | Validation:
|
||||
-- | - registration page: login, password, mail
|
||||
-- | - login and password recovery page: TODO
|
||||
-- | - mail verification: TODO
|
||||
-- | - login and password recovery page
|
||||
-- | - mail verification
|
||||
-- | - domain list: domain (`label`) is insufficient.
|
||||
-- |
|
||||
-- | TODO: when reading a RR `name`, always make it an FQDN by adding `<user-domain>.netlib.re.`.
|
||||
-- |
|
||||
-- | TODO: remove the FQDN when showing RR names.
|
||||
-- |
|
||||
-- | TODO: application-level heartbeat to avoid disconnections.
|
||||
-- |
|
||||
-- | Untested features:
|
||||
-- | - mail recovery, password change
|
||||
module App.Container where
|
||||
|
|
@ -79,6 +77,7 @@ import App.Page.Setup as SetupInterface
|
|||
import App.Page.DomainList as DomainListInterface
|
||||
import App.Page.Zone as ZoneInterface
|
||||
import App.Page.Home as HomeInterface
|
||||
import App.Page.Migration as MigrationInterface
|
||||
import App.Page.Navigation as NavigationInterface
|
||||
|
||||
import App.Text.Explanations as Explanations
|
||||
|
|
@ -144,6 +143,9 @@ data Action
|
|||
-- | Handle events from `ZoneInterface`.
|
||||
| ZoneInterfaceEvent ZoneInterface.Output
|
||||
|
||||
-- | Handle events from `MigrationInterface`.
|
||||
| MigrationInterfaceEvent MigrationInterface.Output
|
||||
|
||||
-- | Disconnect from both `authd` and `dnsmanagerd` (remove sockets),
|
||||
-- | then return to the home page.
|
||||
| Disconnection
|
||||
|
|
@ -232,6 +234,7 @@ type ChildSlots =
|
|||
, setupi :: SetupInterface.Slot Unit
|
||||
, dli :: DomainListInterface.Slot Unit
|
||||
, zi :: ZoneInterface.Slot Unit
|
||||
, mi :: MigrationInterface.Slot Unit
|
||||
)
|
||||
|
||||
_ho = Proxy :: Proxy "ho" -- Home Interface
|
||||
|
|
@ -246,6 +249,7 @@ _admini = Proxy :: Proxy "admini" -- Administration Interface
|
|||
_setupi = Proxy :: Proxy "setupi" -- Setup Interface
|
||||
_dli = Proxy :: Proxy "dli" -- Domain List
|
||||
_zi = Proxy :: Proxy "zi" -- Zone Interface
|
||||
_mi = Proxy :: Proxy "mi" -- Migration Interface
|
||||
|
||||
component :: forall q i o m. MonadAff m => H.Component q i o m
|
||||
component =
|
||||
|
|
@ -287,6 +291,7 @@ render state
|
|||
Zone domain -> render_zone domain
|
||||
Setup -> render_setup
|
||||
Administration -> render_authd_admin_interface
|
||||
Migration -> render_migration
|
||||
LegalNotice -> render_legal_notice
|
||||
-- The footer includes logs and both the WS child components.
|
||||
, Bulma.hr
|
||||
|
|
@ -341,6 +346,9 @@ render state
|
|||
render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_authd_admin_interface = HH.slot _admini unit AdminInterface.component unit AdministrationEvent
|
||||
|
||||
render_migration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_migration = HH.slot_ _mi unit MigrationInterface.component unit
|
||||
|
||||
render_legal_notice :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
|
||||
render_legal_notice
|
||||
= Bulma.section_small [ Explanations.legal_notice
|
||||
|
|
@ -421,6 +429,9 @@ handleAction = case _ of
|
|||
|
||||
H.modify_ _ { current_page = page }
|
||||
|
||||
-- Finally, when changing page, the notification should be discarded.
|
||||
handleAction CloseNotif
|
||||
|
||||
Log message -> do
|
||||
_ <- case message of
|
||||
UnableToSend err -> handleAction $ AddNotif $ BadNotification err
|
||||
|
|
@ -576,7 +587,7 @@ handleAction = case _ of
|
|||
ZoneInterfaceEvent ev -> case ev of
|
||||
ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
ZoneInterface.Log message -> handleAction $ Log message
|
||||
ZoneInterface.ToDomainList -> handleAction $ Routing DomainList
|
||||
ZoneInterface.ToDomainList -> handleAction $ Routing DomainList
|
||||
|
||||
DomainListComponentEvent ev -> case ev of
|
||||
DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
|
|
@ -747,16 +758,29 @@ handleAction = case _ of
|
|||
(AuthD.GotToken msg) -> do
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to authd."
|
||||
H.modify_ _ { token = Just msg.token
|
||||
, user_data = Just (Tuple msg.current_email msg.pending_email) }
|
||||
, user_data = Just (Tuple msg.current_email msg.pending_email)
|
||||
}
|
||||
handleAction $ ToggleAuthenticated (Just msg.token)
|
||||
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
_ <- H.liftEffect $ Storage.setItem "user-authd-token" msg.token sessionstorage
|
||||
|
||||
handleAction AuthenticateToDNSManager
|
||||
|
||||
-- In case the account doesn't have a valid email address, the user
|
||||
-- shouldn't be able to do anything else than to add their address.
|
||||
case msg.current_email of
|
||||
Nothing -> handleAction $ Routing Migration
|
||||
_ -> pure unit
|
||||
|
||||
(AuthD.GotKeepAlive _) -> pure unit
|
||||
pure unit
|
||||
|
||||
-- TODO
|
||||
MigrationInterfaceEvent ev -> case ev of
|
||||
MigrationInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
|
||||
MigrationInterface.Log message -> handleAction $ Log message
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
DispatchAuthDaemonMessage message -> do
|
||||
{ current_page } <- H.get
|
||||
|
|
@ -766,11 +790,8 @@ handleAction = case _ of
|
|||
_ -> handleAction $ Log $ SystemLog "unexpected message from authd"
|
||||
pure unit
|
||||
|
||||
AddNotif n -> do
|
||||
H.modify_ _ { notif = n }
|
||||
|
||||
CloseNotif -> do
|
||||
H.modify_ _ { notif = NoNotification }
|
||||
AddNotif n -> H.modify_ _ { notif = n }
|
||||
CloseNotif -> H.modify_ _ { notif = NoNotification }
|
||||
|
||||
Reconnection -> do
|
||||
H.tell _ws_auth unit WS.Connect
|
||||
|
|
@ -975,6 +996,7 @@ handleAction = case _ of
|
|||
Just "Setup" -> handleAction $ Routing Setup
|
||||
Just "Administration" -> handleAction $ Routing Administration
|
||||
Just "LegalNotice" -> handleAction $ Routing LegalNotice
|
||||
Just "Migration" -> handleAction $ Routing Migration
|
||||
Just "Zone" -> do
|
||||
domain <- H.liftEffect $ Storage.getItem "current-zone" sessionstorage
|
||||
case domain of
|
||||
|
|
|
|||
|
|
@ -60,6 +60,9 @@ codecRegister
|
|||
, email: CAR.optional Email.codec })
|
||||
|
||||
{- 2 -}
|
||||
{- This message is about validating the user account, before they can be authenticated.
|
||||
This message isn't about migrated accounts.
|
||||
-}
|
||||
type ValidateUser = { user :: String, activation_key :: String }
|
||||
codecValidateUser ∷ CA.JsonCodec ValidateUser
|
||||
codecValidateUser
|
||||
|
|
@ -170,6 +173,17 @@ type AuthByToken = { token :: String }
|
|||
codecAuthByToken ∷ CA.JsonCodec AuthByToken
|
||||
codecAuthByToken = CA.object "AuthByToken" (CAR.record { token: CA.string })
|
||||
|
||||
{- Add (or change) your email address. -}
|
||||
{- 16 -}
|
||||
type NewEmailAddress = { email :: String }
|
||||
codecNewEmailAddress ∷ CA.JsonCodec NewEmailAddress
|
||||
codecNewEmailAddress = CA.object "NewEmailAddress" (CAR.record { email: CA.string })
|
||||
|
||||
{- 17 -}
|
||||
type NewEmailAddressToken = { token :: String }
|
||||
codecNewEmailAddressToken ∷ CA.JsonCodec NewEmailAddressToken
|
||||
codecNewEmailAddressToken = CA.object "NewEmailAddressToken" (CAR.record { token: CA.string })
|
||||
|
||||
{- 250 -}
|
||||
type KeepAlive = { }
|
||||
codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
||||
|
|
@ -380,6 +394,8 @@ data RequestMessage
|
|||
| MkSetPermission SetPermission -- 11
|
||||
| MkSearchUser SearchUser -- 12
|
||||
| MkAuthByToken AuthByToken -- 15
|
||||
| MkNewEmailAddress NewEmailAddress -- 16
|
||||
| MkNewEmailAddressToken NewEmailAddressToken -- 16
|
||||
| MkKeepAlive KeepAlive -- 250
|
||||
|
||||
-- All possible answers from the authentication daemon (authd).
|
||||
|
|
@ -430,13 +446,15 @@ encode m = case m of
|
|||
(MkGetUserByName request) -> get_tuple 5 codecGetUserByName request
|
||||
(MkModUser request) -> get_tuple 6 codecModUser request
|
||||
-- 7 MkEditProfileContent
|
||||
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
|
||||
(MkAddUser request) -> get_tuple 9 codecAddUser request
|
||||
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
|
||||
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
|
||||
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
|
||||
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
|
||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
||||
(MkDeleteUser request) -> get_tuple 8 codecDeleteUser request
|
||||
(MkAddUser request) -> get_tuple 9 codecAddUser request
|
||||
(MkCheckPermission request) -> get_tuple 10 codecCheckPermission request
|
||||
(MkSetPermission request) -> get_tuple 11 codecSetPermission request
|
||||
(MkSearchUser request) -> get_tuple 12 codecSearchUser request
|
||||
(MkAuthByToken request) -> get_tuple 15 codecAuthByToken request
|
||||
(MkNewEmailAddress request) -> get_tuple 16 codecNewEmailAddress request
|
||||
(MkNewEmailAddressToken request) -> get_tuple 17 codecNewEmailAddressToken request
|
||||
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive request
|
||||
where
|
||||
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
|
||||
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,194 @@
|
|||
-- | `App.Page.Migration` is the interface for migrated users before they validate their email address.
|
||||
-- | To complete their migration, they need to provide an email address that will be validated with a token.
|
||||
-- | This token will be required before the user can do anything else on the website.
|
||||
-- |
|
||||
-- | Exchanges between the webapp and authd:
|
||||
-- |
|
||||
-- | ```
|
||||
-- | User gives a valid email address -> authd
|
||||
-- | (authd accepts the email address and sends an email)
|
||||
-- |
|
||||
-- | authd -> email pending
|
||||
-- | (we switch tab to "mail validation tab")
|
||||
-- |
|
||||
-- | User gives the received token -> authd
|
||||
-- | (authd accepts the token and validates the email address)
|
||||
-- |
|
||||
-- | authd -> EmailChanged
|
||||
-- | (webapp switches to domain list)
|
||||
-- | ```
|
||||
module App.Page.Migration where
|
||||
|
||||
import Prelude (Unit, between, bind, discard, map, pure, ($), (<>))
|
||||
|
||||
import Data.Array as A
|
||||
import Data.ArrayBuffer.Types (ArrayBuffer)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (Maybe(..))
|
||||
import Data.String as S
|
||||
import Effect.Aff.Class (class MonadAff)
|
||||
import Halogen as H
|
||||
import Halogen.HTML as HH
|
||||
import Halogen.HTML.Events as HE
|
||||
import Web.Event.Event as Event
|
||||
import Web.Event.Event (Event)
|
||||
|
||||
-- import Data.Generic.Rep (class Generic)
|
||||
-- import Data.Show.Generic (genericShow)
|
||||
|
||||
import Bulma as Bulma
|
||||
import Scroll (scrollToTop)
|
||||
|
||||
import App.Type.LogMessage
|
||||
import App.Message.AuthenticationDaemon as AuthD
|
||||
import App.DisplayErrors (show_error_email)
|
||||
import App.Validation.Email as E
|
||||
|
||||
data Output = MessageToSend ArrayBuffer | Log LogMessage
|
||||
|
||||
-- | Once the new email address has been accepted by `authd` as "pending",
|
||||
-- | this page automatically switches to a second tab.
|
||||
data Query a = WaitingForToken a
|
||||
|
||||
type Slot = H.Slot Query Output
|
||||
|
||||
type Input = Unit
|
||||
|
||||
-- | Both value types to validate before sending the appropriate messages to `authd`.
|
||||
data Subject = EmailAddress | Token
|
||||
|
||||
--derive instance eqSubject :: Eq Subject
|
||||
--derive instance genericSubject :: Generic Subject _
|
||||
--instance showSubject :: Show Subject where
|
||||
-- show = genericShow
|
||||
|
||||
data Action
|
||||
-- | Copy user input in the different HTML inputs.
|
||||
= UserInput Subject String
|
||||
|
||||
-- | Verify either the format of the new email address or the token then send the request.
|
||||
| Verify Subject Event
|
||||
|
||||
-- | Send either the new email address or the token to `authd`.
|
||||
| ContactAuthd Subject
|
||||
|
||||
-- | Change the current tab.
|
||||
-- | ChangeTab Subject
|
||||
|
||||
-- | The possible errors from the email format.
|
||||
-- | TODO: check the token.
|
||||
data Error = Email (Array E.Error)
|
||||
|
||||
-- | State is composed of the new email address, the token and the possible errors.
|
||||
type State
|
||||
= { email :: String
|
||||
, token :: String
|
||||
, errors :: Array Error
|
||||
-- , current_tab :: Subject
|
||||
}
|
||||
|
||||
initialState :: Input -> State
|
||||
initialState _
|
||||
= { email: ""
|
||||
, token: ""
|
||||
, errors: []
|
||||
-- , current_tab: EmailAddress
|
||||
}
|
||||
|
||||
component :: forall m. MonadAff m => H.Component Query Input Output m
|
||||
component =
|
||||
H.mkComponent
|
||||
{ initialState
|
||||
, render
|
||||
, eval: H.mkEval $ H.defaultEval
|
||||
{ handleAction = handleAction
|
||||
, handleQuery = handleQuery
|
||||
}
|
||||
}
|
||||
|
||||
handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () Output m (Maybe a)
|
||||
handleQuery = case _ of
|
||||
-- TODO
|
||||
WaitingForToken a -> pure (Just a)
|
||||
|
||||
render :: forall m. State -> H.ComponentHTML Action () m
|
||||
render state
|
||||
= Bulma.section_small [Bulma.columns_
|
||||
[ b email_form
|
||||
, b token_form
|
||||
]]
|
||||
|
||||
where
|
||||
b e = Bulma.column_ [ Bulma.box e ]
|
||||
|
||||
email_form
|
||||
= [ Bulma.h3 "New Email address"
|
||||
-- TODO: put some text here
|
||||
, HH.form
|
||||
[ HE.onSubmit (Verify EmailAddress) ]
|
||||
[ email_input, email_error, Bulma.btn_validation ]
|
||||
]
|
||||
|
||||
email_input = Bulma.email_input "Email" state.email (UserInput EmailAddress)
|
||||
|
||||
email_error
|
||||
= case between 0 5 (S.length state.email), E.email state.email of
|
||||
true, _ -> HH.text ""
|
||||
_, Left errors -> Bulma.error_box "newAddress" "Email error" (show_error $ Email errors)
|
||||
_, Right _ -> HH.text ""
|
||||
|
||||
token_form
|
||||
= [ Bulma.h3 "Email validation token"
|
||||
-- TODO: put some text here
|
||||
, HH.form
|
||||
[ HE.onSubmit (Verify Token) ]
|
||||
[ token_input {-, token_error -}, Bulma.btn_validation ]
|
||||
]
|
||||
|
||||
token_input = Bulma.token_input "Token" state.token (UserInput Token)
|
||||
|
||||
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
|
||||
handleAction = case _ of
|
||||
UserInput subject value -> do
|
||||
case subject of
|
||||
EmailAddress -> H.modify_ _ { email = value }
|
||||
Token -> H.modify_ _ { token = value }
|
||||
|
||||
-- Validate either the email address or the token then send the related requests to `authd`.
|
||||
Verify subject ev -> do
|
||||
H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
state <- H.get
|
||||
case subject of
|
||||
EmailAddress -> do
|
||||
case state.email of
|
||||
"" -> do
|
||||
H.raise $ Log $ UnableToSend "Please, write your new email address."
|
||||
H.liftEffect scrollToTop
|
||||
_ -> do
|
||||
case E.email state.email of
|
||||
Left errors -> H.raise $ Log $ UnableToSend $ show_error $ Email errors
|
||||
Right _ -> handleAction $ ContactAuthd EmailAddress
|
||||
|
||||
Token -> do
|
||||
case state.token of
|
||||
"" -> do
|
||||
H.raise $ Log $ UnableToSend "Please, write your validation token."
|
||||
H.liftEffect scrollToTop
|
||||
_ -> handleAction $ ContactAuthd Token
|
||||
|
||||
ContactAuthd subject -> do
|
||||
state <- H.get
|
||||
case subject of
|
||||
EmailAddress -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddress { email: state.email }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Sending a new email address."
|
||||
Token -> do
|
||||
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkNewEmailAddressToken { token: state.token }
|
||||
H.raise $ MessageToSend message
|
||||
H.raise $ Log $ SystemLog $ "Sending a validation token."
|
||||
|
||||
show_error :: Error -> String
|
||||
show_error = case _ of
|
||||
Email arr -> "Error with the Email: " <> (A.fold $ map show_error_email arr)
|
||||
|
|
@ -3,9 +3,7 @@ module App.Type.Pages where
|
|||
import Prelude
|
||||
import Data.Generic.Rep (class Generic)
|
||||
import Data.Show.Generic (genericShow)
|
||||
-- | This list will grow in a near future.
|
||||
-- |
|
||||
-- | TODO:
|
||||
|
||||
data Page
|
||||
= Home -- | `Home`: presentation of the project.
|
||||
| Authentication -- | `Authentication`: authentication page.
|
||||
|
|
@ -16,6 +14,7 @@ data Page
|
|||
| Setup -- | `Setup`: user account administration page
|
||||
| Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).
|
||||
| LegalNotice -- | `LegalNotice`: to learn about the website host, user agreements, etc.
|
||||
| Migration -- | `Migration`: ask for an email address before anything else.
|
||||
|
||||
derive instance genericPage :: Generic Page _
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue