From e22680237971ab98e1079682d61bed873129add1 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@chelnok.de>
Date: Mon, 8 Dec 2014 15:47:19 +0100
Subject: [PATCH] user signup can now be disabled

---
 Handler/Signup.hs   | 99 +++++++++++++++++++++++++--------------------
 config/settings.yml |  3 +-
 2 files changed, 57 insertions(+), 45 deletions(-)

diff --git a/Handler/Signup.hs b/Handler/Signup.hs
index cadbfc6..096cc82 100644
--- a/Handler/Signup.hs
+++ b/Handler/Signup.hs
@@ -8,55 +8,66 @@ import Data.Maybe
 
 getSignupR :: Handler Html
 getSignupR = do
---  (signupWidget, enctype) <- generateFormPost signupForm
-  defaultLayout $ do
-    setTitle "Eidolon :: Signup"
-    $(widgetFile "signup")
+  block <- fmap extraSignupBlocked appExtra
+  case block of
+    False -> do
+      defaultLayout $ do
+        setTitle "Eidolon :: Signup"
+        $(widgetFile "signup")
+    True -> do
+      setMessage "User signup has been disabled"
+      redirect $ HomeR
 
 postSignupR :: Handler Html
 postSignupR = do
-  mUserName <- lookupPostParam "username"
-  newUserName <- case validateLen (fromJust mUserName) of
-    True -> return $ fromJust $ mUserName
+  block <- fmap extraSignupBlocked appExtra
+  case block of
     False -> do
-      setMessage "Invalid username"
-      redirect $ SignupR
-  mEmail <- lookupPostParam "email"
-  mTos1 <- lookupPostParam "tos-1"
-  mTos2 <- lookupPostParam "tos-2"
-  case (mTos1, mTos2) of
-    (Just "tos-1", Just "tos-2") ->
-      return ()
-    _ -> do
-      setMessage "You need to agree to our terms."
-      redirect $ SignupR
-  -- create user
-  namesakes <- runDB $ selectList [UserName ==. newUserName] []
-  case namesakes of
-    [] -> do
-      salt <- liftIO generateSalt
-      newUser <- return $ User newUserName
-        newUserName
-        (fromJust mEmail)
-        salt
-        ""
-        []
-        False
-      activatorText <- liftIO generateString
-      aId <- runDB $ insert $ Activator activatorText newUser
-      tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
-      activateLink <- ($ ActivateR activatorText) <$> getUrlRender
-      sendMail (userEmail newUser) "Please activate your account!" $
-        [shamlet|
-          <h1>Hello #{userSlug newUser} and Welcome to Eidolon!
-          To complete your sgnup please activate your account by visiting the following link:
-          <a href="#{activateLink}">#{activateLink}
-        |]
-      setMessage "User pending activation"
+      mUserName <- lookupPostParam "username"
+      newUserName <- case validateLen (fromJust mUserName) of
+        True -> return $ fromJust $ mUserName
+        False -> do
+          setMessage "Invalid username"
+          redirect $ SignupR
+      mEmail <- lookupPostParam "email"
+      mTos1 <- lookupPostParam "tos-1"
+      mTos2 <- lookupPostParam "tos-2"
+      case (mTos1, mTos2) of
+        (Just "tos-1", Just "tos-2") ->
+          return ()
+        _ -> do
+          setMessage "You need to agree to our terms."
+          redirect $ SignupR
+      -- create user
+      namesakes <- runDB $ selectList [UserName ==. newUserName] []
+      case namesakes of
+        [] -> do
+          salt <- liftIO generateSalt
+          newUser <- return $ User newUserName
+            newUserName
+            (fromJust mEmail)
+            salt
+            ""
+            []
+            False
+          activatorText <- liftIO generateString
+          aId <- runDB $ insert $ Activator activatorText newUser
+          tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
+          activateLink <- ($ ActivateR activatorText) <$> getUrlRender
+          sendMail (userEmail newUser) "Please activate your account!" $
+            [shamlet|
+              <h1>Hello #{userSlug newUser} and Welcome to Eidolon!
+              To complete your sgnup please activate your account by visiting the following link:
+              <a href="#{activateLink}">#{activateLink}
+            |]
+          setMessage "User pending activation"
+          redirect $ HomeR
+        _ -> do
+          setMessage "This user already exists"
+          redirect $ SignupR
+    True -> do
+      setMessage "User signup is disabled"
       redirect $ HomeR
-    _ -> do
-      setMessage "This user already exists"
-      redirect $ SignupR
 
 validateLen :: Text -> Bool
 validateLen a =
diff --git a/config/settings.yml b/config/settings.yml
index cc386a3..910db87 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -3,7 +3,8 @@ Default: &defaults
   port: 3000
   approot: "http://localhost:3000"
   copyright: Insert copyright statement here
-  #analytics: UA-YOURCODE
+  #enter only True or False
+  signupBlocked: False
 
 Development:
   <<: *defaults