From 7fb9ed53b9e7a736a17871ae21bcd0a25098587f Mon Sep 17 00:00:00 2001
From: sigma-andex <77549848+sigma-andex@users.noreply.github.com>
Date: Tue, 23 Aug 2022 20:23:51 +0100
Subject: [PATCH] Simplify extended request creation

---
 src/HTTPurple/Request.purs | 19 +++++++++------
 src/HTTPurple/Server.purs  | 50 ++++++++++++++++++++++----------------
 2 files changed, 40 insertions(+), 29 deletions(-)

diff --git a/src/HTTPurple/Request.purs b/src/HTTPurple/Request.purs
index 5834e2a..ec3f77d 100644
--- a/src/HTTPurple/Request.purs
+++ b/src/HTTPurple/Request.purs
@@ -1,12 +1,14 @@
 module HTTPurple.Request
-  ( ExtRequest(..)
+  ( ExtRequestNT(..)
+  , ExtRequest
   , Request
   , RequestR
   , fromHTTPRequest
   , fromHTTPRequestExt
   , fromHTTPRequestUnit
   , fullPath
-  ) where
+  )
+  where
 
 import Prelude
 
@@ -58,10 +60,11 @@ type RequestR route r =
 -- | the different parts of the HTTP request.
 type Request route = { | RequestR route () }
 
-newtype ExtRequest :: Type -> Row Type -> Type
-newtype ExtRequest route ext = ExtRequest { | RequestR route ext }
+type ExtRequest route ext = { | RequestR route ext }
+newtype ExtRequestNT :: Type -> Row Type -> Type
+newtype ExtRequestNT route ext = ExtRequestNT { | RequestR route ext }
 
-derive instance Newtype (ExtRequest route ext) _
+derive instance Newtype (ExtRequestNT route ext) _
 
 -- | Return the full resolved path, including query parameters. This may not
 -- | match the requested path--for instance, if there are empty path segments in
@@ -108,14 +111,14 @@ fromHTTPRequestExt ::
   RD.RouteDuplex' route ->
   Proxy ctx ->
   HTTP.Request ->
-  Aff (Either (Request Unit) (ExtRequest route ctx))
+  Aff (Either (Request Unit) (ExtRequestNT route ctx))
 fromHTTPRequestExt route _ nodeRequest = do
   let
     extension :: Record ctx
     extension = pick (unsafeCoerce nodeRequest :: Record ctx)
 
-    addExtension :: Request route -> ExtRequest route ctx
-    addExtension = flip merge extension >>> ExtRequest
+    addExtension :: Request route -> ExtRequestNT route ctx
+    addExtension = flip merge extension >>> ExtRequestNT
 
   request <- fromHTTPRequest route nodeRequest
   pure $ rmap addExtension request
diff --git a/src/HTTPurple/Server.purs b/src/HTTPurple/Server.purs
index 2e1726b..1fb3e1d 100644
--- a/src/HTTPurple/Server.purs
+++ b/src/HTTPurple/Server.purs
@@ -7,15 +7,17 @@ module HTTPurple.Server
   , ServerM
   , defaultMiddlewareErrorHandler
   , serve
-  , serveWithMiddleware
+  , serveExtended
   ) where
 
 import Prelude
 
 import Control.Monad.Cont (runContT)
 import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Newtype (unwrap)
 import Data.Options ((:=))
 import Data.Posix.Signal (Signal(..))
+import Data.Profunctor (lcmap)
 import Data.Profunctor.Choice ((|||))
 import Effect (Effect)
 import Effect.Aff (Aff, catchError, message, runAff)
@@ -25,7 +27,7 @@ import Effect.Console (error)
 import Effect.Exception (Error)
 import HTTPurple.NodeMiddleware (MiddlewareResult(..), NextInvocation(..), NodeMiddlewareStack(..))
 import HTTPurple.Record.Extra as Extra
-import HTTPurple.Request (ExtRequest, Request, RequestR, fromHTTPRequest, fromHTTPRequestExt, fromHTTPRequestUnit)
+import HTTPurple.Request (ExtRequestNT, Request, RequestR, ExtRequest, fromHTTPRequest, fromHTTPRequestExt, fromHTTPRequestUnit)
 import HTTPurple.Response (Response, ResponseM, internalServerError, notFound, send)
 import Justifill (justifill)
 import Justifill.Fillable (class FillableFields)
@@ -80,8 +82,7 @@ type ExtRoutingSettingsR route output r =
 
 type MiddlewareSettingsR :: Row Type -> Row Type -> Row Type
 type MiddlewareSettingsR input output =
-  ( --middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input)
-  middleware :: NodeMiddlewareStack input output
+  ( nodeMiddleware :: NodeMiddlewareStack input output
   )
 
 type ExtRoutingSettings :: Type -> Row Type -> Row Type -> Type
@@ -128,40 +129,39 @@ handleRequestUnit router request httpresponse =
     >>= (onError500 router)
     >>= send httpresponse
 
