Record all signup attempts in DB

misc/thentos-install.sh

@@ -19,6 +19,7 @@ set -o errexit
 declare -a SOURCES
 SUBMODULE_SOURCES=( servant/servant
                     servant/servant-server
+                    servant/servant-cassava
                     servant/servant-client
                     servant/servant-docs
                     servant/servant-blaze

thentos-core/schema/schema.sql

@@ -119,3 +119,10 @@ 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,
+    email      text        NOT NULL,
+    captcha_correct bool   NOT NULL,
+    timestamp  timestamptz NOT NULL
+);

thentos-core/src/Data/Csv/Missing.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Csv.Missing where
+
+import Data.Csv
+import Control.Monad (mzero)
+
+instance ToField Bool where
+    toField True = "1"
+    toField False = "0"
+
+instance FromField Bool where
+    parseField "1" = pure True
+    parseField "0" = pure False
+    parseField _   = mzero

thentos-core/src/Thentos/Action.hs

@@ -78,12 +78,13 @@ module Thentos.Action
     , makeAudioCaptcha
     , solveCaptcha
     , deleteCaptcha
+    , getAllSignupAttempts
 
     , collectGarbage
     )
 where
 
-import Control.Conditional ((<||>), unlessM)
+import Control.Conditional ((<||>))
 import Control.Lens ((^.))
 import Control.Monad (unless, void, when)
 import Control.Monad.Except (throwError, catchError)
@@ -244,8 +245,10 @@ 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)
+    let user = ucUser ucr
+    recordSignupAttempt (udName user) (udEmail user) captchaCorrect
+    unless captchaCorrect $ throwError InvalidCaptchaSolution
     addUnconfirmedUser (ucUser ucr)
     deleteCaptcha . csId $ ucCaptcha ucr
 
@@ -737,6 +740,13 @@ solveCaptcha cid solution = do
 deleteCaptcha :: CaptchaId -> Action e s ()
 deleteCaptcha = query'P . T.deleteCaptcha
 
+recordSignupAttempt :: UserName -> UserEmail -> Bool -> Action e s ()
+recordSignupAttempt name email captchaCorrect =
+    query'P $ T.recordSignupAttempt name email captchaCorrect
+
+getAllSignupAttempts :: Action e s [SignupAttempt]
+getAllSignupAttempts = query'P $ T.getAllSignupAttempts
+
 -- * garbage collection
 
 collectGarbage :: Exception (ActionError e) => Action e s ()

thentos-core/src/Thentos/Backend/Api/Docs/Common.hs

@@ -329,6 +329,11 @@ instance ToSample ServiceSessionToken where
 
 instance ToSample ByUserOrServiceId
 
+instance ToSample SignupAttempt where
+    toSamples _ = Docs.singleSample $ SignupAttempt (UserName "UserName") email False ts
+      where ts = Timestamp $ read "2015-12-15 07:12:34 CET"
+            email = (\(Just e) -> e) $ parseUserEmail "alice@example.com"
+
 
 instance HasDocs sublayout => HasDocs (ThentosAuth :> sublayout) where
     docsFor _ dat opts = docsFor (Proxy :: Proxy sublayout) dat opts & Docs.apiIntros %~ (intro:)

thentos-core/src/Thentos/Backend/Api/Simple.hs

@@ -19,6 +19,7 @@ import Network.Wai (Application)
 import Servant.API ((:<|>)((:<|>)), (:>), Get, Post, Delete, Capture, ReqBody, JSON)
 import Servant.Server (ServerT, Server, serve, enter)
 import Servant.API.ResponseHeaders (Headers, addHeader)
