From ddb26faf5c2b44b4aadff135bd345385e51f1148 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
Date: Tue, 26 Jul 2022 20:25:55 +0200
Subject: [PATCH] implement signup block

---
 src/Control/User.hs   | 41 ++++++++++++++++++++++++-----------------
 src/Model/Settings.hs |  3 +++
 2 files changed, 27 insertions(+), 17 deletions(-)

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