naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-01-10 10:26:46 +09:00
Code Activity

New YAML setting: Optional user limit

Browse source
This commit is contained in:
fr33domlover 2016-07-27 21:46:48 +00:00
parent e642914d2a
commit ddd4393825
3 changed files with 47 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/settings.yml
View file

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

73
src/Vervis/Handler/Person.hs
View file

@ -24,7 +24,7 @@ where
import Vervis.Import hiding ((==.))
--import Prelude
import Database.Esqueleto hiding (isNothing)
import Database.Esqueleto hiding (isNothing, count)
import Vervis.Form.Person
--import Model
import Text.Blaze.Html (toHtml)
@ -45,36 +45,49 @@ getPeopleR = do
-- | Create new user
postPeopleR :: Handler Html
postPeopleR = do
regEnabled <- getsYesod $ appRegister . appSettings
if regEnabled
settings <- getsYesod appSettings
if appRegister settings
then do
((result, widget), enctype) <- runFormPost newPersonForm
case result of
FormSuccess np -> do
now <- liftIO getCurrentTime
runDB $ do
let sharer = Sharer
{ sharerIdent = npLogin np
, sharerName = npName np
, sharerCreated = now
}
sid <- insert sharer
let person = Person
{ personIdent = sid
, personLogin = shr2text $ npLogin np
, personHash = Nothing
, personEmail = npEmail np
}
person' <- setPassword (npPass np) person
insert_ person'
redirectUltDest HomeR
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "person-new")
FormFailure _l -> do
setMessage "User registration failed, see errors below"
defaultLayout $(widgetFile "person-new")
else notFound
room <- case appAccounts settings of
Nothing -> return True
Just cap -> do
current <- runDB $ count ([] :: [Filter Person])
return $ current < cap
if room
then do
((result, widget), enctype) <- runFormPost newPersonForm
case result of
FormSuccess np -> do
now <- liftIO getCurrentTime
runDB $ do
let sharer = Sharer
{ sharerIdent = npLogin np
, sharerName = npName np
, sharerCreated = now
}
sid <- insert sharer
let person = Person
{ personIdent = sid
, personLogin = shr2text $ npLogin np
, personHash = Nothing
, personEmail = npEmail np
}
person' <- setPassword (npPass np) person
insert_ person'
redirectUltDest HomeR
FormMissing -> do
setMessage "Field(s) missing"
defaultLayout $(widgetFile "person-new")
FormFailure _l -> do
setMessage
"User registration failed, see errors below"
defaultLayout $(widgetFile "person-new")
else do
setMessage "Maximal number of registered users reached"
redirect PeopleR
else do
setMessage "User registration disabled"
redirect PeopleR
getPersonNewR :: Handler Html
getPersonNewR = do

3
src/Vervis/Settings.hs
View file

@ -77,6 +77,8 @@ data AppSettings = AppSettings
, appSshKeyFile :: FilePath
-- | Whether new user accounts can be created.
, appRegister :: Bool
-- | The maximal number of user accounts that can be registered.
, appAccounts :: Maybe Int
}
instance FromJSON AppSettings where
@ -104,6 +106,7 @@ instance FromJSON AppSettings where
appSshPort <- o .: "ssh-port"
appSshKeyFile <- o .: "ssh-key-file"
appRegister <- o .: "registration"
appAccounts <- o .: "max-accounts"
return AppSettings {..}