+import Servant.CSV.Cassava (CSV', DefaultEncodeOpts)
 import System.Log.Logger (Priority(INFO))
 
 import qualified Servant.Docs as Docs
@@ -87,6 +88,7 @@ type ThentosUser =
   :<|> "activate" :> ReqBody '[JSON] (JsonTop ConfirmationToken)
                   :> Post '[JSON] (JsonTop ThentosSessionToken)
   :<|> "login" :> ReqBody '[JSON] LoginFormData :> Post '[JSON] (JsonTop ThentosSessionToken)
+  :<|> "registration_attempts" :> Get '[JSON, (CSV', DefaultEncodeOpts)] [SignupAttempt]
   :<|> Capture "uid" UserId :> Delete '[JSON] ()
   :<|> Capture "uid" UserId :> "name" :> Get '[JSON] (JsonTop UserName)
   :<|> Capture "uid" UserId :> "email" :> Get '[JSON] (JsonTop UserEmail)
@@ -100,6 +102,7 @@ thentosUser =
   :<|> addUnconfirmedUserWithCaptcha
   :<|> (JsonTop <$>) . (snd <$>) .  confirmNewUser . fromJsonTop
   :<|> (\(LoginFormData n p) -> JsonTop . snd <$> startThentosSessionByUserName n p)
+  :<|> getAllSignupAttempts
   :<|> deleteUser
   :<|> (JsonTop . ((^. userName) . snd) <$>) . lookupConfirmedUser
   :<|> (JsonTop . ((^. userEmail) . snd) <$>) . lookupConfirmedUser

thentos-core/src/Thentos/Transaction.hs

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

thentos-core/src/Thentos/Types.hs

@@ -62,6 +62,7 @@ module Thentos.Types
     , ImageData(..)
     , CaptchaId(..)
     , CaptchaSolution(..)
+    , SignupAttempt(..)
 
     , ThentosError(..)
 
@@ -84,7 +85,7 @@ where
 import Control.Exception (Exception)
 import Control.Lens (makeLenses)
 import Control.Monad.Except (MonadError, throwError)
-import Control.Monad (when, unless)
+import Control.Monad (when, unless, mzero)
 import Data.Aeson (FromJSON, ToJSON, Value(String), (.=))
 import Data.Aeson.Types (Parser)
 import Data.Attoparsec.ByteString.Char8 (parseOnly)
@@ -95,6 +96,8 @@ import Database.PostgreSQL.Simple.TypeInfo.Static (interval)
 import Database.PostgreSQL.Simple.TypeInfo (typoid)
 import Data.ByteString.Builder (doubleDec)
 import Data.ByteString.Conversion (ToByteString)
+import Data.Csv ((.:))
+import Data.Csv.Missing ()
 import Data.Char (isAlpha)
 import Data.EitherR (fmapL)
 import Data.Function (on)
@@ -122,6 +125,7 @@ import Web.HttpApiData (parseQueryParam)
 
 import qualified Crypto.Scrypt as Scrypt
 import qualified Data.Aeson as Aeson
+import qualified Data.Csv as CSV
 import qualified Data.HashMap.Strict as H
 import qualified Data.ByteString as SBS
 import qualified Data.Text as ST
@@ -187,6 +191,12 @@ newtype UserName = UserName { fromUserName :: ST }
     deriving (Eq, Ord, Show, Read, FromJSON, ToJSON, Typeable, Generic, IsString, FromField,
               ToField)
 
+instance CSV.ToField UserName where
+    toField = CSV.toField . fromUserName
+
+instance CSV.FromField UserName where
+    parseField = pure . UserName . cs
+
 -- | BUG #399: ToJSON instance should go away in order to avoid accidental leakage of cleartext
 -- passwords.  but for the experimentation phase this is too much of a headache.  (Under no
 -- circumstances render to something like "[password hidden]".  Causes a lot of confusion.)
@@ -214,6 +224,14 @@ instance FromField UserEmail where
 instance ToField UserEmail where
     toField = toField . fromUserEmail
 
+instance CSV.ToField UserEmail where
+    toField = toByteString . userEmailAddress
+
+instance CSV.FromField UserEmail where
+    parseField s = case parseUserEmail (cs s) of
+        Just e -> pure e
+        Nothing -> mzero
+
 parseUserEmail :: ST -> Maybe UserEmail
 parseUserEmail t = do
     email <- emailAddress (cs t)
