Add better support for forms

docs/src/pages/docs/todo-app.md

@@ -210,7 +210,7 @@ createTodo :: Connection -> Okapi Response
 createTodo conn = do
   methodPOST
   pathParam @Text `is` "todos"
-  todoForm <- bodyForm
+  todoForm <- bodyURLEncoded
   lift $ insertTodoForm conn todoForm
   respond ok
 
@@ -219,7 +219,7 @@ editTodo conn = do
   methodPUT
   is @Text pathParam "todos"
   todoID <- pathParam @Int
-  todoForm <- bodyForm @TodoForm
+  todoForm <- bodyURLEncoded @TodoForm
   lift $ updateTodo conn todoID todoForm
   respond ok
 

docs/src/pages/index.md

@@ -182,7 +182,7 @@ There is a category of parsers for each component of an HTTP request:
 
    These parsers are for parsing the request body and are prefixed with `body-`.
 
-   Examples: `body`, `bodyJSON`, `bodyForm`
+   Examples: `body`, `bodyJSON`, `bodyURLEncoded`
 
 5. Header parsers
 

examples/car-dealership/Main.hs

@@ -181,7 +181,7 @@ methodAndPathDispatcher database = \case
 
     return $ setHTML html $ ok
   PostCarsRoute -> do
-    maybeCarForSale <- optional $ bodyForm @Car
+    maybeCarForSale <- optional $ bodyURLEncoded @Car
     case maybeCarForSale of
       Nothing -> return $ redirect 302 $ renderURL PostFailureRoute 
       Just carForSale -> do

examples/dotodo/Main.hs

