Implement /register

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)

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

th/routes

@@ -120,6 +120,7 @@
 
 /register/enabled RegisterEnabledR GET
 /register/available RegisterAvailableR GET
+/register RegisterR POST
 
 ---- Client ------------------------------------------------------------------