naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-01-10 16:46: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-port: 5022
ssh-key-file: config/ssh-host-key ssh-key-file: config/ssh-host-key
registration: false registration: false
max-accounts: 3

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

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

3
src/Vervis/Settings.hs
View file

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