implement signup block

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)

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