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,33 +22,45 @@ import Text.Shakespeare.Text
 
 getNewUserR :: Handler Html
 getNewUserR = do
-  today <- liftIO $ return . utctDay =<< getCurrentTime
+  settings <- getsYesod appSettings
-  (newUserWidget, enctype) <- generateFormPost
+  if appUserCreationBlocked settings
-    $ renderBootstrap3 BootstrapBasicForm
+  then do
-    $ newUserForm today
+    setMessageI MsgCreationBlocked
-  defaultLayout $
+    redirect HomeR
-    $(widgetFile "newUser")
+  else do
+    today <- liftIO $ return . utctDay =<< getCurrentTime
+    (newUserWidget, enctype) <- generateFormPost
+      $ renderBootstrap3 BootstrapBasicForm
+      $ newUserForm today
+    defaultLayout $
+      $(widgetFile "newUser")
 
 postNewUserR :: Handler Html
 postNewUserR = do
-  today <- liftIO $ return . utctDay =<< getCurrentTime
+  settings <- getsYesod appSettings
-  ((res, _), _) <- runFormPost
+  if appUserCreationBlocked settings
-    $ renderBootstrap3 BootstrapBasicForm
+  then do
-    $ newUserForm today
+    setMessageI MsgCreationBlocked
-  case res of
+    redirect HomeR
-    FormSuccess user -> do
+  else do
-      namesakes <- runDB $ selectList [UserIdent ==. userIdent user] []
+    today <- liftIO $ return . utctDay =<< getCurrentTime
-      if null namesakes
+    ((res, _), _) <- runFormPost
-        then do
+      $ renderBootstrap3 BootstrapBasicForm
-          runDB $ insert_ user
+      $ newUserForm today
-          setMessageI MsgUserCreated
+    case res of
-          redirect HomeR
+      FormSuccess user -> do
-        else do
+        namesakes <- runDB $ selectList [UserIdent ==. userIdent user] []
-          setMessageI MsgUserIdentNotUnique
+        if null namesakes
-          redirect NewUserR
+          then do
-    _ -> do
+            runDB $ insert_ user
-      setMessageI MsgUserNotCreated
+            setMessageI MsgUserCreated
-      redirect NewUserR
+            redirect HomeR
+          else do
+            setMessageI MsgUserIdentNotUnique
+            redirect NewUserR
+      _ -> do
+        setMessageI MsgUserNotCreated
+        redirect NewUserR
 
 newUserForm :: Day -> AForm Handler User
 newUserForm today = User

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,9 +16,10 @@ $forall (Entity uId user) <- users
       <a href=@{SelectR uId}>
         <p>#{userIdent user}
 
-<article .article #func>
+$if not (appUserCreationBlocked settings)
-  <a href=@{NewUserR}>
+  <article .article #func>
-    <p>_{MsgCreateUser}
+    <a href=@{NewUserR}>
+      <p>_{MsgCreateUser}
 
 $if not (null ousers)
   <article .article #func>