From b8922b3157e8fa37dcfbc5b3a091034712a43243 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Sat, 6 Jul 2024 00:14:36 +0300
Subject: [PATCH] Implement /register
---
src/Vervis/Foundation.hs | 2 ++
src/Vervis/Handler/Client.hs | 47 +++++++++++++++++++++++++++++++++++-
th/routes | 1 +
3 files changed, 49 insertions(+), 1 deletion(-)
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index bb41895..0efeb6a 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -243,6 +243,7 @@ instance Yesod App where
Just (ProjectInboxR _) -> return False
Just (GitUploadRequestR _) -> return False
Just (DvaraR _) -> return False
+ Just RegisterR -> return False
Just r -> isWriteRequest r
)
defaultCsrfHeaderName
@@ -851,6 +852,7 @@ instance YesodBreadcrumbs App where
ActorKey2R -> ("Actor Key 2", Just HomeR)
RegisterEnabledR -> ("", Nothing)
RegisterAvailableR -> ("", Nothing)
+ RegisterR -> ("", Nothing)
HomeR -> ("Home", Nothing)
BrowseR -> ("Browse", Just HomeR)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index 931c250..4f743b8 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -20,6 +20,7 @@ module Vervis.Handler.Client
, getActorKey2R
, getRegisterEnabledR
, getRegisterAvailableR
+ , postRegisterR
, getHomeR
, getBrowseR
@@ -69,6 +70,7 @@ import Control.Applicative
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.Trans.Except
+import Data.Aeson
import Data.Bifunctor
import Data.Bitraversable
import Data.Function
@@ -86,7 +88,7 @@ import Yesod.Auth
import Yesod.Auth.Account
import Yesod.Auth.Account.Message
import Yesod.Core
-import Yesod.Form
+import Yesod.Form hiding (emailField)
import Yesod.Persist.Core
import qualified Data.ByteString.Char8 as BC
@@ -195,6 +197,49 @@ getRegisterAvailableR = do
runDB $ getBy $ UniquePersonUsername $ text2username username
unless (isNothing maybePerson) $ invalidArgs ["taken"]
+postRegisterR :: Handler Encoding
+postRegisterR = do
+ requireAppAuth
+ settings <- asksSite appSettings
+ unless (appRegister settings) $ invalidArgs ["disabled"]
+ room <-
+ case appAccounts settings of
+ Nothing -> return True
+ Just cap -> do
+ current <- runDB $ count ([] :: [Filter Person])
+ return $ current < cap
+ unless room $ invalidArgs ["full"]
+
+ (username, pass, email) <-
+ runInputPost $ (,,)
+ <$> ireq (checkM checkValidUsername textField) "username"
+ <*> ireq passwordField "passphrase"
+ <*> ireq emailField "email"
+
+ muser <- runDB $ getBy $ UniquePersonUsername $ text2username username
+ unless (isNothing muser) $ invalidArgs ["username_taken"]
+
+ muser' <- runDB $ getBy $ UniquePersonEmail email
+ unless (isNothing muser') $ invalidArgs ["email_taken"]
+
+ key <- newVerifyKey
+ hashed <- hashPassphrase pass
+
+ mnew <- unAccountPersistDB' $ addNewUser username email key hashed
+ person <-
+ case mnew of
+ Left err -> invalidArgs [err]
+ Right p -> pure p
+
+ verif <- getsYesod requireEmailVerification
+ if verif
+ then sendVerifyEmail username email $ AuthR $ verifyR username key
+ else unAccountPersistDB' $ verifyAccount person
+
+ return $ pairs
+ ( "email_sent" .= verif
+ )
+
getHomeR :: Handler Html
getHomeR = do
mp <- maybeAuth
diff --git a/th/routes b/th/routes
index 18fe4f8..1c697c5 100644
--- a/th/routes
+++ b/th/routes
@@ -120,6 +120,7 @@
/register/enabled RegisterEnabledR GET
/register/available RegisterAvailableR GET
+/register RegisterR POST
---- Client ------------------------------------------------------------------