Merge pull request #120 from chrisdone/cd/2026-04-25-warp

Add HTTP server support

Author: chrisdone-artificial

examples/43-http.hell

@@ -0,0 +1,17 @@
+main = do
+  Http.run 8080 \request respond ->
+    if Eq.eq (Http.pathInfo request) []
+      then
+        case List.lookup (CI.mk $ Text.encodeUtf8 "Content-Type") (Http.requestHeaders request) of
+          Maybe.Just _x ->
+            respond $ Http.responseBuilder (Http.mkStatus 200 "OK") [] $
+               Builder.byteString $ Text.encodeUtf8 "Hello, World!"
+          Maybe.Nothing ->
+             respond $ Http.responseBuilder (Http.mkStatus 500 "Error") [] $
+               Builder.byteString $ Text.encodeUtf8 "Wobble"
+      else
+        respond $
+          Http.responseFile (Http.mkStatus 400 "Not Found")
+            [(CI.mk (Text.encodeUtf8 "Content-Type"), Text.encodeUtf8 "text/markdown")]
+            "docs/readme.md"
+            Maybe.Nothing

examples/44-char.hell

@@ -0,0 +1,3 @@
+main = do
+  line <- Text.getLine
+  IO.print $ Text.all (Eq.eq 'x') line

hell.cabal

@@ -25,6 +25,7 @@ executable hell
     , async
     , base >=4.17.2.1 && <4.22
     , bytestring
+    , case-insensitive
     , constraints
     , containers
     , criterion
@@ -33,6 +34,7 @@ executable hell
     , ghc-prim
     , haskell-src-exts
     , hspec
+    , http-types
     , lucid2
     , mtl
     , optparse-applicative
@@ -47,6 +49,8 @@ executable hell
     , typed-process
     , unliftio
     , vector
+    , wai
+    , warp
   default-language: Haskell2010
 
 test-suite hell-test
@@ -61,6 +65,7 @@ test-suite hell-test
     , async
     , base >=4.17.2.1 && <4.22
     , bytestring
+    , case-insensitive
     , constraints
     , containers
     , criterion
@@ -69,6 +74,7 @@ test-suite hell-test
     , ghc-prim
     , haskell-src-exts
     , hspec
+    , http-types
     , lucid2
     , mtl
     , optparse-applicative
@@ -83,4 +89,6 @@ test-suite hell-test
     , typed-process
     , unliftio
     , vector
+    , wai
+    , warp
   default-language: Haskell2010

package.yaml

@@ -32,6 +32,10 @@ dependencies:
 - temporary
 - these
 - time
+- warp
+- wai
+- http-types
+- case-insensitive
 
 ghc-options:
   - -Wall

src/Hell.hs

@@ -50,6 +50,13 @@ import Control.Monad
 -- e.g. 'Data.Graph' becomes 'Graph', and are then exposed to the Hell
 -- guest language as such.
 
+import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive (CI, FoldCase)
+import qualified Network.HTTP.Types as Http
+import qualified Network.Wai as Wai
+import qualified Network.Wai.Handler.Warp as Warp
+import Data.ByteString.Builder (Builder)
+import qualified Data.ByteString.Builder as Builder
 import Control.Applicative (Alternative (..), optional)
 import qualified Control.Concurrent as Concurrent
 import Control.Exception (evaluate)
@@ -837,6 +844,7 @@ instances =
     Map.fromList
       [ entail1 @Show @[],
         entail1 @Show @Set,
+        entail1 @Show @CI,
         entail1 @Show @Tree,
         entail1 @Show @Maybe,
         entail1 @Show @Vector,
@@ -852,8 +860,10 @@ instances =
         instance0 @Show @Char,
         instance0 @Show @Text,
         instance0 @Show @ByteString,
+        instance0 @Show @Builder,
         instance0 @Show @ExitCode,
         instance0 @Show @Value,
+        entail1 @Eq @CI,
         entail1 @Eq @[],
         entail1 @Eq @Set,
         entail1 @Eq @Maybe,
@@ -874,6 +884,7 @@ instances =
         instance0 @Eq @ExitCode,
         entail1 @Ord @[],
         entail1 @Ord @Set,
+        entail1 @Ord @CI,
         entail1 @Ord @Maybe,
         entail2 @Ord @Either,
         entail2 @Ord @(,),
@@ -920,7 +931,9 @@ instances =
         instance2 @Semigroup @Options.Mod,
         instance0 @Semigroup @Text,
         instance1 @Semigroup @Vector,
-        instance1 @Semigroup @[]
+        instance1 @Semigroup @[],
+        instance0 @FoldCase @Text,
+        instance0 @FoldCase @ByteString
       ]
 
 --------------------------------------------------------------------------------
