added possibility to block new user creation

Handler/Home.hs

@@ -28,6 +28,7 @@ import Data.Time.Calendar (addDays)
 -- inclined, or create a single monolithic file.
 getHomeR :: Handler Html
 getHomeR = do
+  settings <- getsYesod appSettings
   beverages <- runDB $ selectList [BeverageAmount !=. 0] [Desc BeverageIdent]
   today <- liftIO $ utctDay <$> getCurrentTime
   users <- runDB $ selectList [UserTimestamp >=. addDays (-30) today] [Asc UserIdent]

Handler/NewUser.hs

@@ -13,6 +13,7 @@
 --
 --  You should have received a copy of the GNU Affero General Public License
 --  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE DoAndIfThenElse #-}
 module Handler.NewUser where
 
 import Import as I
@@ -21,6 +22,12 @@ import Text.Shakespeare.Text
 
 getNewUserR :: Handler Html
 getNewUserR = do
+  settings <- getsYesod appSettings
+  if appUserCreationBlocked settings
+  then do
+    setMessageI MsgCreationBlocked
+    redirect HomeR
+  else do
     today <- liftIO $ return . utctDay =<< getCurrentTime
     (newUserWidget, enctype) <- generateFormPost
       $ renderBootstrap3 BootstrapBasicForm
@@ -30,6 +37,12 @@ getNewUserR = do
 
 postNewUserR :: Handler Html
 postNewUserR = do
+  settings <- getsYesod appSettings
+  if appUserCreationBlocked settings
+  then do
+    setMessageI MsgCreationBlocked
+    redirect HomeR
+  else do
     today <- liftIO $ return . utctDay =<< getCurrentTime
     ((res, _), _) <- runFormPost
       $ renderBootstrap3 BootstrapBasicForm

Settings.hs

@@ -76,6 +76,8 @@ data AppSettings = AppSettings
     , appCopyright              :: Text
     , appCopyrightLink          :: Text
     -- ^ Text and link to source
+    , appUserCreationBlocked    :: Bool
+    -- ^ Block user creation
     , appAdminCreds             :: Maybe Login
     -- ^ optional admin credentials
     }
@@ -119,6 +121,8 @@ instance FromJSON AppSettings where
         appCopyright              <- o .: "copyright"
         appCopyrightLink          <- o .: "copyright_link"
 
+        appUserCreationBlocked    <- o .: "block_users"
+
         appAdminCreds             <- o .:? "credentials"
 
         return AppSettings {..}

config/settings.yml

@@ -33,6 +33,8 @@ cash_charge: 50
 copyright: "Powered by YAMMAT"
 copyright_link: "https://github.com/nek0/yammat"
 
+block_users: false
+
 # optional administrative credentials.
 # credentials:
 #   login: "admin"

messages/cz.msg

@@ -145,3 +145,4 @@ Modify: upravit
 UserIdentNotUnique: Uživatelské jméno není jedinečný
 Login: Přihlásit
 Logout: Odhlásit
+CreationBlocked: Nelze vytvořit nové uživatele.

messages/de.msg

@@ -145,3 +145,4 @@ Modify: bearbeiten
 UserIdentNotUnique: Benutzername ist nicht einzigartig
 Login: Login
 Logout: Logout
+CreationBlocked: Es können keine neuen Nutzer angelegt werden.

messages/en.msg

@@ -145,3 +145,4 @@ Modify: modify
 UserIdentNotUnique: Username is not unique
 Login: Login
 Logout: Logout
+CreationBlocked: New users can not be created.

templates/home.hamlet

@@ -16,6 +16,7 @@ $forall (Entity uId user) <- users
       <a href=@{SelectR uId}>
         <p>#{userIdent user}
 
+$if not (appUserCreationBlocked settings)
   <article .article #func>
     <a href=@{NewUserR}>
       <p>_{MsgCreateUser}