Add mail verification.

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)

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)

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,

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 ]

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