store: move the HTTP helpers into Web.Http

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

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 =

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)

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 ()