Skip to content

Adds Fleece request and response support #10

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Apr 7, 2025
Merged

Adds Fleece request and response support #10

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
da720fd
Adds Fleece request and response support
AugmenTab Apr 4, 2025
1be13a4
Corrects documentation for `addResponseSchema202`
AugmenTab Apr 6, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
37 changes: 35 additions & 2 deletions src/Orb/Handler/Handler.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,8 @@ import Data.ByteString.Lazy qualified as LBS
import Data.Kind qualified as Kind
import Data.Maybe (maybeToList)
import Data.Text qualified as T
import Fleece.Aeson qualified as FA
import Fleece.Core qualified as FC
import Network.Wai qualified as Wai
import Network.Wai.Parse qualified as Wai
import Shrubbery qualified as S
Expand Down Expand Up @@ -85,7 +87,11 @@ data NoRequestBody
= NoRequestBody

data RequestBody body tags where
RequestBody ::
RequestSchema ::
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Do we actually need this to be a separate constructor? I think we can do this by having an orb-fleece that wraps around orb to get this, and the other functionality, back.

Copy link
Contributor Author

@AugmenTab AugmenTab Apr 5, 2025 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

requestBody takes this type, so I don't see how we could do that without it just being a re-implementation of orb. Can you walk me through what you're thinking?

Response.Has422Response tags =>
(forall schema. FC.Fleece schema => schema body) ->
RequestBody body tags
RequestRawBody ::
Response.HasResponseCodeWithType tags "422" err =>
(LBS.ByteString -> Either err body) ->
RequestBody body tags
Expand All @@ -109,7 +115,12 @@ runHandler ::
m Wai.ResponseReceived
runHandler handler route =
case requestBody handler of
RequestBody bodyDecoder ->
RequestSchema schema ->
requestSchemaHandler
schema
(handlerResponseBodies handler)
(runPermissionAction handler route)
RequestRawBody bodyDecoder ->
requestBodyHandler
bodyDecoder
(handlerResponseBodies handler)
Expand Down Expand Up @@ -207,6 +218,28 @@ requestFormDataHandler requestDecoder bodies action =
Left err -> Response.return422 err
Right request -> action request

requestSchemaHandler ::
( Response.Has422Response tags
, Response.Has500Response tags
, HasLogger.HasLogger m
, HasRequest.HasRequest m
, HasRespond.HasRespond m
, UnliftIO.MonadUnliftIO m
) =>
(forall schema. FC.Fleece schema => schema request) ->
Response.ResponseBodies tags ->
(request -> m (S.TaggedUnion tags)) ->
m Wai.ResponseReceived
requestSchemaHandler schema bodies action =
emptyRequestBodyHandler bodies $ do
req <- HasRequest.request
body <- UnliftIO.liftIO $ Wai.consumeRequestBodyStrict req
case FA.decode schema body of
Left err ->
Response.return422 . Response.UnprocessableContentMessage $ T.pack err
Right request ->
action request

requestBodyHandler ::
( Response.HasResponseCodeWithType tags "422" err
, Response.Has500Response tags
Expand Down
12 changes: 9 additions & 3 deletions src/Orb/Response/Response.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,7 @@ import Control.Monad.IO.Class qualified as MIO
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Map.Strict qualified as Map
import Fleece.Core qualified as FC
import GHC.TypeLits (KnownNat)
import Network.HTTP.Types qualified as HTTP
import Network.Wai (Response, ResponseReceived)
Expand All @@ -39,9 +40,14 @@ responseBodyList =
Map.toList . responseStatusMap

data ResponseBody where
ResponseContent :: ContentType -> (a -> LBS.ByteString) -> ResponseBody
ResponseDocument :: ResponseBody
EmptyResponseBody :: ResponseBody
ResponseContent ::
ContentType -> (body -> LBS.ByteString) -> ResponseBody
ResponseSchema ::
(forall schema. FC.Fleece schema => schema body) -> ResponseBody
ResponseDocument ::
ResponseBody
EmptyResponseBody ::
ResponseBody

data ResponseData = ResponseData
{ responseDataStatus :: HTTP.Status
Expand Down
Loading