From ddd4393825a54e6db838d654662b43c7c7cd943c Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Wed, 27 Jul 2016 21:46:48 +0000
Subject: [PATCH] New YAML setting: Optional user limit

---
 config/settings.yml          |  1 +
 src/Vervis/Handler/Person.hs | 73 +++++++++++++++++++++---------------
 src/Vervis/Settings.hs       |  3 ++
 3 files changed, 47 insertions(+), 30 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index ce861de..e6d732b 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -42,3 +42,4 @@ repo-dir:     repos
 ssh-port:     5022
 ssh-key-file: config/ssh-host-key
 registration: false
+max-accounts: 3
diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index 310c26b..a5252a3 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@@ -24,7 +24,7 @@ where
 import Vervis.Import hiding ((==.))
 --import Prelude
 
-import Database.Esqueleto hiding (isNothing)
+import Database.Esqueleto hiding (isNothing, count)
 import Vervis.Form.Person
 --import Model
 import Text.Blaze.Html (toHtml)
@@ -45,36 +45,49 @@ getPeopleR = do
 -- | Create new user
 postPeopleR :: Handler Html
 postPeopleR = do
-    regEnabled <- getsYesod $ appRegister . appSettings
-    if regEnabled
+    settings <- getsYesod appSettings
+    if appRegister settings
         then do
-            ((result, widget), enctype) <- runFormPost newPersonForm
-            case result of
-                FormSuccess np -> do
-                    now <- liftIO getCurrentTime
-                    runDB $ do
-                        let sharer = Sharer
-                                { sharerIdent   = npLogin np
-                                , sharerName    = npName np
-                                , sharerCreated = now
-                                }
-                        sid <- insert sharer
-                        let person = Person
-                                { personIdent = sid
-                                , personLogin = shr2text $ npLogin np
-                                , personHash  = Nothing
-                                , personEmail = npEmail np
-                                }
-                        person' <- setPassword (npPass np) person
-                        insert_ person'
-                    redirectUltDest HomeR
-                FormMissing -> do
-                    setMessage "Field(s) missing"
-                    defaultLayout $(widgetFile "person-new")
-                FormFailure _l -> do
-                    setMessage "User registration failed, see errors below"
-                    defaultLayout $(widgetFile "person-new")
-        else notFound
+            room <- case appAccounts settings of
+                Nothing -> return True
+                Just cap -> do
+                    current <- runDB $ count ([] :: [Filter Person])
+                    return $ current < cap
+            if room
+                then do
+                    ((result, widget), enctype) <- runFormPost newPersonForm
+                    case result of
+                        FormSuccess np -> do
+                            now <- liftIO getCurrentTime
+                            runDB $ do
+                                let sharer = Sharer
+                                        { sharerIdent   = npLogin np
+                                        , sharerName    = npName np
+                                        , sharerCreated = now
+                                        }
+                                sid <- insert sharer
+                                let person = Person
+                                        { personIdent = sid
+                                        , personLogin = shr2text $ npLogin np
+                                        , personHash  = Nothing
+                                        , personEmail = npEmail np
+                                        }
+                                person' <- setPassword (npPass np) person
+                                insert_ person'
+                            redirectUltDest HomeR
+                        FormMissing -> do
+                            setMessage "Field(s) missing"
+                            defaultLayout $(widgetFile "person-new")
+                        FormFailure _l -> do
+                            setMessage
+                                "User registration failed, see errors below"
+                            defaultLayout $(widgetFile "person-new")
+                else do
+                    setMessage "Maximal number of registered users reached"
+                    redirect PeopleR
+        else do
+            setMessage "User registration disabled"
+            redirect PeopleR
 
 getPersonNewR :: Handler Html
 getPersonNewR = do
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index 0f005f3..c92000b 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -77,6 +77,8 @@ data AppSettings = AppSettings
     , appSshKeyFile             :: FilePath
       -- | Whether new user accounts can be created.
     , appRegister               :: Bool
+      -- | The maximal number of user accounts that can be registered.
+    , appAccounts               :: Maybe Int
     }
 
 instance FromJSON AppSettings where
@@ -104,6 +106,7 @@ instance FromJSON AppSettings where
         appSshPort                <- o .: "ssh-port"
         appSshKeyFile             <- o .: "ssh-key-file"
         appRegister               <- o .: "registration"
+        appAccounts               <- o .: "max-accounts"
 
         return AppSettings {..}