-handleExtRequest ::
+handleExtRequestNT ::
   forall ctx ctxRL thru route.
   Union ctx thru ctx =>
   RowToList ctx ctxRL =>
   Extra.Keys ctxRL =>
   Nub (RequestR route ctx) (RequestR route ctx) =>
   { route :: RD.RouteDuplex' route
-  , router :: ExtRequest route ctx -> ResponseM
+  , router :: ExtRequestNT route ctx -> ResponseM
   , notFoundHandler :: Request Unit -> ResponseM
   } ->
   HTTP.Request ->
   HTTP.Response ->
   Aff Unit
-handleExtRequest { route, router, notFoundHandler } req resp = do
+handleExtRequestNT { route, router, notFoundHandler } req resp = do
   httpurpleReq <- fromHTTPRequestExt route (Proxy :: Proxy ctx) req
   httpurpleResp <- (notFoundHandler ||| onError500 router) httpurpleReq
   send resp httpurpleResp
 
-handleExtRequestWithMiddleware ::
+handleExtRequestNTWithMiddleware ::
   forall input output outputRL thru route.
   Union output thru output =>
   RowToList output outputRL =>
   Extra.Keys outputRL =>
   Nub (RequestR route output) (RequestR route output) =>
   { route :: RD.RouteDuplex' route
-  --, middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input)
-  , middleware :: NodeMiddlewareStack input output
-  , router :: ExtRequest route output -> ResponseM
+  , nodeMiddleware :: NodeMiddlewareStack input output
+  , router :: ExtRequestNT route output -> ResponseM
   , notFoundHandler :: Request Unit -> ResponseM
   } ->
   HTTP.Request ->
   HTTP.Response ->
   Effect Unit
-handleExtRequestWithMiddleware { route, middleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do
+handleExtRequestNTWithMiddleware { route, nodeMiddleware: NodeMiddlewareStack middleware, router, notFoundHandler } req resp = void $ runAff (\_ -> pure unit) $ do
   eff <- liftEffect $ flip runContT (coerce >>> pure) $ middleware (MiddlewareResult { request: req, response: resp, middlewareResult: NotCalled })
   executeHandler eff
   where
@@ -170,7 +170,7 @@ handleExtRequestWithMiddleware { route, middleware: NodeMiddlewareStack middlewa
   executeHandler (MiddlewareResult { request, response, middlewareResult: ProcessingFailed error }) =
     liftEffect $ handleRequestUnit (defaultMiddlewareErrorHandler error) request response
   executeHandler (MiddlewareResult { request, response, middlewareResult: ProcessingSucceeded }) =
-    handleExtRequest { route, router, notFoundHandler } request response
+    handleExtRequestNT { route, router, notFoundHandler } request response
   executeHandler (MiddlewareResult { middlewareResult: NotCalled }) =
     pure unit
 
@@ -235,7 +235,14 @@ serve inputOptions { route, router } = do
   let closingHandler = close server
   registerClosingHandler filledOptions.closingHandler closingHandler
 
-serveWithMiddleware ::
+asExtended
+  :: forall route ext m
+  . (ExtRequest route ext -> m Response)
+  -> ExtRequestNT route ext
+  -> m Response
+asExtended = lcmap unwrap
+
+serveExtended ::
   forall route from fromRL via missing missingList input output outputRL thru.
   RowToList missing missingList =>
   FillableFields missingList () missing =>
@@ -249,7 +256,7 @@ serveWithMiddleware ::
   { | from } ->
   ExtRoutingSettings route input output ->
   ServerM
-serveWithMiddleware inputOptions settings = do
+serveExtended inputOptions settings = do
   let
     filledOptions :: ListenOptions
     filledOptions = justifillListenOptions inputOptions
@@ -265,14 +272,15 @@ serveWithMiddleware inputOptions settings = do
       , backlog: filledOptions.backlog
       }
 
+    extendedSettings = settings { router = asExtended settings.router }
+
     routingSettings ::
       { route :: RD.RouteDuplex' route
-      --, middleware :: MiddlewareResult input -> ContT (MiddlewareResult output) Effect (MiddlewareResult input)
-      , middleware :: NodeMiddlewareStack input output
-      , router :: ExtRequest route output -> ResponseM
+      , nodeMiddleware :: NodeMiddlewareStack input output
+      , router :: ExtRequestNT route output -> ResponseM
       , notFoundHandler :: Request Unit -> ResponseM
       }
-    routingSettings = merge settings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
+    routingSettings = merge extendedSettings { notFoundHandler: fromMaybe defaultNotFoundHandler filledOptions.notFoundHandler }
 
     sslOptions = { certFile: _, keyFile: _ } <$> filledOptions.certFile <*> filledOptions.keyFile
   server <- case sslOptions of
@@ -281,8 +289,8 @@ serveWithMiddleware inputOptions settings = do
         cert' <- readTextFile UTF8 certFile
         key' <- readTextFile UTF8 keyFile
         let sslOpts = key := keyString key' <> cert := certString cert'
-        HTTPS.createServer sslOpts (handleExtRequestWithMiddleware routingSettings)
-    Nothing -> HTTP.createServer (handleExtRequestWithMiddleware routingSettings)
+        HTTPS.createServer sslOpts (handleExtRequestNTWithMiddleware routingSettings)
+    Nothing -> HTTP.createServer (handleExtRequestNTWithMiddleware routingSettings)
   listen server options onStarted
   let closingHandler = close server
   registerClosingHandler filledOptions.closingHandler closingHandler