mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-04 17:17:39 +00:00
428 lines
16 KiB
Haskell
428 lines
16 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Bots.StoreService.FakeStripe
|
|
( FakeStripe (..),
|
|
FakeRequest (..),
|
|
withFakeStripe,
|
|
fakeSessionMinutes,
|
|
setIntentState,
|
|
failNextCalls,
|
|
useListPageSize,
|
|
useListFixture,
|
|
apiRequests,
|
|
fakeIntentIds,
|
|
fakeIntentStatus,
|
|
stripeSigHeader,
|
|
stripeHexSig,
|
|
stripeEvent,
|
|
)
|
|
where
|
|
|
|
import StoreService.Config (StripeConfig (..))
|
|
import Control.Concurrent.STM
|
|
import Crypto.Hash (Digest, SHA256)
|
|
import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)
|
|
import qualified Data.Aeson as J
|
|
import Data.Aeson.Key (Key)
|
|
import qualified Data.Aeson.Key as K
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import Data.Aeson.Types (Pair)
|
|
import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
-- http-client is imported qualified because its Request has requestHeaders, requestBody and
|
|
-- queryString just as WAI's does.
|
|
import Network.HTTP.Client (Manager)
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import Network.HTTP.Types
|
|
( Query,
|
|
Status,
|
|
badRequest400,
|
|
hAuthorization,
|
|
hContentType,
|
|
methodGet,
|
|
methodPost,
|
|
mkStatus,
|
|
notFound404,
|
|
ok200,
|
|
parseSimpleQuery,
|
|
statusCode,
|
|
statusMessage,
|
|
unauthorized401,
|
|
)
|
|
import Network.HTTP.Types.Header (Header)
|
|
import Network.Wai (Application, Response, pathInfo, queryString, requestHeaders, requestMethod, responseLBS, strictRequestBody)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import Simplex.Messaging.Util (tshow)
|
|
import System.FilePath ((</>))
|
|
import Text.Read (readMaybe)
|
|
|
|
fixtureDir :: FilePath
|
|
fixtureDir = "apps" </> "simplex-store-service" </> "test-fixtures" </> "stripe"
|
|
|
|
-- | A restricted `rk_` key shaped like Stripe's, the kind the service is configured with and never a live one.
|
|
fakeSecretKey :: Text
|
|
fakeSecretKey = "rk_test_51QfakeKEY0000000000000000"
|
|
|
|
fakeWebhookSecret :: Text
|
|
fakeWebhookSecret = "whsec_3d8f5c6a2b1e4f7089abcdef01234567"
|
|
|
|
fakeSessionMinutes :: Int
|
|
fakeSessionMinutes = 60
|
|
|
|
data FakeRequest = FakeRequest
|
|
{ frMethod :: ByteString,
|
|
frPath :: [Text],
|
|
frQuery :: Query,
|
|
frHeaders :: [Header],
|
|
frBody :: LB.ByteString
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data IntentState = IntentState
|
|
{ isStatus :: Text,
|
|
isAmount :: Int,
|
|
isCurrency :: Text
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
data FailPlan = FailPlan {fpCalls :: Int, fpStatus :: Int}
|
|
deriving (Eq, Show)
|
|
|
|
data FakeState = FakeState
|
|
{ fsIntents :: M.Map Text IntentState,
|
|
fsNextId :: Int,
|
|
fsFail :: FailPlan,
|
|
fsList :: Text,
|
|
fsPageSize :: Maybe Int,
|
|
fsRequests :: [FakeRequest]
|
|
}
|
|
|
|
initialState :: FakeState
|
|
initialState =
|
|
FakeState
|
|
{ fsIntents = M.empty,
|
|
fsNextId = 1,
|
|
fsFail = FailPlan {fpCalls = 0, fpStatus = 0},
|
|
fsList = "intent-list",
|
|
fsPageSize = Nothing,
|
|
fsRequests = []
|
|
}
|
|
|
|
data FakeStripe = FakeStripe
|
|
{ fsConfig :: StripeConfig,
|
|
fsBaseUrl :: String,
|
|
fsManager :: Manager,
|
|
fsState :: TVar FakeState
|
|
}
|
|
|
|
-- | Warp chooses the port, because a fixed one could collide with a server left over from an
|
|
-- earlier run and the test would pass against that instead.
|
|
withFakeStripe :: (FakeStripe -> IO a) -> IO a
|
|
withFakeStripe action = do
|
|
fsState <- newTVarIO initialState
|
|
fsManager <- HTTP.newManager HTTP.defaultManagerSettings
|
|
Warp.testWithApplication (pure (fakeApp fsState)) $ \prt -> do
|
|
let fsBaseUrl = "http://127.0.0.1:" <> show prt
|
|
action FakeStripe {fsConfig = fakeConfig (T.pack fsBaseUrl), fsBaseUrl, fsManager, fsState}
|
|
|
|
fakeConfig :: Text -> StripeConfig
|
|
fakeConfig host =
|
|
StripeConfig
|
|
{ sSecretKey = fakeSecretKey,
|
|
sPublishableKey = "pk_test_x",
|
|
sWebhookSecret = fakeWebhookSecret,
|
|
sSessionMinutes = fakeSessionMinutes,
|
|
sHost = host
|
|
}
|
|
|
|
-- | Stripe-Signature: t=<unix>,v1=<hex HMAC-SHA256 of "t.body">.
|
|
stripeSigHeader :: Text -> Int -> LB.ByteString -> [Header]
|
|
stripeSigHeader secret t body =
|
|
[("Stripe-Signature", "t=" <> B8.pack (show t) <> ",v1=" <> stripeHexSig secret t body)]
|
|
|
|
stripeHexSig :: Text -> Int -> LB.ByteString -> ByteString
|
|
stripeHexSig secret t body = convertToBase Base16 digest
|
|
where
|
|
signed = TE.encodeUtf8 (T.pack (show t) <> ".") <> LB.toStrict body
|
|
digest :: Digest SHA256
|
|
digest = hmacGetDigest (hmac (TE.encodeUtf8 secret) signed :: HMAC SHA256)
|
|
|
|
-- | A minimal event of the shape @{type, data:{object:{id}}}@. The verify signs these exact bytes,
|
|
-- so a valid signature cannot mean two different things.
|
|
stripeEvent :: Text -> Text -> LB.ByteString
|
|
stripeEvent eventType pid =
|
|
J.encode (J.object ["type" J..= eventType, "data" J..= J.object ["object" J..= J.object ["id" J..= pid]]])
|
|
|
|
fixtureResponse :: Text -> IO J.Value
|
|
fixtureResponse name = do
|
|
raw <- LB.readFile path
|
|
case J.eitherDecode raw of
|
|
Left e -> fail (path <> ": " <> e)
|
|
Right (J.Object o) -> case (KM.lookup "_fixture" o, KM.lookup "response" o) of
|
|
(Just (J.String _), Just v) -> pure v
|
|
_ -> fail (path <> ": a fixture is {\"_fixture\": <provenance>, \"response\": <body>}")
|
|
Right _ -> fail (path <> ": a fixture is a JSON object")
|
|
where
|
|
path = fixtureDir </> T.unpack name <> ".json"
|
|
|
|
-- | An unknown status falls back to the open body but is patched to the status that was set, so a
|
|
-- status this build has never seen still reaches the adapter verbatim.
|
|
intentFixture :: IntentState -> Text
|
|
intentFixture IntentState {isStatus} = case isStatus of
|
|
"succeeded" -> "intent-succeeded"
|
|
"canceled" -> "intent-canceled"
|
|
_ -> "intent-open"
|
|
|
|
patchIntent :: Text -> IntentState -> J.Value -> J.Value
|
|
patchIntent pid IntentState {isStatus, isAmount, isCurrency} =
|
|
setField "id" (J.String pid)
|
|
. setField "client_secret" (J.String (pid <> "_secret_test"))
|
|
. setField "status" (J.String isStatus)
|
|
. setField "amount_received" (J.toJSON (if isStatus == "succeeded" then isAmount else (0 :: Int)))
|
|
. setField "currency" (J.String isCurrency)
|
|
|
|
setField :: Key -> J.Value -> J.Value -> J.Value
|
|
setField k v = \case
|
|
J.Object o -> J.Object (KM.insert k v o)
|
|
other -> other
|
|
|
|
fakeApp :: TVar FakeState -> Application
|
|
fakeApp stv req respond = do
|
|
body <- strictRequestBody req
|
|
case pathInfo req of
|
|
["_state", pid] | isPost -> control body (setState pid)
|
|
["_fail"] | isPost -> control body setFail
|
|
["_paging"] | isPost -> control body setPaging
|
|
["_fixtures"] | isPost -> control body setFixtures
|
|
"v1" : "payment_intents" : rest -> apiCall body rest
|
|
_ -> refuse notFound404 "no such path on the fake stripe"
|
|
where
|
|
verb = requestMethod req
|
|
isPost = verb == methodPost
|
|
isGet = verb == methodGet
|
|
refuse st message = respond (errorResponse st message)
|
|
ok = respond (jsonResponse ok200 (J.object ["ok" J..= True]))
|
|
|
|
control b act = case J.decode b of
|
|
Just (J.Object o) ->
|
|
act o >>= \case
|
|
Nothing -> ok
|
|
Just message -> refuse badRequest400 message
|
|
_ -> refuse badRequest400 "a control call takes a JSON object"
|
|
|
|
setState pid o = case unknownKeys stateKeys o of
|
|
Just message -> pure (Just message)
|
|
Nothing -> atomically $ do
|
|
st <- readTVar stv
|
|
case M.lookup pid (fsIntents st) of
|
|
Nothing -> pure (Just ("no intent " <> pid <> " was created here"))
|
|
Just s -> do
|
|
let s' = s {isStatus = fromMaybe (isStatus s) (textField "status" o)}
|
|
writeTVar stv st {fsIntents = M.insert pid s' (fsIntents st)}
|
|
pure Nothing
|
|
|
|
setFail o = case unknownKeys ["calls", "status"] o of
|
|
Just message -> pure (Just message)
|
|
Nothing -> case (intField "calls" o, intField "status" o) of
|
|
(Just calls, Just code) -> do
|
|
atomically (modifyTVar' stv (\st -> st {fsFail = FailPlan {fpCalls = calls, fpStatus = code}}))
|
|
pure Nothing
|
|
_ -> pure (Just "_fail takes {\"calls\": <n>, \"status\": <http status>}")
|
|
|
|
setPaging o = case unknownKeys ["size"] o of
|
|
Just message -> pure (Just message)
|
|
Nothing -> case intField "size" o of
|
|
Just size -> do
|
|
atomically (modifyTVar' stv (\st -> st {fsPageSize = Just size}))
|
|
pure Nothing
|
|
Nothing -> pure (Just "_paging takes {\"size\": <n>}")
|
|
|
|
setFixtures o = case unknownKeys ["list"] o of
|
|
Just message -> pure (Just message)
|
|
Nothing -> case textField "list" o of
|
|
Just name -> do
|
|
atomically (modifyTVar' stv (\st -> st {fsList = name}))
|
|
pure Nothing
|
|
Nothing -> pure (Just "_fixtures takes {\"list\": <fixture name>}")
|
|
|
|
apiCall b rest = do
|
|
atomically $
|
|
modifyTVar' stv $ \st ->
|
|
st {fsRequests = FakeRequest verb (pathInfo req) (queryString req) (requestHeaders req) b : fsRequests st}
|
|
case lookup hAuthorization (requestHeaders req) of
|
|
Just given | given == expectedAuth -> injectingFailure (route b rest)
|
|
_ -> refuse unauthorized401 "Authorization must be HTTP Basic with the secret key as username"
|
|
|
|
-- Stripe authenticates the secret key as the Basic username with an empty password, which is
|
|
-- how http-client's applyBasicAuth builds the header.
|
|
expectedAuth = "Basic " <> convertToBase Base64 (TE.encodeUtf8 (fakeSecretKey <> ":"))
|
|
|
|
injectingFailure act = do
|
|
failing <- atomically $ do
|
|
st <- readTVar stv
|
|
case fsFail st of
|
|
plan@FailPlan {fpCalls, fpStatus} | fpCalls > 0 -> do
|
|
writeTVar stv st {fsFail = plan {fpCalls = fpCalls - 1}}
|
|
pure (Just fpStatus)
|
|
_ -> pure Nothing
|
|
case failing of
|
|
Just code -> refuse (mkStatus code "Injected Failure") "the fake was told to fail this call"
|
|
Nothing -> act
|
|
|
|
route b = \case
|
|
[] | isPost -> createIntent b
|
|
[] | isGet -> listIntents
|
|
[pid] | isGet -> withIntent pid $ \s -> serve (intentFixture s) (patchIntent pid s)
|
|
[pid, "cancel"] | isPost -> cancelIntent pid
|
|
_ -> refuse notFound404 "no such payment_intents path on the fake stripe"
|
|
|
|
createIntent b = do
|
|
let form = parseSimpleQuery (LB.toStrict b)
|
|
amount = fromMaybe 0 (lookup "amount" form >>= readMaybe . B8.unpack)
|
|
currency = maybe "usd" TE.decodeUtf8 (lookup "currency" form)
|
|
(pid, s) <- atomically $ do
|
|
st <- readTVar stv
|
|
let pid = "pi_test_" <> T.justifyRight 4 '0' (tshow (fsNextId st))
|
|
s = IntentState {isStatus = "requires_payment_method", isAmount = amount, isCurrency = currency}
|
|
writeTVar stv st {fsNextId = fsNextId st + 1, fsIntents = M.insert pid s (fsIntents st)}
|
|
pure (pid, s)
|
|
serve (intentFixture s) (patchIntent pid s)
|
|
|
|
-- Real Stripe can't cancel a card payment that is processing, paid or already cancelled.
|
|
cancelIntent pid = do
|
|
cancelled <- atomically $ do
|
|
st <- readTVar stv
|
|
case M.lookup pid (fsIntents st) of
|
|
Nothing -> pure Nothing
|
|
Just s
|
|
| isStatus s `elem` ["processing", "succeeded", "canceled"] -> pure (Just (Left s))
|
|
| otherwise -> do
|
|
let s' = s {isStatus = "canceled"}
|
|
writeTVar stv st {fsIntents = M.insert pid s' (fsIntents st)}
|
|
pure (Just (Right s'))
|
|
case cancelled of
|
|
Nothing -> refuse notFound404 ("no intent " <> pid <> " on the fake stripe")
|
|
Just (Left s) ->
|
|
respond . stripeError badRequest400 "payment_intent_unexpected_state" $
|
|
"You cannot cancel this PaymentIntent because it has a status of " <> isStatus s <> "."
|
|
Just (Right s') -> serve (intentFixture s') (patchIntent pid s')
|
|
|
|
listIntents = do
|
|
st <- readTVarIO stv
|
|
full <- fixtureResponse (fsList st)
|
|
let (page, more) = pageItems (fsPageSize st) (queryText "starting_after" (queryString req)) (listItems full)
|
|
respond (jsonResponse ok200 (J.object ["object" J..= ("list" :: Text), "data" J..= page, "has_more" J..= more]))
|
|
|
|
serve name patch = do
|
|
v <- fixtureResponse name
|
|
respond (jsonResponse ok200 (patch v))
|
|
|
|
withIntent pid act = do
|
|
intents <- fsIntents <$> readTVarIO stv
|
|
case M.lookup pid intents of
|
|
Just s -> act s
|
|
Nothing -> refuse notFound404 ("no intent " <> pid <> " on the fake stripe")
|
|
|
|
listItems :: J.Value -> [J.Value]
|
|
listItems = \case
|
|
J.Object o -> case KM.lookup "data" o of
|
|
Just (J.Array vs) -> foldr (:) [] vs
|
|
_ -> []
|
|
_ -> []
|
|
|
|
-- | No page size serves the whole array. With one, `starting_after` names the id after which
|
|
-- the page begins, and `has_more` says whether anything is left.
|
|
pageItems :: Maybe Int -> Maybe Text -> [J.Value] -> ([J.Value], Bool)
|
|
pageItems Nothing _ items = (items, False)
|
|
pageItems (Just size) after items = (take size rest, length rest > size)
|
|
where
|
|
rest = case after of
|
|
Nothing -> items
|
|
Just a -> drop 1 (dropWhile ((/= Just a) . intentId) items)
|
|
|
|
intentId :: J.Value -> Maybe Text
|
|
intentId = \case
|
|
J.Object o -> case KM.lookup "id" o of
|
|
Just (J.String i) -> Just i
|
|
_ -> Nothing
|
|
_ -> Nothing
|
|
|
|
queryText :: ByteString -> Query -> Maybe Text
|
|
queryText k q = case lookup k q of
|
|
Just (Just v) -> Just (TE.decodeUtf8 v)
|
|
_ -> Nothing
|
|
|
|
jsonResponse :: Status -> J.Value -> Response
|
|
jsonResponse st v = responseLBS st [(hContentType, "application/json")] (J.encode v)
|
|
|
|
errorResponse :: Status -> Text -> Response
|
|
errorResponse st = stripeError st (TE.decodeUtf8 (statusMessage st))
|
|
|
|
stripeError :: Status -> Text -> Text -> Response
|
|
stripeError st code message = jsonResponse st (J.object ["error" J..= J.object ["message" J..= message, "code" J..= code]])
|
|
|
|
stateKeys :: [Key]
|
|
stateKeys = ["status"]
|
|
|
|
unknownKeys :: [Key] -> J.Object -> Maybe Text
|
|
unknownKeys known o = case filter (`notElem` known) (KM.keys o) of
|
|
k : _ -> Just ("this control call does not set " <> K.toText k)
|
|
[] -> Nothing
|
|
|
|
textField :: Key -> J.Object -> Maybe Text
|
|
textField k o = case KM.lookup k o of
|
|
Just (J.String t) -> Just t
|
|
_ -> Nothing
|
|
|
|
intField :: Key -> J.Object -> Maybe Int
|
|
intField k o = case KM.lookup k o of
|
|
Just n -> case J.fromJSON n of
|
|
J.Success i -> Just i
|
|
J.Error _ -> Nothing
|
|
Nothing -> Nothing
|
|
|
|
controlPost :: FakeStripe -> String -> J.Value -> IO ()
|
|
controlPost FakeStripe {fsBaseUrl, fsManager} path v = do
|
|
req <- HTTP.parseRequest (fsBaseUrl <> path)
|
|
r <- HTTP.httpLbs req {HTTP.method = methodPost, HTTP.requestBody = HTTP.RequestBodyLBS (J.encode v)} fsManager
|
|
case statusCode (HTTP.responseStatus r) of
|
|
200 -> pure ()
|
|
code -> fail ("fake stripe " <> path <> " answered " <> show code <> ": " <> show (HTTP.responseBody r))
|
|
|
|
setIntentState :: FakeStripe -> Text -> [Pair] -> IO ()
|
|
setIntentState fake pid fields = controlPost fake ("/_state/" <> T.unpack pid) (J.object fields)
|
|
|
|
failNextCalls :: FakeStripe -> Int -> Int -> IO ()
|
|
failNextCalls fake calls code = controlPost fake "/_fail" (J.object ["calls" J..= calls, "status" J..= code])
|
|
|
|
useListPageSize :: FakeStripe -> Int -> IO ()
|
|
useListPageSize fake size = controlPost fake "/_paging" (J.object ["size" J..= size])
|
|
|
|
useListFixture :: FakeStripe -> Text -> IO ()
|
|
useListFixture fake name = controlPost fake "/_fixtures" (J.object ["list" J..= name])
|
|
|
|
fakeRequests :: FakeStripe -> IO [FakeRequest]
|
|
fakeRequests FakeStripe {fsState} = reverse . fsRequests <$> readTVarIO fsState
|
|
|
|
fakeIntentIds :: FakeStripe -> IO [Text]
|
|
fakeIntentIds FakeStripe {fsState} = M.keys . fsIntents <$> readTVarIO fsState
|
|
|
|
fakeIntentStatus :: FakeStripe -> Text -> IO (Maybe Text)
|
|
fakeIntentStatus FakeStripe {fsState} pid = fmap isStatus . M.lookup pid . fsIntents <$> readTVarIO fsState
|
|
|
|
apiRequests :: FakeStripe -> ByteString -> [Text] -> IO [FakeRequest]
|
|
apiRequests fake verb segments = filter matching <$> fakeRequests fake
|
|
where
|
|
matching FakeRequest {frMethod, frPath} =
|
|
frMethod == verb && frPath == ["v1", "payment_intents"] <> segments
|