diff --git a/src/Control/User.hs b/src/Control/User.hs index fc3de31..ea0495f 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -34,24 +34,31 @@ userNew :: UserSubmit -> MateHandler Int userNew (UserSubmit ident email pass) = do - now <- liftIO getCurrentTime conn <- asks rsConnection - uid <- insertUser ident email (utctDay now) conn - salt <- liftIO randomString - let mpasshash = argon2 salt (encodeUtf8 pass) - case mpasshash of - CryptoPassed passhash -> do - liftIO $ print passhash - void $ putUserAuthInfo uid PrimaryPass "Initial password" salt passhash conn - CryptoFailed err -> - throwError $ err500 - { errBody = "Crypto error: " <> fromString (show err) - } - baseRoleId <- queryRoleIdByCapabilities - (False, False, False, False, False, False, False, False, False, False) - conn - void $ associateUserToRole uid baseRoleId conn - return uid + block <- selectSignupBlocked conn + if block + then + throwError $ err401 + { errBody = "User registration has been disabled" + } + else do + now <- liftIO getCurrentTime + uid <- insertUser ident email (utctDay now) conn + salt <- liftIO randomString + let mpasshash = argon2 salt (encodeUtf8 pass) + case mpasshash of + CryptoPassed passhash -> do + liftIO $ print passhash + void $ putUserAuthInfo uid PrimaryPass "Initial password" salt passhash conn + CryptoFailed err -> + throwError $ err500 + { errBody = "Crypto error: " <> fromString (show err) + } + baseRoleId <- queryRoleIdByCapabilities + (False, False, False, False, False, False, False, False, False, False) + conn + void $ associateUserToRole uid baseRoleId conn + return uid userGet :: Maybe (Int, AuthMethod) diff --git a/src/Model/Settings.hs b/src/Model/Settings.hs index 8c7cf51..033bc6f 100644 --- a/src/Model/Settings.hs +++ b/src/Model/Settings.hs @@ -59,6 +59,9 @@ selectSettings conn = liftIO $ do selectIdleTime :: PGS.Connection -> MateHandler Int selectIdleTime conn = settingsIdleTime <$> selectSettings conn +selectSignupBlocked :: PGS.Connection -> MateHandler Bool +selectSignupBlocked conn = settingsBlockRegistration <$> selectSettings conn + updateSettings :: Settings -> PGS.Connection -> MateHandler () updateSettings (Settings block imprint idleTime) conn = do void $ liftIO $ runUpdate_ conn $ Update