diff --git a/src/App/Container.purs b/src/App/Container.purs index 4cb9cd9..8fcda9f 100644 --- a/src/App/Container.purs +++ b/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 `.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 diff --git a/src/App/Message/AuthenticationDaemon.purs b/src/App/Message/AuthenticationDaemon.purs index 1a183f6..8148f0f 100644 --- a/src/App/Message/AuthenticationDaemon.purs +++ b/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). @@ -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) diff --git a/src/App/Page/Migration.purs b/src/App/Page/Migration.purs new file mode 100644 index 0000000..a728f22 --- /dev/null +++ b/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) diff --git a/src/App/Type/Pages.purs b/src/App/Type/Pages.purs index bd41de8..f1277c5 100644 --- a/src/App/Type/Pages.purs +++ b/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 _