added possibility to block new user creation

This commit is contained in:
nek0 2017-06-03 03:00:04 +02:00
parent 36b9af139e
commit 569eb3b95a
8 changed files with 51 additions and 27 deletions

View file

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

View file

@ -13,6 +13,7 @@
-- --
-- You should have received a copy of the GNU Affero General Public License -- 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/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DoAndIfThenElse #-}
module Handler.NewUser where module Handler.NewUser where
import Import as I import Import as I
@ -21,33 +22,45 @@ import Text.Shakespeare.Text
getNewUserR :: Handler Html getNewUserR :: Handler Html
getNewUserR = do 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 :: Handler Html
postNewUserR = do 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 :: Day -> AForm Handler User
newUserForm today = User newUserForm today = User

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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