@@ -0,0 +1,297 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Main where
+
+import Control.Applicative ((<|>))
+import Control.Applicative.Combinators
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.Aeson (ToJSON, toJSON)
+import Data.ByteString.Lazy (fromStrict)
+import Data.Function ((&))
+import Data.Maybe (listToMaybe)
+import Data.Text
+import Data.Text.Encoding (encodeUtf8)
+import Database.SQLite.Simple
+import Database.SQLite.Simple.FromField
+import Database.SQLite.Simple.ToField
+import GHC.Generics (Generic, Par1)
+import Okapi
+import Web.FormUrlEncoded (FromForm)
+import Web.HttpApiData (ToHttpApiData)
+import Web.Internal.HttpApiData
+import Lucid
+import Lucid.Htmx
+
+{-
+We're going to build a Todo API with the following endpoints:
+
+GET /
+Health check. Returns 200 response with "OK" as the body.
+
+GET /todos
+Returns all todos as JSON. Has optional query param "status" to filter todos with that status.
+
+GET /todos/:uid
+Returns the todo with the matching :uid as JSON.
+
+POST /todos
+Accepts a todo/todos encoded as JSON to store on the server.
+
+PATCH /todos/:uid
+Accepts todo information as JSON. For updating a todo with the :uid.
+
+DELETE /todos/:uid
+Deletes the todo with the matching :uid from the server.
+-}
+
+-- TYPES --
+
+data Todo = Todo
+  { todoID :: Int,
+    todoName :: Text,
+    todoStatus :: TodoStatus
+  }
+  deriving (Eq, Ord, Generic, Show)
+
+instance FromRow Todo where
+  fromRow = Todo <$> field <*> field <*> field
+
+data TodoForm = TodoForm
+  { todoFormName :: Text,
+    todoFormStatus :: TodoStatus
+  }
+  deriving (Eq, Ord, Generic, FromForm, Show)
+
+instance ToRow TodoForm where
+  toRow (TodoForm name status) = toRow (name, status)
+
+data TodoStatus
+  = Incomplete
+  | Complete
+  deriving (Eq, Ord, Show)
+
+instance FromHttpApiData TodoStatus where
+  parseQueryParam "incomplete" = Right Incomplete
+  parseQueryParam "complete" = Right Complete
+  parseQueryParam _ = Left "Incorrect format for TodoStatus value"
+
+instance ToHttpApiData TodoStatus where
+  toQueryParam Incomplete = "incomplete"
+  toQueryParam Complete = "complete"
+
+instance ToField TodoStatus where
+  toField status =
+    case status of
+      Incomplete -> SQLText "incomplete"
+      Complete -> SQLText "complete"
+
+instance FromField TodoStatus where
+  fromField field = do
+    case fieldData field of
+      SQLText "incomplete" -> pure Incomplete
+      SQLText "complete" -> pure Complete
+      _ -> returnError ConversionFailed field "Couldn't get TodoStatus value from field"
+
+type Okapi = OkapiT IO
+
+-- MAIN --
+
+main :: IO ()
+main = do
+  conn <- open "todo.db"
+  execute_ conn "CREATE TABLE IF NOT EXISTS todos (id INTEGER PRIMARY KEY, name TEXT, status TEXT)"
+  run id (todoAPI conn)
+  close conn
+
+-- SERVER FUNCTIONS
+
+todoAPI :: (MonadIO m, MonadOkapi m) => Connection -> m Response
+todoAPI conn =
+  home conn
+    <|> getAllTodos conn
+    <|> createTodoForm
+    <|> createTodo conn
+    <|> editTodoStatus conn
+    <|> forgetTodo conn
+    <|> counter
+
+home :: (MonadOkapi m, MonadIO m) => Connection -> m Response
+home conn = do
+  methodGET
+  pathEnd
+
+  todos <- liftIO $ selectAllTodos conn Nothing
+
+  let html = do
+        doctypehtml_ $ do
+            head_ [] $ do
+                script_ [src_ "https://unpkg.com/htmx.org@1.8.0"] ("" :: Html ())
+                -- script_ [src_ "https://cdn.tailwindcss.com"] ("" :: Html ())
+            body_ [] $ do
+                h1_ "Todo App"
+                div_ [id_ "main"] $ do
+                    todosTable todos
+                    createTodoButton
+                    counterHtml 0
+  ok |> setLucid html |> return
+
+counter :: MonadOkapi m => m Response
+counter = do
+  methodGET
+  pathParam @Text `is` "counter"
+  count <- pathParam @Int
+  let newCount = count + 1
+
+  ok |> setLucid (counterHtml newCount) |> return
+
+counterHtml :: Int -> Html ()
+counterHtml count = do
+  div_ [hxGet_ $ "/counter/" <> tShow count, hxTrigger_ "every 1s", hxSwap_ "outerHTML"] $ (toHtml $ tShow count)
+
+getAllTodos :: (MonadOkapi m, MonadIO m) => Connection -> m Response
+getAllTodos conn = do
+  methodGET
+  pathParam @Text `is` "todos"
+  pathEnd
+  status <- optional $ queryParam @TodoStatus "status"
+
+  todos <- liftIO $ selectAllTodos conn status
+
+  let html = do
+        todosTable todos
+        createTodoButton
+  ok |> setLucid html |> return
+
+createTodoForm :: MonadOkapi m => m Response
+createTodoForm = do
+    methodGET
+    pathParam @Text `is` "todos"
+    pathParam @Text `is` "create"
+    pathEnd
+
+    let html = do
+            form_ [hxPost_ "/todos", hxTarget_ "#main"] $ do
+                label_ [name_ "todoFormName", for_ "todoFormName"] "Todo Name: "
+                input_ [name_ "todoFormName", id_ "todoFormName", type_ "text"]
+                br_ []
+                label_ [name_ "todoStatus", for_ "todoStatus"] "Todo Status: "
+                input_ [name_ "todoFormStatus", id_ "todoStatus", type_ "text", value_ "incomplete"]
+                button_ [] "Create Todo"
+
+    ok |> setLucid html |> return
+
+createTodo :: (MonadOkapi m, MonadIO m) => Connection -> m Response
+createTodo conn = do
+  methodPOST
+  pathParam @Text `is` "todos"
+  pathEnd
+
+  todoForm <- bodyURLEncoded
+
+  liftIO $ insertTodoForm conn todoForm
+
+  todos <- liftIO $ selectAllTodos conn Nothing
+
+  let html = do
+        todosTable todos
+        createTodoButton
+  ok |> setLucid html |> return
+
+editTodoStatus :: (MonadOkapi m, MonadIO m) => Connection -> m Response
+editTodoStatus conn = do
+  methodPUT
+  pathParam @Text `is` "todos" -- /todos
+  todoID <- pathParam @Int -- /todos/<todoID>
+  pathEnd
+
+  currentStatus <- queryParam @TodoStatus "status"
+  let newStatus = case currentStatus of
+        Incomplete -> Complete
+        Complete -> Incomplete
+
+  liftIO $ updateTodoStatus conn todoID newStatus
+  ok |> setLucid (flipTodoStatusButton todoID newStatus) |> return
+
+forgetTodo :: (MonadOkapi m, MonadIO m) => Connection -> m Response
+forgetTodo conn = do
+  methodDELETE
+  pathParam @Text `is` "todos"
+  todoID <- pathParam @Int
+  pathEnd
+
+  liftIO $ deleteTodo conn todoID
+
+  todos <- liftIO $ selectAllTodos conn Nothing
+
+  let html = do
+        todosTable todos
+        createTodoButton
+  ok |> setLucid html |> return
+
+-- Views
+
+todoRow :: Todo -> Html ()
+todoRow Todo{..} = tr_ [] $ do
+    td_ [] $ toHtml $ tShow todoID
+    td_ [] $ toHtml todoName
+    td_ [] $ flipTodoStatusButton todoID todoStatus
+    td_ [] $ forgetTodoButton todoID
+
+todosTable :: [Todo] -> Html ()
+todosTable [] = h2_ [] $ "You have no todos."
+todosTable todos = table_ [] $ mapM_ todoRow todos
+
+flipTodoStatusButton :: Int -> TodoStatus -> Html ()
+flipTodoStatusButton todoID todoStatus =
+  button_
+    [hxPut_ $ "/todos/" <> tShow todoID <> "?status=" <> toQueryParam todoStatus, hxSwap_ "outerHTML"]
+    $ case todoStatus of
+        Incomplete -> "Complete"
+        Complete -> "Incomplete"
+
+forgetTodoButton :: Int -> Html ()
+forgetTodoButton todoID =
+    button_ [hxDelete_ $ "/todos/" <> tShow todoID, hxTarget_ "#main"] "DELETE"
+
+createTodoButton :: Html ()
+createTodoButton = button_ [hxGet_ "/todos/create", hxTarget_ "#main"] "Create Todo"
+
+tShow :: Show a => a -> Text
+tShow = pack . show
+
+-- DATABASE FUNCTIONS
+
+insertTodoForm :: MonadIO m => Connection -> TodoForm -> m ()
+insertTodoForm conn todoForm = liftIO $ execute conn "INSERT INTO todos (name, status) VALUES (?, ?)" todoForm
+
+selectTodo :: MonadIO m => Connection -> Int -> m (Maybe Todo)
+selectTodo conn todoID = liftIO $ listToMaybe <$> Database.SQLite.Simple.query conn "SELECT * FROM todos WHERE id = ?" (Only todoID)
+
+selectAllTodos :: MonadIO m => Connection -> Maybe TodoStatus -> m [Todo]
+selectAllTodos conn maybeStatus = liftIO $ case maybeStatus of
+  Nothing -> query_ conn "SELECT * FROM todos"
+  Just status -> Database.SQLite.Simple.query conn "SELECT * FROM todos WHERE status = ?" (Only status)
+
+updateTodoStatus :: MonadIO m => Connection -> Int -> TodoStatus -> m ()
+updateTodoStatus conn todoID todoStatus = liftIO $
+  executeNamed
+    conn
+    "UPDATE todos SET status = :status WHERE id = :id"
+    [":id" := todoID, ":status" := todoStatus]
+
+deleteTodo :: MonadIO m => Connection -> Int -> m ()
+deleteTodo conn todoID = liftIO $ execute conn "DELETE FROM todos WHERE id = ?" (Only todoID)
+
+-- HELPERS
+
+setLucid :: Html a -> Response -> Response
+setLucid html = setHTML $ renderBS html
+
+(|>) = (&)

examples/todo/Main.hs

@@ -157,7 +157,7 @@ createTodo :: Connection -> Okapi Response
 createTodo conn = do
   methodPOST
   pathParam @Text `is` "todos"
-  todoForm <- bodyForm
+  todoForm <- bodyURLEncoded
   lift $ insertTodoForm conn todoForm
   respond ok
 
@@ -166,7 +166,7 @@ editTodo conn = do
   methodPUT
   is @Text pathParam "todos"
   todoID <- pathParam @Int
