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