WIP: new page for the migration.

src/App/Container.purs

@@ -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
@@ -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

src/App/Message/AuthenticationDaemon.purs

@@ -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).
@@ -436,6 +452,8 @@ encode m = case m of
     (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

src/App/Page/Migration.purs

@@ -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)

src/App/Type/Pages.purs

@@ -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 _