diff --git a/apps/simplex-store-service/src/StoreService/Web/Http.hs b/apps/simplex-store-service/src/StoreService/Web/Http.hs new file mode 100644 index 0000000000..3fc855f22b --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Web/Http.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module StoreService.Web.Http + ( HttpEnv (..), + newHttpEnv, + Respond, + Limit (..), + takeToken, + limited, + only, + clientKey, + maxBuckets, + readLimit, + createLimit, + searchLimit, + previewLimit, + codeLimit, + findLimit, + recordsLimit, + holdMicros, + jsonResponse, + jsonError, + notFound, + badRequest, + codeConflict, + providerUnavailable, + rateLimited, + methodNotAllowed, + internalError, + readBoundedBody, + maxBodyBytes, + nameBodyBytes, + parseCodeHash, + ) +where + +import Control.Concurrent.STM +import Data.Aeson ((.=)) +import qualified Data.Aeson as J +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.List (sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Data.Word (Word16) +import Network.HTTP.Types (Header, Method, Status, hCacheControl, hContentType, status400, status404, status405, status409, status429, status500, status503) +import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple) +import Network.Wai +import Numeric (showHex) +import Simplex.Messaging.Util (safeDecodeUtf8) +import StoreService.Config (ListenerConfig (..)) +import Text.Read (readMaybe) + +data HttpEnv = HttpEnv + { heBuckets :: TVar (Map Text Bucket), + heTrustForwardedFor :: Bool + } + +newHttpEnv :: ListenerConfig -> IO HttpEnv +newHttpEnv ListenerConfig {lTrustForwardedFor} = do + heBuckets <- newTVarIO Map.empty + pure HttpEnv {heBuckets, heTrustForwardedFor = lTrustForwardedFor} + +type Respond = Response -> IO ResponseReceived + +-- | Short enough to stay under the idle timeout of any proxy in front of us. +holdMicros :: Int +holdMicros = 30 * 1000000 + +readLimit, createLimit, searchLimit, previewLimit, codeLimit, findLimit, recordsLimit :: Limit +readLimit = Limit {lmName = "read", lmPerMinute = 60} +createLimit = Limit {lmName = "create", lmPerMinute = 5} +searchLimit = Limit {lmName = "search", lmPerMinute = 30} +previewLimit = Limit {lmName = "preview", lmPerMinute = 20} +codeLimit = Limit {lmName = "code", lmPerMinute = 10} +findLimit = Limit {lmName = "find", lmPerMinute = 5} +recordsLimit = Limit {lmName = "records", lmPerMinute = 10} + +maxBodyBytes :: Int +maxBodyBytes = 8192 + +-- | The cap of the names endpoints whose bodies carry a sealed name code. +nameBodyBytes :: Int +nameBodyBytes = 16384 + +sha256Bytes :: Int +sha256Bytes = 32 + +codeHashChars :: Int +codeHashChars = 43 + +data Limit = Limit {lmName :: Text, lmPerMinute :: Int} + deriving (Eq, Show) + +data Bucket = Bucket {bkCount :: Int, bkStarted :: UTCTime} + +limitWindow :: NominalDiffTime +limitWindow = 60 + +maxBuckets :: Int +maxBuckets = 32768 + +reclaim :: UTCTime -> Map Text Bucket -> Map Text Bucket +reclaim now buckets + | Map.size buckets < maxBuckets = buckets + | Map.size live * 2 <= maxBuckets = live + | otherwise = Map.fromList (drop (Map.size live `div` 2) (sortOn (bkCount . snd) (Map.toList live))) + where + live = Map.filter (fresh now) buckets + +fresh :: UTCTime -> Bucket -> Bool +fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow + +takeToken :: HttpEnv -> Limit -> Text -> IO (Maybe Int) +takeToken HttpEnv {heBuckets} Limit {lmName, lmPerMinute} client = do + now <- getCurrentTime + atomically $ do + buckets <- reclaim now <$> readTVar heBuckets + let key = lmName <> "\t" <> client + count bucket = writeTVar heBuckets (Map.insert key bucket buckets) >> pure Nothing + -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit + refuse seconds = writeTVar heBuckets buckets >> pure (Just seconds) + case Map.lookup key buckets of + Just bucket@Bucket {bkCount, bkStarted} + | fresh now bucket -> + if bkCount < lmPerMinute + then count bucket {bkCount = bkCount + 1} + else refuse (secondsLeft now bkStarted) + _ -> count Bucket {bkCount = 1, bkStarted = now} + where + secondsLeft :: UTCTime -> UTCTime -> Int + secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started)) + +limited :: HttpEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived +limited env limit req respond action = + takeToken env limit (clientKey env req) >>= \case + Nothing -> action + Just seconds -> respond (rateLimited seconds) + +only :: Method -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived +only method req respond action + | requestMethod req == method = action + | otherwise = respond (methodNotAllowed method) + +-- | Every line is joined first, so a second header line a caller adds cannot leave its own line the one we read. +clientKey :: HttpEnv -> Request -> Text +clientKey HttpEnv {heTrustForwardedFor} req = fromMaybe (peerText (remoteHost req)) forwarded + where + forwarded + | not heTrustForwardedFor = Nothing + | otherwise = case reverse (concatMap entries (requestHeaders req)) of + (ip : _) | isIpAddress ip -> Just ip + _ -> Nothing + entries (name, raw) + | name /= "x-forwarded-for" = [] + | otherwise = either (const []) (filter (not . T.null) . map T.strip . T.splitOn ",") (decodeUtf8' raw) + +isIpAddress :: Text -> Bool +isIpAddress t = isIPv4 t || isIPv6 t + +asciiDigit :: Char -> Bool +asciiDigit c = c >= '0' && c <= '9' + +-- Data.Char.isDigit and isHexDigit accept Unicode digits, which are not addresses. +asciiHexDigit :: Char -> Bool +asciiHexDigit c = asciiDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') + +-- | A leading zero is refused, so "010.0.0.1" cannot be a second key for "10.0.0.1". +isIPv4 :: Text -> Bool +isIPv4 t = case T.splitOn "." t of + [a, b, c, d] -> all octet [a, b, c, d] + _ -> False + where + octet s = + not (T.null s) + && T.length s <= 3 + && T.all asciiDigit s + && (T.length s == 1 || T.head s /= '0') + && maybe False (<= 255) (readMaybe (T.unpack s) :: Maybe Int) + +isIPv6 :: Text -> Bool +isIPv6 t + | T.any (== '%') t = False + | otherwise = case T.splitOn "::" t of + [full] -> groupCount True (segments full) == Just 8 + [before, after] -> case (groupCount False (segments before), groupCount True (segments after)) of + (Just b, Just a) -> b + a <= 7 -- "::" stands for at least one omitted group + _ -> False + _ -> False + where + segments s = if T.null s then [] else T.splitOn ":" s + +groupCount :: Bool -> [Text] -> Maybe Int +groupCount endsAddress gs + | null gs = Just 0 + | endsAddress && isIPv4 (last gs) = (+ 2) <$> plainGroups (init gs) + | otherwise = plainGroups gs + where + plainGroups ps = if all hexGroup ps then Just (length ps) else Nothing + hexGroup g = not (T.null g) && T.length g <= 4 && T.all asciiHexDigit g + +peerText :: SockAddr -> Text +peerText = \case + SockAddrInet _ addr -> + let (a, b, c, d) = hostAddressToTuple addr + in T.intercalate "." (map tshowInt [a, b, c, d]) + SockAddrInet6 _ _ addr _ -> + let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple addr + in T.intercalate ":" (map hex16 [a, b, c, d, e, f, g, h]) + SockAddrUnix p -> "unix:" <> T.pack p + where + tshowInt :: Show a => a -> Text + tshowInt = T.pack . show + hex16 :: Word16 -> Text + hex16 w = T.pack (showHex w "") + +apiHeaders :: [Header] +apiHeaders = [(hContentType, "application/json"), (hCacheControl, "no-store")] + +jsonResponse :: Status -> J.Value -> Response +jsonResponse st = responseLBS st apiHeaders . J.encode + +jsonError :: Status -> Text -> Response +jsonError st code = jsonResponse st (J.object ["error" .= code]) + +notFound :: Response +notFound = jsonError status404 "not_found" + +badRequest :: Response +badRequest = jsonError status400 "bad_request" + +codeConflict :: Response +codeConflict = jsonError status409 "code_conflict" + +providerUnavailable :: Response +providerUnavailable = jsonError status503 "provider_unavailable" + +rateLimited :: Int -> Response +rateLimited seconds = + responseLBS + status429 + (("Retry-After", B.pack (show seconds)) : apiHeaders) + (J.encode (J.object ["error" .= ("rate_limited" :: Text)])) + +methodNotAllowed :: Method -> Response +methodNotAllowed allow = responseLBS status405 (("Allow", allow) : apiHeaders) (J.encode (J.object ["error" .= ("method_not_allowed" :: Text)])) + +internalError :: Response +internalError = jsonError status500 "internal" + +-- | Returns the bytes exactly as they arrived, since the webhook signature is over those bytes. +readBoundedBody :: Int -> Request -> IO (Maybe LB.ByteString) +readBoundedBody cap req = go 0 [] + where + go :: Int -> [ByteString] -> IO (Maybe LB.ByteString) + go read' acc = do + chunk <- getRequestBodyChunk req + if BS.null chunk + then pure (Just (LB.fromChunks (reverse acc))) + else + let read'' = read' + BS.length chunk + in if read'' > cap then pure Nothing else go read'' (chunk : acc) + +-- | The last character of a 43-character base64 string has two bits no digest byte uses, so a lax +-- decoder would accept four spellings of the same digest, which the re-encode check rejects. +parseCodeHash :: Text -> Maybe ByteString +parseCodeHash t + | T.length t /= codeHashChars = Nothing + | otherwise = case B64U.decode (encodeUtf8 (t <> "=")) of + Right bytes | BS.length bytes == sha256Bytes, canonical bytes == t -> Just bytes + _ -> Nothing + where + canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode diff --git a/apps/simplex-store-service/src/StoreService/Web/Server.hs b/apps/simplex-store-service/src/StoreService/Web/Server.hs index 16fa2b7ba5..7a6318c1b6 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Server.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Server.hs @@ -5,17 +5,12 @@ module StoreService.Web.Server ( WebEnv (..), - Limit (..), newWebEnv, exportWebapp, - takeToken, - maxBuckets, maxWebhookBytes, webApp, webSettings, runWebListener, - holdMicros, - readLimit, ) where @@ -25,6 +20,7 @@ import StoreService.Poller (ReadHints, queueReadHint) import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), WebhookError (..)) import StoreService.Store.Invoices (CreateError (..), InvoicePayment (..), InvoiceRow (..), NewInvoice (..), cancelOpenInvoice, codeHashExists, createInvoiceRows, cryptoCurrencyText, getInvoice, getInvoiceByProviderRef, invoiceStatusText, newInvoiceId, paymentHolds, readCatalogRows, textToInvoiceStatus, truncateToSecond) import StoreService.Waiters (Seen, Waiters, awaitStatus, publish) +import StoreService.Web.Http import Control.Concurrent.STM import qualified Control.Exception as E import StoreService.Log (logError, logInfo, logWarn) @@ -35,33 +31,25 @@ import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Pair) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64.URL as B64U -import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) -import Data.List (find, isPrefixOf, sortOn) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map +import Data.List (find, isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8', encodeUtf8) -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) -import Data.Word (Word16) -import Network.HTTP.Types (Header, Status, hCacheControl, hContentType, status200, status400, status404, status405, status409, status413, status429, status500, status503) -import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) +import Network.HTTP.Types (Header, Status, hCacheControl, hContentType, status200, status400, status409, status413) import Network.Wai import qualified Network.Wai.Handler.Warp as Warp -import Numeric (showHex) import Simplex.Chat.Badges.Types (BadgeOfferId (..), BadgePriceId (..)) import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) import Simplex.Messaging.Agent.Store.Common (DBStore) import Simplex.Messaging.Encoding.String (textEncode) -import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +import Simplex.Messaging.Util (tshow) import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removePathForcibly) import System.FilePath (pathSeparator, takeExtension, ()) -import Text.Read (readMaybe) data WebEnv = WebEnv { weStore :: DBStore, @@ -70,201 +58,26 @@ data WebEnv = WebEnv weProviders :: [Provider], weHoldMicros :: Int, weHints :: ReadHints, - weBuckets :: TVar (Map Text Bucket), + weHttp :: HttpEnv, -- | @Nothing@ when no Stripe key is configured, and the pristine @static_dir@ shell is served instead. weShell :: Maybe LB.ByteString } newWebEnv :: DBStore -> ServiceConfig -> Waiters -> ReadHints -> [Provider] -> IO WebEnv newWebEnv weStore weConfig weWaiters weHints weProviders = do - weBuckets <- newTVarIO Map.empty + weHttp <- newHttpEnv (listener weConfig) weShell <- prepareShell (listener weConfig) (stripe weConfig) - pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weBuckets, weShell} + pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weHttp, weShell} listenerConfig :: WebEnv -> ListenerConfig listenerConfig WebEnv {weConfig} = listener weConfig -type Respond = Response -> IO ResponseReceived - --- | Short enough to stay under the idle timeout of any proxy in front of us. -holdMicros :: Int -holdMicros = 30 * 1000000 - -readLimit :: Limit -readLimit = Limit {lmName = "read", lmPerMinute = 60} - -createLimit :: Limit -createLimit = Limit {lmName = "create", lmPerMinute = 5} - -maxBodyBytes :: Int -maxBodyBytes = 8192 - maxWebhookBytes :: Int maxWebhookBytes = 64 * 1024 -sha256Bytes :: Int -sha256Bytes = 32 - -codeHashChars :: Int -codeHashChars = 43 - -data Limit = Limit {lmName :: Text, lmPerMinute :: Int} - deriving (Eq, Show) - -data Bucket = Bucket {bkCount :: Int, bkStarted :: UTCTime} - -limitWindow :: NominalDiffTime -limitWindow = 60 - -maxBuckets :: Int -maxBuckets = 8192 - -reclaim :: UTCTime -> Map Text Bucket -> Map Text Bucket -reclaim now buckets - | Map.size buckets < maxBuckets = buckets - | Map.size live * 2 <= maxBuckets = live - | otherwise = Map.fromList (drop (Map.size live `div` 2) (sortOn (bkCount . snd) (Map.toList live))) - where - live = Map.filter (fresh now) buckets - -fresh :: UTCTime -> Bucket -> Bool -fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow - -takeToken :: WebEnv -> Limit -> Text -> IO (Maybe Int) -takeToken WebEnv {weBuckets} Limit {lmName, lmPerMinute} client = do - now <- getCurrentTime - atomically $ do - buckets <- reclaim now <$> readTVar weBuckets - let key = lmName <> "\t" <> client - count bucket = writeTVar weBuckets (Map.insert key bucket buckets) >> pure Nothing - -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit - refuse seconds = writeTVar weBuckets buckets >> pure (Just seconds) - case Map.lookup key buckets of - Just bucket@Bucket {bkCount, bkStarted} - | fresh now bucket -> - if bkCount < lmPerMinute - then count bucket {bkCount = bkCount + 1} - else refuse (secondsLeft now bkStarted) - _ -> count Bucket {bkCount = 1, bkStarted = now} - where - secondsLeft :: UTCTime -> UTCTime -> Int - secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started)) - -limited :: WebEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived -limited env limit req respond action = - takeToken env limit (clientKey env req) >>= \case - Nothing -> action - Just seconds -> respond (rateLimited seconds) - --- | Every line is joined first, so a second header line a caller adds cannot leave its own line the one we read. -clientKey :: WebEnv -> Request -> Text -clientKey env req = fromMaybe (peerText (remoteHost req)) forwarded - where - forwarded - | not (lTrustForwardedFor (listenerConfig env)) = Nothing - | otherwise = case reverse (concatMap entries (requestHeaders req)) of - (ip : _) | isIpAddress ip -> Just ip - _ -> Nothing - entries (name, raw) - | name /= "x-forwarded-for" = [] - | otherwise = either (const []) (filter (not . T.null) . map T.strip . T.splitOn ",") (decodeUtf8' raw) - -isIpAddress :: Text -> Bool -isIpAddress t = isIPv4 t || isIPv6 t - -asciiDigit :: Char -> Bool -asciiDigit c = c >= '0' && c <= '9' - --- Data.Char.isDigit and isHexDigit accept Unicode digits, which are not addresses. -asciiHexDigit :: Char -> Bool -asciiHexDigit c = asciiDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') - --- | A leading zero is refused, so "010.0.0.1" cannot be a second key for "10.0.0.1". -isIPv4 :: Text -> Bool -isIPv4 t = case T.splitOn "." t of - [a, b, c, d] -> all octet [a, b, c, d] - _ -> False - where - octet s = - not (T.null s) - && T.length s <= 3 - && T.all asciiDigit s - && (T.length s == 1 || T.head s /= '0') - && maybe False (<= 255) (readMaybe (T.unpack s) :: Maybe Int) - -isIPv6 :: Text -> Bool -isIPv6 t - | T.any (== '%') t = False - | otherwise = case T.splitOn "::" t of - [full] -> groupCount True (segments full) == Just 8 - [before, after] -> case (groupCount False (segments before), groupCount True (segments after)) of - (Just b, Just a) -> b + a <= 7 -- "::" stands for at least one omitted group - _ -> False - _ -> False - where - segments s = if T.null s then [] else T.splitOn ":" s - -groupCount :: Bool -> [Text] -> Maybe Int -groupCount endsAddress gs - | null gs = Just 0 - | endsAddress && isIPv4 (last gs) = (+ 2) <$> plainGroups (init gs) - | otherwise = plainGroups gs - where - plainGroups ps = if all hexGroup ps then Just (length ps) else Nothing - hexGroup g = not (T.null g) && T.length g <= 4 && T.all asciiHexDigit g - -peerText :: SockAddr -> Text -peerText = \case - SockAddrInet _ addr -> - let (a, b, c, d) = hostAddressToTuple addr - in T.intercalate "." (map tshowInt [a, b, c, d]) - SockAddrInet6 _ _ addr _ -> - let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple addr - in T.intercalate ":" (map hex16 [a, b, c, d, e, f, g, h]) - SockAddrUnix p -> "unix:" <> T.pack p - where - tshowInt :: Show a => a -> Text - tshowInt = T.pack . show - hex16 :: Word16 -> Text - hex16 w = T.pack (showHex w "") - -apiHeaders :: [Header] -apiHeaders = [(hContentType, "application/json"), (hCacheControl, "no-store")] - -jsonResponse :: Status -> J.Value -> Response -jsonResponse st = responseLBS st apiHeaders . J.encode - -jsonError :: Status -> Text -> Response -jsonError st code = jsonResponse st (J.object ["error" .= code]) - -notFound :: Response -notFound = jsonError status404 "not_found" - -badRequest :: Response -badRequest = jsonError status400 "bad_request" - catalogChanged :: Response catalogChanged = jsonError status400 "catalog_changed" -codeConflict :: Response -codeConflict = jsonError status409 "code_conflict" - -providerUnavailable :: Response -providerUnavailable = jsonError status503 "provider_unavailable" - -rateLimited :: Int -> Response -rateLimited seconds = - responseLBS - status429 - (("Retry-After", B.pack (show seconds)) : apiHeaders) - (J.encode (J.object ["error" .= ("rate_limited" :: Text)])) - -methodNotAllowed :: ByteString -> Response -methodNotAllowed allow = responseLBS status405 (("Allow", allow) : apiHeaders) (J.encode (J.object ["error" .= ("method_not_allowed" :: Text)])) - -internalError :: Response -internalError = jsonError status500 "internal" - webhookOk, webhookRefused, webhookTooLarge :: Response webhookOk = webhookResponse status200 webhookRefused = webhookResponse status400 @@ -274,23 +87,20 @@ webhookResponse :: Status -> Response webhookResponse st = responseLBS st [(hCacheControl, "no-store")] "" webApp :: WebEnv -> Application -webApp env req respond = case pathInfo req of - [] | serving -> only "GET" $ case weShell env of +webApp env@WebEnv {weHttp} req respond = case pathInfo req of + [] | serving -> only "GET" req respond $ case weShell env of Just shell -> respond (responseLBS status200 shellHeaders shell) Nothing -> serveStatic env ["index.html"] respond - "assets" : rest | serving -> only "GET" $ serveStatic env ("assets" : rest) respond - ["sw.js"] | serving -> only "GET" $ serveStatic env ["sw.js"] respond - ["api", "invoice"] -> only "POST" $ limited env createLimit req respond $ createInvoiceHandler env req respond - ["api", "invoice", iid] -> only "GET" $ limited env readLimit req respond $ readInvoiceHandler env (InvoiceId iid) req respond - ["api", "invoice", iid, "cancel"] -> only "POST" $ limited env createLimit req respond $ cancelInvoiceHandler env (InvoiceId iid) respond - ["webhooks", "btcpay"] -> only "POST" $ webhookHandler env PPCrypto "POST /webhooks/btcpay" req respond - ["webhooks", "stripe"] -> only "POST" $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond + "assets" : rest | serving -> only "GET" req respond $ serveStatic env ("assets" : rest) respond + ["sw.js"] | serving -> only "GET" req respond $ serveStatic env ["sw.js"] respond + ["api", "invoice"] -> only "POST" req respond $ limited weHttp createLimit req respond $ createInvoiceHandler env req respond + ["api", "invoice", iid] -> only "GET" req respond $ limited weHttp readLimit req respond $ readInvoiceHandler env (InvoiceId iid) req respond + ["api", "invoice", iid, "cancel"] -> only "POST" req respond $ limited weHttp createLimit req respond $ cancelInvoiceHandler env (InvoiceId iid) respond + ["webhooks", "btcpay"] -> only "POST" req respond $ webhookHandler env PPCrypto "POST /webhooks/btcpay" req respond + ["webhooks", "stripe"] -> only "POST" req respond $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond _ -> respond notFound where serving = lServeWebapp (listenerConfig env) - only method action - | requestMethod req == method = action - | otherwise = respond (methodNotAllowed method) -- | A @".."@ check would miss separators WAI has already decoded, an absolute path, and a symlink out of the tree. serveStatic :: WebEnv -> [Text] -> Respond -> IO ResponseReceived @@ -610,19 +420,6 @@ providerOf = \case SPMCard CPStripe -> PPStripe SPMCrypto _ -> PPCrypto --- | Returns the bytes exactly as they arrived, since the webhook signature is over those bytes. -readBoundedBody :: Int -> Request -> IO (Maybe LB.ByteString) -readBoundedBody cap req = go 0 [] - where - go :: Int -> [ByteString] -> IO (Maybe LB.ByteString) - go read' acc = do - chunk <- getRequestBodyChunk req - if BS.null chunk - then pure (Just (LB.fromChunks (reverse acc))) - else - let read'' = read' + BS.length chunk - in if read'' > cap then pure Nothing else go read'' (chunk : acc) - parseCreateRequest :: LB.ByteString -> Maybe CreateRequest parseCreateRequest body = case J.decode body of Just (J.Object o) -> do @@ -649,17 +446,6 @@ methodFromText = \case "xmr" -> Just (SPMCrypto CCXmr) _ -> Nothing --- | The last character of a 43-character base64 string has two bits no digest byte uses, so a lax --- decoder would accept four spellings of the same digest, which the re-encode check rejects. -parseCodeHash :: Text -> Maybe ByteString -parseCodeHash t - | T.length t /= codeHashChars = Nothing - | otherwise = case B64U.decode (encodeUtf8 (t <> "=")) of - Right bytes | BS.length bytes == sha256Bytes, canonical bytes == t -> Just bytes - _ -> Nothing - where - canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode - -- | A provider retries a delivery it sees fail, so anything thrown below is caught and answered 200 anyway. webhookHandler :: WebEnv -> PaymentProvider -> Text -> Request -> Respond -> IO ResponseReceived webhookHandler env@WebEnv {weStore, weHints} provider route req respond = diff --git a/simplex-chat.cabal b/simplex-chat.cabal index a4ae682f6b..2812fc3435 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -453,6 +453,7 @@ executable simplex-store-service StoreService.Store.Invoices StoreService.Store.Migrate StoreService.Waiters + StoreService.Web.Http StoreService.Web.Server Paths_simplex_chat ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts @@ -772,6 +773,7 @@ test-suite simplex-chat-test StoreService.Store.Invoices StoreService.Store.Migrate StoreService.Waiters + StoreService.Web.Http StoreService.Web.Server Paths_simplex_chat if flag(client_postgres) diff --git a/tests/Bots/StoreService/WebTests.hs b/tests/Bots/StoreService/WebTests.hs index cfad4943eb..3634923275 100644 --- a/tests/Bots/StoreService/WebTests.hs +++ b/tests/Bots/StoreService/WebTests.hs @@ -17,6 +17,7 @@ import StoreService.Providers.Stripe (stripeProvider) import StoreService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode) import StoreService.Store.Invoices import StoreService.Waiters (awaitStatus, newWaiters, publish, waitingCount) +import StoreService.Web.Http import StoreService.Web.Server import Bots.StoreService.BotTests (codeCounts, newPurchaseKeys) import Bots.StoreService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource) @@ -1434,23 +1435,23 @@ testForwardedForMustBeAnAddress = bounded "forwarded-for is an address" $ withWe testBucketsStayBounded :: IO () testBucketsStayBounded = bounded "bucket cap" $ withWebApp $ \env _ -> do let clients = map (\i -> T.pack ("198.51." <> show (i `div` 256) <> "." <> show (i `mod` 256))) [1 .. maxBuckets * 2 + 100] - mapM_ (takeToken env readLimit) clients - held <- Map.size <$> readTVarIO (weBuckets env) + mapM_ (takeToken (weHttp env) readLimit) clients + held <- Map.size <$> readTVarIO (heBuckets (weHttp env)) held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets - answers <- mapM (\_ -> takeToken env readLimit "203.0.113.9") [1 .. readsPerMinute + 1] + answers <- mapM (\_ -> takeToken (weHttp env) readLimit "203.0.113.9") [1 .. readsPerMinute + 1] length (filter isJust answers) `shouldBe` 1 let fill i = do - n <- Map.size <$> readTVarIO (weBuckets env) + n <- Map.size <$> readTVarIO (heBuckets (weHttp env)) when (n < maxBuckets) $ do - _ <- takeToken env readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256))) + _ <- takeToken (weHttp env) readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256))) fill (i + 1) fill (1 :: Int) - atTheCap <- Map.size <$> readTVarIO (weBuckets env) + atTheCap <- Map.size <$> readTVarIO (heBuckets (weHttp env)) atTheCap `shouldBe` maxBuckets - refusedAgain <- takeToken env readLimit "203.0.113.9" + refusedAgain <- takeToken (weHttp env) readLimit "203.0.113.9" refusedAgain `shouldSatisfy` isJust - afterARefusal <- Map.size <$> readTVarIO (weBuckets env) + afterARefusal <- Map.size <$> readTVarIO (heBuckets (weHttp env)) afterARefusal `shouldSatisfy` (<= atTheCap `div` 2 + 1) testHoldReportsTheRowNotTheWake :: IO ()