From 9f6b8f382784bb446e05e7f88d409cd1dcf7c59c Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Sat, 28 Mar 2026 22:02:39 +0000 Subject: [PATCH 1/3] Add Scotty: Haskell web framework on Warp (first Haskell entry!) Scotty is a lightweight Haskell web framework inspired by Ruby's Sinatra, built on top of the high-performance Warp HTTP server. - Language: Haskell (GHC 9.8, compiled with -O2 -threaded) - Engine: Warp - Tests: baseline, pipelined, noisy, limited-conn, json, upload, compression, mixed, async-db, static - All 29 validation checks pass Implementation notes: - Dataset and large payload pre-loaded into memory at startup - Static files cached in a Map at startup with correct MIME types - Manual gzip/deflate compression using zlib (level 1 for speed) - SQLite via sqlite-simple, PostgreSQL via postgresql-simple - Multi-stage Docker build with bookworm-slim runtime --- frameworks/scotty/Dockerfile | 35 +++ frameworks/scotty/Main.hs | 324 +++++++++++++++++++++++++++ frameworks/scotty/meta.json | 21 ++ frameworks/scotty/scotty-bench.cabal | 28 +++ 4 files changed, 408 insertions(+) create mode 100644 frameworks/scotty/Dockerfile create mode 100644 frameworks/scotty/Main.hs create mode 100644 frameworks/scotty/meta.json create mode 100644 frameworks/scotty/scotty-bench.cabal diff --git a/frameworks/scotty/Dockerfile b/frameworks/scotty/Dockerfile new file mode 100644 index 00000000..be8f40a1 --- /dev/null +++ b/frameworks/scotty/Dockerfile @@ -0,0 +1,35 @@ +FROM haskell:9.8-slim AS builder + +# Fix archived bullseye repos and install build dependencies +RUN sed -i 's|deb.debian.org|archive.debian.org|g' /etc/apt/sources.list && \ + sed -i '/bullseye-updates/d' /etc/apt/sources.list && \ + sed -i '/bullseye-security/d' /etc/apt/sources.list && \ + apt-get -o Acquire::Check-Valid-Until=false update && \ + apt-get install -y --no-install-recommends --allow-downgrades \ + libsqlite3-0=3.34.1-3 libsqlite3-dev libpq-dev zlib1g-dev pkg-config && \ + rm -rf /var/lib/apt/lists/* + +WORKDIR /build + +COPY scotty-bench.cabal . +RUN cabal update && \ + cabal build --only-dependencies \ + --constraint='postgresql-libpq-configure < 0.11' + +COPY Main.hs . +RUN cabal build \ + --constraint='postgresql-libpq-configure < 0.11' && \ + cp $(cabal list-bin scotty-bench) /build/scotty-bench + +FROM debian:bookworm-slim + +RUN apt-get update && \ + apt-get install -y --no-install-recommends libpq5 libsqlite3-0 zlib1g libgmp10 && \ + rm -rf /var/lib/apt/lists/* + +WORKDIR /app +COPY --from=builder /build/scotty-bench /app/scotty-bench + +EXPOSE 8080 + +CMD ["/app/scotty-bench"] diff --git a/frameworks/scotty/Main.hs b/frameworks/scotty/Main.hs new file mode 100644 index 00000000..5fa62e2b --- /dev/null +++ b/frameworks/scotty/Main.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Web.Scotty +import Network.Wai (rawQueryString, requestMethod, requestHeaders) +import Network.Wai.Handler.Warp (defaultSettings, setPort) +import Network.HTTP.Types.Status (status404, status500) +import Network.HTTP.Types.Method (methodPost) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Encoding as TE +import Data.Aeson (FromJSON, Value(..), encode, eitherDecodeStrict, object, (.=), (.:)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson + +import qualified Codec.Compression.GZip as GZip +import qualified Codec.Compression.Zlib as Zlib + +import qualified Database.SQLite.Simple as SQLite +import qualified Database.PostgreSQL.Simple as PG + +import Data.IORef +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Char (isSpace) +import qualified Data.Map.Strict as Map +import System.Environment (lookupEnv) +import System.Directory (doesFileExist, doesDirectoryExist, listDirectory) +import System.FilePath (takeExtension, ()) +import Control.Monad (when, forM) +import Control.Monad.IO.Class (liftIO) +import Control.Exception (try, SomeException, bracket) +import Text.Read (readMaybe) + +-- Dataset item as loaded from JSON +data DatasetItem = DatasetItem + { diId :: !Int + , diName :: !T.Text + , diCategory :: !T.Text + , diPrice :: !Double + , diQuantity :: !Int + , diActive :: !Bool + , diTags :: ![T.Text] + , diRating :: !RatingVal + } deriving (Show) + +data RatingVal = RatingVal + { rvScore :: !Double + , rvCount :: !Int + } deriving (Show) + +instance FromJSON RatingVal where + parseJSON = Aeson.withObject "RatingVal" $ \v -> + RatingVal <$> v .: "score" <*> v .: "count" + +instance FromJSON DatasetItem where + parseJSON = Aeson.withObject "DatasetItem" $ \v -> + DatasetItem + <$> v .: "id" + <*> v .: "name" + <*> v .: "category" + <*> v .: "price" + <*> v .: "quantity" + <*> v .: "active" + <*> v .: "tags" + <*> v .: "rating" + +-- Build processed JSON Value from DatasetItem (with total field) +processedItemValue :: DatasetItem -> Value +processedItemValue di = object + [ "id" .= diId di + , "name" .= diName di + , "category" .= diCategory di + , "price" .= diPrice di + , "quantity" .= diQuantity di + , "active" .= diActive di + , "tags" .= diTags di + , "rating" .= object ["score" .= rvScore (diRating di), "count" .= rvCount (diRating di)] + , "total" .= (fromIntegral (round (diPrice di * fromIntegral (diQuantity di) * 100) :: Int) / 100.0 :: Double) + ] + +-- Parse query string: "?a=1&b=2" -> sum of integer values +parseQuerySum :: BS.ByteString -> Int +parseQuerySum qs = + let qs' = if not (BS.null qs) && BS.head qs == 63 {- '?' -} then BS.drop 1 qs else qs + pairs = BC.split '&' qs' + parseVal pair = case BC.split '=' pair of + [_, v] -> readMaybe (BC.unpack v) :: Maybe Int + _ -> Nothing + in sum $ mapMaybe parseVal pairs + +-- MIME type lookup +mimeForExt :: String -> BS.ByteString +mimeForExt ".css" = "text/css" +mimeForExt ".js" = "application/javascript" +mimeForExt ".html" = "text/html" +mimeForExt ".woff2" = "font/woff2" +mimeForExt ".svg" = "image/svg+xml" +mimeForExt ".webp" = "image/webp" +mimeForExt ".json" = "application/json" +mimeForExt _ = "application/octet-stream" + +main :: IO () +main = do + -- Load dataset + datasetPath <- fromMaybe "/data/dataset.json" <$> lookupEnv "DATASET_PATH" + datasetItems <- do + exists <- doesFileExist datasetPath + if exists + then do + raw <- BS.readFile datasetPath + case eitherDecodeStrict raw of + Right items -> return (items :: [DatasetItem]) + Left _ -> return [] + else return [] + + -- Pre-compute large JSON payload for compression endpoint + largePayload <- do + exists <- doesFileExist "/data/dataset-large.json" + if exists + then do + raw <- BS.readFile "/data/dataset-large.json" + case eitherDecodeStrict raw of + Right items -> do + let processed = map processedItemValue (items :: [DatasetItem]) + resp = encode $ object ["items" .= processed, "count" .= length processed] + return (Just (BL.toStrict resp)) + Left _ -> return Nothing + else return Nothing + + -- Load static files into memory + staticCache <- do + let dir = "/data/static" + exists <- doesDirectoryExist dir + if exists + then do + files <- listDirectory dir + entries <- forM files $ \name -> do + content <- BS.readFile (dir name) + let ct = mimeForExt (takeExtension name) + return (name, (content, ct)) + return (Map.fromList entries) + else return Map.empty + + -- SQLite connection (read-only) + dbRef <- newIORef (Nothing :: Maybe SQLite.Connection) + do + exists <- doesFileExist "/data/benchmark.db" + when exists $ do + conn <- SQLite.open "/data/benchmark.db" + SQLite.execute_ conn "PRAGMA mmap_size=268435456" + writeIORef dbRef (Just conn) + + -- Postgres URL + pgUrl <- lookupEnv "DATABASE_URL" + + let opts = Options 0 (setPort 8080 defaultSettings) False + + scottyOpts opts $ do + + -- Pipeline test: GET /pipeline -> "ok" + get "/pipeline" $ do + setHeader "Server" "scotty" + text "ok" + + -- Baseline HTTP/1.1: GET|POST /baseline11 + let handleBaseline = do + req <- request + let qSum = parseQuerySum (rawQueryString req) + bodySum <- if requestMethod req == methodPost + then do + b <- body + let trimmed = BLC.dropWhile isSpace b + return $ fromMaybe 0 (readMaybe (BLC.unpack trimmed) :: Maybe Int) + else return 0 + setHeader "Server" "scotty" + text $ TL.pack $ show (qSum + bodySum) + + get "/baseline11" handleBaseline + post "/baseline11" handleBaseline + + -- Baseline HTTP/2: GET /baseline2 + get "/baseline2" $ do + req <- request + let qSum = parseQuerySum (rawQueryString req) + setHeader "Server" "scotty" + text $ TL.pack $ show qSum + + -- JSON processing: GET /json + get "/json" $ do + let items = map processedItemValue datasetItems + resp = encode $ object ["items" .= items, "count" .= length items] + setHeader "Server" "scotty" + setHeader "Content-Type" "application/json" + raw resp + + -- Compression: GET /compression + get "/compression" $ do + case largePayload of + Nothing -> do + status status500 + text "No dataset" + Just payload -> do + req <- request + let ae = fromMaybe "" $ lookup "Accept-Encoding" (requestHeaders req) + setHeader "Server" "scotty" + setHeader "Content-Type" "application/json" + if "deflate" `BS.isInfixOf` ae + then do + setHeader "Content-Encoding" "deflate" + raw $ Zlib.compressWith + Zlib.defaultCompressParams { Zlib.compressLevel = Zlib.bestSpeed } + (BL.fromStrict payload) + else if "gzip" `BS.isInfixOf` ae + then do + setHeader "Content-Encoding" "gzip" + raw $ GZip.compressWith + GZip.defaultCompressParams { GZip.compressLevel = GZip.bestSpeed } + (BL.fromStrict payload) + else raw (BL.fromStrict payload) + + -- Upload: POST /upload -> byte count + post "/upload" $ do + b <- body + setHeader "Server" "scotty" + text $ TL.pack $ show (BL.length b) + + -- SQLite DB: GET /db + get "/db" $ do + mConn <- liftIO $ readIORef dbRef + case mConn of + Nothing -> do + setHeader "Server" "scotty" + setHeader "Content-Type" "application/json" + raw "{\"items\":[],\"count\":0}" + Just conn -> do + minP <- paramWithDefault "min" 10.0 + maxP <- paramWithDefault "max" 50.0 + rows <- liftIO $ SQLite.query conn + "SELECT id, name, category, price, quantity, active, tags, rating_score, rating_count FROM items WHERE price BETWEEN ? AND ? LIMIT 50" + (minP :: Double, maxP :: Double) + let items = map sqliteRowToValue rows + resp = encode $ object ["items" .= items, "count" .= length items] + setHeader "Server" "scotty" + setHeader "Content-Type" "application/json" + raw resp + + -- Async DB (PostgreSQL): GET /async-db + get "/async-db" $ do + setHeader "Server" "scotty" + setHeader "Content-Type" "application/json" + case pgUrl of + Nothing -> raw "{\"items\":[],\"count\":0}" + Just url -> do + minP <- paramWithDefault "min" 10.0 + maxP <- paramWithDefault "max" 50.0 + result <- liftIO $ try $ bracket + (PG.connectPostgreSQL (BC.pack url)) + PG.close + (\conn -> PG.query conn + "SELECT id, name, category, price, quantity, active, tags::text, rating_score, rating_count FROM items WHERE price BETWEEN ? AND ? LIMIT 50" + (minP :: Double, maxP :: Double)) + case result of + Left (_ :: SomeException) -> raw "{\"items\":[],\"count\":0}" + Right rows -> do + let items = map pgRowToValue rows + raw $ encode $ object ["items" .= items, "count" .= length items] + + -- Static files: GET /static/:filename + get "/static/:filename" $ do + filename <- pathParam "filename" :: ActionM T.Text + let key = T.unpack filename + case Map.lookup key staticCache of + Just (content, ct) -> do + setHeader "Server" "scotty" + setHeader "Content-Type" (TL.fromStrict (TE.decodeUtf8 ct)) + raw (BL.fromStrict content) + Nothing -> do + status status404 + text "Not Found" + +-- Helper: get query parameter with default +paramWithDefault :: String -> Double -> ActionM Double +paramWithDefault name def = do + mv <- queryParamMaybe (TL.pack name) + case mv of + Nothing -> return def + Just v -> return $ fromMaybe def (readMaybe (TL.unpack v) :: Maybe Double) + +-- Convert SQLite row to JSON Value +sqliteRowToValue :: (Int, T.Text, T.Text, Double, Int, Int, T.Text, Double, Int) -> Value +sqliteRowToValue (rid, name, category, price, quantity, active, tagsJson, rScore, rCount) = + let tags = fromMaybe ([] :: [T.Text]) (Aeson.decodeStrict (TE.encodeUtf8 tagsJson)) + in object + [ "id" .= rid + , "name" .= name + , "category" .= category + , "price" .= price + , "quantity" .= quantity + , "active" .= (active == 1) + , "tags" .= tags + , "rating" .= object ["score" .= rScore, "count" .= rCount] + ] + +-- Convert PostgreSQL row to JSON Value +pgRowToValue :: (Int, T.Text, T.Text, Double, Int, Bool, T.Text, Double, Int) -> Value +pgRowToValue (rid, name, category, price, quantity, active, tagsJson, rScore, rCount) = + let tags = fromMaybe ([] :: [Value]) (Aeson.decodeStrict (TE.encodeUtf8 tagsJson)) + in object + [ "id" .= rid + , "name" .= name + , "category" .= category + , "price" .= price + , "quantity" .= quantity + , "active" .= active + , "tags" .= tags + , "rating" .= object ["score" .= rScore, "count" .= rCount] + ] diff --git a/frameworks/scotty/meta.json b/frameworks/scotty/meta.json new file mode 100644 index 00000000..9618791f --- /dev/null +++ b/frameworks/scotty/meta.json @@ -0,0 +1,21 @@ +{ + "display_name": "Scotty", + "language": "Haskell", + "type": "framework", + "engine": "warp", + "description": "Scotty web framework on Warp, a lightweight Haskell framework inspired by Ruby's Sinatra.", + "repo": "https://github.com/scotty-web/scotty", + "enabled": true, + "tests": [ + "baseline", + "pipelined", + "noisy", + "limited-conn", + "json", + "upload", + "compression", + "mixed", + "async-db", + "static" + ] +} diff --git a/frameworks/scotty/scotty-bench.cabal b/frameworks/scotty/scotty-bench.cabal new file mode 100644 index 00000000..ea7e9800 --- /dev/null +++ b/frameworks/scotty/scotty-bench.cabal @@ -0,0 +1,28 @@ +cabal-version: 3.0 +name: scotty-bench +version: 0.1.0.0 +build-type: Simple + +executable scotty-bench + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N -A64m -I0" + build-depends: + base >= 4.14 && < 5 + , scotty >= 0.22 + , warp >= 3.3 + , wai >= 3.2 + , http-types >= 0.12 + , aeson >= 2.0 + , bytestring >= 0.10 + , text >= 1.2 + , containers >= 0.6 + , directory >= 1.3 + , filepath >= 1.4 + , zlib >= 0.6 + , sqlite-simple >= 0.4 + , postgresql-simple >= 0.6 + , mtl >= 2.2 + default-extensions: + OverloadedStrings + ScopedTypeVariables From 194682abdea99a3fb93c427540836791d1ae0af3 Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Sat, 28 Mar 2026 22:32:18 +0000 Subject: [PATCH 2/3] fix(scotty): stream upload body instead of buffering entire 20MB in memory MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Upload was using Scotty's 'body' (strictRequestBody) which reads the entire request body into a lazy ByteString before processing. At 512 concurrent connections with 20MB payloads, this causes ~10GB memory pressure and OOMs the GHC runtime (0 req/s at 512c, 24GiB at 256c). Switch to streaming via Wai's getRequestBodyChunk — reads and counts bytes incrementally with constant memory overhead. --- frameworks/scotty/Main.hs | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/frameworks/scotty/Main.hs b/frameworks/scotty/Main.hs index 5fa62e2b..04147c20 100644 --- a/frameworks/scotty/Main.hs +++ b/frameworks/scotty/Main.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} module Main where import Web.Scotty -import Network.Wai (rawQueryString, requestMethod, requestHeaders) +import Network.Wai (Request, rawQueryString, requestMethod, requestHeaders, getRequestBodyChunk) import Network.Wai.Handler.Warp (defaultSettings, setPort) import Network.HTTP.Types.Status (status404, status500) import Network.HTTP.Types.Method (methodPost) @@ -225,11 +226,12 @@ main = do (BL.fromStrict payload) else raw (BL.fromStrict payload) - -- Upload: POST /upload -> byte count + -- Upload: POST /upload -> byte count (streaming to avoid buffering entire body) post "/upload" $ do - b <- body + req <- request + totalBytes <- liftIO $ countBodyBytes req setHeader "Server" "scotty" - text $ TL.pack $ show (BL.length b) + text $ TL.pack $ show totalBytes -- SQLite DB: GET /db get "/db" $ do @@ -285,6 +287,16 @@ main = do status status404 text "Not Found" +-- Stream request body and count bytes without buffering +countBodyBytes :: Request -> IO Int +countBodyBytes req = go 0 + where + go !acc = do + chunk <- getRequestBodyChunk req + if BS.null chunk + then return acc + else go (acc + BS.length chunk) + -- Helper: get query parameter with default paramWithDefault :: String -> Double -> ActionM Double paramWithDefault name def = do From cf7b8bcba5b11abb2c5cbe88e8056278207e838c Mon Sep 17 00:00:00 2001 From: BennyFranciscus <268274351+BennyFranciscus@users.noreply.github.com> Date: Sat, 28 Mar 2026 22:38:25 +0000 Subject: [PATCH 3/3] perf(scotty): limit RTS to -N4 -qn4 for better core utilization MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit GHC's IO manager doesn't scale well past a few cores for network workloads — -N (all 64 cores) was only hitting ~270% CPU due to scheduler and lock contention. -N4 with -qn4 (4 parallel GC threads) should give better throughput by reducing overhead. --- frameworks/scotty/scotty-bench.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/frameworks/scotty/scotty-bench.cabal b/frameworks/scotty/scotty-bench.cabal index ea7e9800..fa879138 100644 --- a/frameworks/scotty/scotty-bench.cabal +++ b/frameworks/scotty/scotty-bench.cabal @@ -6,7 +6,7 @@ build-type: Simple executable scotty-bench main-is: Main.hs default-language: Haskell2010 - ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N -A64m -I0" + ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N4 -A64m -I0 -qn4" build-depends: base >= 4.14 && < 5 , scotty >= 0.22