-  todoForm <- bodyForm @TodoForm
+  todoForm <- bodyURLEncoded @TodoForm
   lift $ updateTodo conn todoID todoForm
   respond ok
 

examples/todo2/Main.hs

@@ -168,7 +168,7 @@ postRoutes conn = do
   methodPOST
   route path $ \case
     CreateTodo -> do
-      todoForm <- bodyForm
+      todoForm <- bodyURLEncoded
       lift $ insertTodoForm conn todoForm
       respond ok
     _ -> next
@@ -178,7 +178,7 @@ putRoutes conn = do
   methodPUT
   route path $ \case
     PutTodo todoID -> do
-      todoForm <- bodyForm @TodoForm
+      todoForm <- bodyURLEncoded @TodoForm
       lift $ updateTodo conn todoID todoForm
       respond ok
     _ -> next

examples/todo3/Main.hs

@@ -157,11 +157,11 @@ main = do
         todos <- lift $ selectAllTodos conn $ Just status
         ok & setJSON todos & respond
       CreateTodo -> do
-        todoForm <- bodyForm
+        todoForm <- bodyURLEncoded
         lift $ insertTodoForm conn todoForm
         respond ok
       PutTodo todoID -> do
-        todoForm <- bodyForm
+        todoForm <- bodyURLEncoded
         lift $ updateTodo conn todoID todoForm
         respond ok
       ForgetTodo todoID -> do

experimental/Operator.hs

