diff --git a/misc/thentos-install.sh b/misc/thentos-install.sh index 0c62fc70..1b80332c 100755 --- a/misc/thentos-install.sh +++ b/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 diff --git a/thentos-core/schema/schema.sql b/thentos-core/schema/schema.sql index f183fa18..effc4b61 100644 --- a/thentos-core/schema/schema.sql +++ b/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 +); diff --git a/thentos-core/src/Data/Csv/Missing.hs b/thentos-core/src/Data/Csv/Missing.hs new file mode 100644 index 00000000..2d71fe8d --- /dev/null +++ b/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 diff --git a/thentos-core/src/Thentos/Action.hs b/thentos-core/src/Thentos/Action.hs index 52923e65..212ad8b8 100644 --- a/thentos-core/src/Thentos/Action.hs +++ b/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 () diff --git a/thentos-core/src/Thentos/Backend/Api/Docs/Common.hs b/thentos-core/src/Thentos/Backend/Api/Docs/Common.hs index dbac80c7..871ff4c1 100644 --- a/thentos-core/src/Thentos/Backend/Api/Docs/Common.hs +++ b/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:) diff --git a/thentos-core/src/Thentos/Backend/Api/Simple.hs b/thentos-core/src/Thentos/Backend/Api/Simple.hs index 787551eb..a6c6bd90 100644 --- a/thentos-core/src/Thentos/Backend/Api/Simple.hs +++ b/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 diff --git a/thentos-core/src/Thentos/Transaction.hs b/thentos-core/src/Thentos/Transaction.hs index a34f29ca..a2c3951f 100644 --- a/thentos-core/src/Thentos/Transaction.hs +++ b/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. diff --git a/thentos-core/src/Thentos/Types.hs b/thentos-core/src/Thentos/Types.hs index 783fcd30..7a89693a 100644 --- a/thentos-core/src/Thentos/Types.hs +++ b/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 diff --git a/thentos-core/thentos-core.cabal b/thentos-core/thentos-core.cabal index 64553451..5408e464 100644 --- a/thentos-core/thentos-core.cabal +++ b/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 diff --git a/thentos-tests/tests/Thentos/ActionSpec.hs b/thentos-tests/tests/Thentos/ActionSpec.hs index 2e3161e5..081ec922 100644 --- a/thentos-tests/tests/Thentos/ActionSpec.hs +++ b/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 diff --git a/thentos-tests/tests/Thentos/Backend/Api/SimpleSpec.hs b/thentos-tests/tests/Thentos/Backend/Api/SimpleSpec.hs index c9bb74f1..d0febd9b 100644 --- a/thentos-tests/tests/Thentos/Backend/Api/SimpleSpec.hs +++ b/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 diff --git a/thentos-tests/thentos-tests.cabal b/thentos-tests/thentos-tests.cabal index 042cf8c4..a706849d 100644 --- a/thentos-tests/thentos-tests.cabal +++ b/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