Allows permissions to run without reading the request body

This introduces `PermissionRequest`, a variant of `HandlerRequest` for
which the body has not been read or parsed yet. This allows the permission
actions to be run and reject the request without having to ever read
the body.

A permission action than needs the body to check permissions can read
it explicitly using the handle provided to it. The body will be only
by read once if it is used by both the permission action and the handler.

Author: qxjit

orb.cabal

@@ -130,6 +130,7 @@ test-suite orb-test
       Fixtures.NullableRef
       Fixtures.NullableRefCollectComponents
       Fixtures.OpenApiSubset
+      Fixtures.PermissionReadsBody
       Fixtures.SchemaBounds
       Fixtures.SchemaDescriptions
       Fixtures.SimpleGet

src/Orb/Handler/Handler.hs

@@ -11,7 +11,9 @@
 
 module Orb.Handler.Handler
   ( Handler (..)
-  , HandlerRequest (..)
+  , RequestWithBody (..)
+  , HandlerRequest
+  , PermissionRequest
   , runHandler
   , HasHandler (..)
   , NoRequestBody (..)
@@ -23,6 +25,8 @@ module Orb.Handler.Handler
   , formDataRequestBody
   , formDataRequestBodyWith
   , emptyRequestBody
+  , BodyHandle
+  , decodeBody
   , NoRequestQuery (..)
   , RequestQuery (..)
   , schemaRequestQuery
@@ -38,6 +42,7 @@ module Orb.Handler.Handler
 where
 
 import Beeline.Params qualified as BP
+import Control.Concurrent.MVar qualified as MVar
 import Control.Exception.Safe qualified as Safe
 import Control.Monad.IO.Class qualified as MIO
 import Data.ByteString.Lazy qualified as LBS
@@ -58,21 +63,29 @@ import Orb.HasRequest qualified as HasRequest
 import Orb.HasRespond qualified as HasRespond
 import Orb.Response qualified as Response
 
-data HandlerRequest route = HandlerRequest
+data RequestWithBody body route = HandlerRequest
   { reqRoute :: route
-  , reqBody :: HandlerRequestBody route
+  , reqBody :: body
   , reqQuery :: HandlerRequestQuery route
   , reqHeaders :: HandlerRequestHeaders route
   }
 
+type HandlerRequest route =
+  RequestWithBody (HandlerRequestBody route) route
+
+type PermissionRequest route =
+  RequestWithBody
+    (BodyHandle (S.TaggedUnion (HandlerResponses route)) (HandlerRequestBody route))
+    route
+
 data Handler route = Handler
   { handlerId :: String
   , requestBody :: RequestBody (HandlerRequestBody route) (HandlerResponses route)
   , handlerResponseBodies :: Response.ResponseBodies (HandlerResponses route)
   , requestQuery :: RequestQuery (HandlerRequestQuery route) (HandlerResponses route)
   , requestHeaders :: RequestHeaders (HandlerRequestHeaders route) (HandlerResponses route)
   , mkPermissionAction ::
-      HandlerRequest route ->
+      PermissionRequest route ->
       HandlerPermissionAction route
   , handleRequest ::
       HandlerRequest route ->
@@ -180,6 +193,27 @@ emptyRequestBody =
     , requestBodyParser = const (pure (Right NoRequestBody))
     }
 
+newtype BodyHandle err body
+  = BodyHandle (IO (Either err body))
+
+decodeBody :: MIO.MonadIO m => BodyHandle err body -> m (Either err body)
+decodeBody (BodyHandle decode) =
+  MIO.liftIO decode
+
+newBodyHandle :: IO (Either err body) -> IO (BodyHandle err body)
+newBodyHandle decode = do
+  cacheVar <- MVar.newMVar Nothing
+  pure . BodyHandle $ do
+    exceptionOrResult <-
+      MVar.modifyMVar cacheVar $ \cached ->
+        case cached of
+          Just result ->
+            pure (cached, result)
+          Nothing -> do
+            result <- Safe.tryAny decode
+            pure (Just result, result)
+    either Safe.throwIO pure exceptionOrResult
+
 data NoRequestQuery
   = NoRequestQuery
 
@@ -278,20 +312,14 @@ runHandler handler route = do
           Left errResponse ->
             pure errResponse
           Right query -> do
-            errOrBody <- readBody handler
-            case errOrBody of
-              Left errResponse -> pure errResponse
-              Right body ->
-                let
-                  request =
-                    HandlerRequest
-                      { reqRoute = route
-                      , reqBody = body
-                      , reqQuery = query
-                      , reqHeaders = headers
-                      }
-                in
-                  runPermissionAction handler request
+            body <- newRequestBodyHandle handler
+            runPermissionAction handler $
+              HandlerRequest
+                { reqRoute = route
+                , reqBody = body
+                , reqQuery = query
+                , reqHeaders = headers
+                }
 
   let
     responseData =
@@ -330,39 +358,44 @@ readQuery ::
 readQuery handler =
   requestQueryParser (requestQuery handler) <$> HasRequest.request
 
-readBody ::
+newRequestBodyHandle ::
   ( MIO.MonadIO m
   , HasRequest.HasRequest m
   , tags ~ HandlerResponses route
   ) =>
   Handler route ->
-  m (Either (S.TaggedUnion tags) (HandlerRequestBody route))
-readBody handler = do
+  m (BodyHandle (S.TaggedUnion tags) (HandlerRequestBody route))
+newRequestBodyHandle handler = do
   req <- HasRequest.request
-  MIO.liftIO $ requestBodyParser (requestBody handler) req
+  MIO.liftIO . newBodyHandle $ requestBodyParser (requestBody handler) req
 
 runPermissionAction ::
-  ( Monad m
+  ( MIO.MonadIO m
   , HasHandler route
   , PA.PermissionActionMonad (HandlerPermissionAction route) ~ m
   ) =>
   Handler route ->
-  HandlerRequest route ->
+  PermissionRequest route ->
   m (S.TaggedUnion (HandlerResponses route))
-runPermissionAction handler request = do
+runPermissionAction handler permissionRequest = do
   let
     permissionAction =
-      mkPermissionAction handler request
+      mkPermissionAction handler permissionRequest
 
   errOrPermissionResult <- PA.checkPermissionAction permissionAction
 
   case errOrPermissionResult of
     Left err -> PE.returnPermissionError err
-    Right permissionResult ->
-      PA.runPermissionActionHandler
-        permissionAction
-        permissionResult
-        (handleRequest handler request)
+    Right permissionResult -> do
+      errOrBody <- decodeBody (reqBody permissionRequest)
+      case errOrBody of
+        Left errResponse ->
+          pure errResponse
+        Right body ->
+          PA.runPermissionActionHandler
+            permissionAction
+            permissionResult
+            (handleRequest handler permissionRequest {reqBody = body})
 
 returnAnyExceptionAs500 ::
   ( MIO.MonadIO m

test/Fixtures.hs

@@ -13,6 +13,7 @@ import Fixtures.NoPermissions as Export
 import Fixtures.NullableRef as Export
 import Fixtures.NullableRefCollectComponents as Export
 import Fixtures.OpenApiSubset as Export
+import Fixtures.PermissionReadsBody as Export
 import Fixtures.SchemaBounds as Export
 import Fixtures.SimpleGet as Export
 import Fixtures.SimplePost as Export

test/Fixtures/PermissionReadsBody.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Fixtures.PermissionReadsBody
+  ( PermissionReadsBody (..)
+  , permissionReadsBodyOpenApiRouter
+  ) where
+
+import Beeline.Routing ((/-), (/:))
+import Beeline.Routing qualified as R
+import Data.Text qualified as T
+import Fleece.Core ((#+))
+import Fleece.Core qualified as FC
+import Network.HTTP.Types qualified as HTTP
+import Network.Wai qualified as Wai
+import Shrubbery qualified as S
+
+import Orb qualified
+import TestDispatchM qualified as TDM
+
+permissionReadsBodyOpenApiRouter :: Orb.OpenApiProvider r => r (S.Union '[PermissionReadsBody])
+permissionReadsBodyOpenApiRouter =
+  Orb.provideOpenApi "permission-reads-body"
+    . R.routeList
+    $ Orb.post (R.make PermissionReadsBody /- "test" /- "permission_reads_body")
+      /: R.emptyRoutes
+
+data PermissionReadsBody = PermissionReadsBody
+
+instance Orb.HasHandler PermissionReadsBody where
+  type HandlerRequestBody PermissionReadsBody = PermissionReadsBodyBody
+  type HandlerResponses PermissionReadsBody = Responses
+  type HandlerPermissionAction PermissionReadsBody = BodyPermission
+  type HandlerMonad PermissionReadsBody = TDM.TestDispatchM
+  routeHandler = handler
+
+type Responses =
+  [ Orb.Response "200" Orb.SuccessMessage
+  , Orb.Response "401" Orb.UnauthorizedMessage
+  , Orb.Response "422" Orb.UnprocessableContentMessage
+  , Orb.Response "500" Orb.InternalServerError
+  ]
+
+newtype PermissionReadsBodyBody = PermissionReadsBodyBody
+  { permissionReadsBodyBodyParam :: T.Text
+  }
+
+permissionReadsBodyBodySchema :: FC.Fleece t => FC.Schema t PermissionReadsBodyBody
+permissionReadsBodyBodySchema =
+  FC.object $
+    FC.constructor PermissionReadsBodyBody
+      #+ FC.required "postParam" permissionReadsBodyBodyParam FC.text
+
+newtype BodyPermission
+  = BodyPermission (Orb.BodyHandle (S.TaggedUnion Responses) PermissionReadsBodyBody)
+
+newtype BodyPermissionError = BodyPermissionError T.Text
+
+instance Orb.PermissionAction BodyPermission where
+  type PermissionActionMonad BodyPermission = TDM.TestDispatchM
+  type PermissionActionError BodyPermission = BodyPermissionError
+  type PermissionActionResult BodyPermission = ()
+
+  checkPermissionAction (BodyPermission body) = do
+    request <- Orb.request
+    if lookup HTTP.hAuthorization (Wai.requestHeaders request) /= Just "Bearer good"
+      then pure (Left (BodyPermissionError "Invalid token"))
+      else do
+        errOrBody <- Orb.decodeBody body
+        pure $
+          case errOrBody of
+            Right decoded
+              | permissionReadsBodyBodyParam decoded /= "allowed" ->
+                  Left (BodyPermissionError "Not allowed")
+            _ ->
+              Right ()
+
+instance Orb.PermissionError BodyPermissionError where
+  type PermissionErrorConstraints BodyPermissionError tags = Orb.Has401Response tags
+  type PermissionErrorMonad BodyPermissionError = TDM.TestDispatchM
+
+  returnPermissionError (BodyPermissionError message) =
+    Orb.returnResponse Orb.status401 (Orb.UnauthorizedMessage message)
+
+handler :: Orb.Handler PermissionReadsBody
+handler =
+  Orb.Handler
+    { Orb.handlerId = "permissionReadsBody"
+    , Orb.requestBody = Orb.schemaRequestBody permissionReadsBodyBodySchema
+    , Orb.requestQuery = Orb.emptyRequestQuery
+    , Orb.requestHeaders = Orb.emptyRequestHeaders
+    , Orb.handlerResponseBodies =
+        Orb.responseBodies
+          . Orb.addResponseSchema Orb.status200 Orb.successMessageSchema
+          . Orb.addResponseSchema Orb.status401 Orb.unauthorizedMessageSchema
+          . Orb.addResponseSchema Orb.status422 Orb.unprocessableContentSchema
+          . Orb.addResponseSchema Orb.status500 Orb.internalServerErrorSchema
+          $ Orb.noResponseBodies
+    , Orb.mkPermissionAction =
+        BodyPermission . Orb.reqBody
+    , Orb.handleRequest =
+        \request () ->
+          Orb.returnResponse Orb.status200
+            . Orb.SuccessMessage
+            . permissionReadsBodyBodyParam
+            . Orb.reqBody
+            $ request
+    }

test/Handler.hs

@@ -8,6 +8,8 @@ module Handler
 
 import Beeline.Routing qualified as R
 import Control.Monad.IO.Class qualified as MIO
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
 import Hedgehog qualified as HH
 import Network.HTTP.Types qualified as HTTPTypes
 import Network.Wai qualified as Wai
@@ -34,6 +36,10 @@ testGroup =
     , TastyHH.testProperty "serves a custom status code" prop_customStatusCode
     , TastyHH.testProperty "serves a schema body with a custom parse error response" prop_customBodyError
     , TastyHH.testProperty "responds to an unparseable schema body with a custom error" prop_customBodyErrorInvalid
+    , TastyHH.testProperty "checks permission before decoding a schema body" prop_permissionBeforeBody
+    , TastyHH.testProperty "reuses a body the permission action decoded" prop_permissionReadsBody
+    , TastyHH.testProperty "lets a permission action reject based on the body" prop_permissionRejectsBody
+    , TastyHH.testProperty "answers a body decode failure after permission" prop_permissionReadsInvalidBody
     ]
 
 prop_simpleGet :: HH.Property
@@ -172,6 +178,43 @@ prop_customBodyErrorInvalid = HH.withTests 1 . HH.property $ do
     WaiTest.assertContentType "application/json" response
     WaiTest.assertBodyContains "\"errorCode\":\"invalid_body\"" response
 
+prop_permissionBeforeBody :: HH.Property
+prop_permissionBeforeBody = HH.withTests 1 . HH.property $
+  evalAppSession Fixtures.permissionReadsBodyOpenApiRouter $ do
+    response <- WaiTest.srequest (permissionReadsBodyRequest "Bearer bad" "not json")
+    WaiTest.assertStatus 401 response
+    WaiTest.assertBody "{\"unauthorized\":\"Invalid token\"}" response
+
+prop_permissionReadsBody :: HH.Property
+prop_permissionReadsBody = HH.withTests 1 . HH.property $
+  evalAppSession Fixtures.permissionReadsBodyOpenApiRouter $ do
+    response <- WaiTest.srequest (permissionReadsBodyRequest "Bearer good" "{\"postParam\": \"allowed\"}")
+    WaiTest.assertStatus 200 response
+    WaiTest.assertBody "{\"success\":\"allowed\"}" response
+
+prop_permissionRejectsBody :: HH.Property
+prop_permissionRejectsBody = HH.withTests 1 . HH.property $
+  evalAppSession Fixtures.permissionReadsBodyOpenApiRouter $ do
+    response <- WaiTest.srequest (permissionReadsBodyRequest "Bearer good" "{\"postParam\": \"denied\"}")
+    WaiTest.assertStatus 401 response
+    WaiTest.assertBody "{\"unauthorized\":\"Not allowed\"}" response
+
+prop_permissionReadsInvalidBody :: HH.Property
+prop_permissionReadsInvalidBody = HH.withTests 1 . HH.property $
+  evalAppSession Fixtures.permissionReadsBodyOpenApiRouter $ do
+    response <- WaiTest.srequest (permissionReadsBodyRequest "Bearer good" "not json")
+    WaiTest.assertStatus 422 response
+    WaiTest.assertContentType "application/json" response
+    WaiTest.assertBodyContains "\"unprocessable_content\"" response
+
+permissionReadsBodyRequest :: BS.ByteString -> LBS.ByteString -> WaiTest.SRequest
+permissionReadsBodyRequest token =
+  WaiTest.SRequest
+    (WaiTest.setPath Wai.defaultRequest "/test/permission_reads_body")
+      { Wai.requestMethod = HTTPTypes.methodPost
+      , Wai.requestHeaders = [(HTTPTypes.hAuthorization, token)]
+      }
+
 evalAppSession ::
   ( Orb.Dispatchable TDM.TestDispatchM a
   , HH.MonadTest m