diff --git a/src/App/Container.purs b/src/App/Container.purs index 2c10a5b..51e2264 100644 --- a/src/App/Container.purs +++ b/src/App/Container.purs @@ -45,6 +45,7 @@ import Data.Either (Either(..)) import Data.Tuple (Tuple(..)) import App.AuthenticationInterface as AI import App.RegistrationInterface as RI +import App.MailValidationInterface as MVI import App.Log as AppLog import App.WS as WS import App.AuthenticationDaemonAdminInterface as AAI @@ -68,7 +69,7 @@ import App.LogMessage (LogMessage(..)) -- | List all pages the application has: -- | Home, Login, Domain list, Zone, `authd` administration. -- | This list will grows in a near future. -data Page = Home | Authentication | Registration | DomainList | Zone String | AuthAdmin +data Page = Home | Authentication | Registration | MailValidation | DomainList | Zone String | AuthAdmin type Token = String type Login = String @@ -79,9 +80,12 @@ data Action -- | Handle events from `AuthenticationInterface`. = AuthenticationInterfaceEvent AI.Output - -- | Handle events from `AuthenticationComponent`. + -- | Handle events from `RegistrationInterface`. | RegistrationInterfaceEvent RI.Output + -- | Handle events from `MailValidationInterface`. + | MailValidationInterfaceEvent MVI.Output + -- | Handle events from `AuthenticationDaemonAdminComponent`. | AuthenticationDaemonAdminComponentEvent AAI.Output -- Admin interface for authd. @@ -141,8 +145,8 @@ type State = { token :: Maybe String } -- | The list of child components: log, `WS` twice (once for each ws connection), --- | then all the pages (AuthenticationInterface, RegistrationInterface, HomeInterface, DomainListInterface, --- | ZoneInterface and AuthenticationDaemonAdminInterface). +-- | then all the pages (AuthenticationInterface, RegistrationInterface, MailValidationInterface, +-- | HomeInterface, DomainListInterface, ZoneInterface and AuthenticationDaemonAdminInterface). type ChildSlots = ( log :: AppLog.Slot Unit , ho :: HomeInterface.Slot Unit @@ -150,6 +154,7 @@ type ChildSlots = , ws_dns :: WS.Slot Unit , ai :: AI.Slot Unit , ri :: RI.Slot Unit + , mvi :: MVI.Slot Unit , aai :: AAI.Slot Unit , dli :: DomainListInterface.Slot Unit , zi :: ZoneInterface.Slot Unit @@ -161,6 +166,7 @@ _ws_auth = Proxy :: Proxy "ws_auth" -- WS with `authd` _ws_dns = Proxy :: Proxy "ws_dns" -- WS with `dnsmanagerd` _ai = Proxy :: Proxy "ai" -- Authentication Interface _ri = Proxy :: Proxy "ri" -- Registration Interface +_mvi = Proxy :: Proxy "mvi" -- Mail Validation Interface _aai = Proxy :: Proxy "aai" -- Authd Administration Interface _dli = Proxy :: Proxy "dli" -- Domain List _zi = Proxy :: Proxy "zi" -- Zone Interface @@ -190,6 +196,7 @@ render state Home -> render_home Authentication -> render_auth_form Registration -> render_registration + MailValidation -> render_mail_validation DomainList -> render_domainlist_interface Zone domain -> render_zone domain AuthAdmin -> render_authd_admin_interface @@ -207,6 +214,8 @@ render state render_auth_form = HH.slot _ai unit AI.component unit AuthenticationInterfaceEvent render_registration :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_registration = HH.slot _ri unit RI.component unit RegistrationInterfaceEvent + render_mail_validation :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad + 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 domain = HH.slot _zi unit ZoneInterface.component domain ZoneInterfaceEvent render_authd_admin_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad @@ -226,6 +235,7 @@ render state (Routing AuthAdmin) (Routing Authentication) (Routing Registration) + (Routing MailValidation) Disconnection render_header :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad @@ -251,6 +261,7 @@ handleAction = case _ of Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage + MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" sessionstorage DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage @@ -284,6 +295,10 @@ handleAction = case _ of RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) RI.Log message -> H.tell _log unit (AppLog.Log message) + MailValidationInterfaceEvent ev -> case ev of + MVI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) + MVI.Log message -> H.tell _log unit (AppLog.Log message) + AuthenticationDaemonAdminComponentEvent ev -> case ev of AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AAI.Log message -> H.tell _log unit (AppLog.Log message) diff --git a/src/App/MailValidationInterface.purs b/src/App/MailValidationInterface.purs new file mode 100644 index 0000000..e1d67b7 --- /dev/null +++ b/src/App/MailValidationInterface.purs @@ -0,0 +1,197 @@ +-- | `App.MailValidationInterface` is a simple interface for mail verification. +-- | A token is sent at registration at the provided email address. +-- | This token has to be used to validate the email address. +module App.MailValidationInterface where + +import Prelude (Unit, bind, discard, pure, ($), (<<<), (<>), map, show) + +import Data.Array as A +import Data.ArrayBuffer.Types (ArrayBuffer) +import Data.Maybe (Maybe(..), maybe) +import Data.Either (Either(..)) +import Effect.Aff.Class (class MonadAff) +import Halogen as H +import Halogen.HTML as HH +import Halogen.HTML.Events as HE +import Halogen.HTML.Properties as HP +import Web.Event.Event as Event +import Web.Event.Event (Event) + +import Bulma as Bulma + +import App.LogMessage +import App.Messages.AuthenticationDaemon as AuthD + +import App.Validation.Login as L +import App.Validation.Token as T + +data Output + = MessageToSend ArrayBuffer + | Log LogMessage + +-- | The component is informed when the connection went up or down. +data Query a + = ConnectionIsDown a + | ConnectionIsUp a + +type Slot = H.Slot Query Output + +type Input = Unit + +data RegisterInput + = VALIDATION_INP_login String + | VALIDATION_INP_token String + +data Action + -- | Simply get the inputs from the form. + = HandleValidationInput RegisterInput + -- | Validate inputs (login, email, password) then send the request + -- | (via `SendMailValidationToken`) or log errors. + | ValidateInputs Event + -- | Send the registration request to `dnsmanagerd`. + -- | This action is automatically called from `ValidateInputs`. + | SendMailValidationToken + +-- | The possible errors come from either the login or token input. +data Error + = Login (Array L.Error) + | Token (Array T.Error) + +-- | The whole mail validation form is composed of two strings: the login and the token. +type MailValidationForm = { login :: String, token :: String } + +-- | State is composed of the registration form, the errors and an indication whether +-- | the websocket connection with `authd` is up or not. +type State = + { mailValidationForm :: MailValidationForm + , errors :: Array Error + , wsUp :: Boolean + } + +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 + } + } + +initialState :: Input -> State +initialState _ = + { mailValidationForm: { login: "", token: "" } + , errors: [] + , wsUp: true + } + +render :: forall m. State -> H.ComponentHTML Action () m +render { wsUp, mailValidationForm } + = Bulma.section_small + [ case wsUp of + false -> Bulma.p "You are disconnected." + true -> Bulma.columns_ [ b mail_validation_form ] + ] + + where + b e = Bulma.column_ [ Bulma.box e ] + 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 + [ HE.onSubmit ValidateInputs ] + [ Bulma.box_input "loginValidation" "Login" "login" -- title, placeholder + (HandleValidationInput <<< VALIDATION_INP_login) -- action + mailValidationForm.login -- value + should_be_disabled -- condition + , Bulma.box_input "tokenValidation" "Token" "token" -- title, placeholder + (HandleValidationInput <<< VALIDATION_INP_token) -- action + mailValidationForm.token -- value + should_be_disabled -- condition + , HH.div_ + [ HH.button + [ HP.style "padding: 0.5rem 1.25rem;" + , HP.type_ HP.ButtonSubmit + , (if wsUp then (HP.enabled true) else (HP.disabled true)) + ] + [ HH.text "Send Message to Server" ] + ] + ] + +handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit +handleAction = case _ of + HandleValidationInput reginp -> do + case reginp of + VALIDATION_INP_login v -> H.modify_ _ { mailValidationForm { login = v } } + VALIDATION_INP_token v -> H.modify_ _ { mailValidationForm { token = v } } + + -- Validate inputs (login, token) then send the request + -- (via SendMailValidationToken) or log errors. + ValidateInputs ev -> do + H.liftEffect $ Event.preventDefault ev + + { mailValidationForm } <- H.get + let { login, token } = mailValidationForm + + case login, token of + "", _ -> + H.raise $ Log $ UnableToSend "Write your login!" + + _, "" -> + H.raise $ Log $ UnableToSend "Write your token!" + + _, _ -> do + case L.login login, T.token token of + Left errors, _ -> H.raise $ Log $ UnableToSend $ show_error $ Login errors + _, Left errors -> H.raise $ Log $ UnableToSend $ show_error $ Token errors + Right _, Right _ -> handleAction $ SendMailValidationToken + + SendMailValidationToken -> do + { mailValidationForm } <- H.get + let { login, token } = mailValidationForm + message <- H.liftEffect $ AuthD.serialize $ AuthD.MkValidateUser { user: login, activation_key: token } + H.raise $ MessageToSend message + H.raise $ Log $ SimpleLog $ "[😇] Trying to register (login: " <> login <> ")" + +show_error :: Error -> String +show_error = case _ of + Login arr -> "Error with the Login: " <> (A.fold $ map show_error_login arr) + Token arr -> "Error with the Token: " <> (A.fold $ map show_error_token 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_token :: T.Error -> String +show_error_token = case _ of + T.ParsingError {error, position} -> + "position " <> show position <> " " <> maybe "" string_error_token error + +string_error_token :: T.TokenParsingError -> String +string_error_token = case _ of + T.CannotParse -> "cannot parse the token" + T.CannotEntirelyParse -> "cannot entirely parse the token" + T.Size min max n -> "token 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) diff --git a/src/App/Messages/AuthenticationDaemon.purs b/src/App/Messages/AuthenticationDaemon.purs index fefd924..d7a2504 100644 --- a/src/App/Messages/AuthenticationDaemon.purs +++ b/src/App/Messages/AuthenticationDaemon.purs @@ -60,11 +60,11 @@ codecRegister , email: CAR.optional Email.codec }) {- 2 -} -type ValidateUser = { user :: UserID, activation_key :: String } +type ValidateUser = { user :: String, activation_key :: String } codecValidateUser ∷ CA.JsonCodec ValidateUser codecValidateUser = CA.object "ValidateUser" (CAR.record - { user: CA.int + { user: CA.string , activation_key: CA.string }) {- NOTE: "user" attribute for both PasswordRecovery and AskPasswordRecovery could be UserID, diff --git a/src/App/Nav.purs b/src/App/Nav.purs index 36953fe..62e772b 100644 --- a/src/App/Nav.purs +++ b/src/App/Nav.purs @@ -20,10 +20,10 @@ import Bulma as Bulma -- | `actionDisconnection` (the action to disconnect the user) -- | -- | TODO: make the "burger" component actually useful. For now, it's empty. -netlibre_navbar :: forall w i. Boolean -> Boolean -> i -> i -> i -> i -> i -> i -> HH.HTML w i +netlibre_navbar :: forall w i. Boolean -> Boolean -> i -> i -> i -> i -> i -> i -> i -> HH.HTML w i netlibre_navbar authenticated admin actionHome actionDomainList actionAuthdAdmin - actionLogin actionRegistration actionDisconnection = + actionLogin actionRegistration actionMailValidation actionDisconnection = main_nav [ nav_brand [ logo, burger_menu ] , nav_menu @@ -45,6 +45,7 @@ netlibre_navbar authenticated admin [ HH.div [HP.classes C.buttons] $ case authenticated of false -> [ nav_button C.is_info "Login" actionLogin , nav_button_strong "Register" actionRegistration + , nav_button C.is_info "Mail verification" actionMailValidation , nav_button_code ] _ -> [ nav_button_disconnection, nav_button_code ] diff --git a/src/App/Validation/Token.purs b/src/App/Validation/Token.purs new file mode 100644 index 0000000..931c4b9 --- /dev/null +++ b/src/App/Validation/Token.purs @@ -0,0 +1,44 @@ +module App.Validation.Token where + +import Prelude + +import Control.Alt ((<|>)) +import Data.Either (Either(..)) +import Data.String.CodeUnits as CU +import Data.Maybe (Maybe(..)) +import Data.Validation.Semigroup (V, invalid, toEither) + +import GenericParser.RFC5234 (vchar) +import GenericParser.SomeParsers as SomeParsers +import GenericParser.Parser as G + +data TokenParsingError + = CannotParse + | CannotEntirelyParse + | Size Int Int Int + +data Error + = ParsingError (G.Error TokenParsingError) + +-- | TODO: this number should be exactly the size of the provided token. +min_token_size :: Int +min_token_size = 20 +max_token_size :: Int +max_token_size = 60 + +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 + Left x -> invalid $ [c x] + Right x -> pure x.result + +token_parser :: G.Parser TokenParsingError String +token_parser = do + l <- G.many1 vchar <|> G.Parser \i -> G.failureError i.position (Just CannotParse) + _ <- SomeParsers.eof <|> G.Parser \i -> G.failureError i.position (Just CannotEntirelyParse) + pos <- G.current_position + if pos < min_token_size || pos > max_token_size + then G.Parser \i -> G.failureError i.position (Just $ Size min_token_size max_token_size pos) + else pure $ CU.fromCharArray l + +token :: String -> Either (Array Error) String +token s = toEither $ parse token_parser s ParsingError