@@ -455,6 +473,12 @@ instance ToField Timestamp where
 instance FromField Timestamp where
     fromField f dat = Timestamp . toThyme <$> fromField f dat
 
+instance CSV.ToField Timestamp where
+    toField = cs . timestampToString
+
+instance CSV.FromField Timestamp where
+    parseField = timestampFromString . cs
+
 newtype Timeout = Timeoutms { toMilliseconds :: Int }
   deriving (Eq, Ord, Show)
 
@@ -731,6 +755,35 @@ data CaptchaSolution = CaptchaSolution
 instance Aeson.FromJSON CaptchaSolution where parseJSON = Aeson.gparseJson
 instance Aeson.ToJSON CaptchaSolution where toJSON = Aeson.gtoJson
 
+data SignupAttempt = SignupAttempt UserName UserEmail Bool Timestamp
+    deriving (Show, Generic)
+
+instance Aeson.ToJSON SignupAttempt where
+    toJSON = Aeson.gtoJson
+
+instance Aeson.FromJSON SignupAttempt where
+    parseJSON = Aeson.gparseJson
+
+instance CSV.ToNamedRecord SignupAttempt where
+    toNamedRecord (SignupAttempt name email captcha ts) =
+        CSV.namedRecord [
+            ("name", CSV.toField name),
+            ("email", CSV.toField email),
+            ("captcha_solved", CSV.toField captcha),
+            ("timestamp", CSV.toField ts)
+        ]
+
+instance CSV.FromNamedRecord SignupAttempt where
+    parseNamedRecord v = SignupAttempt <$>
+            v .: "name" <*>
+            v .: "email" <*>
+            v .: "captcha_solved" <*>
+            v .: "timestamp"
+
+instance CSV.FromRecord SignupAttempt
+
+instance CSV.DefaultOrdered SignupAttempt where
+    headerOrder _ = CSV.header ["name", "email", "captcha_solved", "timestamp"]
 
 -- * errors
 

thentos-core/thentos-core.cabal

@@ -51,6 +51,7 @@ library
     cpp-options: -DDEVELOPMENT
   exposed-modules:
       Database.PostgreSQL.Simple.Missing
+    , Data.Csv.Missing
     , LIO.Missing
     , Paths.TH
     , Paths_thentos_core__
@@ -100,6 +101,7 @@ library
     , bytestring >=0.10.6.0 && <0.11
     , bytestring-conversion >=0.3.1 && <0.4
     , case-insensitive >=1.2.0.4 && <1.3
+    , cassava >= 0.4.4 && <0.5
     , cond >=0.4 && <0.5
     , configifier >=0.0.7 && <0.1
     , containers >=0.5.6.2 && <0.6
@@ -146,6 +148,7 @@ library
     , sandi >=0.3.5 && <0.4
     , scrypt >=0.5.0 && <0.6
     , servant ==0.5
+    , servant-cassava == 0.4.4.2
     , servant-blaze ==0.5
     , servant-docs ==0.5
     , servant-foreign ==0.5

thentos-tests/tests/Thentos/ActionSpec.hs