@@ -12,7 +12,7 @@ import qualified Web.HttpApiData as Web
 -- | Parses and discards a single path segment matching the given @Text@ value
 --
 -- >>> parser = get // "store" // "clothing" >> respond ok
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/store/clothing" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/store/clothing" "")
 -- >>> assertResponse is200 result
 -- True
 (//) :: forall m a. MonadOkapi m => m a -> Text.Text -> m ()

experimental/Parser.hs

@@ -48,7 +48,7 @@ module Okapi.Parser
 
     -- | Parsers for extracting data from the body of a request
     bodyJSON,
-    bodyForm,
+    bodyURLEncoded,
     bodyRaw,
 
     -- * Response Helpers
@@ -125,7 +125,7 @@ import Prelude hiding (head)
 
 -- |
 -- >>> let parser = get >> respond ok
--- >>> result <- testParserIO parser $ request GET "" "" []
+-- >>> result <- testIO parser $ request GET "" "" []
 -- >>> assertResponse is200 result
 -- True
 get :: forall m. MonadOkapi m => m ()
@@ -133,7 +133,7 @@ get = method HTTP.methodGet
 
 -- |
 -- >>> let parser = post >> respond ok
--- >>> result <- testParserIO parser (TestRequest "POST" [] "" "")
+-- >>> result <- testIO parser (TestRequest "POST" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 post :: forall m. MonadOkapi m => m ()
@@ -141,7 +141,7 @@ post = method HTTP.methodPost
 
 -- |
 -- >>> let parser = Okapi.Parser.head >> respond ok
--- >>> result <- testParserIO parser (TestRequest "HEAD" [] "" "")
+-- >>> result <- testIO parser (TestRequest "HEAD" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 head :: forall m. MonadOkapi m => m ()
@@ -149,7 +149,7 @@ head = method HTTP.methodHead
 
 -- |
 -- >>> let parser = put >> respond ok
--- >>> result <- testParserIO parser (TestRequest "PUT" [] "" "")
+-- >>> result <- testIO parser (TestRequest "PUT" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 put :: forall m. MonadOkapi m => m ()
@@ -157,7 +157,7 @@ put = method HTTP.methodPut
 
 -- |
 -- >>> let parser = delete >> respond ok
--- >>> result <- testParserIO parser (TestRequest "DELETE" [] "" "")
+-- >>> result <- testIO parser (TestRequest "DELETE" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 delete :: forall m. MonadOkapi m => m ()
@@ -165,7 +165,7 @@ delete = method HTTP.methodDelete
 
 -- |
 -- >>> let parser = trace >> respond ok
--- >>> result <- testParserIO parser (TestRequest "TRACE" [] "" "")
+-- >>> result <- testIO parser (TestRequest "TRACE" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 trace :: forall m. MonadOkapi m => m ()
@@ -173,7 +173,7 @@ trace = method HTTP.methodTrace
 
 -- |
 -- >>> let parser = connect >> respond ok
--- >>> result <- testParserIO parser (TestRequest "CONNECT" [] "" "")
+-- >>> result <- testIO parser (TestRequest "CONNECT" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 connect :: forall m. MonadOkapi m => m ()
@@ -181,7 +181,7 @@ connect = method HTTP.methodConnect
 
 -- |
 -- >>> let parser = options >> respond ok
--- >>> result <- testParserIO parser (TestRequest "OPTIONS" [] "" "")
+-- >>> result <- testIO parser (TestRequest "OPTIONS" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 options :: forall m. MonadOkapi m => m ()
@@ -189,7 +189,7 @@ options = method HTTP.methodOptions
 
 -- |
 -- >>> let parser = patch >> respond ok
--- >>> result <- testParserIO parser (TestRequest "PATCH" [] "" "")
+-- >>> result <- testIO parser (TestRequest "PATCH" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 patch :: forall m. MonadOkapi m => m ()
@@ -197,7 +197,7 @@ patch = method HTTP.methodPatch
 
 -- |
 -- >>> let parser = anyMethod >> respond ok
--- >>> result <- testParserIO parser (TestRequest "FOOBLAH" [] "" "")
+-- >>> result <- testIO parser (TestRequest "FOOBLAH" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 anyMethod :: forall m. MonadOkapi m => m ()
@@ -205,7 +205,7 @@ anyMethod = parseMethod >> pure ()
 
 -- |
 -- >>> let parser = method "CUSTOM" >> respond ok
--- >>> result <- testParserIO parser (TestRequest "CUSTOM" [] "" "")
+-- >>> result <- testIO parser (TestRequest "CUSTOM" [] "" "")
 -- >>> assertResponse is200 result
 -- True
 method :: forall m. MonadOkapi m => HTTP.Method -> m ()
@@ -225,7 +225,7 @@ method method = do
 --   respond ok;
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/store/clothing" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/store/clothing" "")
 -- >>> assertResponse is200 result
 -- True
 pathSeg :: forall m. MonadOkapi m => Text.Text -> m ()
@@ -240,7 +240,7 @@ pathSeg goal = pathSegWith (goal ==)
 --   respond ok
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/store/clothing" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/store/clothing" "")
 -- >>> assertResponse is200 result
 -- True
 path :: forall m. MonadOkapi m => [Text.Text] -> m ()
@@ -257,7 +257,7 @@ path = mapM_ pathSeg
 --   respond $ json productID $ ok;
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/product/242301" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/product/242301" "")
 -- >>> assertResponse is200 result
 -- True
 pathParam :: forall a m. (MonadOkapi m, Web.FromHttpApiData a) => m a
@@ -276,7 +276,7 @@ pathParam = do
 --   respond $ json productID $ ok
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/product/242301" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/product/242301" "")
 -- >>> assertResponse is200 result
 -- True
 pathParamRaw :: forall m. MonadOkapi m => m Text.Text
@@ -294,10 +294,10 @@ pathParamRaw = parsePathSeg
 --   respond ok
 -- :}
 --
--- >>> result1 <- testParserIO parser (TestRequest "GET" [] "/product/242301" "")
+-- >>> result1 <- testIO parser (TestRequest "GET" [] "/product/242301" "")
 -- >>> assertResponse is200 result1
 -- True
--- >>> result2 <- testParserIO parser (TestRequest "GET" [] "/product/5641" "")
+-- >>> result2 <- testIO parser (TestRequest "GET" [] "/product/5641" "")
 -- >>> assertFailure isSkip result2
 -- True
 pathSegWith :: forall m. MonadOkapi m => (Text.Text -> Bool) -> m ()
@@ -331,7 +331,7 @@ pathWildcard = do
 --   respond $ setBodyRaw (showLBS $ minQty + 3) $ ok
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/product?min_qty=2" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/product?min_qty=2" "")
 -- >>> assertResponse is200 result
 -- True
 -- >>> assertResponse (hasBodyRaw "5") result
@@ -366,7 +366,7 @@ queryParam queryItemName = do
 --     Nothing   -> throw _500
 -- :}
 --
--- >>> result <- testParserIO parser (TestRequest "GET" [] "/flip/my/bit?value=b0" "")
+-- >>> result <- testIO parser (TestRequest "GET" [] "/flip/my/bit?value=b0" "")
 -- >>> assertResponse (hasBodyRaw "1") result
 -- True
 queryParamRaw :: forall m. MonadOkapi m => Text.Text -> m Text.Text
@@ -389,13 +389,13 @@ queryParamRaw queryItemName = do
 --       else json ["Derek", "Alice", "Bob", "Casey", "Alex", "Larry"] $ ok
 -- :}
 --
--- >>> result1 <- testParserIO parser (TestRequest "GET" [] "/users?admin" "")
+-- >>> result1 <- testIO parser (TestRequest "GET" [] "/users?admin" "")
 -- >>> assertResponse (hasBodyRaw "[\"Derek\",\"Alice\"]") result1
 -- True
--- >>> result2 <- testParserIO parser (TestRequest "GET" [] "/users?admin=foobarbaz" "")
+-- >>> result2 <- testIO parser (TestRequest "GET" [] "/users?admin=foobarbaz" "")
 -- >>> assertResponse (hasBodyRaw "[\"Derek\",\"Alice\"]") result2
 -- True
--- >>> result3 <- testParserIO parser (TestRequest "GET" [] "/users" "")
+-- >>> result3 <- testIO parser (TestRequest "GET" [] "/users" "")
 -- >>> assertResponse (hasBodyRaw "[\"Derek\",\"Alice\",\"Bob\",\"Casey\",\"Alex\",\"Larry\"]") result3
 -- True
 queryFlag :: forall a m. MonadOkapi m => Text.Text -> m Bool
@@ -448,8 +448,8 @@ bodyJSON = do
   body <- bodyRaw
   maybe next pure (Aeson.decode body)
 
-bodyForm :: forall a m. (MonadOkapi m, Web.FromForm a) => m a
-bodyForm = do
+bodyURLEncoded :: forall a m. (MonadOkapi m, Web.FromForm a) => m a
+bodyURLEncoded = do
   body <- bodyRaw
   maybe next pure (eitherToMaybe $ Web.urlDecodeAsForm body)
   where

experimental/Pattern12.hs

@@ -86,19 +86,19 @@ pattern BlogRouteIdSection blogID sectionName =
 
 -- | Test example patterns in Okapi.Pattern module
 --
--- >>> result1 <- testParserIO testMatcher (TestRequest "GET" [] "/blog" "")
+-- >>> result1 <- testIO testMatcher (TestRequest "GET" [] "/blog" "")
 -- >>> assertResponse is200 result1
 -- True
--- >>> result2 <- testParserIO testMatcher (TestRequest "GET" [] "/blog/2" "")
+-- >>> result2 <- testIO testMatcher (TestRequest "GET" [] "/blog/2" "")
 -- >>> assertResponse is200 result2
 -- True
--- >>> result3 <- testParserIO testMatcher (TestRequest "GET" [] "/blog/7/intro" "")
+-- >>> result3 <- testIO testMatcher (TestRequest "GET" [] "/blog/7/intro" "")
 -- >>> assertResponse is200 result3
 -- True
--- >>> result4 <- testParserIO testMatcher (TestRequest "GET" [] "/blog?author=Diamond&category=pets" "")
+-- >>> result4 <- testIO testMatcher (TestRequest "GET" [] "/blog?author=Diamond&category=pets" "")
 -- >>> assertResponse is200 result4
 -- True
--- >>> result5 <- testParserIO testMatcher (TestRequest "GET" [] "/blog?author=Johnson" "")
+-- >>> result5 <- testIO testMatcher (TestRequest "GET" [] "/blog?author=Johnson" "")
 -- >>> assertResponse is200 result5
 -- True
 testMatcher :: MonadOkapi m => m Response

experimental/Pattern2.hs

@@ -146,21 +146,21 @@ pattern BlogQueryRoute author category <-
 --
 -- >>> parser = testMatcher
 --
--- >>> result1 <- testParserIO parser (TestRequest "GET" [] "/blog" "")
+-- >>> result1 <- testIO parser (TestRequest "GET" [] "/blog" "")
 -- >>> assertResponse is200 result1
 -- True
--- >>> result2 <- testParserIO parser (TestRequest "GET" [] "/blog/2" "")
+-- >>> result2 <- testIO parser (TestRequest "GET" [] "/blog/2" "")
 -- >>> assertResponse is200 result2
 -- True
--- >>> result3 <- testParserIO parser (TestRequest "GET" [] "/blog/7/intro" "")
+-- >>> result3 <- testIO parser (TestRequest "GET" [] "/blog/7/intro" "")
 -- >>> assertResponse is200 result3
 -- True
 --
--- >>> result4 <- testParserIO parser (TestRequest "GET" [] "/blog?author=Diamond&category=pets" "")
+-- >>> result4 <- testIO parser (TestRequest "GET" [] "/blog?author=Diamond&category=pets" "")
 -- >>> assertResponse is200 result4
 -- True
 --
--- >>> result5 <- testParserIO parser (TestRequest "GET" [] "/blog?author=Diamond" "")
+-- >>> result5 <- testIO parser (TestRequest "GET" [] "/blog?author=Diamond" "")
 -- >>> assertResponse is200 result5
 -- False
 testMatcher :: MonadOkapi m => m Response

experimental/Spec.hs

@@ -95,21 +95,21 @@ pattern BlogQueryRoute author category <-
 --
 -- >>> parser = testMatcher
 --
--- >>> result1 <- testParserIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog" "")
+-- >>> result1 <- testIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog" "")
 -- >>> assertResponse is200 result1
 -- True
--- >>> result2 <- testParserIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog/2" "")
+-- >>> result2 <- testIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog/2" "")
 -- >>> assertResponse is200 result2
 -- True
--- >>> result3 <- testParserIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog/7/intro" "")
+-- >>> result3 <- testIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog/7/intro" "")
 -- >>> assertResponse is200 result3
 -- True
 --
--- >>> result4 <- testParserIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog?author=Diamond&category=pets" "")
+-- >>> result4 <- testIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog?author=Diamond&category=pets" "")
 -- >>> assertResponse is200 result4
 -- True
 --
--- >>> result5 <- testParserIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog?author=Diamond" "")
+-- >>> result5 <- testIO parser (TestRequest "Okapi.Patterns.GET" [] "/blog?author=Diamond" "")
 -- >>> assertResponse is200 result5
 -- False
 testMatcher :: MonadOkapi m => m Okapi.Response

experimental/Test.hs

@@ -5,8 +5,8 @@
 {-# OPTIONS_GHC -Wno-overlapping-patterns #-}
 
 module Okapi.Test
-  ( testParser,
-    testParserIO,
+  ( test,
+    testIO,
     assertFailure,
     assertState,
     assertResponse,
@@ -93,20 +93,20 @@ pathToURL :: Path -> URL
 pathToURL [] = ""
 pathToURL (pathSeg : path) = "/" <> URL pathSeg <> pathToURL path
 
-testParser ::
+test ::
   Monad m =>
   OkapiT m Response ->
   Request ->
   (Either Failure Response, State)
-testParser hoister okapiT request =
+test hoister okapiT request =
   (State.runStateT . Except.runExceptT . unOkapiT $ Morph.hoist hoister okapiT)
     (requestToState request)
 
-testParserIO ::
+testIO ::
   OkapiT IO Response ->
   Request ->
   IO (Either Failure Response, State)
-testParserIO = testParser id
+testIO = test id
 
 requestToState :: Request -> State
 requestToState stateRequest =

experimental/chess/Main.hs

@@ -269,7 +269,7 @@ register :: Okapi Result
 register = do
   Okapi.post
   Okapi.seg "register"
-  Player {..} <- bodyForm
+  Player {..} <- bodyURLEncoded
   envRef <- ask
   liftIO $ atomically $ addPlayerToWaitPool envRef playerName
   okLucid [] $ JoinedPool playerName

okapi.cabal

@@ -1,22 +1,19 @@
 cabal-version:      1.12
-
--- This file has been generated from package.yaml by hpack version 0.34.4.
---
--- see: https://github.com/sol/hpack
-
 name:               okapi
 version:            0.2.0.0
-description:    Please see the README on GitHub at <https://github.com/monadicsystems/okapi#readme>
-category:       Web
-homepage:       https://github.com/monadicsystems/okapi#readme
-bug-reports:    https://github.com/monadicsystems/okapi/issues
-author:         Monadic Systems LLC
-maintainer:     tech@monadic.systems
-copyright:      2022 Monadic Systems LLC
 license:            BSD3
 license-file:       LICENSE
-build-type:     Simple
+copyright:          2022 Monadic Systems LLC
+maintainer:         tech@monadic.systems
+author:             Monadic Systems LLC
+homepage:           https://github.com/monadicsystems/okapi#readme
+bug-reports:        https://github.com/monadicsystems/okapi/issues
 synopsis:           A micro web framework based on monadic parsing
+description:
+    Please see the README on GitHub at <https://github.com/monadicsystems/okapi#readme>
+
+category:           Web
+build-type:         Simple
 extra-source-files:
     README.md
     ChangeLog.md
@@ -26,419 +23,434 @@ source-repository head
     location: https://github.com/monadicsystems/okapi
 
 library
-  exposed-modules:
-      Okapi
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      src
-  build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , parser-combinators
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
+    exposed-modules:  Okapi
+    hs-source-dirs:   src
+    other-modules:    Paths_okapi
     default-language: Haskell2010
+    build-depends:
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        parser-combinators,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable calculator-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/calculator
+    hs-source-dirs:   examples/calculator
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable calculator2-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/calculator2
+    hs-source-dirs:   examples/calculator2
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable car-dealership-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/car-dealership
+    hs-source-dirs:   examples/car-dealership
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , interpolatedstring-perl6
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , random
-    , sqlite-simple
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        interpolatedstring-perl6,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        random,
+        sqlite-simple,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
+
+executable dotodo-exe
+    main-is:          Main.hs
+    hs-source-dirs:   examples/dotodo
+    other-modules:    Paths_okapi
     default-language: Haskell2010
+    ghc-options:      -threaded -rtsopts -with-rtsopts=-N
+    build-depends:
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        lucid2,
+        lucid2-htmx,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        sqlite-simple,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable sse-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/sse
+    hs-source-dirs:   examples/sse
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , slave-thread
-    , text
-    , time
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        slave-thread,
+        text,
+        time,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable static-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/static
+    hs-source-dirs:   examples/static
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable todo-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/todo
+    hs-source-dirs:   examples/todo
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , sqlite-simple
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        sqlite-simple,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable todo2-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/todo2
+    hs-source-dirs:   examples/todo2
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , sqlite-simple
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        sqlite-simple,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable todo3-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/todo3
+    hs-source-dirs:   examples/todo3
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , interpolatedstring-perl6
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , sqlite-simple
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        interpolatedstring-perl6,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        sqlite-simple,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 executable twitter-clone-exe
     main-is:          Main.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      examples/twitter-clone
+    hs-source-dirs:   examples/twitter-clone
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , rel8
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        rel8,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets
 
 test-suite okapi-test
     type:             exitcode-stdio-1.0
     main-is:          Spec.hs
-  other-modules:
-      Paths_okapi
-  hs-source-dirs:
-      test
+    hs-source-dirs:   test
+    other-modules:    Paths_okapi
+    default-language: Haskell2010
     ghc-options:      -threaded -rtsopts -with-rtsopts=-N
     build-depends:
-      aeson >=1.4.7
-    , attoparsec
-    , base >=4.7 && <5
-    , base64
-    , bytestring
-    , containers
-    , cookie
-    , cryptonite
-    , doctest-parallel
-    , extra
-    , http-api-data
-    , http-types
-    , memory
-    , mmorph
-    , mtl
-    , network
-    , okapi
-    , parser-combinators
-    , text
-    , transformers
-    , unagi-chan
-    , vault
-    , wai
-    , wai-extra
-    , wai-websockets
-    , warp
-    , warp-tls
-    , websockets
-  default-language: Haskell2010
+        aeson >=1.4.7,
+        attoparsec,
+        base >=4.7 && <5,
+        base64,
+        bytestring,
+        containers,
+        cookie,
+        cryptonite,
+        doctest-parallel,
+        extra,
+        http-api-data,
+        http-types,
+        memory,
+        mmorph,
+        mtl,
+        network,
+        okapi,
+        parser-combinators,
+        text,
+        transformers,
+        unagi-chan,
+        vault,
+        wai,
+        wai-extra,
+        wai-websockets,
+        warp,
+        warp-tls,
+        websockets

package.yaml

@@ -205,6 +205,18 @@ executables:
     dependencies:
     - okapi
     - rel8
+  dotodo-exe:
+    main:                Main.hs
+    source-dirs:         examples/dotodo
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - okapi
+    - sqlite-simple
+    - lucid2-htmx
+    - lucid2
 
 tests:
   okapi-test:

release.md

@@ -122,9 +122,9 @@ body :: MonadOkapi m => m Body
 
 bodyJSON :: MonadOkapi m, FromJSON a => m a
 
-bodyFormURLEncoded :: FromForm a, MonadOkapi m => m a
+bodyURLEncoded :: FromForm a, MonadOkapi m => m a
 
-bodyFormMultipart :: FromForm a, MonadOkapi m => m (a, [File])
+bodyMultipart :: FromForm a, MonadOkapi m => m (a, [File])
 ```
 
 8. Headers Parsers

src/Okapi.hs

@@ -76,7 +76,7 @@ module Okapi
     -- $bodyParsers
     body,
     bodyJSON,
-    bodyForm,
+    bodyURLEncoded,
     bodyEnd,
 
     -- *** Header Parsers
@@ -175,9 +175,9 @@ module Okapi
 
     -- * Testing
     -- $testing
-    testParser,
-    testParserPure,
-    testParserIO,
+    test,
+    testPure,
+    testIO,
     assert,
     assert200,
     assert404,
@@ -264,12 +264,13 @@ import qualified Network.HTTP.Types as HTTP
 import qualified Network.Socket as Socket
 import qualified Network.Wai as WAI
 import qualified Network.Wai.EventSource as WAI
-import qualified Network.Wai.Handler.Warp as WAI
+import qualified Network.Wai.Handler.Warp as WAI hiding (FileInfo(..))
 import qualified Network.Wai.Handler.WarpTLS as WAI
 import qualified Network.Wai.Handler.WebSockets as WAI
 import qualified Network.Wai.Handler.WebSockets as WebSockets
 import qualified Network.Wai.Internal as WAI
 import qualified Network.Wai.Middleware.Gzip as WAI
+import qualified Network.Wai.Parse as WAI
 import qualified Network.Wai.Test as WAI
 import qualified Network.WebSockets as WebSockets
 import qualified Web.Cookie as Web
@@ -416,7 +417,9 @@ type QueryItem = (Text.Text, QueryValue)
 
 data QueryValue = QueryParam Text.Text | QueryFlag deriving (Eq, Show) -- QueryList [Text]
 
-type Body = LBS.ByteString
+data Body = BodyRaw LBS.ByteString
+  | BodyMultipart ([WAI.Param], [WAI.File LBS.ByteString])
+  deriving (Eq, Show)
 
 type Headers = [Header]
 
@@ -568,40 +571,66 @@ queryEnd = do
 
 -- $bodyParsers
 
+-- | For getting the raw body of the request.
 body :: MonadOkapi m => m Body
 body = do
   currentBody <- State.gets (requestBody . stateRequest)
-  if LBS.null currentBody
-    then next
-    else do
-      State.modify (\state -> state {stateRequest = (stateRequest state) {requestBody = ""}})
+  case currentBody of
+    BodyRaw (LBS.null -> True) -> next
+    BodyMultipart ([], []) -> next
+    BodyRaw _ -> do
+      State.modify (\state -> state {stateRequest = (stateRequest state) {requestBody = BodyRaw ""}})
+      pure currentBody
+    BodyMultipart _ -> do
+      State.modify (\state -> state {stateRequest = (stateRequest state) {requestBody = BodyMultipart ([], [])}})
       pure currentBody
 
--- TODO: Parse body in chunks abstraction?
-
+-- | Parse request body as JSON
 bodyJSON :: (Aeson.FromJSON a, MonadOkapi m) => m a
 bodyJSON = do
-  lbs <- body
-  maybe next pure (Aeson.decode lbs)
+  body' <- body
+  case body' of
+    BodyRaw lbs -> maybe next pure (Aeson.decode lbs)
+    BodyMultipart _ -> next
 
-bodyForm :: (Web.FromForm a, MonadOkapi m) => m a
-bodyForm = do
-  lbs <- body
-  maybe next pure (eitherToMaybe $ Web.urlDecodeAsForm lbs)
+-- | Parse URLEncoded form parameters from request body
+bodyURLEncoded :: (Web.FromForm a, MonadOkapi m) => m a
+bodyURLEncoded = do
+  body' <- body
+  case body' of
+    BodyRaw lbs -> maybe next pure (eitherToMaybe $ Web.urlDecodeAsForm lbs)
+    BodyMultipart _ -> next
   where
     eitherToMaybe :: Either l r -> Maybe r
     eitherToMaybe either = case either of
       Left _ -> Nothing
       Right value -> Just value
 
--- TODO: Add abstraction for multipart forms
+-- | Parse multipart form data from request body
+bodyMultipart :: MonadOkapi m => m ([WAI.Param], [WAI.File LBS.ByteString])
+bodyMultipart = do
+  body' <- body
+  case body' of
+    BodyRaw _ -> next
+    BodyMultipart formData -> pure formData
+
+bodyXML = undefined
+
+-- | Parse a single form parameter
+formParam :: forall a m. (Web.FromHttpApiData a, MonadOkapi m) => BS.ByteString -> m a
+formParam = undefined
+
+-- | Parse a single form file
+formFile :: MonadOkapi m => BS.ByteString -> m (WAI.FileInfo BS.ByteString)
+formFile = undefined
 
 bodyEnd :: MonadOkapi m => m ()
 bodyEnd = do
-  currentBody <- body
-  if LBS.null currentBody
-    then pure ()
-    else next
+  currentBody <- State.gets (requestBody . stateRequest)
+  case currentBody of
+    BodyRaw (LBS.null -> True) -> pure ()
+    BodyMultipart ([], []) -> pure ()
+    _ -> next
 
 -- $headerParsers
 --
@@ -1027,14 +1056,15 @@ app defaultResponse hoister okapiT waiRequest respond = do
 
     waiRequestToState :: WAI.Request -> IO State
     waiRequestToState waiRequest = do
-      requestBody <- WAI.strictRequestBody waiRequest -- TODO: Use lazy request body???
+      requestBody <- case lookup "Content-Type" $ WAI.requestHeaders waiRequest of
+          Just "multipart/form-data" -> BodyMultipart <$> WAI.parseRequestBody WAI.lbsBackEnd waiRequest
+          _ -> BodyRaw <$> WAI.strictRequestBody waiRequest -- TODO: Use lazy request body???
       let requestMethod = Just $ WAI.requestMethod waiRequest
           requestPath = WAI.pathInfo waiRequest
           requestQuery = map (\case (name, Nothing) -> (name, QueryFlag); (name, Just txt) -> (name, QueryParam txt)) $ HTTP.queryToQueryText $ WAI.queryString waiRequest
           requestHeaders = WAI.requestHeaders waiRequest
           stateRequest = Request {..}
           stateVault = WAI.vault waiRequest
-
       pure State {..}
 
 -- | Turns a parsers into a WAI application with WebSocket functionality
@@ -1099,18 +1129,6 @@ route parser dispatcher = parser >>= dispatcher
 
 -- $patterns
 
-pattern PathParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> Text.Text
-pattern PathParam param <-
-  (Web.parseUrlPiece -> Right param)
-  where
-    PathParam param = Web.toUrlPiece param
-
-pattern IsQueryParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> QueryValue
-pattern IsQueryParam param <-
-  QueryParam (Web.parseUrlPiece -> Right param)
-  where
-    IsQueryParam param = QueryParam $ Web.toUrlPiece param
-
 pattern GET :: Method
 pattern GET = Just "GET"
 
@@ -1126,8 +1144,17 @@ pattern DELETE = Just "DELETE"
 pattern PUT :: Method
 pattern PUT = Just "PUT"
 
--- pattern IsQueryParam :: Web.FromHttpApiData a => a -> Maybe QueryValue
--- pattern IsQueryParam value <- Just (QueryParam (Web.parseQueryParam -> Right value))
+pattern PathParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> Text.Text
+pattern PathParam param <-
+  (Web.parseUrlPiece -> Right param)
+  where
+    PathParam param = Web.toUrlPiece param
+
+pattern IsQueryParam :: (Web.ToHttpApiData a, Web.FromHttpApiData a) => a -> QueryValue
+pattern IsQueryParam param <-
+  QueryParam (Web.parseUrlPiece -> Right param)
+  where
+    IsQueryParam param = QueryParam $ Web.toUrlPiece param
 
 pattern HasQueryFlag :: Maybe QueryValue
 pattern HasQueryFlag <- Just QueryFlag
@@ -1203,29 +1230,29 @@ parseRelURL possibleRelURL = Either.eitherToMaybe $
 --
 -- There are two ways to test in Okapi.
 
-testParser ::
+test ::
   Monad m =>
   OkapiT m Response ->
   Request ->
   m (Either Failure Response, State)
-testParser okapiT request =
+test okapiT request =
   (State.runStateT . Except.runExceptT . unOkapiT $ okapiT)
     (requestToState request)
   where
     requestToState :: Request -> State
     requestToState stateRequest = let stateVault = mempty in State {..}
 
-testParserPure ::
+testPure ::
   OkapiT Identity.Identity Response ->
   Request ->
   Identity.Identity (Either Failure Response, State)
-testParserPure = testParser
+testPure = test
 
-testParserIO ::
+testIO ::
   OkapiT IO Response ->
   Request ->
   IO (Either Failure Response, State)
-testParserIO = testParser
+testIO = test
 
 -- TODO: Add common assertion helpers. Use Predicate for Contravariant interface??
 
@@ -1274,7 +1301,10 @@ testRequest = WAI.srequest . requestToSRequest
     requestToSRequest :: Request -> WAI.SRequest
     requestToSRequest request@(Request mbMethod path query body headers) =
       let requestMethod = Maybe.fromMaybe HTTP.methodGet mbMethod
-          sRequestBody = body
+          sRequestBody =
+            case body of
+              BodyRaw lbs -> lbs
+              BodyMultipart _ -> error "Must use BodyRaw for testRequest"
           rawPath = RelURL path query Function.& \relURL -> Text.encodeUtf8 $ renderRelURL relURL
           sRequestRequest = WAI.setPath (WAI.defaultRequest {WAI.requestMethod = requestMethod, WAI.requestHeaders = headers}) rawPath
        in WAI.SRequest sRequestRequest sRequestBody
@@ -1292,9 +1322,9 @@ session :: (MonadOkapi m, HasSession m) => m Session
 session = do
   cachedSession <- getSession
   maybe sessionInCookie pure cachedSession
-
-sessionInCookie :: (MonadOkapi m, HasSession m) => m Session
-sessionInCookie = do
+  where
+    sessionInCookie :: (MonadOkapi m, HasSession m) => m Session
+    sessionInCookie = do
       encodedSession <- cookieCrumb "session"
       secret <- sessionSecret
       pure $ decodeSession secret encodedSession

stack.yaml

@@ -36,7 +36,13 @@ packages:
 # forks / in-progress versions pinned to a git hash. For example:
 #
 extra-deps:
-- lucid-htmx-0.1.0.6@sha256:83d9eed5ff74778a2dfc3f320a66b08592a2880abca28d75747a0513a39bd871,1528
+- lucid2-0.0.20220526@sha256:b5d346d428a63610d458aba1c4e0fe4924628fec609f028d74777bfaca1d92b5,1877
+- containers-0.6.6@sha256:008d007dfff018954e05ecdb8d628d8e32531f7dc3c6bb7e9bd55118c1224514,2589
+- lucid2-htmx-0.1.0.8@sha256:cde494a8e4d199dfcc59331f41c72e1a60c3d2106e1bee56e61d97b09425f850,1541
+- Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459
+- binary-0.8.9.1@sha256:81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801,6523
+- parsec-3.1.15.1@sha256:8c7a36aaadff12a38817fc3c4ff6c87e3352cffd1a58df640de7ed7a97ad8fa3,4601
+- text-1.2.5.0@sha256:791f0f6c97ed96113f17ab520cf0efe1a3a4f883a8c85910a5660567c8241c40,7895
 
 pvp-bounds: both
 

stack.yaml.lock

@@ -5,12 +5,54 @@
 
 packages:
 - completed:
-    hackage: lucid-htmx-0.1.0.6@sha256:83d9eed5ff74778a2dfc3f320a66b08592a2880abca28d75747a0513a39bd871,1528
+    hackage: lucid2-0.0.20220526@sha256:b5d346d428a63610d458aba1c4e0fe4924628fec609f028d74777bfaca1d92b5,1877
     pantry-tree:
-      size: 427
-      sha256: e7e0ebb5432ec6dd278e1ac594a94aa3311e378c683275274874dfee2e12dfe3
+      size: 477
+      sha256: 355acf57a4ac40d06c48f903c41eda4136d4a218f38bdbfebee7960d23651421
   original:
-    hackage: lucid-htmx-0.1.0.6@sha256:83d9eed5ff74778a2dfc3f320a66b08592a2880abca28d75747a0513a39bd871,1528
+    hackage: lucid2-0.0.20220526@sha256:b5d346d428a63610d458aba1c4e0fe4924628fec609f028d74777bfaca1d92b5,1877
+- completed:
+    hackage: containers-0.6.6@sha256:008d007dfff018954e05ecdb8d628d8e32531f7dc3c6bb7e9bd55118c1224514,2589
+    pantry-tree:
+      size: 2822
+      sha256: de48bcf6b468c4793bbdd22f969d940bfe74425c74654b0efbf0487792c239b5
+  original:
+    hackage: containers-0.6.6@sha256:008d007dfff018954e05ecdb8d628d8e32531f7dc3c6bb7e9bd55118c1224514,2589
+- completed:
+    hackage: lucid2-htmx-0.1.0.8@sha256:cde494a8e4d199dfcc59331f41c72e1a60c3d2106e1bee56e61d97b09425f850,1541
+    pantry-tree:
+      size: 318
+      sha256: bccf8d27fd23db6daa9b1a7e64d54715537161014db7817dc9905015b1de5214
+  original:
+    hackage: lucid2-htmx-0.1.0.8@sha256:cde494a8e4d199dfcc59331f41c72e1a60c3d2106e1bee56e61d97b09425f850,1541
+- completed:
+    hackage: Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459
+    pantry-tree:
+      size: 19757
+      sha256: b250a53bdb56844f047a2927833bb565b936a289abfa85dfc2a63148d776368a
+  original:
+    hackage: Cabal-3.6.3.0@sha256:ff97c442b0c679c1c9876acd15f73ac4f602b973c45bde42b43ec28265ee48f4,12459
+- completed:
+    hackage: binary-0.8.9.1@sha256:81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801,6523
+    pantry-tree:
+      size: 1976
+      sha256: 956ecd662408f69615977b87a92e042abcdc447b7824b8aabf5788c4393c10c5
+  original:
+    hackage: binary-0.8.9.1@sha256:81f468c1c75fd6535152ab69b2d32ac6cfcc03e345267b069abe4da56ec95801,6523
+- completed:
+    hackage: parsec-3.1.15.1@sha256:8c7a36aaadff12a38817fc3c4ff6c87e3352cffd1a58df640de7ed7a97ad8fa3,4601
+    pantry-tree:
+      size: 2630
+      sha256: 147ad21b8aa90273721903a6b294cc4ecd660d229d88c4e84c6275bc5d630ae6
+  original:
+    hackage: parsec-3.1.15.1@sha256:8c7a36aaadff12a38817fc3c4ff6c87e3352cffd1a58df640de7ed7a97ad8fa3,4601
+- completed:
+    hackage: text-1.2.5.0@sha256:791f0f6c97ed96113f17ab520cf0efe1a3a4f883a8c85910a5660567c8241c40,7895
+    pantry-tree:
+      size: 7395
+      sha256: f41504ec5c04a3f3358ef104362f02fdef29cbce4e5e4e6dbd6b6db70c40d4bf
+  original:
+    hackage: text-1.2.5.0@sha256:791f0f6c97ed96113f17ab520cf0efe1a3a4f883a8c85910a5660567c8241c40,7895
 snapshots:
 - completed:
     size: 617355