@@ -1693,6 +1706,8 @@ supportedTypeConstructors =
       ("Day", SomeTypeRep $ typeRep @Day),
       ("UTCTime", SomeTypeRep $ typeRep @UTCTime),
       ("TimeOfDay", SomeTypeRep $ typeRep @TimeOfDay),
+      ("Builder", SomeTypeRep $ typeRep @Builder),
+      ("CI", SomeTypeRep $ typeRep @CI),
       -- Internal, hidden types
       ("hell:Hell.NilL", SomeTypeRep $ typeRep @('NilL)),
       ("hell:Hell.ConsL", SomeTypeRep $ typeRep @('ConsL)),
@@ -1770,10 +1785,11 @@ supportedLits =
       lit' "Text.reverse" Text.reverse,
       lit' "Text.toLower" Text.toLower,
       lit' "Text.toUpper" Text.toUpper,
-      -- Needs Char operations.
-      -- ("Text.any", lit' Text.any),
-      -- ("Text.all", lit' Text.all),
-      -- ("Text.filter", lit' Text.filter),
+      lit' "Text.any" Text.any,
+      lit' "Text.unpack" Text.unpack,
+      lit' "Text.pack" Text.pack,
+      lit' "Text.all" Text.all,
+      lit' "Text.filter" Text.filter,
       lit' "Text.take" Text.take,
       lit' "Text.splitOn" Text.splitOn,
       lit' "Text.takeEnd" Text.takeEnd,
@@ -1883,7 +1899,21 @@ supportedLits =
       -- Options
       lit' "Options.switch" Options.switch,
       lit' "Options.strOption" (Options.strOption @Text),
-      lit' "Options.strArgument" (Options.strArgument @Text)
+      lit' "Options.strArgument" (Options.strArgument @Text),
+      -- Http
+      lit' "Http.run" warp_run,
+      lit' "Http.responseBuilder" Wai.responseBuilder,
+      lit' "Http.responseStream" Wai.responseStream,
+      lit' "Http.responseFile" wai_responseFile,
+      lit' "Http.mkStatus" http_mkStatus,
+      lit' "Http.pathInfo" Wai.pathInfo,
+      lit' "Http.FilePart" Wai.FilePart,
+      lit' "Http.requestHeaders" Wai.requestHeaders,
+      lit' "Http.queryString" Wai.queryString,
+      lit' "Http.getRequestBodyChunk" Wai.getRequestBodyChunk,
+      lit' "Http.consumeRequestBodyStrict" (fmap L.toStrict . Wai.consumeRequestBodyStrict),
+      -- Builder
+      lit' "Builder.byteString" Builder.byteString
     ]
   where
     lit' :: forall a. (Type.Typeable a) => String -> a -> (String, (UTerm (), SomeTypeRep))
@@ -2150,6 +2180,10 @@ polyLits =
                "Exit.exitWith" Exit.exitWith :: forall a. ExitCode -> IO a
                "Exit.exitCode" exit_exitCode :: forall a. a -> (Int -> a) -> ExitCode -> a
 
+               -- CI
+               "CI.foldedCase" CI.foldedCase :: forall s. CI s -> s
+               "CI.mk" CI.mk :: forall s. CI.FoldCase s => s -> CI s
+
                -- Exceptions
                "Error.error" (error . Text.unpack) :: forall a. Text -> a
 
@@ -2500,6 +2534,18 @@ t_appendFile fp t = ByteString.appendFile (Text.unpack fp) (Text.encodeUtf8 t)
 t_readFile :: Text -> IO Text
 t_readFile fp = fmap Text.decodeUtf8 (ByteString.readFile (Text.unpack fp))
 
+-- Same as Warp.run, but with HTTP/2 support disabled.
+-- Stick to HTTP/1.2; simpler, fewer moving parts.
+warp_run :: Int -> Wai.Application -> IO ()
+warp_run p = Warp.runSettings (Warp.setHTTP2Disabled $ Warp.setPort p $ Warp.defaultSettings)
+
+-- No point using ByteString here.
+http_mkStatus :: Int -> Text -> Http.Status
+http_mkStatus i = Http.mkStatus i . Text.encodeUtf8
+
+wai_responseFile :: Http.Status -> Http.ResponseHeaders -> Text -> Maybe Wai.FilePart -> Wai.Response
+wai_responseFile s r f = Wai.responseFile s r (Text.unpack f)
+
 --------------------------------------------------------------------------------
 -- JSON operations