Add settings option to disable registration

config/settings.yml

@@ -41,3 +41,4 @@ database:
 repo-dir:     repos
 ssh-port:     5022
 ssh-key-file: config/ssh-host-key
+registration: false

src/Vervis/Handler/Person.hs

@@ -44,30 +44,34 @@ getPeopleR = do
 -- | Create new user
 postPeopleR :: Handler Html
 postPeopleR = do
-    ((result, widget), enctype) <- runFormPost formPersonNew
+    regEnabled <- appRegister . appSettings <$> getYesod
-    case result of
+    if regEnabled
-        FormSuccess pn -> do
+        then do
-            runDB $ do
+            ((result, widget), enctype) <- runFormPost formPersonNew
-                let sharer = Sharer
+            case result of
-                        { sharerIdent = uLogin pn
+                FormSuccess pn -> do
-                        , sharerName  = Nothing
+                    runDB $ do
-                        }
+                        let sharer = Sharer
-                sid <- insert sharer
+                                { sharerIdent = uLogin pn
-                let person = Person
+                                , sharerName  = Nothing
-                        { personIdent = sid
+                                }
-                        , personLogin = uLogin pn
+                        sid <- insert sharer
-                        , personHash  = Nothing
+                        let person = Person
-                        , personEmail = uEmail pn
+                                { personIdent = sid
-                        }
+                                , personLogin = uLogin pn
-                person' <- setPassword (uPass pn) person
+                                , personHash  = Nothing
-                insert_ person'
+                                , personEmail = uEmail pn
-            redirectUltDest HomeR
+                                }
-        FormMissing -> do
+                        person' <- setPassword (uPass pn) person
-            setMessage "Field(s) missing"
+                        insert_ person'
-            defaultLayout $(widgetFile "person-new")
+                    redirectUltDest HomeR
-        FormFailure l -> do
+                FormMissing -> do
-            setMessage $ toHtml $ intercalate "; " l
+                    setMessage "Field(s) missing"
-            defaultLayout $(widgetFile "person-new")
+                    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
+            regEnabled <- appRegister . appSettings <$> getYesod
-            defaultLayout $ do
+            if regEnabled
-                setTitle "Vervis > People > New"
+                then do
-                $(widgetFile "person-new")
+                    ((_result, widget), enctype) <- runFormPost formPersonNew
+                    defaultLayout $ do
+                        setTitle "Vervis > People > New"
+                        $(widgetFile "person-new")
+                else notFound
 
 getPersonR :: Text -> Handler Html
 getPersonR ident = do

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 {..}