Record all signup attempts in the database

thentos-core/schema/schema.sql

@@ -119,3 +119,9 @@ CREATE TABLE IF NOT EXISTS captchas (
     solution   text         NOT NULL,
     timestamp  timestamptz  NOT NULL DEFAULT now()
 );
+
+CREATE TABLE IF NOT EXISTS signup_attempts (
+    user_name  text        NOT NULL,
+    captcha_correct bool   NOT NULL,
+    timestamp  timestamptz NOT NULL
+);

thentos-core/src/Thentos/Action.hs

@@ -82,7 +82,7 @@ module Thentos.Action
     )
 where
 
-import Control.Conditional ((<||>), unlessM)
+import Control.Conditional ((<||>))
 import Control.Lens ((^.))
 import Control.Monad (unless, void, when)
 import Control.Monad.Except (throwError, catchError)
@@ -243,8 +243,9 @@ sendUserExistsMail email = do
 -- captcha remains in the DB to allow another attempt.  See also: 'makeCaptcha', 'confirmNewUser'.
 addUnconfirmedUserWithCaptcha :: (Show e, Typeable e) => UserCreationRequest -> Action e s ()
 addUnconfirmedUserWithCaptcha ucr = do
-    unlessM (solveCaptcha (csId $ ucCaptcha ucr) (csSolution $ ucCaptcha ucr)) $
-        throwError InvalidCaptchaSolution
+    captchaCorrect <- solveCaptcha (csId $ ucCaptcha ucr) (csSolution $ ucCaptcha ucr)
+    recordSignupAttempt (udName $ ucUser ucr) captchaCorrect
+    unless captchaCorrect $ throwError InvalidCaptchaSolution
     addUnconfirmedUser (ucUser ucr)
     deleteCaptcha . csId $ ucCaptcha ucr
 
@@ -726,6 +727,10 @@ solveCaptcha cid solution = do
 deleteCaptcha :: CaptchaId -> Action e s ()
 deleteCaptcha = query'P . T.deleteCaptcha
 
+recordSignupAttempt :: UserName -> Bool -> Action e s ()
+recordSignupAttempt name captchaCorrect =
+    query'P $ T.storeSignupAttempt name captchaCorrect
+
 -- * garbage collection
 
 collectGarbage :: Exception (ActionError e) => Action e s ()

thentos-core/src/Thentos/Transaction.hs

@@ -618,6 +618,12 @@ garbageCollectCaptchas timeout = void $ execT
     [sql| DELETE FROM captchas WHERE timestamp < now() - ?::interval; |] (Only timeout)
 
 
+-- | store signup attempt in the db
+recordSignupAttempt :: UserName -> Bool -> ThentosQuery e ()
+recordSignupAttempt name captchaCorrect = void $ execT
+    [sql| INSERT INTO signup_attempts (user_name, captcha_correct, timestamp)
+           VALUES (?, ?, now()) |] (name, captchaCorrect)
+
 -- * helpers
 
 -- | Throw an error from a situation which (we believe) will never arise.

thentos-tests/tests/Thentos/ActionSpec.hs

@@ -112,6 +112,23 @@ spec_user = describe "user" $ do
             void . runWithoutPrivs sta $ confirmUserEmailChange token
             checkEmail uid $ (==) newEmail
 
+    describe "addUnconfirmedUserWithCaptcha" $ do
+        it "records signup attempts in the database" $ \sta -> do
+            let ActionState (conns, _, _) = sta
+                name = UserName "someName"
+                userData = UserFormData name "secret" (forceUserEmail "me@example.com")
+                cid = "myCaptchaId"
+                solution = "theSolution"
+                captchaSolution = CaptchaSolution cid solution
+                req = UserCreationRequest userData captchaSolution
+            Right () <- runVoidedQuery conns $ T.storeCaptcha cid solution
+            void . runPrivs [RoleAdmin] sta $ addUnconfirmedUserWithCaptcha req
+            [(name', captchaCorrect)] <- doQuery conns
+                [sql| SELECT user_name, captcha_correct
+                      FROM user_add_attempts |] ()
+            name `shouldBe` name'
+            captchaCorrect `shouldBe` True
+
 spec_service :: SpecWith ActionState
 spec_service = describe "service" $ do
     describe "addService, lookupService, deleteService" $ do