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.
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]

View file

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

View file

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

View file

@ -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"

View file

@ -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.

View file

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

View file

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

View file

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