warp-effectful-1.1.1: test/Main.hs

module Main where

import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)
import Control.Monad (replicateM)
import Data.ByteString.Lazy (LazyByteString)
import Data.ByteString.Lazy.Char8 qualified as LazyByteString
import Effectful
import Effectful.Hspec
import Effectful.HttpClient
import Effectful.State.Static.Local (State, evalState, get, modify)
import Effectful.Wai hiding (Response, responseStatus)
import Effectful.Wai.Handler.Warp
import Network.HTTP.Types qualified as HTTP
import Prelude

post :: (HttpClient :> es) => LazyByteString -> Port -> Eff es (Response LazyByteString)
post body port = do
    req <- parseRequest $ "http://127.0.0.1:" <> show port <> "/hello"
    httpLbs
        req
            { method = "POST"
            , requestBody = RequestBodyLBS body
            , requestHeaders = [("Connection", "close")]
            }

main :: IO ()
main = runEff . runHttpClient . runHspec . describe "Warp" $ do
    it "serves a request over a real listener" do
        let app :: Application es
            app _req respond = respond $ responseLBS HTTP.ok200 [] "hello world"
        resp <- withApplication (pure app) (post mempty)
        responseStatus resp `shouldBe` HTTP.ok200

    it "round-trips a request body" do
        let app :: (IOE :> es) => Application es
            app req respond = do
                body <- strictRequestBody req
                respond $ responseLBS HTTP.ok200 [] body
        resp <- withApplication (pure app) (post "hello world")
        responseBody resp `shouldBe` "hello world"

    it "serves through testWithApplicationSettings" do
        let app :: Application es
            app _req respond = respond $ responseLBS HTTP.ok200 [] "hello world"
        (_counter, settings) <- makeSettingsAndCounter
        resp <- testWithApplicationSettings settings (pure app) (post mempty)
        responseStatus resp `shouldBe` HTTP.ok200

    it "gives each connection its own copy of the environment" do
        let app :: (State Int :> es) => Application es
            app _req respond = do
                modify @Int (+ 1)
                n <- get @Int
                respond . responseLBS HTTP.ok200 [] . LazyByteString.pack $ show n
            connections :: Int
            connections = 64
        bodies <- evalState @Int 0 $ withApplication (pure app) \port ->
            replicateConcurrently connections $ responseBody <$> post mempty port
        bodies `shouldBe` replicate connections "1"

replicateConcurrently :: (IOE :> es) => Int -> Eff es a -> Eff es [a]
replicateConcurrently n action = withEffToIO (ConcUnlift Persistent Unlimited) \unlift -> do
    dones <- replicateM n newEmptyMVar
    mapM_ (\done -> forkIO $ unlift action >>= putMVar done) dones
    mapM takeMVar dones