@@ -112,6 +112,38 @@ 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 ([] :: [Bool]) sta $ addUnconfirmedUserWithCaptcha req
+            [(name', captchaCorrect)] <- doQuery conns
+                [sql| SELECT user_name, captcha_correct
+                      FROM signup_attempts |] ()
+            name `shouldBe` name'
+            captchaCorrect `shouldBe` True
+
+        it "records signup attempts in the database if the captcha is wrong" $ \sta -> do
+            let ActionState (conns, _, _) = sta
+                name = UserName "someName"
+                userData = UserFormData name "secret" (forceUserEmail "me@example.com")
+                cid = "myCaptchaId"
+                captchaSolution = CaptchaSolution cid "wrong answer"
+                req = UserCreationRequest userData captchaSolution
+            Right () <- runVoidedQuery conns $ T.storeCaptcha cid "right answer"
+            Left _ <- runPrivsE ([] :: [Bool]) sta $ addUnconfirmedUserWithCaptcha req
+            [(name', captchaCorrect)] <- doQuery conns
+                [sql| SELECT user_name, captcha_correct
+                      FROM signup_attempts |] ()
+            name `shouldBe` name'
+            captchaCorrect `shouldBe` False
+
 spec_service :: SpecWith ActionState
 spec_service = describe "service" $ do
     describe "addService, lookupService, deleteService" $ do

thentos-tests/tests/Thentos/Backend/Api/SimpleSpec.hs

@@ -40,7 +40,9 @@ import Test.Hspec.Wai (shouldRespondWith, WaiSession, with, request, matchStatus
 
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Csv as CSV
 import qualified Data.Text as ST
+import qualified Data.Vector as V
 
 import Thentos.Action.Core
 import Thentos.Backend.Api.Simple (serveApi)
@@ -312,6 +314,31 @@ specRest = do
                 lrsp <- request "POST" "/user/login" jsonHeader $ Aeson.encode loginData
                 liftIO $ statusCode (simpleStatus lrsp) `shouldBe` 401
 
+        describe "registration_attempts" $ do
+            it "returns a json list of all registration attempts" $ do
+                (cid, solution) <- getCaptchaAndSolution
+                _ <- registerUserAndGetConfirmationToken (cid, solution)
+                rsp <- request "GET" "/user/registration_attempts" jsonHeader ""
+                liftIO $ statusCode (simpleStatus rsp) `shouldBe` 200
+                let body = simpleBody rsp
+                    Just (signupAttempts :: [SignupAttempt]) = Aeson.decode body
+                    [SignupAttempt name email captchaCorrect _] = signupAttempts
+                liftIO $ name `shouldBe` udName defaultUserData
+                liftIO $ email `shouldBe` udEmail defaultUserData
+                liftIO $ captchaCorrect `shouldBe` True
+
+            it "returns a csv list of all registration attempts" $ do
+                (cid, solution) <- getCaptchaAndSolution
+                _ <- registerUserAndGetConfirmationToken (cid, solution)
+                rsp <- request "GET" "/user/registration_attempts" csvHeader ""
+                liftIO $ statusCode (simpleStatus rsp) `shouldBe` 200
+                let body = simpleBody rsp
+                    Right signupAttempts = CSV.decode CSV.HasHeader body
+                    SignupAttempt name email captchaCorrect _ = V.head signupAttempts
+                liftIO $ name `shouldBe` udName defaultUserData
+                liftIO $ email `shouldBe` udEmail defaultUserData
+                liftIO $ captchaCorrect `shouldBe` True
+
 
     describe "thentos_session" $ do
         describe "ReqBody '[JSON] ThentosSessionToken :> Get Bool" $ do
@@ -344,6 +371,9 @@ postDefaultUser = do
 jsonHeader :: [Header]
 jsonHeader = [("Content-Type", "application/json")]
 
+csvHeader :: [Header]
+csvHeader = [("Content-Type", "application/json"), ("Accept", "text/csv")]
+
 -- | God Headers plus content-type = json
 ctHeader :: IO [Header]
 ctHeader = (("Content-Type", "application/json") :) <$> readIORef godHeaders

thentos-tests/thentos-tests.cabal

@@ -103,6 +103,7 @@ test-suite tests
     , blaze-html
     , bytestring
     , case-insensitive >=1
+    , cassava >=0.4.4.0 && <0.5
     , configifier >=0.0.7 && <0.1
     , containers >=0.5.6.2 && <0.6
     , cookie >=0.4.1.6 && <4.2
@@ -135,6 +136,7 @@ test-suite tests
     , thyme >=0.3.5.5 && <0.4
     , transformers >=0.4.2.0 && <0.5
     , vault >=0.3.0.4 && <3.1
+    , vector >=0.10 && <0.11
     , wai >=3.0.3.0 && <3.1
     , wai-extra >=3.0.10 && <3.1
     , wai-session >=0.3.2 && <0.4