From 4c3371beda317079e6e67b30c4de42b86c400f4b Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Tue, 19 Apr 2016 16:03:27 +0000
Subject: [PATCH] Add settings option to disable registration

---
 config/settings.yml          |  1 +
 src/Vervis/Handler/Person.hs | 64 ++++++++++++++++++++----------------
 src/Vervis/Settings.hs       |  3 ++
 3 files changed, 40 insertions(+), 28 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 63b842c..ce861de 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -41,3 +41,4 @@ database:
 repo-dir:     repos
 ssh-port:     5022
 ssh-key-file: config/ssh-host-key
+registration: false
diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs
index 3046a36..80a289d 100644
--- a/src/Vervis/Handler/Person.hs
+++ b/src/Vervis/Handler/Person.hs
@@ -44,30 +44,34 @@ getPeopleR = do
 -- | Create new user
 postPeopleR :: Handler Html
 postPeopleR = do
-    ((result, widget), enctype) <- runFormPost formPersonNew
-    case result of
-        FormSuccess pn -> do
-            runDB $ do
-                let sharer = Sharer
-                        { sharerIdent = uLogin pn
-                        , sharerName  = Nothing
-                        }
-                sid <- insert sharer
-                let person = Person
-                        { personIdent = sid
-                        , personLogin = uLogin pn
-                        , personHash  = Nothing
-                        , personEmail = uEmail pn
-                        }
-                person' <- setPassword (uPass pn) person
-                insert_ person'
-            redirectUltDest HomeR
-        FormMissing -> do
-            setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "person-new")
-        FormFailure l -> do
-            setMessage $ toHtml $ intercalate "; " l
-            defaultLayout $(widgetFile "person-new")
+    regEnabled <- appRegister . appSettings <$> getYesod
+    if regEnabled
+        then do
+            ((result, widget), enctype) <- runFormPost formPersonNew
+            case result of
+                FormSuccess pn -> do
+                    runDB $ do
+                        let sharer = Sharer
+                                { sharerIdent = uLogin pn
+                                , sharerName  = Nothing
+                                }
+                        sid <- insert sharer
+                        let person = Person
+                                { personIdent = sid
+                                , personLogin = uLogin pn
+                                , personHash  = Nothing
+                                , personEmail = uEmail pn
+                                }
+                        person' <- setPassword (uPass pn) person
+                        insert_ person'
+                    redirectUltDest HomeR
+                FormMissing -> do
+                    setMessage "Field(s) missing"
+                    defaultLayout $(widgetFile "person-new")
+                FormFailure l -> do
+                    setMessage $ toHtml $ intercalate "; " l
+                    defaultLayout $(widgetFile "person-new")
+        else notFound
     --TODO NEXT:
     -- * Maybe make the form return Form Person and just insert defaults (using
     -- 'pure') for the remaining Person fields? Then, maybe the same form can
@@ -80,10 +84,14 @@ getPersonNewR = do
     if isJust mpid
         then redirect HomeR
         else do
-            ((_result, widget), enctype) <- runFormPost formPersonNew
-            defaultLayout $ do
-                setTitle "Vervis > People > New"
-                $(widgetFile "person-new")
+            regEnabled <- appRegister . appSettings <$> getYesod
+            if regEnabled
+                then do
+                    ((_result, widget), enctype) <- runFormPost formPersonNew
+                    defaultLayout $ do
+                        setTitle "Vervis > People > New"
+                        $(widgetFile "person-new")
+                else notFound
 
 getPersonR :: Text -> Handler Html
 getPersonR ident = do
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index ca14a90..0f005f3 100644
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@@ -75,6 +75,8 @@ data AppSettings = AppSettings
     , appSshPort                :: Int
       -- | Path to the server's SSH private key file
     , appSshKeyFile             :: FilePath
+      -- | Whether new user accounts can be created.
+    , appRegister               :: Bool
     }
 
 instance FromJSON AppSettings where
@@ -101,6 +103,7 @@ instance FromJSON AppSettings where
         appRepoDir                <- o .: "repo-dir"
         appSshPort                <- o .: "ssh-port"
         appSshKeyFile             <- o .: "ssh-key-file"
+        appRegister               <- o .: "registration"
 
         return AppSettings {..}